Commit 0e697d54 authored by Vladislav Zavialov's avatar Vladislav Zavialov

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
parent f97d1fb6
Pipeline #16304 passed with stages
in 419 minutes and 53 seconds
......@@ -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
......
......@@ -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
......
......@@ -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
-- -----------------------------------------------------------------------------
......
......@@ -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))
......
......@@ -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,
......
......@@ -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].
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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))
......
......@@ -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
......
......@@ -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.
......
This diff is collapsed.
......@@ -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
......
......@@ -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.
......
This diff is collapsed.
......@@ -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
......
......@@ -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)
......
......@@ -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)] }
......
......@@ -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 ()) $
......
......@@ -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
......
......@@ -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)
......
......@@ -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)
......
......@@ -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?
......
......@@ -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
......
......@@ -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
......
......@@ -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)]
......
......@@ -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"
......
"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\""
......@@ -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 _) = []
......
Subproject commit 78d0e033a2f8ce5dc1f5e2e4eb8b823ee4d1d1bf
Subproject commit b104c573fdc6efcecc3bfaa2fb6084b7679f32da