summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorVladislav Zavialov <vlad.z.4096@gmail.com>2020-01-23 23:03:04 +0300
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-02-29 05:06:31 -0500
commit327b29e1a05d9f1ea04465c9b23aed92473dd453 (patch)
tree0b6db26b4677c2677a32754de523eb842f9cb849
parent37f126033f1e5bf0331143f005ef90ba6e2e02cd (diff)
downloadhaskell-327b29e1a05d9f1ea04465c9b23aed92473dd453.tar.gz
Monotonic locations (#17632)
When GHC is parsing a file generated by a tool, e.g. by the C preprocessor, the tool may insert #line pragmas to adjust the locations reported to the user. As the result, the locations recorded in RealSrcLoc are not monotonic. Elements that appear later in the StringBuffer are not guaranteed to have a higher line/column number. In fact, there are no guarantees whatsoever, as #line pragmas can arbitrarily modify locations. This lack of guarantees makes ideas such as #17544 infeasible. This patch adds an additional bit of information to every SrcLoc: newtype BufPos = BufPos { bufPos :: Int } A BufPos represents the location in the StringBuffer, unaffected by any pragmas. Updates haddock submodule. Metric Increase: haddock.Cabal haddock.base haddock.compiler MultiLayerModules Naperian parsing001 T12150
Diffstat
-rw-r--r--compiler/GHC.hs6
-rw-r--r--compiler/GHC/Cmm/Lexer.x20
-rw-r--r--compiler/GHC/Cmm/Parser.y2
-rw-r--r--compiler/GHC/CoreToStg/Prep.hs2
-rw-r--r--compiler/GHC/HsToCore/Coverage.hs10
-rw-r--r--compiler/GHC/HsToCore/Docs.hs4
-rw-r--r--compiler/GHC/HsToCore/Expr.hs3
-rw-r--r--compiler/GHC/HsToCore/Monad.hs4
-rw-r--r--compiler/GHC/HsToCore/PmCheck.hs4
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs10
-rw-r--r--compiler/GHC/Iface/Ext/Utils.hs14
-rw-r--r--compiler/GHC/Rename/Names.hs2
-rw-r--r--compiler/GHC/Rename/Unbound.hs2
-rw-r--r--compiler/basicTypes/Name.hs2
-rw-r--r--compiler/basicTypes/RdrName.hs2
-rw-r--r--compiler/basicTypes/SrcLoc.hs154
-rw-r--r--compiler/main/ErrUtils.hs2
-rw-r--r--compiler/main/HeaderInfo.hs4
-rw-r--r--compiler/parser/Lexer.x223
-rw-r--r--compiler/parser/Parser.y4
-rw-r--r--compiler/parser/RdrHsSyn.hs2
-rw-r--r--compiler/typecheck/TcErrors.hs4
-rw-r--r--compiler/typecheck/TcRnDriver.hs2
-rw-r--r--compiler/typecheck/TcRnMonad.hs6
-rw-r--r--compiler/typecheck/TcSplice.hs2
-rw-r--r--compiler/utils/Binary.hs19
-rw-r--r--ghc/GHCi/UI.hs22
-rw-r--r--ghc/GHCi/UI/Info.hs6
-rw-r--r--ghc/GHCi/UI/Tags.hs2
-rw-r--r--testsuite/tests/ghc-api/annotations/comments.hs2
-rw-r--r--testsuite/tests/ghc-api/annotations/listcomps.hs2
-rw-r--r--testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout10
-rw-r--r--utils/check-api-annotations/Main.hs2
m---------utils/haddock0
34 files changed, 341 insertions, 214 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)
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 31243edfc1..7793b7183a 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -559,7 +559,7 @@ ghciLogAction old_log_action lastErrLocations
old_log_action dflags flag severity srcSpan style msg
case severity of
SevError -> case srcSpan of
- RealSrcSpan rsp -> modifyIORef lastErrLocations
+ RealSrcSpan rsp _ -> modifyIORef lastErrLocations
(++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
_ -> return ()
_ -> return ()
@@ -2220,7 +2220,7 @@ parseSpanArg s = do
-- while simply unpacking 'UnhelpfulSpan's
showSrcSpan :: SrcSpan -> String
showSrcSpan (UnhelpfulSpan s) = unpackFS s
-showSrcSpan (RealSrcSpan spn) = showRealSrcSpan spn
+showSrcSpan (RealSrcSpan spn _) = showRealSrcSpan spn
-- | Variant of 'showSrcSpan' for 'RealSrcSpan's
showRealSrcSpan :: RealSrcSpan -> String
@@ -3465,7 +3465,7 @@ stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
Just loc -> do
md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule
current_toplevel_decl <- enclosingTickSpan md loc
- doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep
+ doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl Nothing) GHC.SingleStep
stepModuleCmd :: GhciMonad m => String -> m ()
stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
@@ -3483,7 +3483,7 @@ stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
-- | Returns the span of the largest tick containing the srcspan given
enclosingTickSpan :: GhciMonad m => Module -> SrcSpan -> m RealSrcSpan
enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
-enclosingTickSpan md (RealSrcSpan src) = do
+enclosingTickSpan md (RealSrcSpan src _) = do
ticks <- getTickArray md
let line = srcSpanStartLine src
ASSERT(inRange (bounds ticks) line) do
@@ -3710,7 +3710,7 @@ findBreakAndSet md lookupTickTree = do
(alreadySet, nm) <-
recordBreak $ BreakLocation
{ breakModule = md
- , breakLoc = RealSrcSpan pan
+ , breakLoc = RealSrcSpan pan Nothing
, breakTick = tick
, onBreakCmd = ""
, breakEnabled = True
@@ -3755,7 +3755,7 @@ findBreakForBind name modbreaks _ = filter (not . enclosed) ticks
ticks = [ (index, span)
| (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks),
n == occNameString (nameOccName name),
- RealSrcSpan span <- [GHC.modBreaks_locs modbreaks ! index] ]
+ RealSrcSpan span _ <- [GHC.modBreaks_locs modbreaks ! index] ]
enclosed (_,sp0) = any subspan ticks
where subspan (_,sp) = sp /= sp0 &&
realSrcSpanStart sp <= realSrcSpanStart sp0 &&
@@ -3772,7 +3772,7 @@ findBreakByCoord mb_file (line, col) arr
ticks = arr ! line
-- the ticks that span this coordinate
- contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan `spans` (line,col),
+ contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan Nothing `spans` (line,col),
is_correct_file pan ]
is_correct_file pan
@@ -3817,7 +3817,7 @@ listCmd "" = do
case mb_span of
Nothing ->
printForUser $ text "Not stopped at a breakpoint; nothing to list"
- Just (RealSrcSpan pan) ->
+ Just (RealSrcSpan pan _) ->
listAround pan True
Just pan@(UnhelpfulSpan _) ->
do resumes <- GHC.getResumeContext
@@ -3848,7 +3848,7 @@ list2 [arg] = do
wantNameFromInterpretedModule noCanDo arg $ \name -> do
let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
case loc of
- RealSrcLoc l ->
+ RealSrcLoc l _ ->
do tickArray <- ASSERT( isExternalName name )
getTickArray (GHC.nameModule name)
let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))
@@ -3970,9 +3970,9 @@ discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})
mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
mkTickArray ticks
= accumArray (flip (:)) [] (1, max_line)
- [ (line, (nm,pan)) | (nm,RealSrcSpan pan) <- ticks, line <- srcSpanLines pan ]
+ [ (line, (nm,pan)) | (nm,RealSrcSpan pan _) <- ticks, line <- srcSpanLines pan ]
where
- max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp) <- ticks ]
+ max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ]
srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]
-- don't reset the counter back to zero?
diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs
index 5ec1ca76a4..290a11ff2a 100644
--- a/ghc/GHCi/UI/Info.hs
+++ b/ghc/GHCi/UI/Info.hs
@@ -140,7 +140,7 @@ findNameUses infos span0 string =
locToSpans (modinfo,name',span') =
stripSurrounding (span' : map toSrcSpan spans)
where
- toSrcSpan = RealSrcSpan . spaninfoSrcSpan
+ toSrcSpan s = RealSrcSpan (spaninfoSrcSpan s) Nothing
spans = filter ((== Just name') . fmap getName . spaninfoVar)
(modinfoSpans modinfo)
@@ -150,7 +150,7 @@ stripSurrounding xs = filter (not . isRedundant) xs
where
isRedundant x = any (x `strictlyContains`) xs
- (RealSrcSpan s1) `strictlyContains` (RealSrcSpan s2)
+ (RealSrcSpan s1 _) `strictlyContains` (RealSrcSpan s2 _)
= s1 /= s2 && s1 `containsSpan` s2
_ `strictlyContains` _ = False
@@ -371,7 +371,7 @@ processAllTypeCheckedModule tcm = do
-- | Pretty print the types into a 'SpanInfo'.
toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo
- toSpanInfo (n,RealSrcSpan spn,typ)
+ toSpanInfo (n,RealSrcSpan spn _,typ)
= Just $ spanInfoFromRealSrcSpan spn (Just typ) n
toSpanInfo _ = Nothing
diff --git a/ghc/GHCi/UI/Tags.hs b/ghc/GHCi/UI/Tags.hs
index ce85bb30cf..69c92a7aca 100644
--- a/ghc/GHCi/UI/Tags.hs
+++ b/ghc/GHCi/UI/Tags.hs
@@ -103,7 +103,7 @@ listModuleTags m = do
, let exported = GHC.modInfoIsExportedName mInfo name
, let kind = tyThing2TagKind tyThing
, let loc = srcSpanStart (nameSrcSpan name)
- , RealSrcLoc realLoc <- [loc]
+ , RealSrcLoc realLoc _ <- [loc]
]
where
diff --git a/testsuite/tests/ghc-api/annotations/comments.hs b/testsuite/tests/ghc-api/annotations/comments.hs
index 8a36043e55..60d30426b1 100644
--- a/testsuite/tests/ghc-api/annotations/comments.hs
+++ b/testsuite/tests/ghc-api/annotations/comments.hs
@@ -52,7 +52,7 @@ testOneFile libdir fileName useHaddock = do
ann_comments = apiAnnComments anns
ann_rcomments = apiAnnRogueComments anns
comments =
- map (\(s,v) -> (RealSrcSpan s, v)) (Map.toList ann_comments)
+ map (\(s,v) -> (RealSrcSpan s Nothing, v)) (Map.toList ann_comments)
++
[(noSrcSpan, ann_rcomments)]
diff --git a/testsuite/tests/ghc-api/annotations/listcomps.hs b/testsuite/tests/ghc-api/annotations/listcomps.hs
index 8af3bf6b69..5050a290c9 100644
--- a/testsuite/tests/ghc-api/annotations/listcomps.hs
+++ b/testsuite/tests/ghc-api/annotations/listcomps.hs
@@ -61,7 +61,7 @@ testOneFile libdir fileName = do
getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast
where
getSrcSpan :: SrcSpan -> [RealSrcSpan]
- getSrcSpan (RealSrcSpan ss) = [ss]
+ getSrcSpan (RealSrcSpan ss _) = [ss]
getSrcSpan (UnhelpfulSpan _) = []
showAnns anns = "[\n" ++ (intercalate "\n"
diff --git a/testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout b/testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout
index f89656598a..cbd4dbeb61 100644
--- a/testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout
+++ b/testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout
@@ -1,7 +1,7 @@
-"RealSrcLoc SrcLoc \"filename\" 1 3"
-"RealSrcLoc SrcLoc \"filename\" 1 5"
+"RealSrcLoc SrcLoc \"filename\" 1 3 Nothing"
+"RealSrcLoc SrcLoc \"filename\" 1 5 Nothing"
"UnhelpfulLoc \"bad loc\""
-"RealSrcSpan SrcSpanPoint \"filename\" 1 3"
-"RealSrcSpan SrcSpanOneLine \"filename\" 1 3 5"
-"RealSrcSpan SrcSpanMultiLine \"filename\" 1 5 10 1"
+"RealSrcSpan SrcSpanPoint \"filename\" 1 3 Nothing"
+"RealSrcSpan SrcSpanOneLine \"filename\" 1 3 5 Nothing"
+"RealSrcSpan SrcSpanMultiLine \"filename\" 1 5 10 1 Nothing"
"UnhelpfulSpan \"bad span\""
diff --git a/utils/check-api-annotations/Main.hs b/utils/check-api-annotations/Main.hs
index 51d389ce13..83568c573f 100644
--- a/utils/check-api-annotations/Main.hs
+++ b/utils/check-api-annotations/Main.hs
@@ -82,7 +82,7 @@ testOneFile libdir fileName = do
getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast
where
getSrcSpan :: SrcSpan -> [RealSrcSpan]
- getSrcSpan (RealSrcSpan ss) = [ss]
+ getSrcSpan (RealSrcSpan ss _) = [ss]
getSrcSpan (UnhelpfulSpan _) = []
diff --git a/utils/haddock b/utils/haddock
-Subproject 78d0e033a2f8ce5dc1f5e2e4eb8b823ee4d1d1b
+Subproject b104c573fdc6efcecc3bfaa2fb6084b7679f32d
View Lorry Controller Status