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}
......@@ -7,10 +7,11 @@
-- in source files, and allow tagging of those things with locations
module SrcLoc (
-- * SrcLoc
SrcLoc, -- Abstract
RealSrcLoc, -- Abstract
SrcLoc(..),
-- ** Constructing SrcLoc
mkSrcLoc, mkGeneralSrcLoc,
mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc,
noSrcLoc, -- "I'm sorry, I haven't a clue"
generatedSrcLoc, -- Code generated within the compiler
......@@ -26,22 +27,21 @@ module SrcLoc (
-- ** Misc. operations on SrcLoc
pprDefnLoc,
-- ** Predicates on SrcLoc
isGoodSrcLoc,
-- * SrcSpan
SrcSpan, -- Abstract
RealSrcSpan, -- Abstract
SrcSpan(..),
-- ** Constructing SrcSpan
mkGeneralSrcSpan, mkSrcSpan,
mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,
noSrcSpan,
wiredInSrcSpan, -- Something wired into the compiler
srcLocSpan,
srcLocSpan, realSrcLocSpan,
combineSrcSpans,
-- ** Deconstructing SrcSpan
srcSpanStart, srcSpanEnd,
realSrcSpanStart, realSrcSpanEnd,
srcSpanFileName_maybe,
-- ** Unsafely deconstructing SrcSpan
......@@ -54,7 +54,9 @@ module SrcLoc (
isGoodSrcSpan, isOneLineSpan,
-- * Located
Located(..),
Located,
RealLocated,
GenLocated(..),
-- ** Constructing Located
noLoc,
......@@ -89,10 +91,13 @@ We keep information about the {\em definition} point for each entity;
this is the obvious stuff:
\begin{code}
-- | Represents a single point within a file
data SrcLoc
data RealSrcLoc
= SrcLoc FastString -- A precise location (file name)
{-# UNPACK #-} !Int -- line number, begins at 1
{-# UNPACK #-} !Int -- column number, begins at 1
data SrcLoc
= RealSrcLoc {-# UNPACK #-}!RealSrcLoc
| UnhelpfulLoc FastString -- Just a general indication
\end{code}
......@@ -104,7 +109,10 @@ data SrcLoc
\begin{code}
mkSrcLoc :: FastString -> Int -> Int -> SrcLoc
mkSrcLoc x line col = SrcLoc x line col
mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col)
mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc x line col = SrcLoc x line col
-- | Built-in "bad" 'SrcLoc' values for particular locations
noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc
......@@ -116,35 +124,26 @@ interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive session>")
mkGeneralSrcLoc :: FastString -> SrcLoc
mkGeneralSrcLoc = UnhelpfulLoc
-- | "Good" 'SrcLoc's have precise information about their location
isGoodSrcLoc :: SrcLoc -> Bool
isGoodSrcLoc (SrcLoc _ _ _) = True
isGoodSrcLoc _other = False
-- | Gives the filename of the 'SrcLoc' if it is available, otherwise returns a dummy value
srcLocFile :: SrcLoc -> FastString
-- | Gives the filename of the 'RealSrcLoc'
srcLocFile :: RealSrcLoc -> FastString
srcLocFile (SrcLoc fname _ _) = fname
srcLocFile _other = (fsLit "<unknown file")
-- | Raises an error when used on a "bad" 'SrcLoc'
srcLocLine :: SrcLoc -> Int
srcLocLine :: RealSrcLoc -> Int
srcLocLine (SrcLoc _ l _) = l
srcLocLine (UnhelpfulLoc s) = pprPanic "srcLocLine" (ftext s)
-- | Raises an error when used on a "bad" 'SrcLoc'
srcLocCol :: SrcLoc -> Int
srcLocCol :: RealSrcLoc -> Int
srcLocCol (SrcLoc _ _ c) = c
srcLocCol (UnhelpfulLoc s) = pprPanic "srcLocCol" (ftext s)
-- | Move the 'SrcLoc' down by one line if the character is a newline,
-- to the next 8-char tabstop if it is a tab, and across by one
-- character in any other case
advanceSrcLoc :: SrcLoc -> Char -> SrcLoc
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) _ = SrcLoc f l (c + 1)
advanceSrcLoc loc _ = loc -- Better than nothing
\end{code}
%************************************************************************
......@@ -157,21 +156,31 @@ advanceSrcLoc loc _ = loc -- Better than nothing
-- SrcLoc is an instance of Ord so that we can sort error messages easily
instance Eq SrcLoc where
loc1 == loc2 = case loc1 `cmpSrcLoc` loc2 of
EQ -> True
_other -> False
EQ -> True
_other -> False
instance Eq RealSrcLoc where
loc1 == loc2 = case loc1 `cmpRealSrcLoc` loc2 of
EQ -> True
_other -> False
instance Ord SrcLoc where
compare = cmpSrcLoc
instance Ord RealSrcLoc where
compare = cmpRealSrcLoc
cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering
cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2
cmpSrcLoc (UnhelpfulLoc _) (SrcLoc _ _ _) = GT
cmpSrcLoc (SrcLoc _ _ _) (UnhelpfulLoc _) = LT
cmpSrcLoc (UnhelpfulLoc _) (RealSrcLoc _) = GT
cmpSrcLoc (RealSrcLoc _) (UnhelpfulLoc _) = LT
cmpSrcLoc (RealSrcLoc l1) (RealSrcLoc l2) = (l1 `compare` l2)
cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2)
cmpRealSrcLoc :: RealSrcLoc -> RealSrcLoc -> Ordering
cmpRealSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2)
= (s1 `compare` s2) `thenCmp` (l1 `compare` l2) `thenCmp` (c1 `compare` c2)
instance Outputable SrcLoc where
instance Outputable RealSrcLoc where
ppr (SrcLoc src_path src_line src_col)
= getPprStyle $ \ sty ->
if userStyle sty || debugStyle sty then
......@@ -183,8 +192,16 @@ instance Outputable SrcLoc where
hcat [text "{-# LINE ", int src_line, space,
char '\"', pprFastFilePath src_path, text " #-}"]
instance Outputable SrcLoc where
ppr (RealSrcLoc l) = ppr l
ppr (UnhelpfulLoc s) = ftext s
instance Data RealSrcSpan where
-- don't traverse?
toConstr _ = abstractConstr "RealSrcSpan"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "RealSrcSpan"
instance Data SrcSpan where
-- don't traverse?
toConstr _ = abstractConstr "SrcSpan"
......@@ -209,7 +226,7 @@ The end position is defined to be the column /after/ the end of the
span. That is, a span of (1,1)-(1,2) is one character long, and a
span of (1,1)-(1,1) is zero characters long.
-}
data SrcSpan
data RealSrcSpan
= SrcSpanOneLine -- a common case: a single line
{ srcSpanFile :: !FastString,
srcSpanLine :: {-# UNPACK #-} !Int,
......@@ -230,7 +247,15 @@ data SrcSpan
srcSpanLine :: {-# UNPACK #-} !Int,
srcSpanCol :: {-# UNPACK #-} !Int
}
#ifdef DEBUG
deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, becuase we
-- derive Show for Token
#else
deriving (Eq, Typeable)
#endif
data SrcSpan =
RealSrcSpan !RealSrcSpan
| UnhelpfulSpan !FastString -- Just a general indication
-- also used to indicate an empty span
......@@ -253,13 +278,14 @@ mkGeneralSrcSpan = UnhelpfulSpan
-- | Create a 'SrcSpan' corresponding to a single point
srcLocSpan :: SrcLoc -> SrcSpan
srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
srcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col
srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l)
realSrcLocSpan :: RealSrcLoc -> RealSrcSpan
realSrcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col
-- | Create a 'SrcSpan' between two points in a file
mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
mkSrcSpan loc1 loc2
mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan loc1 loc2
| line1 == line2 = if col1 == col2
then SrcSpanPoint file line1 col1
else SrcSpanOneLine file line1 col1 col2
......@@ -271,12 +297,25 @@ mkSrcSpan loc1 loc2
col2 = srcLocCol loc2
file = srcLocFile loc1
-- | Create a 'SrcSpan' between two points in a file
mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2)
= RealSrcSpan (mkRealSrcSpan loc1 loc2)
-- | Combines two 'SrcSpan' into one that spans at least all the characters
-- within both spans. Assumes the "file" part is the same in both inputs
combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful
combineSrcSpans l (UnhelpfulSpan _) = l
combineSrcSpans span1 span2
combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)
= RealSrcSpan (combineRealSrcSpans span1 span2)
-- | Combines two 'SrcSpan' into one that spans at least all the characters
-- within both spans. Assumes the "file" part is the same in both inputs
combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan
combineRealSrcSpans span1 span2
= if line_start == line_end
then if col_start == col_end
then SrcSpanPoint file line_start col_start
......@@ -299,17 +338,14 @@ combineSrcSpans span1 span2
\begin{code}
-- | Test if a 'SrcSpan' is "good", i.e. has precise location information
isGoodSrcSpan :: SrcSpan -> Bool
isGoodSrcSpan SrcSpanOneLine{} = True
isGoodSrcSpan SrcSpanMultiLine{} = True
isGoodSrcSpan SrcSpanPoint{} = True
isGoodSrcSpan _ = False
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 s
| isGoodSrcSpan s = srcSpanStartLine s == srcSpanEndLine s
| otherwise = False
isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s
isOneLineSpan (UnhelpfulSpan _) = False
\end{code}
......@@ -321,34 +357,26 @@ isOneLineSpan s
\begin{code}
-- | Raises an error when used on a "bad" 'SrcSpan'
srcSpanStartLine :: SrcSpan -> Int
-- | Raises an error when used on a "bad" 'SrcSpan'
srcSpanEndLine :: SrcSpan -> Int
-- | Raises an error when used on a "bad" 'SrcSpan'
srcSpanStartCol :: SrcSpan -> Int
-- | Raises an error when used on a "bad" 'SrcSpan'
srcSpanEndCol :: SrcSpan -> Int
srcSpanStartLine :: RealSrcSpan -> Int
srcSpanEndLine :: RealSrcSpan -> Int
srcSpanStartCol :: RealSrcSpan -> Int
srcSpanEndCol :: RealSrcSpan -> Int
srcSpanStartLine SrcSpanOneLine{ srcSpanLine=l } = l
srcSpanStartLine SrcSpanMultiLine{ srcSpanSLine=l } = l
srcSpanStartLine SrcSpanPoint{ srcSpanLine=l } = l
srcSpanStartLine _ = panic "SrcLoc.srcSpanStartLine"
srcSpanEndLine SrcSpanOneLine{ srcSpanLine=l } = l
srcSpanEndLine SrcSpanMultiLine{ srcSpanELine=l } = l
srcSpanEndLine SrcSpanPoint{ srcSpanLine=l } = l
srcSpanEndLine _ = panic "SrcLoc.srcSpanEndLine"
srcSpanStartCol SrcSpanOneLine{ srcSpanSCol=l } = l
srcSpanStartCol SrcSpanMultiLine{ srcSpanSCol=l } = l
srcSpanStartCol SrcSpanPoint{ srcSpanCol=l } = l
srcSpanStartCol _ = panic "SrcLoc.srcSpanStartCol"
srcSpanEndCol SrcSpanOneLine{ srcSpanECol=c } = c
srcSpanEndCol SrcSpanMultiLine{ srcSpanECol=c } = c
srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c
srcSpanEndCol _ = panic "SrcLoc.srcSpanEndCol"
\end{code}
......@@ -362,26 +390,28 @@ srcSpanEndCol _ = panic "SrcLoc.srcSpanEndCol"
-- | 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)
-- | 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)
srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str
srcSpanStart s = mkSrcLoc (srcSpanFile s)
(srcSpanStartLine s)
(srcSpanStartCol s)
realSrcSpanStart :: RealSrcSpan -> RealSrcLoc
realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s)
(srcSpanStartLine s)
(srcSpanStartCol s)
srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str
srcSpanEnd s =
mkSrcLoc (srcSpanFile s)
(srcSpanEndLine s)
(srcSpanEndCol s)
realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc
realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s)
(srcSpanEndLine s)
(srcSpanEndCol s)
-- | Obtains the filename for a 'SrcSpan' if it is "good"
srcSpanFileName_maybe :: SrcSpan -> Maybe FastString
srcSpanFileName_maybe (SrcSpanOneLine { srcSpanFile = nm }) = Just nm
srcSpanFileName_maybe (SrcSpanMultiLine { srcSpanFile = nm }) = Just nm
srcSpanFileName_maybe (SrcSpanPoint { srcSpanFile = nm}) = Just nm
srcSpanFileName_maybe _ = Nothing
srcSpanFileName_maybe (RealSrcSpan s) = Just (srcSpanFile s)
srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing
\end{code}
......@@ -400,17 +430,31 @@ instance Ord SrcSpan where
(srcSpanEnd a `compare` srcSpanEnd b)
instance Outputable SrcSpan where
instance Outputable RealSrcSpan where
ppr span
= getPprStyle $ \ sty ->
if userStyle sty || debugStyle sty then
pprUserSpan True span
pprUserRealSpan True span
else
hcat [text "{-# LINE ", int (srcSpanStartLine span), space,
char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"]
instance Outputable SrcSpan where
ppr span
= getPprStyle $ \ sty ->
if userStyle sty || debugStyle sty then
pprUserSpan True span
else
case span of
UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan"
RealSrcSpan s -> ppr s
pprUserSpan :: Bool -> SrcSpan -> SDoc
pprUserSpan show_path (SrcSpanOneLine src_path line start_col end_col)
pprUserSpan _ (UnhelpfulSpan s) = ftext s
pprUserSpan show_path (RealSrcSpan s) = pprUserRealSpan show_path s
pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc
pprUserRealSpan show_path (SrcSpanOneLine src_path line start_col end_col)
= hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
, int line, char ':', int start_col
, ppUnless (end_col - start_col <= 1)
......@@ -420,7 +464,7 @@ pprUserSpan show_path (SrcSpanOneLine src_path line start_col end_col)
]
pprUserSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol)
pprUserRealSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol)
= hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
, parens (int sline <> char ',' <> int scol)
, char '-'
......@@ -428,17 +472,13 @@ pprUserSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol)
if ecol == 0 then int ecol else int (ecol-1))
]
pprUserSpan show_path (SrcSpanPoint src_path line col)
pprUserRealSpan show_path (SrcSpanPoint src_path line col)
= hcat [ ppWhen show_path $ (pprFastFilePath src_path <> colon)
, int line, char ':', int col ]
pprUserSpan _ (UnhelpfulSpan s) = ftext s
pprDefnLoc :: SrcSpan -> SDoc
pprDefnLoc :: RealSrcSpan -> SDoc
-- ^ Pretty prints information about the 'SrcSpan' in the style "defined at ..."
pprDefnLoc loc
| isGoodSrcSpan loc = ptext (sLit "Defined at") <+> ppr loc
| otherwise = ppr loc
pprDefnLoc loc = ptext (sLit "Defined at") <+> ppr loc
\end{code}
%************************************************************************
......@@ -449,13 +489,16 @@ pprDefnLoc loc
\begin{code}
-- | We attach SrcSpans to lots of things, so let's have a datatype for it.
data Located e = L SrcSpan e
data GenLocated l e = L l e
deriving (Eq, Ord, Typeable, Data)
unLoc :: Located e -> e
type Located e = GenLocated SrcSpan e
type RealLocated e = GenLocated RealSrcSpan e
unLoc :: GenLocated l e -> e
unLoc (L _ e) = e
getLoc :: Located e -> SrcSpan
getLoc :: GenLocated l e -> l
getLoc (L l _) = l
noLoc :: e -> Located e
......@@ -483,12 +526,16 @@ eqLocated a b = unLoc a == unLoc b
cmpLocated :: Ord a => Located a -> Located a -> Ordering
cmpLocated a b = unLoc a `compare` unLoc b
instance Functor Located where
instance Functor (GenLocated l) where
fmap f (L l e) = L l (f e)
instance Outputable e => Outputable (Located e) where
ppr (L l e) = ifPprDebug (braces (pprUserSpan False l)) $$ ppr e
-- Print spans without the file name etc
instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
ppr (L l e) = -- TODO: We can't do this since Located was refactored into
-- GenLocated:
-- Print spans without the file name etc
-- ifPprDebug (braces (pprUserSpan False l))
ifPprDebug (braces (ppr l))
$$ ppr e
\end{code}
%************************************************************************
......@@ -506,11 +553,11 @@ leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b)
`thenCmp`
(srcSpanEnd b `compare` srcSpanEnd a)
-- | Determines whether a span encloses a given line and column index
spans :: SrcSpan -> (Int, Int) -> Bool
spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
where loc = mkSrcLoc (srcSpanFile span) l c
spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan"
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
......
......@@ -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