diff options
Diffstat (limited to 'compiler')
26 files changed, 318 insertions, 191 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index f973507dee..af0fb5885a 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -1397,7 +1397,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 @@ -1417,13 +1417,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/Lexer.x b/compiler/GHC/Cmm/Lexer.x index d8f15b916c..be2f676608 100644 --- a/compiler/GHC/Cmm/Lexer.x +++ b/compiler/GHC/Cmm/Lexer.x @@ -185,7 +185,7 @@ data CmmToken -- ----------------------------------------------------------------------------- -- Lexer actions -type Action = RealSrcSpan -> StringBuffer -> Int -> PD (RealLocated CmmToken) +type Action = PsSpan -> StringBuffer -> Int -> PD (PsLocated CmmToken) begin :: Int -> Action begin code _span _str _len = do liftP (pushLexState code); lexToken @@ -290,7 +290,7 @@ tok_string str = CmmT_String (read str) -- Line pragmas setLine :: Int -> Action -setLine code span buf len = do +setLine code (PsSpan span _) buf len = do let line = parseUnsignedInteger buf len 10 octDecDigit liftP $ do setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) @@ -300,7 +300,7 @@ setLine code span buf len = do lexToken setFile :: Int -> Action -setFile code span buf len = do +setFile code (PsSpan span _) buf len = do let file = lexemeToFastString (stepOn buf) (len-2) liftP $ do setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) @@ -315,23 +315,23 @@ cmmlex :: (Located CmmToken -> PD a) -> PD a cmmlex cont = do (L span tok) <- lexToken --trace ("token: " ++ show tok) $ do - cont (L (RealSrcSpan span) tok) + cont (L (mkSrcSpanPs span) tok) -lexToken :: PD (RealLocated CmmToken) +lexToken :: PD (PsLocated CmmToken) lexToken = do inp@(loc1,buf) <- getInput sc <- liftP getLexState case alexScan inp sc of - AlexEOF -> do let span = mkRealSrcSpan loc1 loc1 + AlexEOF -> do let span = mkPsSpan loc1 loc1 liftP (setLastToken span 0) return (L span CmmT_EOF) - AlexError (loc2,_) -> liftP $ failLocMsgP loc1 loc2 "lexical error" + AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) "lexical error" AlexSkip inp2 _ -> do setInput inp2 lexToken AlexToken inp2@(end,_buf2) len t -> do setInput inp2 - let span = mkRealSrcSpan loc1 end + let span = mkPsSpan loc1 end span `seq` liftP (setLastToken span len) t span buf len @@ -339,7 +339,7 @@ lexToken = do -- Monad stuff -- Stuff that Alex needs to know about our input type: -type AlexInput = (RealSrcLoc,StringBuffer) +type AlexInput = (PsLoc,StringBuffer) alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (_,s) = prevChar s '\n' @@ -357,7 +357,7 @@ alexGetByte (loc,s) | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s')) where c = currentChar s b = fromIntegral $ ord $ c - loc' = advanceSrcLoc loc c + loc' = advancePsLoc loc c s' = stepOn s getInput :: PD AlexInput diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index fd875aa8e8..d303e435d0 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -1356,7 +1356,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 3e7e5f3f55..f40cfeb286 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -240,7 +240,7 @@ mkDataConWorkers dflags mod_loc data_tycons -- worker. This is useful, especially for heap profiling. tick_it name | debugLevel dflags == 0 = 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 $ showSDoc dflags (ppr name)) diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 960b2840fa..b12d579382 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -93,7 +93,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds , 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 dflags @@ -1145,7 +1145,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 @@ -1169,7 +1169,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 @@ -1241,7 +1241,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do , mixEntries = me:mixEntries st } return $ Breakpoint c ids - SourceNotes | RealSrcSpan pos' <- pos -> + SourceNotes | RealSrcSpan pos' _ <- pos -> return $ SourceNote pos' cc_name _otherwise -> panic "mkTickish: bad source span!" @@ -1278,7 +1278,7 @@ mkBinTickBoxHpc boxLabel pos e = ) 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 e6c63efade..a34beae019 100644 --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -75,7 +75,7 @@ mkMaps instances decls = -> ( [(Name, HsDocString)] , [(Name, Map Int (HsDocString))] ) - mappings (L (RealSrcSpan l) decl, docStrs) = + mappings (L (RealSrcSpan l _) decl, docStrs) = (dm, am) where doc = concatDocs docStrs @@ -94,7 +94,7 @@ mkMaps instances decls = mappings (L (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 l (InstD _ d) = maybeToList $ -- See Note [1]. diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 5736d61104..36ab7eee9d 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -489,7 +489,8 @@ dsExpr (HsStatic _ expr@(L loc _)) = do dflags <- getDynFlags let (line, col) = case loc of - RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r + RealSrcSpan r _ -> + ( srcLocLine $ realSrcSpanStart r , srcLocCol $ realSrcSpanStart r ) _ -> (0, 0) diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index 8260c6b773..4893d13bb1 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -392,12 +392,12 @@ updPmDeltas delta = updLclEnv (\env -> env { dsl_deltas = delta }) getSrcSpanDs :: DsM SrcSpan getSrcSpanDs = do { env <- getLclEnv - ; return (RealSrcSpan (dsl_loc env)) } + ; return (RealSrcSpan (dsl_loc env) Nothing) } 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 -- | Emit a warning for the current source location diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs index 9c93f9850c..efe9a80871 100644 --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/compiler/GHC/HsToCore/PmCheck.hs @@ -174,8 +174,8 @@ data AnnotatedTree -- ^ Mirrors 'Empty' for preserving the skeleton of a 'GrdTree's. pprRhsInfo :: RhsInfo -> SDoc -pprRhsInfo (L (RealSrcSpan rss) _) = ppr (srcSpanStartLine rss) -pprRhsInfo (L s _) = ppr s +pprRhsInfo (L (RealSrcSpan rss _) _) = ppr (srcSpanStartLine rss) +pprRhsInfo (L s _) = ppr s instance Outputable GrdTree where ppr (Rhs info) = text "->" <+> pprRhsInfo info diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index d6386357ca..cb910d927b 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -297,7 +297,7 @@ enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do ] getRealSpan :: SrcSpan -> Maybe Span -getRealSpan (RealSrcSpan sp) = Just sp +getRealSpan (RealSrcSpan sp _) = Just sp getRealSpan _ = Nothing grhss_span :: GRHSs p body -> SrcSpan @@ -307,7 +307,7 @@ grhss_span (XGRHSs _) = panic "XGRHS has no span" bindingsOnly :: [Context Name] -> [HieAST a] bindingsOnly [] = [] bindingsOnly (C c n : xs) = case nameSrcSpan n of - RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs + RealSrcSpan span _ -> Node nodeinfo span [] : bindingsOnly xs where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info) info = mempty{identInfo = S.singleton c} _ -> bindingsOnly xs @@ -531,7 +531,7 @@ instance ToHie (TScoped NoExtField) where toHie _ = pure [] instance ToHie (IEContext (Located ModuleName)) where - toHie (IEC c (L (RealSrcSpan span) mname)) = + toHie (IEC c (L (RealSrcSpan span _) mname)) = pure $ [Node (NodeInfo S.empty [] idents) span []] where details = mempty{identInfo = S.singleton (IEThing c)} idents = M.singleton (Left mname) details @@ -539,7 +539,7 @@ instance ToHie (IEContext (Located ModuleName)) where instance ToHie (Context (Located Var)) where toHie c = case c of - C context (L (RealSrcSpan span) name') + C context (L (RealSrcSpan span _) name') -> do m <- asks name_remapping let name = case lookupNameEnv m (varName name') of @@ -557,7 +557,7 @@ instance ToHie (Context (Located Var)) where instance ToHie (Context (Located Name)) where toHie c = case c of - C context (L (RealSrcSpan span) name') -> do + C context (L (RealSrcSpan span _) name') -> do m <- asks name_remapping let name = case lookupNameEnv m name' of Just var -> varName var diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs index 1e0a241384..0f962c7164 100644 --- a/compiler/GHC/Iface/Ext/Utils.hs +++ b/compiler/GHC/Iface/Ext/Utils.hs @@ -227,7 +227,7 @@ getNameScopeAndBinding -> M.Map FastString (HieAST a) -> Maybe ([Scope], Maybe Span) getNameScopeAndBinding n asts = case nameSrcSpan n of - RealSrcSpan sp -> do -- @Maybe + RealSrcSpan sp _ -> do -- @Maybe ast <- M.lookup (srcSpanFile sp) asts defNode <- selectLargestContainedBy sp ast getFirst $ foldMap First $ do -- @[] @@ -290,7 +290,7 @@ selectSmallestContaining sp node definedInAsts :: M.Map FastString (HieAST a) -> Name -> Bool definedInAsts asts n = case nameSrcSpan n of - RealSrcSpan sp -> srcSpanFile sp `elem` M.keys asts + RealSrcSpan sp _ -> srcSpanFile sp `elem` M.keys asts _ -> False isOccurrence :: ContextInfo -> Bool @@ -406,13 +406,13 @@ simpleNodeInfo :: FastString -> FastString -> NodeInfo a simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty locOnly :: SrcSpan -> [HieAST a] -locOnly (RealSrcSpan span) = +locOnly (RealSrcSpan span _) = [Node e span []] where e = NodeInfo S.empty [] M.empty locOnly _ = [] mkScope :: SrcSpan -> Scope -mkScope (RealSrcSpan sp) = LocalScope sp +mkScope (RealSrcSpan sp _) = LocalScope sp mkScope _ = NoScope mkLScope :: Located a -> Scope @@ -424,7 +424,7 @@ combineScopes _ ModuleScope = ModuleScope combineScopes NoScope x = x combineScopes x NoScope = x combineScopes (LocalScope a) (LocalScope b) = - mkScope $ combineSrcSpans (RealSrcSpan a) (RealSrcSpan b) + mkScope $ combineSrcSpans (RealSrcSpan a Nothing) (RealSrcSpan b Nothing) {-# INLINEABLE makeNode #-} makeNode @@ -433,7 +433,7 @@ makeNode -> SrcSpan -- ^ return an empty list if this is unhelpful -> m [HieAST b] makeNode x spn = pure $ case spn of - RealSrcSpan span -> [Node (simpleNodeInfo cons typ) span []] + RealSrcSpan span _ -> [Node (simpleNodeInfo cons typ) span []] _ -> [] where cons = mkFastString . show . toConstr $ x @@ -447,7 +447,7 @@ makeTypeNode -> Type -- ^ type to associate with the node -> m [HieAST Type] makeTypeNode x spn etyp = pure $ case spn of - RealSrcSpan span -> + RealSrcSpan span _ -> [Node (NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []] _ -> [] where diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index d57453fdd7..999389bb02 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -1474,7 +1474,7 @@ mkImportMap gres add_one gre@(GRE { gre_imp = imp_specs }) imp_map = case srcSpanEnd (is_dloc (is_decl best_imp_spec)) of -- For srcSpanEnd see Note [The ImportMap] - RealSrcLoc decl_loc -> Map.insertWith add decl_loc [gre] imp_map + RealSrcLoc decl_loc _ -> Map.insertWith add decl_loc [gre] imp_map UnhelpfulLoc _ -> imp_map where best_imp_spec = bestImport imp_specs diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs index 4380e9ef17..78a49d954c 100644 --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -133,7 +133,7 @@ similarNameSuggestions where_look dflags global_env pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined 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)) pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+> -- Imported parens (text "imported from" <+> ppr (is_mod is)) diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs index 418d0a3da4..9741fb1957 100644 --- a/compiler/basicTypes/Name.hs +++ b/compiler/basicTypes/Name.hs @@ -632,7 +632,7 @@ pprNameDefnLoc name -- nameSrcLoc rather than nameSrcSpan -- It seems less cluttered to show a location -- rather than a span for the definition point - RealSrcLoc s -> text "at" <+> ppr s + RealSrcLoc s _ -> text "at" <+> ppr s UnhelpfulLoc s | isInternalName name || isSystemName name -> text "at" <+> ftext s diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs index 82584b0903..d0d12e3607 100644 --- a/compiler/basicTypes/RdrName.hs +++ b/compiler/basicTypes/RdrName.hs @@ -1306,7 +1306,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 -- | Display info about the treatment of '*' under NoStarIsType. diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs index 113756ffea..896168b474 100644 --- a/compiler/basicTypes/SrcLoc.hs +++ b/compiler/basicTypes/SrcLoc.hs @@ -28,6 +28,7 @@ module SrcLoc ( interactiveSrcLoc, -- Code from an interactive session advanceSrcLoc, + advanceBufPos, -- ** Unsafely deconstructing SrcLoc -- These are dubious exports, because they crash on some inputs @@ -64,6 +65,10 @@ module SrcLoc ( isGoodSrcSpan, isOneLineSpan, containsSpan, + -- * StringBuffer locations + BufPos(..), + BufSpan(..), + -- * Located Located, RealLocated, @@ -87,7 +92,18 @@ module SrcLoc ( sortRealLocated, lookupSrcLoc, lookupSrcSpan, - liftL + liftL, + + -- * Parser locations + PsLoc(..), + PsSpan(..), + PsLocated, + advancePsLoc, + mkPsSpan, + psSpanStart, + psSpanEnd, + mkSrcSpanPs, + ) where import GhcPrelude @@ -98,6 +114,7 @@ import Outputable import FastString import Control.DeepSeq +import Control.Applicative (liftA2) import Data.Bits import Data.Data import Data.List (sortBy, intercalate) @@ -124,9 +141,19 @@ data RealSrcLoc {-# UNPACK #-} !Int -- column number, begins at 1 deriving (Eq, Ord) +-- | 0-based index identifying the raw location in the StringBuffer. +-- +-- Unlike 'RealSrcLoc', it is not affected by #line and {-# LINE ... #-} +-- pragmas. In particular, notice how 'setSrcLoc' and 'resetAlrLastLoc' in +-- Lexer.x update 'PsLoc' preserving 'BufPos'. +-- +-- The parser guarantees that 'BufPos' are monotonic. See #17632. +newtype BufPos = BufPos { bufPos :: Int } + deriving (Eq, Ord, Show) + -- | Source Location data SrcLoc - = RealSrcLoc {-# UNPACK #-}!RealSrcLoc + = RealSrcLoc !RealSrcLoc !(Maybe BufPos) -- See Note [Why Maybe BufPos] | UnhelpfulLoc FastString -- Just a general indication deriving (Eq, Show) @@ -139,7 +166,7 @@ data SrcLoc -} mkSrcLoc :: FastString -> Int -> Int -> SrcLoc -mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) +mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Nothing mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc mkRealSrcLoc x line col = SrcLoc x line col @@ -171,10 +198,15 @@ srcLocCol (SrcLoc _ _ c) = c -- character in any other case advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1 -advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (((((c - 1) `shiftR` 3) + 1) - `shiftL` 3) + 1) +advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (advance_tabstop c) advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) +advance_tabstop :: Int -> Int +advance_tabstop c = ((((c - 1) `shiftR` 3) + 1) `shiftL` 3) + 1 + +advanceBufPos :: BufPos -> BufPos +advanceBufPos (BufPos i) = BufPos (i+1) + {- ************************************************************************ * * @@ -190,11 +222,11 @@ sortRealLocated :: [RealLocated a] -> [RealLocated a] sortRealLocated = sortBy (compare `on` getLoc) lookupSrcLoc :: SrcLoc -> Map.Map RealSrcLoc a -> Maybe a -lookupSrcLoc (RealSrcLoc l) = Map.lookup l +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 @@ -214,7 +246,7 @@ instance Outputable RealSrcLoc where -- char '\"', pprFastFilePath src_path, text " #-}"] instance Outputable SrcLoc where - ppr (RealSrcLoc l) = ppr l + ppr (RealSrcLoc l _) = ppr l ppr (UnhelpfulLoc s) = ftext s instance Data RealSrcSpan where @@ -259,21 +291,46 @@ data RealSrcSpan } deriving Eq +-- | StringBuffer Source Span +data BufSpan = + BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos } + deriving (Eq, Ord, Show) + -- | Source Span -- -- A 'SrcSpan' identifies either a specific portion of a text file -- or a human-readable description of a location. data SrcSpan = - RealSrcSpan !RealSrcSpan + RealSrcSpan !RealSrcSpan !(Maybe BufSpan) -- See Note [Why Maybe BufPos] | UnhelpfulSpan !FastString -- Just a general indication -- also used to indicate an empty span deriving (Eq, Show) -- Show is used by Lexer.x, because we -- derive Show for Token +{- Note [Why Maybe BufPos] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +In SrcLoc we store (Maybe BufPos); in SrcSpan we store (Maybe BufSpan). +Why the Maybe? + +Surely, the lexer can always fill in the buffer position, and it guarantees to do so. +However, sometimes the SrcLoc/SrcSpan is constructed in a different context +where the buffer location is not available, and then we use Nothing instead of +a fake value like BufPos (-1). + +Perhaps the compiler could be re-engineered to pass around BufPos more +carefully and never discard it, and this 'Maybe' could be removed. If you're +interested in doing so, you may find this ripgrep query useful: + + rg "RealSrc(Loc|Span).*?Nothing" + +For example, it is not uncommon to whip up source locations for e.g. error +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)) @@ -299,7 +356,7 @@ mkGeneralSrcSpan = UnhelpfulSpan -- | Create a 'SrcSpan' corresponding to a single point srcLocSpan :: SrcLoc -> SrcSpan srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str -srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l) +srcLocSpan (RealSrcLoc l mb) = RealSrcSpan (realSrcLocSpan l) (fmap (\b -> BufSpan b b) mb) realSrcLocSpan :: RealSrcLoc -> RealSrcSpan realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col @@ -328,17 +385,17 @@ isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2) mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str -mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2) - = RealSrcSpan (mkRealSrcSpan loc1 loc2) +mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 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) (RealSrcSpan span2) +combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2) | srcSpanFile span1 == srcSpanFile span2 - = RealSrcSpan (combineRealSrcSpans span1 span2) + = RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2) | otherwise = UnhelpfulSpan (fsLit "<combineSrcSpans: files differ>") -- | Combines two 'SrcSpan' into one that spans at least all the characters @@ -353,13 +410,25 @@ combineRealSrcSpans span1 span2 (srcSpanEndLine span2, srcSpanEndCol span2) file = srcSpanFile span1 +combineBufSpans :: BufSpan -> BufSpan -> BufSpan +combineBufSpans span1 span2 = BufSpan start end + where + start = min (bufSpanStart span1) (bufSpanStart span2) + end = max (bufSpanEnd span1) (bufSpanEnd span2) + + -- | Convert a SrcSpan into one that represents only its first character srcSpanFirstCharacter :: SrcSpan -> SrcSpan srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l -srcSpanFirstCharacter (RealSrcSpan span) = RealSrcSpan $ mkRealSrcSpan loc1 loc2 +srcSpanFirstCharacter (RealSrcSpan span mbspan) = + RealSrcSpan (mkRealSrcSpan loc1 loc2) (fmap mkBufSpan mbspan) where loc1@(SrcLoc f l c) = realSrcSpanStart span loc2 = SrcLoc f l (c+1) + mkBufSpan bspan = + let bpos1@(BufPos i) = bufSpanStart bspan + bpos2 = BufPos (i+1) + in BufSpan bpos1 bpos2 {- ************************************************************************ @@ -371,13 +440,13 @@ srcSpanFirstCharacter (RealSrcSpan span) = RealSrcSpan $ mkRealSrcSpan loc1 loc2 -- | 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 -- | Tests whether the first span "contains" the other span, meaning @@ -420,12 +489,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 str) = UnhelpfulLoc str -srcSpanStart (RealSrcSpan s) = RealSrcLoc (realSrcSpanStart s) +srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b) -- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable srcSpanEnd :: SrcSpan -> SrcLoc srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str -srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s) +srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b) realSrcSpanStart :: RealSrcSpan -> RealSrcLoc realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s) @@ -439,7 +508,7 @@ 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 {- @@ -501,7 +570,7 @@ instance Outputable SrcSpan where pprUserSpan :: Bool -> SrcSpan -> SDoc pprUserSpan _ (UnhelpfulSpan s) = ftext s -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 _ _) @@ -602,22 +671,22 @@ leftmost_largest = compareSrcSpanBy $ \a b -> (realSrcSpanEnd b `compare` realSrcSpanEnd a) 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 @@ -639,3 +708,34 @@ getRealSrcSpan (L l _) = l unRealSrcSpan :: RealLocated a -> a unRealSrcSpan (L _ e) = e + + +-- | A location as produced by the parser. Consists of two components: +-- +-- * The location in the file, adjusted for #line and {-# LINE ... #-} pragmas (RealSrcLoc) +-- * The location in the string buffer (BufPos) with monotonicity guarantees (see #17632) +data PsLoc + = PsLoc { psRealLoc :: !RealSrcLoc, psBufPos :: !BufPos } + deriving (Eq, Ord, Show) + +data PsSpan + = PsSpan { psRealSpan :: !RealSrcSpan, psBufSpan :: !BufSpan } + deriving (Eq, Ord, Show) + +type PsLocated = GenLocated PsSpan + +advancePsLoc :: PsLoc -> Char -> PsLoc +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) + +psSpanStart :: PsSpan -> PsLoc +psSpanStart (PsSpan r b) = PsLoc (realSrcSpanStart r) (bufSpanStart b) + +psSpanEnd :: PsSpan -> PsLoc +psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b) + +mkSrcSpanPs :: PsSpan -> SrcSpan +mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Just b) diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs index 94ed59eccd..2a05476dc9 100644 --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -247,7 +247,7 @@ getSeverityColour _ = const mempty getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty -getCaretDiagnostic severity (RealSrcSpan span) = do +getCaretDiagnostic severity (RealSrcSpan span _) = do caretDiagnostic <$> getSrcLine (srcSpanFile span) row where diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index f7b2cd7fc5..8d88f7b097 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -192,7 +192,7 @@ lazyGetToks dflags filename handle = do _other -> do rest <- lazyLexBuf handle state' eof size return (t : rest) _ | not eof -> getMore handle state size - | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof] + | otherwise -> return [L (mkSrcSpanPs (last_loc state)) ITeof] -- parser assumes an ITeof sentinel at the end getMore :: Handle -> PState -> Int -> IO [Located Token] @@ -216,7 +216,7 @@ getToks dflags filename buf = lexAll (pragState dflags buf loc) lexAll state = case unP (lexer False return) state of POk _ t@(L _ ITeof) -> [t] POk state' t -> t : lexAll state' - _ -> [L (RealSrcSpan (last_loc state)) ITeof] + _ -> [L (mkSrcSpanPs (last_loc state)) ITeof] -- | Parse OPTIONS and LANGUAGE pragmas of the source file. diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 050a49c8c6..5fa0af85ad 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -822,11 +822,11 @@ data Token | ITdollar -- prefix $ | ITdollardollar -- prefix $$ | ITtyQuote -- '' - | ITquasiQuote (FastString,FastString,RealSrcSpan) + | ITquasiQuote (FastString,FastString,PsSpan) -- ITquasiQuote(quoter, quote, loc) -- represents a quasi-quote of the form -- [quoter| quote |] - | ITqQuasiQuote (FastString,FastString,FastString,RealSrcSpan) + | ITqQuasiQuote (FastString,FastString,FastString,PsSpan) -- ITqQuasiQuote(Qual, quoter, quote, loc) -- represents a qualified quasi-quote of the form -- [Qual.quoter| quote |] @@ -995,7 +995,7 @@ reservedSymsFM = listToUFM $ -- ----------------------------------------------------------------------------- -- Lexer actions -type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token) +type Action = PsSpan -> StringBuffer -> Int -> P (PsLocated Token) special :: Token -> Action special tok span _buf _len = return (L span tok) @@ -1045,13 +1045,13 @@ hopefully_open_brace span buf len = do relaxed <- getBit RelaxedLayoutBit ctx <- getContext (AI l _) <- getInput - let offset = srcLocCol l + let offset = srcLocCol (psRealLoc l) isOK = relaxed || case ctx of Layout prev_off _ : _ -> prev_off < offset _ -> True if isOK then pop_and open_brace span buf len - else addFatalError (RealSrcSpan span) (text "Missing block") + else addFatalError (mkSrcSpanPs span) (text "Missing block") pop_and :: Action -> Action pop_and act span buf len = do _ <- popLexState @@ -1186,7 +1186,7 @@ lineCommentToken span buf len = do nested comments require traversing by hand, they can't be parsed using regular expressions. -} -nested_comment :: P (RealLocated Token) -> Action +nested_comment :: P (PsLocated Token) -> Action nested_comment cont span buf len = do input <- getInput go (reverse $ lexemeToString buf len) (1::Int) input @@ -1198,18 +1198,18 @@ nested_comment cont span buf len = do then docCommentEnd input commentAcc ITblockComment buf span else cont go commentAcc n input = case alexGetChar' input of - Nothing -> errBrace input span + Nothing -> errBrace input (psRealSpan span) Just ('-',input) -> case alexGetChar' input of - Nothing -> errBrace input span + Nothing -> errBrace input (psRealSpan span) Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}' Just (_,_) -> go ('-':commentAcc) n input Just ('\123',input) -> case alexGetChar' input of -- '{' char - Nothing -> errBrace input span + Nothing -> errBrace input (psRealSpan span) Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input Just (_,_) -> go ('\123':commentAcc) n input -- See Note [Nested comment line pragmas] Just ('\n',input) -> case alexGetChar' input of - Nothing -> errBrace input span + Nothing -> errBrace input (psRealSpan span) Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input go (parsedAcc ++ '\n':commentAcc) n input Just (_,_) -> go ('\n':commentAcc) n input @@ -1219,14 +1219,14 @@ nested_doc_comment :: Action nested_doc_comment span buf _len = withLexedDocType (go "") where go commentAcc input docType _ = case alexGetChar' input of - Nothing -> errBrace input span + Nothing -> errBrace input (psRealSpan span) Just ('-',input) -> case alexGetChar' input of - Nothing -> errBrace input span + Nothing -> errBrace input (psRealSpan span) Just ('\125',input) -> docCommentEnd input commentAcc docType buf span Just (_,_) -> go ('-':commentAcc) input docType False Just ('\123', input) -> case alexGetChar' input of - Nothing -> errBrace input span + Nothing -> errBrace input (psRealSpan span) Just ('-',input) -> do setInput input let cont = do input <- getInput; go commentAcc input docType False @@ -1234,7 +1234,7 @@ nested_doc_comment span buf _len = withLexedDocType (go "") Just (_,_) -> go ('\123':commentAcc) input docType False -- See Note [Nested comment line pragmas] Just ('\n',input) -> case alexGetChar' input of - Nothing -> errBrace input span + Nothing -> errBrace input (psRealSpan span) Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input go (parsedAcc ++ '\n':commentAcc) input docType False Just (_,_) -> go ('\n':commentAcc) input docType False @@ -1252,7 +1252,7 @@ parseNestedPragma input@(AI _ buf) = do setExts (.&. complement (xbit InNestedCommentBit)) postInput@(AI _ postBuf) <- getInput setInput origInput - case unRealSrcSpan lt of + case unLoc lt of ITcomment_line_prag -> do let bytes = byteDiff buf postBuf diff = lexemeToString buf bytes @@ -1286,8 +1286,8 @@ return control to parseNestedPragma by returning the ITcomment_line_prag token. See #314 for more background on the bug this fixes. -} -withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token)) - -> P (RealLocated Token) +withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (PsLocated Token)) + -> P (PsLocated Token) withLexedDocType lexDocComment = do input@(AI _ buf) <- getInput case prevChar buf ' ' of @@ -1347,19 +1347,19 @@ endPrag span _buf _len = do -- called afterwards, so it can just update the state. docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer -> - RealSrcSpan -> P (RealLocated Token) + PsSpan -> P (PsLocated Token) docCommentEnd input commentAcc docType buf span = do setInput input let (AI loc nextBuf) = input comment = reverse commentAcc - span' = mkRealSrcSpan (realSrcSpanStart span) loc + span' = mkPsSpan (psSpanStart span) loc last_len = byteDiff buf nextBuf span `seq` setLastToken span' last_len return (L span' (docType comment)) errBrace :: AlexInput -> RealSrcSpan -> P a -errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'" +errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) "unterminated `{-'" open_brace, close_brace :: Action open_brace span _str _len = do @@ -1414,7 +1414,7 @@ varid span buf len = lambdaCase <- getBit LambdaCaseBit unless lambdaCase $ do pState <- getPState - addError (RealSrcSpan (last_loc pState)) $ text + addError (mkSrcSpanPs (last_loc pState)) $ text "Illegal lambda-case (use LambdaCase)" return ITlcase _ -> return ITcase @@ -1513,7 +1513,7 @@ tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = let src = lexemeToString buf len when ((not numericUnderscores) && ('_' `elem` src)) $ do pState <- getPState - addError (RealSrcSpan (last_loc pState)) $ text + addError (mkSrcSpanPs (last_loc pState)) $ text "Use NumericUnderscores to allow underscores in integer literals" return $ L span $ itint (SourceText src) $! transint $ parseUnsignedInteger @@ -1555,7 +1555,7 @@ tok_frac drop f span buf len = do let src = lexemeToString buf (len-drop) when ((not numericUnderscores) && ('_' `elem` src)) $ do pState <- getPState - addError (RealSrcSpan (last_loc pState)) $ text + addError (mkSrcSpanPs (last_loc pState)) $ text "Use NumericUnderscores to allow underscores in floating literals" return (L span $! (f $! src)) @@ -1636,7 +1636,7 @@ new_layout_context :: Bool -> Bool -> Token -> Action new_layout_context strict gen_semic tok span _buf len = do _ <- popLexState (AI l _) <- getInput - let offset = srcLocCol l - len + let offset = srcLocCol (psRealLoc l) - len ctx <- getContext nondecreasing <- getBit NondecreasingIndentationBit let strict' = strict || not nondecreasing @@ -1661,7 +1661,7 @@ do_layout_left span _buf _len = do -- LINE pragmas setLineAndFile :: Int -> Action -setLineAndFile code span buf len = do +setLineAndFile code (PsSpan span _) buf len = do let src = lexemeToString buf (len - 1) -- drop trailing quotation mark linenumLen = length $ head $ words src linenum = parseUnsignedInteger buf linenumLen 10 octDecDigit @@ -1679,7 +1679,7 @@ setLineAndFile code span buf len = do -- System.FilePath.normalise before printing out -- filenames and it does not remove duplicate -- backslashes after the drive letter (should it?). - setAlrLastLoc $ alrInitialLoc file + resetAlrLastLoc file setSrcLoc (mkRealSrcLoc file (fromIntegral linenum - 1) (srcSpanEndCol span)) -- subtract one: the line number refers to the *following* line addSrcFile file @@ -1688,7 +1688,7 @@ setLineAndFile code span buf len = do lexToken setColumn :: Action -setColumn span buf len = do +setColumn (PsSpan span _) buf len = do let column = case reads (lexemeToString buf len) of [(column, _)] -> column @@ -1710,10 +1710,10 @@ alrInitialLoc file = mkRealSrcSpan loc loc lex_string_prag :: (String -> Token) -> Action lex_string_prag mkTok span _buf _len = do input <- getInput - start <- getRealSrcLoc + start <- getParsedLoc tok <- go [] input - end <- getRealSrcLoc - return (L (mkRealSrcSpan start end) tok) + end <- getParsedLoc + return (L (mkPsSpan start end) tok) where go acc input = if isString input "#-}" then do setInput input @@ -1726,7 +1726,7 @@ lex_string_prag mkTok span _buf _len = case alexGetChar i of Just (c,i') | c == x -> isString i' xs _other -> False - err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma" + err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) "unterminated options pragma" -- ----------------------------------------------------------------------------- @@ -1744,7 +1744,7 @@ lex_string_tok span buf _len = do ITstring _ s -> ITstring (SourceText src) s _ -> panic "lex_string_tok" src = lexemeToString buf (cur bufEnd - cur buf) - return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok') + return (L (mkPsSpan (psSpanStart span) end) tok') lex_string :: String -> P Token lex_string s = do @@ -1764,7 +1764,7 @@ lex_string s = do setInput i when (any (> '\xFF') s') $ do pState <- getPState - addError (RealSrcSpan (last_loc pState)) $ text + addError (mkSrcSpanPs (last_loc pState)) $ text "primitive string literal must contain only characters <= \'\\xFF\'" return (ITprimstring (SourceText s') (unsafeMkByteString s')) _other -> @@ -1806,13 +1806,13 @@ lex_char_tok :: Action -- see if there's a trailing quote lex_char_tok span buf _len = do -- We've seen ' i1 <- getInput -- Look ahead to first character - let loc = realSrcSpanStart span + let loc = psSpanStart span case alexGetChar' i1 of Nothing -> lit_error i1 Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' setInput i2 - return (L (mkRealSrcSpan loc end2) ITtyQuote) + return (L (mkPsSpan loc end2) ITtyQuote) Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash setInput i2 @@ -1836,9 +1836,9 @@ lex_char_tok span buf _len = do -- We've seen ' -- (including the possibility of EOF) -- Just parse the quote only let (AI end _) = i1 - return (L (mkRealSrcSpan loc end) ITsimpleQuote) + return (L (mkPsSpan loc end) ITsimpleQuote) -finish_char_tok :: StringBuffer -> RealSrcLoc -> Char -> P (RealLocated Token) +finish_char_tok :: StringBuffer -> PsLoc -> Char -> P (PsLocated Token) finish_char_tok buf loc ch -- We've already seen the closing quote -- Just need to check for trailing # = do magicHash <- getBit MagicHashBit @@ -1848,13 +1848,13 @@ finish_char_tok buf loc ch -- We've already seen the closing quote case alexGetChar' i of Just ('#',i@(AI end _)) -> do setInput i - return (L (mkRealSrcSpan loc end) + return (L (mkPsSpan loc end) (ITprimchar (SourceText src) ch)) _other -> - return (L (mkRealSrcSpan loc end) + return (L (mkPsSpan loc end) (ITchar (SourceText src) ch)) else do - return (L (mkRealSrcSpan loc end) (ITchar (SourceText src) ch)) + return (L (mkPsSpan loc end) (ITchar (SourceText src) ch)) isAny :: Char -> Bool isAny c | c > '\x7f' = isPrint c @@ -1984,27 +1984,27 @@ getCharOrFail i = do lex_qquasiquote_tok :: Action lex_qquasiquote_tok span buf len = do let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False - quoteStart <- getRealSrcLoc - quote <- lex_quasiquote quoteStart "" - end <- getRealSrcLoc - return (L (mkRealSrcSpan (realSrcSpanStart span) end) + quoteStart <- getParsedLoc + quote <- lex_quasiquote (psRealLoc quoteStart) "" + end <- getParsedLoc + return (L (mkPsSpan (psSpanStart span) end) (ITqQuasiQuote (qual, quoter, mkFastString (reverse quote), - mkRealSrcSpan quoteStart end))) + mkPsSpan quoteStart end))) lex_quasiquote_tok :: Action lex_quasiquote_tok span buf len = do let quoter = tail (lexemeToString buf (len - 1)) -- 'tail' drops the initial '[', -- while the -1 drops the trailing '|' - quoteStart <- getRealSrcLoc - quote <- lex_quasiquote quoteStart "" - end <- getRealSrcLoc - return (L (mkRealSrcSpan (realSrcSpanStart span) end) + quoteStart <- getParsedLoc + quote <- lex_quasiquote (psRealLoc quoteStart) "" + end <- getParsedLoc + return (L (mkPsSpan (psSpanStart span) end) (ITquasiQuote (mkFastString quoter, mkFastString (reverse quote), - mkRealSrcSpan quoteStart end))) + mkPsSpan quoteStart end))) lex_quasiquote :: RealSrcLoc -> String -> P String lex_quasiquote start s = do @@ -2026,19 +2026,19 @@ lex_quasiquote start s = do quasiquote_error :: RealSrcLoc -> P a quasiquote_error start = do (AI end buf) <- getInput - reportLexError start end buf "unterminated quasiquotation" + reportLexError start (psRealLoc end) buf "unterminated quasiquotation" -- ----------------------------------------------------------------------------- -- Warnings warnTab :: Action warnTab srcspan _buf _len = do - addTabWarning srcspan + addTabWarning (psRealSpan srcspan) lexToken warnThen :: WarningFlag -> SDoc -> Action -> Action warnThen option warning action srcspan buf len = do - addWarning option (RealSrcSpan srcspan) warning + addWarning option (RealSrcSpan (psRealSpan srcspan) Nothing) warning action srcspan buf len -- ----------------------------------------------------------------------------- @@ -2093,22 +2093,22 @@ data PState = PState { tab_first :: Maybe RealSrcSpan, -- pos of first tab warning in the file tab_count :: !Int, -- number of tab warnings in the file last_tk :: Maybe Token, - last_loc :: RealSrcSpan, -- pos of previous token + last_loc :: PsSpan, -- pos of previous token last_len :: !Int, -- len of previous token - loc :: RealSrcLoc, -- current loc (end of prev token + 1) + loc :: PsLoc, -- current loc (end of prev token + 1) context :: [LayoutContext], lex_state :: [Int], srcfiles :: [FastString], -- Used in the alternative layout rule: -- These tokens are the next ones to be sent out. They are -- just blindly emitted, without the rule looking at them again: - alr_pending_implicit_tokens :: [RealLocated Token], + alr_pending_implicit_tokens :: [PsLocated Token], -- This is the next token to be considered or, if it is Nothing, -- we need to get the next token from the input stream: - alr_next_token :: Maybe (RealLocated Token), + alr_next_token :: Maybe (PsLocated Token), -- This is what we consider to be the location of the last token -- emitted: - alr_last_loc :: RealSrcSpan, + alr_last_loc :: PsSpan, -- The stack of layout contexts: alr_context :: [ALRContext], -- Are we expecting a '{'? If it's Just, then the ALRLayout tells @@ -2166,11 +2166,11 @@ thenP :: P a -> (a -> P b) -> P b failMsgP :: String -> P a failMsgP msg = do pState <- getPState - addFatalError (RealSrcSpan (last_loc pState)) (text msg) + addFatalError (mkSrcSpanPs (last_loc pState)) (text msg) failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a failLocMsgP loc1 loc2 str = - addFatalError (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str) + addFatalError (RealSrcSpan (mkRealSrcSpan loc1 loc2) Nothing) (text str) getPState :: P PState getPState = P $ \s -> POk s s @@ -2189,10 +2189,15 @@ setExts f = P $ \s -> POk s { } () setSrcLoc :: RealSrcLoc -> P () -setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () +setSrcLoc new_loc = + P $ \s@(PState{ loc = PsLoc _ buf_loc }) -> + POk s{ loc = PsLoc new_loc buf_loc } () getRealSrcLoc :: P RealSrcLoc -getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc +getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s (psRealLoc loc) + +getParsedLoc :: P PsLoc +getParsedLoc = P $ \s@(PState{ loc=loc }) -> POk s loc addSrcFile :: FastString -> P () addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } () @@ -2200,7 +2205,7 @@ addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } () setEofPos :: RealSrcSpan -> P () setEofPos span = P $ \s -> POk s{ eof_pos = Just span } () -setLastToken :: RealSrcSpan -> Int -> P () +setLastToken :: PsSpan -> Int -> P () setLastToken loc len = P $ \s -> POk s { last_loc=loc, last_len=len @@ -2212,7 +2217,7 @@ setLastTk tk = P $ \s -> POk s { last_tk = Just tk } () getLastTk :: P (Maybe Token) getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk -data AlexInput = AI RealSrcLoc StringBuffer +data AlexInput = AI PsLoc StringBuffer {- Note [Unicode in Alex] @@ -2305,7 +2310,7 @@ alexGetByte (AI loc s) --trace (show (ord c)) $ Just (byte, (AI loc' s')) where (c,s') = nextChar s - loc' = advanceSrcLoc loc c + loc' = advancePsLoc loc c byte = adjustChar c -- This version does not squash unicode characters, it is used when @@ -2317,7 +2322,7 @@ alexGetChar' (AI loc s) --trace (show (ord c)) $ Just (c, (AI loc' s')) where (c,s') = nextChar s - loc' = advanceSrcLoc loc c + loc' = advancePsLoc loc c getInput :: P AlexInput getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b) @@ -2339,7 +2344,7 @@ popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls getLexState :: P Int getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls -popNextToken :: P (Maybe (RealLocated Token)) +popNextToken :: P (Maybe (PsLocated Token)) popNextToken = P $ \s@PState{ alr_next_token = m } -> POk (s {alr_next_token = Nothing}) m @@ -2353,10 +2358,15 @@ activeContext = do ([],Nothing) -> return impt _other -> return True -setAlrLastLoc :: RealSrcSpan -> P () +resetAlrLastLoc :: FastString -> P () +resetAlrLastLoc file = + P $ \s@(PState {alr_last_loc = PsSpan _ buf_span}) -> + POk s{ alr_last_loc = PsSpan (alrInitialLoc file) buf_span } () + +setAlrLastLoc :: PsSpan -> P () setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () -getAlrLastLoc :: P RealSrcSpan +getAlrLastLoc :: P PsSpan getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l getALRContext :: P [ALRContext] @@ -2373,7 +2383,7 @@ setJustClosedExplicitLetBlock :: Bool -> P () setJustClosedExplicitLetBlock b = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) () -setNextToken :: RealLocated Token -> P () +setNextToken :: PsLocated Token -> P () setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () implicitTokenPending :: P Bool @@ -2383,14 +2393,14 @@ implicitTokenPending [] -> POk s False _ -> POk s True -popPendingImplicitToken :: P (Maybe (RealLocated Token)) +popPendingImplicitToken :: P (Maybe (PsLocated Token)) popPendingImplicitToken = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> case ts of [] -> POk s Nothing (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t) -setPendingImplicitTokens :: [RealLocated Token] -> P () +setPendingImplicitTokens :: [PsLocated Token] -> P () setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) () getAlrExpectingOCurly :: P (Maybe ALRLayout) @@ -2582,15 +2592,15 @@ mkPStatePure options buf loc = tab_first = Nothing, tab_count = 0, last_tk = Nothing, - last_loc = mkRealSrcSpan loc loc, + last_loc = mkPsSpan init_loc init_loc, last_len = 0, - loc = loc, + loc = init_loc, context = [], lex_state = [bol, 0], srcfiles = [], alr_pending_implicit_tokens = [], alr_next_token = Nothing, - alr_last_loc = alrInitialLoc (fsLit "<no file>"), + alr_last_loc = PsSpan (alrInitialLoc (fsLit "<no file>")) (BufSpan (BufPos 0) (BufPos 0)), alr_context = [], alr_expecting_ocurly = Nothing, alr_justClosedExplicitLetBlock = False, @@ -2599,6 +2609,7 @@ mkPStatePure options buf loc = comment_q = [], annotations_comments = [] } + where init_loc = PsLoc loc (BufPos 0) -- | An mtl-style class for monads that support parsing-related operations. -- For example, sometimes we make a second pass over the parsing results to validate, @@ -2675,7 +2686,7 @@ instance MonadP P where addError span msg >> P PFailed getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s) in b `seq` POk s b - addAnnotation (RealSrcSpan l) a (RealSrcSpan v) = do + addAnnotation (RealSrcSpan l _) a (RealSrcSpan v _) = do addAnnotationOnly l a v allocateCommentsP l addAnnotation _ _ _ = return () @@ -2703,7 +2714,7 @@ mkTabWarning PState{tab_first=tf, tab_count=tc} d = <> text "." $+$ text "Please use spaces instead." in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $ - mkWarnMsg d (RealSrcSpan s) alwaysQualify message) tf + mkWarnMsg d (RealSrcSpan s Nothing) alwaysQualify message) tf -- | Get a bag of the errors that have been accumulated so far. -- Does not take -Werror into account. @@ -2733,12 +2744,12 @@ popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx, (_:tl) -> POk s{ context = tl } () [] -> - unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s + unP (addFatalError (mkSrcSpanPs last_loc) (srcParseErr o buf len)) s -- Push a new layout context at the indentation of the last token read. pushCurrentContext :: GenSemic -> P () pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } -> - POk s{context = Layout (srcSpanStartCol loc) gen_semic : ctx} () + POk s{context = Layout (srcSpanStartCol (psRealSpan loc)) gen_semic : ctx} () -- This is only used at the outer level of a module when the 'module' keyword is -- missing. @@ -2747,7 +2758,7 @@ pushModuleContext = pushCurrentContext generateSemic getOffside :: P (Ordering, Bool) getOffside = P $ \s@PState{last_loc=loc, context=stk} -> - let offs = srcSpanStartCol loc in + let offs = srcSpanStartCol (psRealSpan loc) in let ord = case stk of Layout n gen_semic : _ -> --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ @@ -2793,7 +2804,7 @@ srcParseErr options buf len srcParseFail :: P a srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len, last_loc = last_loc } -> - unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s + unP (addFatalError (mkSrcSpanPs last_loc) (srcParseErr o buf len)) s -- A lexical error is reported at a particular position in the source file, -- not over a token range. @@ -2801,7 +2812,7 @@ lexError :: String -> P a lexError str = do loc <- getRealSrcLoc (AI end buf) <- getInput - reportLexError loc end buf str + reportLexError loc (psRealLoc end) buf str -- ----------------------------------------------------------------------------- -- This is the top-level function: called from the parser each time a @@ -2816,19 +2827,19 @@ lexer queueComments cont = do --trace ("token: " ++ show tok) $ do if (queueComments && isDocComment tok) - then queueComment (L span tok) + then queueComment (L (psRealSpan span) tok) else return () if (queueComments && isComment tok) - then queueComment (L span tok) >> lexer queueComments cont - else cont (L (RealSrcSpan span) tok) + then queueComment (L (psRealSpan span) tok) >> lexer queueComments cont + else cont (L (mkSrcSpanPs span) tok) -- Use this instead of 'lexer' in Parser.y to dump the tokens for debugging. lexerDbg queueComments cont = lexer queueComments contDbg where contDbg tok = trace ("token: " ++ show (unLoc tok)) (cont tok) -lexTokenAlr :: P (RealLocated Token) +lexTokenAlr :: P (PsLocated Token) lexTokenAlr = do mPending <- popPendingImplicitToken t <- case mPending of Nothing -> @@ -2839,8 +2850,8 @@ lexTokenAlr = do mPending <- popPendingImplicitToken alternativeLayoutRuleToken t Just t -> return t - setAlrLastLoc (getRealSrcSpan t) - case unRealSrcSpan t of + setAlrLastLoc (getLoc t) + case unLoc t of ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere) ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet) ITof -> setAlrExpectingOCurly (Just ALRLayoutOf) @@ -2851,7 +2862,7 @@ lexTokenAlr = do mPending <- popPendingImplicitToken _ -> return () return t -alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token) +alternativeLayoutRuleToken :: PsLocated Token -> P (PsLocated Token) alternativeLayoutRuleToken t = do context <- getALRContext lastLoc <- getAlrLastLoc @@ -2859,10 +2870,10 @@ alternativeLayoutRuleToken t transitional <- getBit ALRTransitionalBit justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock setJustClosedExplicitLetBlock False - let thisLoc = getRealSrcSpan t - thisCol = srcSpanStartCol thisLoc - newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc - case (unRealSrcSpan t, context, mExpectingOCurly) of + let thisLoc = getLoc t + thisCol = srcSpanStartCol (psRealSpan thisLoc) + newLine = srcSpanStartLine (psRealSpan thisLoc) > srcSpanEndLine (psRealSpan lastLoc) + case (unLoc t, context, mExpectingOCurly) of -- This case handles a GHC extension to the original H98 -- layout rule... (ITocurly, _, Just alrLayout) -> @@ -2921,7 +2932,7 @@ alternativeLayoutRuleToken t (ITwhere, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional -> do addWarning Opt_WarnAlternativeLayoutRuleTransitional - (RealSrcSpan thisLoc) + (mkSrcSpanPs thisLoc) (transitionalAlternativeLayoutWarning "`where' clause at the same depth as implicit layout block") setALRContext ls @@ -2933,7 +2944,7 @@ alternativeLayoutRuleToken t (ITvbar, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional -> do addWarning Opt_WarnAlternativeLayoutRuleTransitional - (RealSrcSpan thisLoc) + (mkSrcSpanPs thisLoc) (transitionalAlternativeLayoutWarning "`|' at the same depth as implicit layout block") setALRContext ls @@ -2944,8 +2955,8 @@ alternativeLayoutRuleToken t (_, ALRLayout _ col : ls, _) | newLine && thisCol == col -> do setNextToken t - let loc = realSrcSpanStart thisLoc - zeroWidthLoc = mkRealSrcSpan loc loc + let loc = psSpanStart thisLoc + zeroWidthLoc = mkPsSpan loc loc return (L zeroWidthLoc ITsemi) | newLine && thisCol < col -> do setALRContext ls @@ -3049,29 +3060,29 @@ topNoLayoutContainsCommas [] = False topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b -lexToken :: P (RealLocated Token) +lexToken :: P (PsLocated Token) lexToken = do inp@(AI loc1 buf) <- getInput sc <- getLexState exts <- getExts case alexScanUser exts inp sc of AlexEOF -> do - let span = mkRealSrcSpan loc1 loc1 - setEofPos span + let span = mkPsSpan loc1 loc1 + setEofPos (psRealSpan span) setLastToken span 0 return (L span ITeof) AlexError (AI loc2 buf) -> - reportLexError loc1 loc2 buf "lexical error" + reportLexError (psRealLoc loc1) (psRealLoc loc2) buf "lexical error" AlexSkip inp2 _ -> do setInput inp2 lexToken AlexToken inp2@(AI end buf2) _ t -> do setInput inp2 - let span = mkRealSrcSpan loc1 end + let span = mkPsSpan loc1 end let bytes = byteDiff buf buf2 span `seq` setLastToken span bytes lt <- t span buf bytes - let lt' = unRealSrcSpan lt + let lt' = unLoc lt unless (isComment lt') (setLastTk lt') return lt @@ -3216,15 +3227,15 @@ addAnnotationOnly l a v = P $ \s -> POk s { -- and end of the span mkParensApiAnn :: SrcSpan -> [AddAnn] mkParensApiAnn (UnhelpfulSpan _) = [] -mkParensApiAnn (RealSrcSpan ss) = [AddAnn AnnOpenP lo,AddAnn AnnCloseP lc] +mkParensApiAnn (RealSrcSpan ss _) = [AddAnn AnnOpenP lo,AddAnn AnnCloseP lc] where f = srcSpanFile ss sl = srcSpanStartLine ss sc = srcSpanStartCol ss el = srcSpanEndLine ss ec = srcSpanEndCol ss - lo = RealSrcSpan (mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1))) - lc = RealSrcSpan (mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)) + lo = RealSrcSpan (mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1))) Nothing + lc = RealSrcSpan (mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)) Nothing queueComment :: RealLocated Token -> P() queueComment c = P $ \s -> POk s { diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 73e3c52851..26c56d062b 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -2565,11 +2565,11 @@ quasiquote :: { Located (HsSplice GhcPs) } : TH_QUASIQUOTE { let { loc = getLoc $1 ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 ; quoterId = mkUnqual varName quoter } - in sL1 $1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } + in sL1 $1 (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) } | TH_QQUASIQUOTE { let { loc = getLoc $1 ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1 ; quoterId = mkQual varName (qual, quoter) } - in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } + in sL (getLoc $1) (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) } exp :: { ECP } : infixexp '::' sigtype diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 8bf18fc928..1be2c76864 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -2918,7 +2918,7 @@ instance MonadP PV where PV $ \ctx acc -> let b = ext `xtest` pExtsBitmap (pv_options ctx) in PV_Ok acc $! b - addAnnotation (RealSrcSpan l) a (RealSrcSpan v) = + addAnnotation (RealSrcSpan l _) a (RealSrcSpan v _) = PV $ \_ acc -> let (comment_q', new_ann_comments) = allocateComments l (pv_comment_q acc) diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index d098edac8a..e111afc08a 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -982,7 +982,7 @@ mkErrorMsgFromCt ctxt ct report mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs) = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) - ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env)) + ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env) Nothing) (errDoc important [context] (relevant_bindings ++ valid_subs)) } @@ -1100,7 +1100,7 @@ mkHoleError tidy_simples ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort } ; imp_info <- getImports ; curr_mod <- getModule ; hpt <- getHpt - ; mkErrDocAt (RealSrcSpan (tcl_loc lcl_env)) $ + ; mkErrDocAt (RealSrcSpan (tcl_loc lcl_env) Nothing) $ errDoc [out_of_scope_msg] [] [unknownNameSuggestions dflags hpt curr_mod rdr_env (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)] } diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 930dc3c15a..aff3ff4ee2 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -165,7 +165,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 dflags (text "Renamer/typechecker"<+>brackets (ppr this_mod)) (const ()) $ diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 672ba804f9..b1330be15d 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -823,10 +823,10 @@ addDependentFiles fs = do getSrcSpanM :: TcRn SrcSpan -- Avoid clash with Name.getSrcLoc -getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) } +getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) } setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -setSrcSpan (RealSrcSpan real_loc) thing_inside +setSrcSpan (RealSrcSpan real_loc _) thing_inside = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside -- Don't overwrite useful info with useless: setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside @@ -1668,7 +1668,7 @@ emitNamedWildCardHoleConstraints wcs , cc_hole = TypeHole } where real_span = case nameSrcSpan name of - RealSrcSpan span -> span + RealSrcSpan span _ -> span UnhelpfulSpan str -> pprPanic "emitNamedWildCardHoleConstraints" (ppr name <+> quotes (ftext str)) -- Wildcards are defined locally, and so have RealSrcSpans diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 5acbd79084..ecbf07c36d 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -1079,7 +1079,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 = unitIdString (moduleUnitId m) diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 498c4924de..1c52cb56fb 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -1380,10 +1380,24 @@ instance Binary RealSrcSpan where return (mkRealSrcSpan (mkRealSrcLoc f sl sc) (mkRealSrcLoc f el ec)) +instance Binary BufPos where + put_ bh (BufPos i) = put_ bh i + get bh = BufPos <$> get bh + +instance Binary BufSpan where + put_ bh (BufSpan start end) = do + put_ bh start + put_ bh end + get bh = do + start <- get bh + end <- get bh + return (BufSpan start end) + instance Binary SrcSpan where - put_ bh (RealSrcSpan ss) = do + put_ bh (RealSrcSpan ss sb) = do putByte bh 0 put_ bh ss + put_ bh sb put_ bh (UnhelpfulSpan s) = do putByte bh 1 @@ -1393,7 +1407,8 @@ instance Binary SrcSpan where h <- getByte bh case h of 0 -> do ss <- get bh - return (RealSrcSpan ss) + sb <- get bh + return (RealSrcSpan ss sb) _ -> do s <- get bh return (UnhelpfulSpan s) |