Commit b2bd63f9 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

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