diff options
Diffstat (limited to 'compiler')
30 files changed, 136 insertions, 123 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 26f870a5bc..16c02dcadb 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -1607,7 +1607,7 @@ addSourceToTokens _ _ [] = [] addSourceToTokens loc buf (t@(L span _) : ts) = case span of UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts - RealSrcSpan s _ -> (t,str) : addSourceToTokens newLoc newBuf ts + RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts where (newLoc, newBuf, str) = go "" loc buf start = realSrcSpanStart s @@ -1627,13 +1627,13 @@ showRichTokenStream ts = go startLoc ts "" where sourceFile = getFile $ map (getLoc . fst) ts getFile [] = panic "showRichTokenStream: No source file found" getFile (UnhelpfulSpan _ : xs) = getFile xs - getFile (RealSrcSpan s _ : _) = srcSpanFile s + getFile (RealSrcSpan s : _) = srcSpanFile s startLoc = mkRealSrcLoc sourceFile 1 1 go _ [] = id go loc ((L span _, str):ts) = case span of UnhelpfulSpan _ -> go loc ts - RealSrcSpan s _ + RealSrcSpan s | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++) . (str ++) . go tokEnd ts diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index ae6e126b68..410f19faca 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -1432,7 +1432,7 @@ withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c withSourceNote a b parse = do name <- getName case combineSrcSpans (getLoc a) (getLoc b) of - RealSrcSpan span _ -> code (emitTick (SourceNote span name)) >> parse + RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse _other -> parse -- ----------------------------------------------------------------------------- diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index f4430918e6..e66eb9604b 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -47,6 +47,7 @@ import GHC.Data.OrdList import GHC.Data.FastString import GHC.Data.Pair import GHC.Data.Graph.UnVar +import qualified GHC.Data.Strict as Strict import GHC.Utils.Error import GHC.Utils.Misc @@ -300,12 +301,12 @@ mkDataConWorkers generate_debug_info mod_loc data_tycons -- worker. This is useful, especially for heap profiling. tick_it name | not generate_debug_info = id - | RealSrcSpan span _ <- nameSrcSpan name = tick span + | RealSrcSpan span <- nameSrcSpan name = tick span | Just file <- ml_hs_file mod_loc = tick (span1 file) | otherwise = tick (span1 "???") where tick span = Tick $ SourceNote span $ renderWithContext defaultSDocContext $ ppr name - span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1 + span1 file = realSrcLocSpan (mkRealSrcLoc (mkFastString file) 1 1) Strict.Nothing {- Note [Floating out of top level bindings] diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index e5a1d915fc..df9f69d592 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -256,6 +256,7 @@ import GHC.Data.StringBuffer import qualified GHC.Data.Stream as Stream import GHC.Data.Stream (Stream) import GHC.Data.Maybe +import qualified GHC.Data.Strict as Strict import qualified GHC.SysTools import GHC.SysTools (initSysTools) @@ -679,7 +680,7 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do outer_mod' = mkHomeModule home_unit mod_name inner_mod = homeModuleNameInstantiation home_unit mod_name src_filename = ms_hspp_file mod_summary - real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 + real_loc = realSrcLocSpan (mkRealSrcLoc (mkFastString src_filename) 1 1) Strict.Nothing keep_rn' = gopt Opt_WriteHie dflags || keep_rn massert (isHomeModule home_unit outer_mod) tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod) diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index cec5a581de..b861d7200e 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -65,7 +65,7 @@ writeMixEntries hpc_dir mod extendedMixEntries filename return hashNo mkHpcPos :: SrcSpan -> HpcPos -mkHpcPos pos@(RealSrcSpan s _) +mkHpcPos pos@(RealSrcSpan s) | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s, srcSpanStartCol s, srcSpanEndLine s, diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs index f162dadaf5..a65ff1de69 100644 --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -249,7 +249,7 @@ mkMaps env instances decls = -> ( [(Name, [HsDoc GhcRn])] , [(Name, IntMap (HsDoc GhcRn))] ) - mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, doc) = + mappings (L (SrcSpanAnn _ (RealSrcSpan l)) decl, doc) = (dm, am) where args = declTypeDocs decl @@ -266,7 +266,7 @@ mkMaps env instances decls = mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = ([], []) instanceMap :: Map RealSrcSpan Name - instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ] + instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l <- [getSrcSpan n] ] names :: RealSrcSpan -> HsDecl GhcRn -> [Name] names _ (InstD _ d) = maybeToList $ lookupSrcSpan (getInstLoc d) instanceMap diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 65a83667a3..f599ea4573 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -447,7 +447,7 @@ dsExpr (HsStatic (_, whole_ty) expr@(L loc _)) = do dflags <- getDynFlags let platform = targetPlatform dflags let (line, col) = case locA loc of - RealSrcSpan r _ -> + RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r , srcLocCol $ realSrcSpanStart r ) diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index 8a0b600a66..26726e7a53 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -335,7 +335,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var else Nothing) } if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod) NotBoot - real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1) + real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1) Strict.Nothing gbl_env = DsGblEnv { ds_mod = mod , ds_fam_inst_env = fam_inst_env , ds_gbl_rdr_env = rdr_env @@ -406,12 +406,12 @@ updPmNablas nablas = updLclEnv (\env -> env { dsl_nablas = nablas }) getSrcSpanDs :: DsM SrcSpan getSrcSpanDs = do { env <- getLclEnv - ; return (RealSrcSpan (dsl_loc env) Strict.Nothing) } + ; return (RealSrcSpan (dsl_loc env)) } putSrcSpanDs :: SrcSpan -> DsM a -> DsM a putSrcSpanDs (UnhelpfulSpan {}) thing_inside = thing_inside -putSrcSpanDs (RealSrcSpan real_span _) thing_inside +putSrcSpanDs (RealSrcSpan real_span) thing_inside = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside putSrcSpanDsA :: SrcSpanAnn' ann -> DsM a -> DsM a diff --git a/compiler/GHC/HsToCore/Pmc/Types.hs b/compiler/GHC/HsToCore/Pmc/Types.hs index d3046e5812..1689560247 100644 --- a/compiler/GHC/HsToCore/Pmc/Types.hs +++ b/compiler/GHC/HsToCore/Pmc/Types.hs @@ -131,8 +131,8 @@ newtype PmPatBind p = PmPatBind (PmGRHS p) instance Outputable SrcInfo where - ppr (SrcInfo (L (RealSrcSpan rss _) _)) = ppr (srcSpanStartLine rss) - ppr (SrcInfo (L s _)) = ppr s + ppr (SrcInfo (L (RealSrcSpan rss) _)) = ppr (srcSpanStartLine rss) + ppr (SrcInfo (L s _)) = ppr s -- | Format LYG guards as @| True <- x, let x = 42, !z@ instance Outputable GrdVec where diff --git a/compiler/GHC/HsToCore/Ticks.hs b/compiler/GHC/HsToCore/Ticks.hs index 43a12e5ed8..c42ee2b174 100644 --- a/compiler/GHC/HsToCore/Ticks.hs +++ b/compiler/GHC/HsToCore/Ticks.hs @@ -118,7 +118,7 @@ addTicksToBinds logger cfg , inScope = emptyVarSet , blackList = Set.fromList $ mapMaybe (\tyCon -> case getSrcSpan (tyConName tyCon) of - RealSrcSpan l _ -> Just l + RealSrcSpan l -> Just l UnhelpfulSpan _ -> Nothing) tyCons , density = mkDensity tickish $ ticks_profAuto cfg @@ -1104,7 +1104,7 @@ getFileName :: TM FastString getFileName = fileName `liftM` getEnv isGoodSrcSpan' :: SrcSpan -> Bool -isGoodSrcSpan' pos@(RealSrcSpan _ _) = srcSpanStart pos /= srcSpanEnd pos +isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos isGoodSrcSpan' (UnhelpfulSpan _) = False isGoodTickSrcSpan :: SrcSpan -> TM Bool @@ -1128,7 +1128,7 @@ bindLocals new_ids (TM m) where occs = [ nameOccName (idName id) | id <- new_ids ] isBlackListed :: SrcSpan -> TM Bool -isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList env), noFVs, st) +isBlackListed (RealSrcSpan pos) = TM $ \ env st -> (Set.member pos (blackList env), noFVs, st) isBlackListed (UnhelpfulSpan _) = return False -- the tick application inherits the source position of its @@ -1196,7 +1196,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do Breakpoints -> Breakpoint noExtField <$> addMixEntry me <*> pure ids - SourceNotes | RealSrcSpan pos' _ <- pos -> + SourceNotes | RealSrcSpan pos' <- pos -> return $ SourceNote pos' cc_name _otherwise -> panic "mkTickish: bad source span!" diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 8f97f51833..e193684776 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -246,7 +246,7 @@ getUnlocatedEvBinds file = do mkNodeInfo (n,ci) = (Right (varName n), IdentifierDetails (Just $ varType n) ci) go e@(v,_) (xs,ys) = case nameSrcSpan $ varName v of - RealSrcSpan spn _ + RealSrcSpan spn | srcSpanFile spn == file -> let node = Node (mkSourcedNodeInfo org ni) spn [] ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e] @@ -336,10 +336,11 @@ enrichHie ts (hsGrp, imports, exports, docs) ev_bs insts tcs = Just c -> forM_ (classSCSelIds c) $ \v -> addUnlocatedEvBind v (EvidenceVarBind (EvInstBind True (className c)) ModuleScope Nothing) let spanFile file children = case nonEmpty children of - Nothing -> realSrcLocSpan (mkRealSrcLoc file 1 1) + Nothing -> realSrcLocSpan (mkRealSrcLoc file 1 1) Strict.Nothing Just children -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan (NE.head children)) (realSrcSpanEnd $ nodeSpan (NE.last children)) + Strict.Nothing flat_asts = concat [ tasts @@ -354,7 +355,7 @@ enrichHie ts (hsGrp, imports, exports, docs) ev_bs insts tcs = top_ev_asts :: [HieAST Type] <- do let l :: SrcSpanAnnA - l = noAnnSrcSpan (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Strict.Nothing) + l = noAnnSrcSpan (RealSrcSpan (realSrcLocSpan (mkRealSrcLoc file 1 1) Strict.Nothing)) toHie $ EvBindContext ModuleScope Nothing $ L l (EvBinds ev_bs) @@ -401,7 +402,7 @@ getRealSpanA :: SrcSpanAnn' ann -> Maybe Span getRealSpanA la = getRealSpan (locA la) getRealSpan :: SrcSpan -> Maybe Span -getRealSpan (RealSrcSpan sp _) = Just sp +getRealSpan (RealSrcSpan sp) = Just sp getRealSpan _ = Nothing grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcAnn NoEpAnns) @@ -414,7 +415,7 @@ bindingsOnly (C c n : xs) = do org <- ask rest <- bindingsOnly xs pure $ case nameSrcSpan n of - RealSrcSpan span _ -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest + RealSrcSpan span -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info) info = mempty{identInfo = S.singleton c} _ -> rest @@ -609,7 +610,7 @@ instance (ToHie a) => ToHie (Maybe a) where toHie = maybe (pure []) toHie instance ToHie (IEContext (LocatedA ModuleName)) where - toHie (IEC c (L (SrcSpanAnn _ (RealSrcSpan span _)) mname)) = do + toHie (IEC c (L (SrcSpanAnn _ (RealSrcSpan span)) mname)) = do org <- ask pure $ [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []] where details = mempty{identInfo = S.singleton (IEThing c)} @@ -624,7 +625,7 @@ instance ToHie (Context (Located a)) => ToHie (Context (LocatedA a)) where instance ToHie (Context (Located Var)) where toHie c = case c of - C context (L (RealSrcSpan span _) name') + C context (L (RealSrcSpan span) name') | varUnique name' == mkBuiltinUnique 1 -> pure [] -- `mkOneRecordSelector` makes a field var using this unique, which we ignore | otherwise -> do @@ -651,7 +652,7 @@ instance ToHie (Context (Located Var)) where instance ToHie (Context (Located Name)) where toHie c = case c of - C context (L (RealSrcSpan span _) name') + C context (L (RealSrcSpan span) name') | nameUnique name' == mkBuiltinUnique 1 -> pure [] -- `mkOneRecordSelector` makes a field var using this unique, which we ignore | otherwise -> do diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs index 954ab3af57..5008b076c7 100644 --- a/compiler/GHC/Iface/Ext/Utils.hs +++ b/compiler/GHC/Iface/Ext/Utils.hs @@ -93,7 +93,7 @@ selectPoint hf (sl,sc) = getFirst $ Just ast' -> Just ast' where sloc fs = mkRealSrcLoc fs sl sc - sp fs = mkRealSrcSpan (sloc fs) (sloc fs) + sp fs = mkRealSrcSpan (sloc fs) (sloc fs) Strict.Nothing findEvidenceUse :: NodeIdentifiers a -> [Name] findEvidenceUse ni = [n | (Right n, dets) <- xs, any isEvidenceUse (identInfo dets)] @@ -309,7 +309,7 @@ getNameScopeAndBinding -> M.Map HiePath (HieAST a) -> Maybe ([Scope], Maybe Span) getNameScopeAndBinding n asts = case nameSrcSpan n of - RealSrcSpan sp _ -> do -- @Maybe + RealSrcSpan sp -> do -- @Maybe ast <- M.lookup (HiePath (srcSpanFile sp)) asts defNode <- selectLargestContainedBy sp ast getFirst $ foldMap First $ do -- @[] @@ -373,7 +373,7 @@ selectSmallestContaining sp node definedInAsts :: M.Map HiePath (HieAST a) -> Name -> Bool definedInAsts asts n = case nameSrcSpan n of - RealSrcSpan sp _ -> M.member (HiePath (srcSpanFile sp)) asts + RealSrcSpan sp -> M.member (HiePath (srcSpanFile sp)) asts _ -> False getEvidenceBindDeps :: ContextInfo -> [Name] @@ -520,7 +520,7 @@ simpleNodeInfo :: FastString -> FastString -> NodeInfo a simpleNodeInfo cons typ = NodeInfo (S.singleton (NodeAnnotation cons typ)) [] M.empty locOnly :: Monad m => SrcSpan -> ReaderT NodeOrigin m [HieAST a] -locOnly (RealSrcSpan span _) = do +locOnly (RealSrcSpan span) = do org <- ask let e = mkSourcedNodeInfo org $ emptyNodeInfo pure [Node e span []] @@ -530,7 +530,7 @@ mkScopeA :: SrcSpanAnn' ann -> Scope mkScopeA l = mkScope (locA l) mkScope :: SrcSpan -> Scope -mkScope (RealSrcSpan sp _) = LocalScope sp +mkScope (RealSrcSpan sp) = LocalScope sp mkScope _ = NoScope mkLScope :: Located a -> Scope @@ -548,7 +548,7 @@ combineScopes _ ModuleScope = ModuleScope combineScopes NoScope x = x combineScopes x NoScope = x combineScopes (LocalScope a) (LocalScope b) = - mkScope $ combineSrcSpans (RealSrcSpan a Strict.Nothing) (RealSrcSpan b Strict.Nothing) + mkScope $ combineSrcSpans (RealSrcSpan a) (RealSrcSpan b) mkSourcedNodeInfo :: NodeOrigin -> NodeInfo a -> SourcedNodeInfo a mkSourcedNodeInfo org ni = SourcedNodeInfo $ M.singleton org ni @@ -570,7 +570,7 @@ makeNode makeNode x spn = do org <- ask pure $ case spn of - RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []] + RealSrcSpan span -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []] _ -> [] where cons = mkFastString . show . toConstr $ x @@ -595,7 +595,7 @@ makeTypeNode makeTypeNode x spn etyp = do org <- ask pure $ case spn of - RealSrcSpan span _ -> + RealSrcSpan span -> [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []] _ -> [] where diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index 299dfe553b..5fad9e1737 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -44,6 +44,7 @@ module GHC.Iface.Syntax ( import GHC.Prelude +import qualified GHC.Data.Strict as Strict import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey ) import GHC.Types.Unique ( hasKey ) import GHC.Iface.Type @@ -2464,7 +2465,7 @@ instance Binary IfaceTickish where let start = mkRealSrcLoc file sl sc end = mkRealSrcLoc file el ec name <- get bh - return (IfaceSource (mkRealSrcSpan start end) name) + return (IfaceSource (mkRealSrcSpan start end Strict.Nothing) name) _ -> panic ("get IfaceTickish " ++ show h) instance Binary IfaceConAlt where diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index fd1cd5d3ae..7bfa16ba05 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -3931,7 +3931,7 @@ getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) getSPEC_INLINE (L _ (ITspec_inline_prag src True)) = (Inline src,FunLike) getSPEC_INLINE (L _ (ITspec_inline_prag src False)) = (NoInline src,FunLike) getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x -getVOCURLY (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l +getVOCURLY (L (RealSrcSpan l) ITvocurly) = srcSpanStartCol l getINTEGERs (L _ (ITinteger (IL src _ _))) = src getCHARs (L _ (ITchar src _)) = src @@ -4390,7 +4390,7 @@ commentsPA la@(L l a) = do return (L (addCommentsToSrcAnn l cs) a) rs :: SrcSpan -> RealSrcSpan -rs (RealSrcSpan l _) = l +rs (RealSrcSpan l) = l rs _ = panic "Parser should only have RealSrcSpan" hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs index 101c14f4ef..56e9f87a2a 100644 --- a/compiler/GHC/Parser/Annotation.hs +++ b/compiler/GHC/Parser/Annotation.hs @@ -518,11 +518,11 @@ data EpAnn ann -- the element relative to its container. If it is moved, that -- relationship is tracked in the 'anchor_op' instead. -data Anchor = Anchor { anchor :: RealSrcSpan +data Anchor = Anchor { anchor :: !RealSrcSpan -- ^ Base location for the start of -- the syntactic element holding -- the annotations. - , anchor_op :: AnchorOperation } + , anchor_op :: !AnchorOperation } deriving (Data, Eq, Show) -- | If tools modify the parsed source, the 'MovedAnchor' variant can @@ -912,10 +912,10 @@ reLocN (L (SrcSpanAnn _ l) a) = L l a -- --------------------------------------------------------------------- realSrcSpan :: SrcSpan -> RealSrcSpan -realSrcSpan (RealSrcSpan s _) = s -realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary +realSrcSpan (RealSrcSpan s) = s +realSrcSpan _ = mkRealSrcSpan l l Strict.Nothing -- AZ temporary where - l = mkRealSrcLoc (fsLit "foo") (-1) (-1) + l = mkRealSrcLoc (fsLit "from UnhelpfulSpan") (-1) (-1) la2r :: SrcSpanAnn' a -> RealSrcSpan la2r l = realSrcSpan (locA l) @@ -977,7 +977,7 @@ widenSpan :: SrcSpan -> [AddEpAnn] -> SrcSpan widenSpan s as = foldl combineSrcSpans s (go as) where go [] = [] - go (AddEpAnn _ (EpaSpan s):rest) = RealSrcSpan s Strict.Nothing : go rest + go (AddEpAnn _ (EpaSpan s):rest) = RealSrcSpan s : go rest go (AddEpAnn _ (EpaDelta _ _):rest) = go rest -- | The annotations need to all come after the anchor. Make sure @@ -1074,7 +1074,7 @@ noComments = EpAnn (Anchor placeholderRealSpan UnchangedAnchor) NoEpAnns emptyCo -- TODO:AZ get rid of this placeholderRealSpan :: RealSrcSpan -placeholderRealSpan = realSrcLocSpan (mkRealSrcLoc (mkFastString "placeholder") (-1) (-1)) +placeholderRealSpan = realSrcLocSpan (mkRealSrcLoc (mkFastString "placeholder") (-1) (-1)) Strict.Nothing comment :: RealSrcSpan -> EpAnnComments -> EpAnnCO comment loc cs = EpAnn (Anchor loc UnchangedAnchor) NoEpAnns cs diff --git a/compiler/GHC/Parser/HaddockLex.x b/compiler/GHC/Parser/HaddockLex.x index e215769f9e..932ca8145b 100644 --- a/compiler/GHC/Parser/HaddockLex.x +++ b/compiler/GHC/Parser/HaddockLex.x @@ -120,7 +120,7 @@ getIdentifier :: Int -- ^ adornment length -- ^ The remaining input beginning with the found token -> (RealSrcSpan, ByteString) getIdentifier !i !loc0 !len0 !s0 = - (mkRealSrcSpan loc1 loc2, ident) + (mkRealSrcSpan loc1 loc2 Strict.Nothing, ident) where (adornment, s1) = BS.splitAt i s0 ident = BS.take (len0 - 2*i) s1 @@ -145,7 +145,7 @@ lexStringLiteral identParser (L l sl@(StringLiteral _ fs _)) plausibleIdents :: [(SrcSpan,ByteString)] plausibleIdents = case l of - RealSrcSpan span _ -> [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) bs] + RealSrcSpan span -> [(RealSrcSpan span', tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) bs] UnhelpfulSpan reason -> [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc bs] fakeLoc = mkRealSrcLoc (mkFastString "") 0 0 @@ -164,8 +164,8 @@ lexHsDoc identParser doc = maybeDocIdentifier = uncurry (validateIdentWith identParser) plausibleIdents :: LHsDocStringChunk -> [(SrcSpan,ByteString)] - plausibleIdents (L (RealSrcSpan span _) (HsDocStringChunk s)) - = [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) s] + plausibleIdents (L (RealSrcSpan span) (HsDocStringChunk s)) + = [(RealSrcSpan span', tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) s] plausibleIdents (L (UnhelpfulSpan reason) (HsDocStringChunk s)) = [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc s] -- preserve the original reason @@ -190,12 +190,12 @@ validateIdentWith identParser mloc str0 = } buffer = stringBufferFromByteString str0 realSrcLc = case mloc of - RealSrcSpan loc _ -> realSrcSpanStart loc + RealSrcSpan loc -> realSrcSpanStart loc UnhelpfulSpan _ -> mkRealSrcLoc (mkFastString "") 0 0 pstate = initParserState pflags buffer realSrcLc in case unP identParser pstate of POk _ name -> Just $ case mloc of - RealSrcSpan _ _ -> reLoc name + RealSrcSpan _ -> reLoc name UnhelpfulSpan _ -> L mloc (unLoc name) -- Preserve the original reason _ -> Nothing } diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs index 9daf8e5d71..65561ff846 100644 --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -362,7 +362,7 @@ toArgs starting_loc orig_str advance_src_loc_many = foldl' advanceSrcLoc locate :: RealSrcLoc -> RealSrcLoc -> a -> Located a - locate begin end x = L (RealSrcSpan (mkRealSrcSpan begin end) Strict.Nothing) x + locate begin end x = L (RealSrcSpan (mkRealSrcSpan begin end Strict.Nothing)) x toArgs' :: RealSrcLoc -> String -> Either String [Located String] -- Remove outer quotes: diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index 26f0de2873..52bcf93966 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -1980,7 +1980,7 @@ setColumn (PsSpan span _) buf len _buf2 = do lexToken alrInitialLoc :: FastString -> RealSrcSpan -alrInitialLoc file = mkRealSrcSpan loc loc +alrInitialLoc file = mkRealSrcSpan loc loc Strict.Nothing -- invalid loc, so not needed where -- This is a hack to ensure that the first line in a file -- looks like it is after the initial location: loc = mkRealSrcLoc file (-1) (-1) @@ -2348,7 +2348,7 @@ warnTab srcspan _buf _len _buf2 = do warnThen :: PsMessage -> Action -> Action warnThen warning action srcspan buf len buf2 = do - addPsMessage (RealSrcSpan (psRealSpan srcspan) Strict.Nothing) warning + addPsMessage (RealSrcSpan (psRealSpan srcspan)) warning action srcspan buf len buf2 -- ----------------------------------------------------------------------------- @@ -2518,7 +2518,7 @@ failMsgP f = do failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> MsgEnvelope PsMessage) -> P a failLocMsgP loc1 loc2 f = - addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Strict.Nothing)) + addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2 Strict.Nothing))) getPState :: P PState getPState = P $ \s -> POk s s @@ -3057,15 +3057,15 @@ instance MonadP P where } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns) getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments -getCommentsFor (RealSrcSpan l _) = allocateCommentsP l +getCommentsFor (RealSrcSpan l) = allocateCommentsP l getCommentsFor _ = return emptyComments getPriorCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments -getPriorCommentsFor (RealSrcSpan l _) = allocatePriorCommentsP l +getPriorCommentsFor (RealSrcSpan l) = allocatePriorCommentsP l getPriorCommentsFor _ = return emptyComments getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments -getFinalCommentsFor (RealSrcSpan l _) = allocateFinalCommentsP l +getFinalCommentsFor (RealSrcSpan l) = allocateFinalCommentsP l getFinalCommentsFor _ = return emptyComments getEofPos :: P (Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan)) @@ -3103,7 +3103,7 @@ getPsMessages p = Strict.Nothing -> ws Strict.Just tf -> let msg = mkPlainMsgEnvelope diag_opts - (RealSrcSpan tf Strict.Nothing) + (RealSrcSpan tf) (PsWarnTab (tab_count p)) in msg `addMessage` ws in (ws', errors p) @@ -3564,7 +3564,7 @@ warn_unknown_prag prags span buf len buf2 = do let uppercase = map toUpper unknown_prag = uppercase (clean_pragma (lexemeToString buf len)) suggestions = map uppercase (Map.keys prags) - addPsMessage (RealSrcSpan (psRealSpan span) Strict.Nothing) $ + addPsMessage (RealSrcSpan (psRealSpan span)) $ PsWarnUnrecognisedPragma unknown_prag suggestions nested_comment span buf len buf2 @@ -3588,8 +3588,8 @@ mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo),AddEpAnn AnnCloseP (EpaSpan l sc = srcSpanStartCol ss el = srcSpanEndLine ss ec = srcSpanEndCol ss - lo = mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1)) - lc = mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss) + lo = mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1)) Strict.Nothing + lc = mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss) Strict.Nothing queueComment :: RealLocated Token -> P() queueComment c = P $ \s -> POk s { diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 99e8fd10c8..9fd20a4a67 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -1041,13 +1041,13 @@ checkTyClHdr is_cls ty let lr = combineRealSrcSpans (realSrcSpan l) (anchor as) an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c []) cs) - in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing) + in SrcSpanAnn an (RealSrcSpan lr) newAnns _ EpAnnNotUsed = panic "missing AnnParen" newAnns (SrcSpanAnn (EpAnn ap (AnnListItem ta) csp) l) (EpAnn as (AnnParen _ o c) cs) = let lr = combineRealSrcSpans (anchor ap) (anchor as) an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c ta) (csp Semi.<> cs)) - in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing) + in SrcSpanAnn an (RealSrcSpan lr) -- | Yield a parse error if we have a function applied directly to a do block -- etc. and BlockArguments is not enabled. @@ -1133,18 +1133,18 @@ checkImportDecl mPre mPost = do -- 'ImportQualifiedPost' is not in effect. whenJust mPost $ \post -> when (not importQualifiedPostEnabled) $ - failNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing) + failNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post)) -- Error if 'qualified' occurs in both pre and postpositive -- positions. whenJust mPost $ \post -> when (isJust mPre) $ - failImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing) + failImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post)) -- Warn if 'qualified' found in prepositive position and -- 'Opt_WarnPrepositiveQualifiedModule' is enabled. whenJust mPre $ \pre -> - warnPrepositiveQualifiedModule (RealSrcSpan (epaLocationRealSrcSpan pre) Strict.Nothing) + warnPrepositiveQualifiedModule (RealSrcSpan (epaLocationRealSrcSpan pre)) -- ------------------------------------------------------------------------- -- Checking Patterns. @@ -3125,13 +3125,13 @@ mkMultTy pct t arr = HsExplicitMult pct t arr mkTokenLocation :: SrcSpan -> TokenLocation mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc -mkTokenLocation (RealSrcSpan r _) = TokenLoc (EpaSpan r) +mkTokenLocation (RealSrcSpan r) = TokenLoc (EpaSpan r) -- Precondition: the TokenLocation has EpaSpan, never EpaDelta. token_location_widenR :: TokenLocation -> SrcSpan -> TokenLocation token_location_widenR NoTokenLoc _ = NoTokenLoc token_location_widenR tl (UnhelpfulSpan _) = tl -token_location_widenR (TokenLoc (EpaSpan r1)) (RealSrcSpan r2 _) = +token_location_widenR (TokenLoc (EpaSpan r1)) (RealSrcSpan r2) = (TokenLoc (EpaSpan (combineRealSrcSpans r1 r2))) token_location_widenR (TokenLoc (EpaDelta _ _)) _ = -- Never happens because the parser does not produce EpaDelta. diff --git a/compiler/GHC/Stg/Debug.hs b/compiler/GHC/Stg/Debug.hs index 4dbd5af526..a03b3f026e 100644 --- a/compiler/GHC/Stg/Debug.hs +++ b/compiler/GHC/Stg/Debug.hs @@ -74,7 +74,7 @@ collectStgRhs bndr (StgRhsClosure ext cc us bs e)= do -- If the name has a span, use that initially as the source position in-case -- we don't get anything better. with_span = case nameSrcSpan name of - RealSrcSpan pos _ -> withSpan (pos, occNameString (getOccName name)) + RealSrcSpan pos -> withSpan (pos, occNameString (getOccName name)) _ -> id e' <- with_span $ collectExpr e recordInfo bndr e' diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 021d163d84..6fbd422422 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -76,7 +76,6 @@ import GHC.Utils.FV ( fvVarList, unionFV ) import GHC.Data.Bag import GHC.Data.List.SetOps ( equivClasses, nubOrdBy ) import GHC.Data.Maybe -import qualified GHC.Data.Strict as Strict import Control.Monad ( unless, when, foldM, forM_ ) import Data.Foldable ( toList ) @@ -1177,7 +1176,7 @@ mkErrorReport tcl_env msg mb_ctxt supplementary (vcat $ map (pprSolverReportSupplementary hfdc) supplementary) ; let detailed_msg = mkDetailedMessage err_info msg ; mkTcRnMessage - (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing) + (RealSrcSpan (tcl_loc tcl_env)) (TcRnMessageWithInfo unit_state $ detailed_msg) } diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index f4490244f8..c856523f4f 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -1401,7 +1401,7 @@ instance TH.Quasi TcM where ; r <- case l of UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" (ppr l) - RealSrcSpan s _ -> return s + RealSrcSpan s -> return s ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) , TH.loc_module = moduleNameString (moduleName m) , TH.loc_package = unitString (moduleUnit m) diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 68728cd3d7..a38977b91e 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -203,7 +203,7 @@ tcRnModule :: HscEnv tcRnModule hsc_env mod_sum save_rn_syntax parsedModule@HsParsedModule {hpm_module= L loc this_module} - | RealSrcSpan real_loc _ <- loc + | RealSrcSpan real_loc <- loc = withTiming logger (text "Renamer/typechecker"<+>brackets (ppr this_mod)) (const ()) $ diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 4cba3f20b1..06219fb374 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -84,6 +84,7 @@ import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Data.Maybe +import qualified GHC.Data.Strict as Strict import Control.Monad import Data.List (find) @@ -368,7 +369,7 @@ tcRnCheckUnit hsc_env uid = HsigFile -- bogus False (mainModIs (hsc_HUE hsc_env)) - (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus + (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0) Strict.Nothing) -- bogus $ checkUnit uid where dflags = hsc_dflags hsc_env diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 8319212147..272701b6c3 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -423,7 +423,7 @@ initTcInteractive :: HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a) initTcInteractive hsc_env thing_inside = initTc hsc_env HsSrcFile False (icInteractiveModule (hsc_IC hsc_env)) - (realSrcLocSpan interactive_src_loc) + (realSrcLocSpan interactive_src_loc Strict.Nothing) thing_inside where interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1 @@ -964,7 +964,7 @@ addDependentFiles fs = do getSrcSpanM :: TcRn SrcSpan -- Avoid clash with Name.getSrcLoc -getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Strict.Nothing) } +getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) } -- See Note [Error contexts in generated code] inGeneratedCode :: TcRn Bool @@ -973,7 +973,7 @@ inGeneratedCode = tcl_in_gen_code <$> getLclEnv setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -- See Note [Error contexts in generated code] -- for the tcl_in_gen_code manipulation -setSrcSpan (RealSrcSpan loc _) thing_inside +setSrcSpan (RealSrcSpan loc) thing_inside = updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False }) thing_inside diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs index 3bc7937df0..84e87d7802 100644 --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -548,7 +548,7 @@ getMessageClassColour _ = const mempty getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty -getCaretDiagnostic msg_class (RealSrcSpan span _) = +getCaretDiagnostic msg_class (RealSrcSpan span) = caretDiagnostic <$> getSrcLine (srcSpanFile span) row where getSrcLine fn i = diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs index 53890e8daf..62190c7917 100644 --- a/compiler/GHC/Types/Hint/Ppr.hs +++ b/compiler/GHC/Types/Hint/Ppr.hs @@ -267,7 +267,7 @@ pprSimilarName tried_ns (SimilarRdrName rdr_name how_in_scope) where loc' = case loc of UnhelpfulSpan l -> parens (ppr l) - RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l)) + RealSrcSpan l -> parens (text "line" <+> int (srcSpanStartLine l)) ImportedBy is -> pp_ns rdr_name <+> quotes (ppr rdr_name) <+> parens (text "imported from" <+> ppr (is_mod is)) diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs index feecb3bfc3..142242d05a 100644 --- a/compiler/GHC/Types/Name/Reader.hs +++ b/compiler/GHC/Types/Name/Reader.hs @@ -1370,7 +1370,7 @@ instance Outputable ImportSpec where | otherwise = empty pprLoc :: SrcSpan -> SDoc -pprLoc (RealSrcSpan s _) = text "at" <+> ppr s +pprLoc (RealSrcSpan s) = text "at" <+> ppr s pprLoc (UnhelpfulSpan {}) = empty -- | Indicate if the given name is the "@" operator diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs index 1f6d285b38..59c3cb7ded 100644 --- a/compiler/GHC/Types/SrcLoc.hs +++ b/compiler/GHC/Types/SrcLoc.hs @@ -300,7 +300,7 @@ lookupSrcLoc (RealSrcLoc l _) = Map.lookup l lookupSrcLoc (UnhelpfulLoc _) = const Nothing lookupSrcSpan :: SrcSpan -> Map.Map RealSrcSpan a -> Maybe a -lookupSrcSpan (RealSrcSpan l _) = Map.lookup l +lookupSrcSpan (RealSrcSpan l ) = Map.lookup l lookupSrcSpan (UnhelpfulSpan _) = const Nothing instance Outputable RealSrcLoc where @@ -361,7 +361,8 @@ data RealSrcSpan srcSpanSLine :: {-# UNPACK #-} !Int, srcSpanSCol :: {-# UNPACK #-} !Int, srcSpanELine :: {-# UNPACK #-} !Int, - srcSpanECol :: {-# UNPACK #-} !Int + srcSpanECol :: {-# UNPACK #-} !Int, + srcSpanBufSpan :: !(Strict.Maybe BufSpan) -- See Note [Why Maybe BufPos] } deriving Eq @@ -379,7 +380,7 @@ instance Semigroup BufSpan where -- A 'SrcSpan' identifies either a specific portion of a text file -- or a human-readable description of a location. data SrcSpan = - RealSrcSpan !RealSrcSpan !(Strict.Maybe BufSpan) -- See Note [Why Maybe BufPos] + RealSrcSpan !RealSrcSpan | UnhelpfulSpan !UnhelpfulSpanReason deriving (Eq, Show) -- Show is used by GHC.Parser.Lexer, because we @@ -394,7 +395,8 @@ data UnhelpfulSpanReason deriving (Eq, Show) removeBufSpan :: SrcSpan -> SrcSpan -removeBufSpan (RealSrcSpan s _) = RealSrcSpan s Strict.Nothing +removeBufSpan (RealSrcSpan (RealSrcSpan' f sl sc el ec _)) + = RealSrcSpan (RealSrcSpan' f sl sc el ec Strict.Nothing) removeBufSpan s = s {- Note [Why Maybe BufPos] @@ -419,7 +421,7 @@ messages, constructing a SrcSpan without a BufSpan. instance ToJson SrcSpan where json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")] - json (RealSrcSpan rss _) = json rss + json (RealSrcSpan rss) = json rss instance ToJson RealSrcSpan where json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)) @@ -433,7 +435,7 @@ instance NFData SrcSpan where rnf x = x `seq` () getBufSpan :: SrcSpan -> Strict.Maybe BufSpan -getBufSpan (RealSrcSpan _ mbspan) = mbspan +getBufSpan (RealSrcSpan s) = srcSpanBufSpan s getBufSpan (UnhelpfulSpan _) = Strict.Nothing -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty @@ -458,14 +460,14 @@ mkGeneralSrcSpan = UnhelpfulSpan . UnhelpfulOther -- | Create a 'SrcSpan' corresponding to a single point srcLocSpan :: SrcLoc -> SrcSpan srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan (UnhelpfulOther str) -srcLocSpan (RealSrcLoc l mb) = RealSrcSpan (realSrcLocSpan l) (fmap (\b -> BufSpan b b) mb) +srcLocSpan (RealSrcLoc l mb) = RealSrcSpan (realSrcLocSpan l (fmap (\b -> BufSpan b b) mb)) -realSrcLocSpan :: RealSrcLoc -> RealSrcSpan +realSrcLocSpan :: RealSrcLoc -> (Strict.Maybe BufSpan) -> RealSrcSpan realSrcLocSpan (SrcLoc (LexicalFastString file) line col) = RealSrcSpan' file line col line col -- | Create a 'SrcSpan' between two points in a file -mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan -mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2 +mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> (Strict.Maybe BufSpan) -> RealSrcSpan +mkRealSrcSpan loc1 loc2 mb = RealSrcSpan' file line1 col1 line2 col2 mb where line1 = srcLocLine loc1 line2 = srcLocLine loc2 @@ -475,12 +477,12 @@ mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2 -- | 'True' if the span is known to straddle only one line. isOneLineRealSpan :: RealSrcSpan -> Bool -isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _) +isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _ _) = line1 == line2 -- | 'True' if the span is a single point isPointRealSpan :: RealSrcSpan -> Bool -isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2) +isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2 _) = line1 == line2 && col1 == col2 -- | Create a 'SrcSpan' between two points in a file @@ -488,16 +490,16 @@ mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan (UnhelpfulOther str) mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan (UnhelpfulOther str) mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 mbpos2) - = RealSrcSpan (mkRealSrcSpan loc1 loc2) (liftA2 BufSpan mbpos1 mbpos2) + = RealSrcSpan (mkRealSrcSpan loc1 loc2 (liftA2 BufSpan mbpos1 mbpos2)) -- | Combines two 'SrcSpan' into one that spans at least all the characters -- within both spans. Returns UnhelpfulSpan if the files differ. combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful combineSrcSpans l (UnhelpfulSpan _) = l -combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2) +combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2) | srcSpanFile span1 == srcSpanFile span2 - = RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2) + = RealSrcSpan (combineRealSrcSpans span1 span2) | otherwise = UnhelpfulSpan $ UnhelpfulOther (fsLit "<combineSrcSpans: files differ>") @@ -505,13 +507,16 @@ combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2) -- within both spans. Assumes the "file" part is the same in both inputs combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan combineRealSrcSpans span1 span2 - = RealSrcSpan' file line_start col_start line_end col_end + = RealSrcSpan' file line_start col_start line_end col_end mbspan where (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) (srcSpanStartLine span2, srcSpanStartCol span2) (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) (srcSpanEndLine span2, srcSpanEndCol span2) file = srcSpanFile span1 + mbspan = case ((srcSpanBufSpan span1), (srcSpanBufSpan span2)) of + (Strict.Just mb1, Strict.Just mb2) -> Strict.Just (combineBufSpans mb1 mb2) + _ -> Strict.Nothing combineBufSpans :: BufSpan -> BufSpan -> BufSpan combineBufSpans span1 span2 = BufSpan start end @@ -523,9 +528,10 @@ combineBufSpans span1 span2 = BufSpan start end -- | Convert a SrcSpan into one that represents only its first character srcSpanFirstCharacter :: SrcSpan -> SrcSpan srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l -srcSpanFirstCharacter (RealSrcSpan span mbspan) = - RealSrcSpan (mkRealSrcSpan loc1 loc2) (fmap mkBufSpan mbspan) +srcSpanFirstCharacter (RealSrcSpan span) = + RealSrcSpan (mkRealSrcSpan loc1 loc2 (fmap mkBufSpan mbspan)) where + mbspan = srcSpanBufSpan span loc1@(SrcLoc f l c) = realSrcSpanStart span loc2 = SrcLoc f l (c+1) mkBufSpan bspan = @@ -543,20 +549,20 @@ srcSpanFirstCharacter (RealSrcSpan span mbspan) = -- | Test if a 'SrcSpan' is "good", i.e. has precise location information isGoodSrcSpan :: SrcSpan -> Bool -isGoodSrcSpan (RealSrcSpan _ _) = True +isGoodSrcSpan (RealSrcSpan _) = True isGoodSrcSpan (UnhelpfulSpan _) = False isOneLineSpan :: SrcSpan -> Bool -- ^ True if the span is known to straddle only one line. -- For "bad" 'SrcSpan', it returns False -isOneLineSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s +isOneLineSpan (RealSrcSpan s ) = srcSpanStartLine s == srcSpanEndLine s isOneLineSpan (UnhelpfulSpan _) = False isZeroWidthSpan :: SrcSpan -> Bool -- ^ True if the span has a width of zero, as returned for "virtual" -- semicolons in the lexer. -- For "bad" 'SrcSpan', it returns False -isZeroWidthSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s +isZeroWidthSpan (RealSrcSpan s ) = srcSpanStartLine s == srcSpanEndLine s && srcSpanStartCol s == srcSpanEndCol s isZeroWidthSpan (UnhelpfulSpan _) = False @@ -600,12 +606,12 @@ srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c -- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable srcSpanStart :: SrcSpan -> SrcLoc srcSpanStart (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r) -srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b) +srcSpanStart (RealSrcSpan s) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart $ srcSpanBufSpan s) -- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable srcSpanEnd :: SrcSpan -> SrcLoc srcSpanEnd (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r) -srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b) +srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd $ srcSpanBufSpan s) realSrcSpanStart :: RealSrcSpan -> RealSrcLoc realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s) @@ -619,11 +625,11 @@ realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s) -- | Obtains the filename for a 'SrcSpan' if it is "good" srcSpanFileName_maybe :: SrcSpan -> Maybe FastString -srcSpanFileName_maybe (RealSrcSpan s _) = Just (srcSpanFile s) +srcSpanFileName_maybe (RealSrcSpan s ) = Just (srcSpanFile s) srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing srcSpanToRealSrcSpan :: SrcSpan -> Maybe RealSrcSpan -srcSpanToRealSrcSpan (RealSrcSpan ss _) = Just ss +srcSpanToRealSrcSpan (RealSrcSpan ss ) = Just ss srcSpanToRealSrcSpan _ = Nothing {- @@ -645,7 +651,7 @@ instance Show RealSrcLoc where -- Show is used by GHC.Parser.Lexer, because we derive Show for Token instance Show RealSrcSpan where - show span@(RealSrcSpan' file sl sc el ec) + show span@(RealSrcSpan' file sl sc el ec _) | isPointRealSpan span = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc]) @@ -697,16 +703,16 @@ pprUnhelpfulSpanReason r = ftext (unhelpfulSpanFS r) pprUserSpan :: Bool -> SrcSpan -> SDoc pprUserSpan _ (UnhelpfulSpan r) = pprUnhelpfulSpanReason r -pprUserSpan show_path (RealSrcSpan s _) = pprUserRealSpan show_path s +pprUserSpan show_path (RealSrcSpan s ) = pprUserRealSpan show_path s pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc -pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _) +pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _ _) | isPointRealSpan span = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) , int line <> colon , int col ] -pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol) +pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol _) | isOneLineRealSpan span = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) , int line <> colon @@ -715,7 +721,7 @@ pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol) -- For single-character or point spans, we just -- output the starting column number -pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol) +pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol _) = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) , parens (int sline <> comma <> int scol) , char '-' @@ -788,7 +794,7 @@ instance (Outputable e) => Outputable (Located e) where instance (Outputable e) => Outputable (GenLocated RealSrcSpan e) where ppr (L l e) = -- GenLocated: -- Print spans without the file name etc - whenPprDebug (braces (pprUserSpan False (RealSrcSpan l Strict.Nothing))) + whenPprDebug (braces (pprUserSpan False (RealSrcSpan l))) $$ ppr e @@ -820,22 +826,22 @@ leftmost_largest = compareSrcSpanBy $ on compare realSrcSpanStart S.<> flip (on compare realSrcSpanEnd) compareSrcSpanBy :: (RealSrcSpan -> RealSrcSpan -> Ordering) -> SrcSpan -> SrcSpan -> Ordering -compareSrcSpanBy cmp (RealSrcSpan a _) (RealSrcSpan b _) = cmp a b -compareSrcSpanBy _ (RealSrcSpan _ _) (UnhelpfulSpan _) = LT -compareSrcSpanBy _ (UnhelpfulSpan _) (RealSrcSpan _ _) = GT +compareSrcSpanBy cmp (RealSrcSpan a ) (RealSrcSpan b ) = cmp a b +compareSrcSpanBy _ (RealSrcSpan _ ) (UnhelpfulSpan _) = LT +compareSrcSpanBy _ (UnhelpfulSpan _) (RealSrcSpan _ ) = GT compareSrcSpanBy _ (UnhelpfulSpan _) (UnhelpfulSpan _) = EQ -- | Determines whether a span encloses a given line and column index spans :: SrcSpan -> (Int, Int) -> Bool spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" -spans (RealSrcSpan span _) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span +spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span where loc = mkRealSrcLoc (srcSpanFile span) l c -- | Determines whether a span is enclosed by another one isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other -> SrcSpan -- ^ The span it may be enclosed by -> Bool -isSubspanOf (RealSrcSpan src _) (RealSrcSpan parent _) = isRealSubspanOf src parent +isSubspanOf (RealSrcSpan src) (RealSrcSpan parent) = isRealSubspanOf src parent isSubspanOf _ _ = False -- | Determines whether a span is enclosed by another one @@ -862,6 +868,7 @@ data PsLoc = PsLoc { psRealLoc :: !RealSrcLoc, psBufPos :: !BufPos } deriving (Eq, Ord, Show) +-- TODO:AZ: PsSpan can go away? data PsSpan = PsSpan { psRealSpan :: !RealSrcSpan, psBufSpan :: !BufSpan } deriving (Eq, Ord, Show, Data) @@ -876,7 +883,8 @@ advancePsLoc (PsLoc real_loc buf_loc) c = PsLoc (advanceSrcLoc real_loc c) (advanceBufPos buf_loc) mkPsSpan :: PsLoc -> PsLoc -> PsSpan -mkPsSpan (PsLoc r1 b1) (PsLoc r2 b2) = PsSpan (mkRealSrcSpan r1 r2) (BufSpan b1 b2) +mkPsSpan (PsLoc r1 b1) (PsLoc r2 b2) + = PsSpan (mkRealSrcSpan r1 r2 (Strict.Just (BufSpan b1 b2))) (BufSpan b1 b2) psSpanStart :: PsSpan -> PsLoc psSpanStart (PsSpan r b) = PsLoc (realSrcSpanStart r) (bufSpanStart b) @@ -885,7 +893,7 @@ psSpanEnd :: PsSpan -> PsLoc psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b) mkSrcSpanPs :: PsSpan -> SrcSpan -mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Strict.Just b) +mkSrcSpanPs (PsSpan r _) = RealSrcSpan r -- | Layout information for declarations. data LayoutInfo = diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs index f224589ee0..aa9848c707 100644 --- a/compiler/GHC/Utils/Binary.hs +++ b/compiler/GHC/Utils/Binary.hs @@ -1310,7 +1310,8 @@ instance Binary RealSrcSpan where el <- get bh ec <- get bh return (mkRealSrcSpan (mkRealSrcLoc f sl sc) - (mkRealSrcLoc f el ec)) + (mkRealSrcLoc f el ec) + Strict.Nothing) instance Binary UnhelpfulSpanReason where put_ bh r = case r of @@ -1330,7 +1331,7 @@ instance Binary UnhelpfulSpanReason where _ -> UnhelpfulOther <$> get bh instance Binary SrcSpan where - put_ bh (RealSrcSpan ss _sb) = do + put_ bh (RealSrcSpan ss) = do putByte bh 0 -- BufSpan doesn't ever get serialised because the positions depend -- on build location. @@ -1344,7 +1345,7 @@ instance Binary SrcSpan where h <- getByte bh case h of 0 -> do ss <- get bh - return (RealSrcSpan ss Strict.Nothing) + return (RealSrcSpan ss) _ -> do s <- get bh return (UnhelpfulSpan s) |