Commit b2bd63f9 authored by Ian Lynagh's avatar Ian Lynagh

Refactor SrcLoc and SrcSpan

The "Unhelpful" cases are now in a separate type. This allows us to
improve various things, e.g.:
* Most of the panic's in SrcLoc are now gone
* The Lexer now works with RealSrcSpans rather than SrcSpans, i.e. it
  knows that it has real locations and thus can assume that the line
  number etc really exists
* Some of the more suspicious cases are no longer necessary, e.g.
  we no longer need this case in advanceSrcLoc:
      advanceSrcLoc loc _ = loc -- Better than nothing

More improvements can probably be made, e.g. tick locations can
probably use RealSrcSpans too.
parent cba098d7
......@@ -480,12 +480,14 @@ ppr_z_occ_name occ = ftext (zEncodeFS (occNameFS occ))
-- Prints (if mod information is available) "Defined at <loc>" or
-- "Defined in <mod>" information for a Name.
pprNameLoc :: Name -> SDoc
pprNameLoc name
| isGoodSrcSpan loc = pprDefnLoc loc
| isInternalName name || isSystemName name
= ptext (sLit "<no location info>")
| otherwise = ptext (sLit "Defined in ") <> ppr (nameModule name)
where loc = nameSrcSpan name
pprNameLoc name = case nameSrcSpan name of
RealSrcSpan s ->
pprDefnLoc s
UnhelpfulSpan _
| isInternalName name || isSystemName name ->
ptext (sLit "<no location info>")
| otherwise ->
ptext (sLit "Defined in ") <> ppr (nameModule name)
\end{code}
%************************************************************************
......
......@@ -677,14 +677,16 @@ pprNameProvenance (GRE {gre_name = name, gre_prov = Imported whys})
-- If we know the exact definition point (which we may do with GHCi)
-- then show that too. But not if it's just "imported from X".
ppr_defn :: SrcLoc -> SDoc
ppr_defn loc | isGoodSrcLoc loc = parens (ptext (sLit "defined at") <+> ppr loc)
| otherwise = empty
ppr_defn (RealSrcLoc loc) = parens (ptext (sLit "defined at") <+> ppr loc)
ppr_defn (UnhelpfulLoc _) = empty
instance Outputable ImportSpec where
ppr imp_spec
= ptext (sLit "imported from") <+> ppr (importSpecModule imp_spec)
<+> if isGoodSrcSpan loc then ptext (sLit "at") <+> ppr loc
else empty
<+> pprLoc
where
loc = importSpecLoc imp_spec
pprLoc = case loc of
RealSrcSpan s -> ptext (sLit "at") <+> ppr s
UnhelpfulSpan _ -> empty
\end{code}
This diff is collapsed.
......@@ -173,7 +173,7 @@ data CmmToken
-- -----------------------------------------------------------------------------
-- Lexer actions
type Action = SrcSpan -> StringBuffer -> Int -> P (Located CmmToken)
type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated CmmToken)
begin :: Int -> Action
begin code _span _str _len = do pushLexState code; lexToken
......@@ -268,7 +268,7 @@ tok_string str = CmmT_String (read str)
setLine :: Int -> Action
setLine code span buf len = do
let line = parseUnsignedInteger buf len 10 octDecDigit
setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
-- subtract one: the line number refers to the *following* line
-- trace ("setLine " ++ show line) $ do
popLexState
......@@ -278,7 +278,7 @@ setLine code span buf len = do
setFile :: Int -> Action
setFile code span buf len = do
let file = lexemeToFastString (stepOn buf) (len-2)
setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
popLexState
pushLexState code
lexToken
......@@ -289,16 +289,16 @@ setFile code span buf len = do
cmmlex :: (Located CmmToken -> P a) -> P a
cmmlex cont = do
tok@(L _ tok__) <- lexToken
--trace ("token: " ++ show tok__) $ do
cont tok
(L span tok) <- lexToken
--trace ("token: " ++ show tok) $ do
cont (L (RealSrcSpan span) tok)
lexToken :: P (Located CmmToken)
lexToken :: P (RealLocated CmmToken)
lexToken = do
inp@(loc1,buf) <- getInput
sc <- getLexState
case alexScan inp sc of
AlexEOF -> do let span = mkSrcSpan loc1 loc1
AlexEOF -> do let span = mkRealSrcSpan loc1 loc1
setLastToken span 0
return (L span CmmT_EOF)
AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error"
......@@ -307,7 +307,7 @@ lexToken = do
lexToken
AlexToken inp2@(end,buf2) len t -> do
setInput inp2
let span = mkSrcSpan loc1 end
let span = mkRealSrcSpan loc1 end
span `seq` setLastToken span len
t span buf len
......@@ -315,7 +315,7 @@ lexToken = do
-- Monad stuff
-- Stuff that Alex needs to know about our input type:
type AlexInput = (SrcLoc,StringBuffer)
type AlexInput = (RealSrcLoc,StringBuffer)
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (_,s) = prevChar s '\n'
......
......@@ -1062,7 +1062,7 @@ parseCmmFile dflags filename = do
showPass dflags "ParseCmm"
buf <- hGetStringBuffer filename
let
init_loc = mkSrcLoc (mkFastString filename) 1 1
init_loc = mkRealSrcLoc (mkFastString filename) 1 1
init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
-- reset the lex_state: the Lexer monad leaves some stuff
-- in there we don't want.
......
......@@ -846,26 +846,16 @@ allocBinTickBox boxLabel pos m
allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e)
isGoodSrcSpan' :: SrcSpan -> Bool
isGoodSrcSpan' pos
| not (isGoodSrcSpan pos) = False
| start == end = False
| otherwise = True
where
start = srcSpanStart pos
end = srcSpanEnd pos
isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
isGoodSrcSpan' (UnhelpfulSpan _) = False
mkHpcPos :: SrcSpan -> HpcPos
mkHpcPos pos
| not (isGoodSrcSpan' pos) = panic "bad source span; expected such spans to be filtered out"
| otherwise = hpcPos
where
start = srcSpanStart pos
end = srcSpanEnd pos
hpcPos = toHpcPos ( srcLocLine start
, srcLocCol start
, srcLocLine end
, srcLocCol end - 1
)
mkHpcPos pos@(RealSrcSpan s)
| isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
srcSpanStartCol s,
srcSpanEndLine s,
srcSpanEndCol s)
mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
hpcSrcSpan :: SrcSpan
hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
......
......@@ -15,7 +15,7 @@ import HsDoc ( HsDocString )
import Outputable
import FastString
import SrcLoc ( Located(..), noLoc )
import SrcLoc
import Data.Data
\end{code}
......
......@@ -41,7 +41,7 @@ import HsDoc
-- others:
import IfaceSyn ( IfaceBinding )
import Outputable
import SrcLoc ( Located(..) )
import SrcLoc
import Module ( Module, ModuleName )
import FastString
......
......@@ -187,7 +187,7 @@ module GHC (
-- ** Source locations
SrcLoc, pprDefnLoc,
mkSrcLoc, isGoodSrcLoc, noSrcLoc,
mkSrcLoc, noSrcLoc,
srcLocFile, srcLocLine, srcLocCol,
SrcSpan,
mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
......@@ -197,7 +197,7 @@ module GHC (
srcSpanStartCol, srcSpanEndCol,
-- ** Located
Located(..),
GenLocated(..), Located,
-- *** Constructing Located
noLoc, mkGeneralLocated,
......@@ -1105,7 +1105,7 @@ getModuleSourceAndFlags mod = do
getTokenStream :: GhcMonad m => Module -> m [Located Token]
getTokenStream mod = do
(sourceFile, source, flags) <- getModuleSourceAndFlags mod
let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return ts
PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
......@@ -1116,7 +1116,7 @@ getTokenStream mod = do
getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
getRichTokenStream mod = do
(sourceFile, source, flags) <- getModuleSourceAndFlags mod
let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return $ addSourceToTokens startLoc source ts
PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
......@@ -1124,21 +1124,22 @@ getRichTokenStream mod = do
-- | Given a source location and a StringBuffer corresponding to this
-- location, return a rich token stream with the source associated to the
-- tokens.
addSourceToTokens :: SrcLoc -> StringBuffer -> [Located Token]
addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
-> [(Located Token, String)]
addSourceToTokens _ _ [] = []
addSourceToTokens loc buf (t@(L span _) : ts)
| not (isGoodSrcSpan span) = (t,"") : addSourceToTokens loc buf ts
| otherwise = (t,str) : addSourceToTokens newLoc newBuf ts
where
(newLoc, newBuf, str) = go "" loc buf
start = srcSpanStart span
end = srcSpanEnd span
go acc loc buf | loc < start = go acc nLoc nBuf
| start <= loc && loc < end = go (ch:acc) nLoc nBuf
| otherwise = (loc, buf, reverse acc)
where (ch, nBuf) = nextChar buf
nLoc = advanceSrcLoc loc ch
= case span of
UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts
RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts
where
(newLoc, newBuf, str) = go "" loc buf
start = realSrcSpanStart s
end = realSrcSpanEnd s
go acc loc buf | loc < start = go acc nLoc nBuf
| start <= loc && loc < end = go (ch:acc) nLoc nBuf
| otherwise = (loc, buf, reverse acc)
where (ch, nBuf) = nextChar buf
nLoc = advanceSrcLoc loc ch
-- | Take a rich token stream such as produced from 'getRichTokenStream' and
......@@ -1146,21 +1147,26 @@ addSourceToTokens loc buf (t@(L span _) : ts)
-- insignificant whitespace.)
showRichTokenStream :: [(Located Token, String)] -> String
showRichTokenStream ts = go startLoc ts ""
where sourceFile = srcSpanFile (getLoc . fst . head $ ts)
startLoc = mkSrcLoc sourceFile 1 1
where sourceFile = getFile $ map (getLoc . fst) ts
getFile [] = panic "showRichTokenStream: No source file found"
getFile (UnhelpfulSpan _ : xs) = getFile xs
getFile (RealSrcSpan s : _) = srcSpanFile s
startLoc = mkRealSrcLoc sourceFile 1 1
go _ [] = id
go loc ((L span _, str):ts)
| not (isGoodSrcSpan span) = go loc ts
| locLine == tokLine = ((replicate (tokCol - locCol) ' ') ++)
. (str ++)
. go tokEnd ts
| otherwise = ((replicate (tokLine - locLine) '\n') ++)
. ((replicate tokCol ' ') ++)
. (str ++)
. go tokEnd ts
where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
(tokLine, tokCol) = (srcSpanStartLine span, srcSpanStartCol span)
tokEnd = srcSpanEnd span
= case span of
UnhelpfulSpan _ -> go loc ts
RealSrcSpan s
| locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++)
. (str ++)
. go tokEnd ts
| otherwise -> ((replicate (tokLine - locLine) '\n') ++)
. ((replicate tokCol ' ') ++)
. (str ++)
. go tokEnd ts
where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
(tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s)
tokEnd = realSrcSpanEnd s
-- -----------------------------------------------------------------------------
-- Interactive evaluation
......@@ -1258,7 +1264,7 @@ parser :: String -- ^ Haskell module source text (full Unicode is suppor
parser str dflags filename =
let
loc = mkSrcLoc (mkFastString filename) 1 1
loc = mkRealSrcLoc (mkFastString filename) 1 1
buf = stringToStringBuffer str
in
case unP Parser.parseModule (mkPState dflags buf loc) of
......
......@@ -55,7 +55,7 @@ getImports :: DynFlags
-> IO ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
-- ^ The source imports, normal imports, and the module name.
getImports dflags buf filename source_filename = do
let loc = mkSrcLoc (mkFastString filename) 1 1
let loc = mkRealSrcLoc (mkFastString filename) 1 1
case unP parseHeader (mkPState dflags buf loc) of
PFailed span err -> parseError span err
POk pst rdr_module -> do
......@@ -143,7 +143,7 @@ lazyGetToks dflags filename handle = do
buf <- hGetStringBufferBlock handle blockSize
unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False
where
loc = mkSrcLoc (mkFastString filename) 1 1
loc = mkRealSrcLoc (mkFastString filename) 1 1
lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token]
lazyLexBuf handle state eof = do
......@@ -160,7 +160,7 @@ lazyGetToks dflags filename handle = do
_other -> do rest <- lazyLexBuf handle state' eof
return (t : rest)
_ | not eof -> getMore handle state
| otherwise -> return [L (last_loc state) ITeof]
| otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof]
-- parser assumes an ITeof sentinel at the end
getMore :: Handle -> PState -> IO [Located Token]
......@@ -175,12 +175,12 @@ lazyGetToks dflags filename handle = do
getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
getToks dflags filename buf = lexAll (pragState dflags buf loc)
where
loc = mkSrcLoc (mkFastString filename) 1 1
loc = mkRealSrcLoc (mkFastString filename) 1 1
lexAll state = case unP (lexer return) state of
POk _ t@(L _ ITeof) -> [t]
POk state' t -> t : lexAll state'
_ -> [L (last_loc state) ITeof]
_ -> [L (RealSrcSpan (last_loc state)) ITeof]
-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
......
......@@ -340,7 +340,7 @@ hscParse' mod_summary
Just b -> return b
Nothing -> liftIO $ hGetStringBuffer src_filename
let loc = mkSrcLoc (mkFastString src_filename) 1 1
let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
case unP parseModule (mkPState dflags buf loc) of
PFailed span err ->
......@@ -1186,7 +1186,7 @@ hscParseThingWithLocation source linenumber parser str
liftIO $ showPass dflags "Parser"
let buf = stringToStringBuffer str
loc = mkSrcLoc (fsLit source) linenumber 1
loc = mkRealSrcLoc (fsLit source) linenumber 1
case unP parser (mkPState dflags buf loc) of
......
......@@ -136,7 +136,7 @@ import CoreSyn ( CoreRule, CoreVect )
import Maybes ( orElse, expectJust, catMaybes )
import Outputable
import BreakArray
import SrcLoc ( SrcSpan, Located(..) )
import SrcLoc
import UniqFM ( lookupUFM, eltsUFM, emptyUFM )
import UniqSupply ( UniqSupply )
import FastString
......
This diff is collapsed.
......@@ -41,9 +41,7 @@ import ForeignCall ( Safety(..), CExportSpec(..), CLabelString,
)
import OccName ( varName, dataName, tcClsName, tvName )
import DataCon ( DataCon, dataConName )
import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
SrcSpan, combineLocs, srcLocFile,
mkSrcLoc, mkSrcSpan )
import SrcLoc
import Module
import StaticFlags ( opt_SccProfilingOn, opt_Hpc )
import Type ( Kind, liftedTypeKind, unliftedTypeKind )
......@@ -1262,7 +1260,7 @@ quasiquote :: { Located (HsQuasiQuote RdrName) }
: TH_QUASIQUOTE { let { loc = getLoc $1
; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1
; quoterId = mkUnqual varName quoter }
in L1 (mkHsQuasiQuote quoterId quoteSpan quote) }
in L1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
exp :: { LHsExpr RdrName }
: infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 }
......
......@@ -1053,7 +1053,11 @@ unknownNameSuggestErr where_look tried_rdr_name
where
pp_item :: (RdrName, HowInScope) -> SDoc
pp_item (rdr, Left loc) = quotes (ppr rdr) <+> -- Locally defined
parens (ptext (sLit "line") <+> int (srcSpanStartLine loc))
parens (ptext (sLit "line") <+> int (srcSpanStartLine loc'))
where loc' = case loc of
UnhelpfulSpan _ ->
panic "unknownNameSuggestErr UnhelpfulSpan"
RealSrcSpan l -> l
pp_item (rdr, Right is) = quotes (ppr rdr) <+> -- Imported
parens (ptext (sLit "imported from") <+> ppr (is_mod is))
......
......@@ -3,7 +3,7 @@ module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where
import TcRnTypes
import HsSyn
import SrcLoc ( Located(..) )
import SrcLoc
rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString)
......
......@@ -22,7 +22,7 @@ import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon )
import Name ( Name, getName, isTyVarName )
import NameSet
import BasicTypes ( Boxity )
import SrcLoc ( Located(..), unLoc )
import SrcLoc
\end{code}
%************************************************************************
......
......@@ -1256,7 +1256,9 @@ warnUnusedImportDecls gbl_env
; ifDOptM Opt_D_dump_minimal_imports $
printMinimalImports usage }
where
explicit_import (L loc _) = isGoodSrcSpan loc
explicit_import (L loc _) = case loc of
UnhelpfulSpan _ -> False
RealSrcSpan _ -> True
-- Filter out the implicit Prelude import
-- which we do not want to bleat about
\end{code}
......
......@@ -494,9 +494,10 @@ getSrcSpanM :: TcRn SrcSpan
getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
setSrcSpan loc thing_inside
| isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
| otherwise = thing_inside -- Don't overwrite useful info with useless
setSrcSpan loc@(RealSrcSpan _) thing_inside
= updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
-- Don't overwrite useful info with useless:
setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
addLocM :: (a -> TcM b) -> Located a -> TcM b
addLocM fn (L loc a) = setSrcSpan loc $ fn a
......
......@@ -897,13 +897,17 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
qReport False msg = addReport (text msg) empty
qLocation = do { m <- getModule
; l <- getSrcSpanM
; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
, TH.loc_module = moduleNameString (moduleName m)
, TH.loc_package = packageIdString (modulePackageId m)
, TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
, TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) }
; l <- getSrcSpanM
; r <- case l of
UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
(ppr l)
RealSrcSpan s -> return s
; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
, TH.loc_module = moduleNameString (moduleName m)
, TH.loc_package = packageIdString (modulePackageId m)
, TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
, TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
qReify v = reify v
qClassInstances = lookupClassInstances
......
......@@ -18,6 +18,7 @@ import GHC
import GhciMonad
import Outputable
import Util
import SrcLoc
-- ToDo: figure out whether we need these, and put something appropriate
-- into the GHC API instead
......@@ -91,13 +92,13 @@ listModuleTags m = do
let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo
let localNames = filter ((m==) . nameModule) names
mbTyThings <- mapM GHC.lookupName localNames
return $! [ tagInfo unqual exported kind name loc
return $! [ tagInfo unqual exported kind name realLoc
| tyThing <- catMaybes mbTyThings
, let name = getName tyThing
, let exported = GHC.modInfoIsExportedName mInfo name
, let kind = tyThing2TagKind tyThing
, let loc = srcSpanStart (nameSrcSpan name)
, isGoodSrcLoc loc
, RealSrcLoc realLoc <- [loc]
]
where
......@@ -120,7 +121,7 @@ data TagInfo = TagInfo
-- get tag info, for later translation into Vim or Emacs style
tagInfo :: PrintUnqualified -> Bool -> Char -> Name -> SrcLoc -> TagInfo
tagInfo :: PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc -> TagInfo
tagInfo unqual exported kind name loc
= TagInfo exported kind
(showSDocForUser unqual $ pprOccName (nameOccName name))
......
......@@ -687,7 +687,7 @@ checkInputForLayout stmt getStmt = do
let dflags = xopt_set dflags' Opt_AlternativeLayoutRule
st <- lift $ getGHCiState
let buf = stringToStringBuffer stmt
loc = mkSrcLoc (fsLit (progname st)) (line_number st) 1
loc = mkRealSrcLoc (fsLit (progname st)) (line_number st) 1
pstate = Lexer.mkPState dflags buf loc
case Lexer.unP goToEnd pstate of
(Lexer.POk _ False) -> return $ Just stmt
......@@ -2061,12 +2061,15 @@ stepModuleCmd expression = stepCmd expression
-- | Returns the span of the largest tick containing the srcspan given
enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
enclosingTickSpan mod src = do
enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
enclosingTickSpan mod (RealSrcSpan src) = do
ticks <- getTickArray mod
let line = srcSpanStartLine src
ASSERT (inRange (bounds ticks) line) do
let enclosing_spans = [ span | (_,span) <- ticks ! line
, srcSpanEnd span >= srcSpanEnd src]
let toRealSrcSpan (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
toRealSrcSpan (RealSrcSpan s) = s
enclosing_spans = [ span | (_,span) <- ticks ! line
, realSrcSpanEnd (toRealSrcSpan span) >= realSrcSpanEnd src]
return . head . sortBy leftmost_largest $ enclosing_spans
traceCmd :: String -> GHCi ()
......@@ -2178,13 +2181,15 @@ breakSwitch (arg1:rest)
| otherwise = do -- try parsing it as an identifier
wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
if GHC.isGoodSrcLoc loc
then ASSERT( isExternalName name )
case loc of
RealSrcLoc l ->
ASSERT( isExternalName name )
findBreakAndSet (GHC.nameModule name) $
findBreakByCoord (Just (GHC.srcLocFile loc))
(GHC.srcLocLine loc,
GHC.srcLocCol loc)
else noCanDo name $ text "can't find its location: " <> ppr loc
findBreakByCoord (Just (GHC.srcLocFile l))
(GHC.srcLocLine l,
GHC.srcLocCol l)
UnhelpfulLoc _ ->
noCanDo name $ text "can't find its location: " <> ppr loc
where
noCanDo n why = printForUser $
text "cannot set breakpoint on " <> ppr n <> text ": " <> why
......@@ -2249,10 +2254,12 @@ findBreakByLine line arr
ticks = arr ! line
starts_here = [ tick | tick@(_,span) <- ticks,
GHC.srcSpanStartLine span == line ]
GHC.srcSpanStartLine (toRealSpan span) == line ]
(complete,incomplete) = partition ends_here starts_here
where ends_here (_,span) = GHC.srcSpanEndLine span == line
where ends_here (_,span) = GHC.srcSpanEndLine (toRealSpan span) == line
toRealSpan (RealSrcSpan span) = span
toRealSpan (UnhelpfulSpan _) = panic "findBreakByLine UnhelpfulSpan"
findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
-> Maybe (BreakIndex,SrcSpan)
......@@ -2269,12 +2276,16 @@ findBreakByCoord mb_file (line, col) arr
is_correct_file span ]
is_correct_file span
| Just f <- mb_file = GHC.srcSpanFile span == f
| Just f <- mb_file = GHC.srcSpanFile (toRealSpan span) == f
| otherwise = True
after_here = [ tick | tick@(_,span) <- ticks,
GHC.srcSpanStartLine span == line,
GHC.srcSpanStartCol span >= col ]
let span' = toRealSpan span,
GHC.srcSpanStartLine span' == line,
GHC.srcSpanStartCol span' >= col ]
toRealSpan (RealSrcSpan span) = span
toRealSpan (UnhelpfulSpan _) = panic "findBreakByCoord UnhelpfulSpan"
-- For now, use ANSI bold on terminals that we know support it.
-- Otherwise, we add a line of carets under the active expression instead.
......@@ -2300,9 +2311,9 @@ listCmd' "" = do
case mb_span of
Nothing ->
printForUser $ text "Not stopped at a breakpoint; nothing to list"
Just span
| GHC.isGoodSrcSpan span -> listAround span True
| otherwise ->
Just (RealSrcSpan span) ->
listAround span True
Just span@(UnhelpfulSpan _) ->
do resumes <- GHC.getResumeContext
case resumes of
[] -> panic "No resumes"
......@@ -2328,17 +2339,18 @@ list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
list2 [arg] = do
wantNameFromInterpretedModule noCanDo arg $ \name -> do
let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
if GHC.isGoodSrcLoc loc
then do
tickArray <- ASSERT( isExternalName name )
case loc of
RealSrcLoc l ->
do tickArray <- ASSERT( isExternalName name )
lift $ getTickArray (GHC.nameModule name)
let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
(GHC.srcLocLine loc, GHC.srcLocCol loc)
let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))
(GHC.srcLocLine l, GHC.srcLocCol l)
tickArray
case mb_span of
Nothing -> listAround (GHC.srcLocSpan loc) False
Just (_,span) -> listAround span False
else
Nothing -> listAround (realSrcLocSpan l) False
Just (_, UnhelpfulSpan _) -> panic "list2 UnhelpfulSpan"
Just (_, RealSrcSpan span) -> listAround span False
UnhelpfulLoc _ ->
noCanDo name $ text "can't find its location: " <>
ppr loc
where
......@@ -2355,8 +2367,8 @@ listModuleLine modl line = do
[] -> panic "listModuleLine"
summ:_ -> do
let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
listAround (GHC.srcLocSpan loc) False
loc = mkRealSrcLoc (mkFastString (filename)) line 0
listAround (realSrcLocSpan loc) False
-- | list a section of a source file around a particular SrcSpan.
-- If the highlight flag is True, also highlight the span using
......@@ -2367,7 +2379,7 @@ listModuleLine modl line = do
-- 2) convert the BS to String using utf-string, and write it out.
-- It would be better if we could convert directly between UTF-8 and the
-- console encoding, of course.
listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()
listAround span do_highlight = do
contents <- liftIO $ BS.readFile (unpackFS file)
let
......@@ -2454,11 +2466,14 @@ mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
mkTickArray ticks
= accumArray (flip (:)) [] (1, max_line)
[ (line, (nm,span)) | (nm,span) <- ticks,
line <- srcSpanLines span ]
let span' = toRealSpan span,
line <- srcSpanLines span' ]
where
max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
max_line = foldr max 0 (map (GHC.srcSpanEndLine . toRealSpan . snd) ticks)
srcSpanLines span = [ GHC.srcSpanStartLine span ..
GHC.srcSpanEndLine span ]
toRealSpan (RealSrcSpan span) = span
toRealSpan (UnhelpfulSpan _) = panic "mkTickArray UnhelpfulSpan"
lookupModule :: GHC.GhcMonad m => String -> m Module
lookupModule modName
......@@ -2500,3 +2515,4 @@ setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
setBreakFlag toggle array index
| toggle = GHC.setBreakOn array index
| otherwise = GHC.setBreakOff array index
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment