Commit 327b29e1 authored by Vladislav Zavialov's avatar Vladislav Zavialov Committed by Marge Bot

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 37f12603
Pipeline #16332 failed with stages
in 360 minutes and 1 second
......@@ -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.
......
......@@ -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