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.
22 files changed:
-- Prints (if mod information is available) "Defined at <loc>" or
-- "Defined in <mod>" information for a Name.
pprNameLoc :: Name -> SDoc
-- 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}
%************************************************************************
\end{code}
%************************************************************************
-- 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
-- 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)
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
where
loc = importSpecLoc imp_spec
where
loc = importSpecLoc imp_spec
+ pprLoc = case loc of
+ RealSrcSpan s -> ptext (sLit "at") <+> ppr s
+ UnhelpfulSpan _ -> empty
-- in source files, and allow tagging of those things with locations
module SrcLoc (
-- * SrcLoc
-- in source files, and allow tagging of those things with locations
module SrcLoc (
-- * SrcLoc
+ RealSrcLoc, -- Abstract
+ SrcLoc(..),
-- ** Constructing SrcLoc
-- ** Constructing SrcLoc
- mkSrcLoc, mkGeneralSrcLoc,
+ mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc,
noSrcLoc, -- "I'm sorry, I haven't a clue"
generatedSrcLoc, -- Code generated within the compiler
noSrcLoc, -- "I'm sorry, I haven't a clue"
generatedSrcLoc, -- Code generated within the compiler
-- ** Misc. operations on SrcLoc
pprDefnLoc,
-- ** Misc. operations on SrcLoc
pprDefnLoc,
-
- -- ** Predicates on SrcLoc
- isGoodSrcLoc,
+ RealSrcSpan, -- Abstract
+ SrcSpan(..),
-- ** Constructing SrcSpan
-- ** Constructing SrcSpan
- mkGeneralSrcSpan, mkSrcSpan,
+ mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,
noSrcSpan,
wiredInSrcSpan, -- Something wired into the compiler
noSrcSpan,
wiredInSrcSpan, -- Something wired into the compiler
+ srcLocSpan, realSrcLocSpan,
combineSrcSpans,
-- ** Deconstructing SrcSpan
srcSpanStart, srcSpanEnd,
combineSrcSpans,
-- ** Deconstructing SrcSpan
srcSpanStart, srcSpanEnd,
+ realSrcSpanStart, realSrcSpanEnd,
srcSpanFileName_maybe,
-- ** Unsafely deconstructing SrcSpan
srcSpanFileName_maybe,
-- ** Unsafely deconstructing SrcSpan
isGoodSrcSpan, isOneLineSpan,
-- * Located
isGoodSrcSpan, isOneLineSpan,
-- * Located
+ Located,
+ RealLocated,
+ GenLocated(..),
-- ** Constructing Located
noLoc,
-- ** Constructing Located
noLoc,
this is the obvious stuff:
\begin{code}
-- | Represents a single point within a file
this is the obvious stuff:
\begin{code}
-- | Represents a single point within a file
= SrcLoc FastString -- A precise location (file name)
{-# UNPACK #-} !Int -- line number, begins at 1
{-# UNPACK #-} !Int -- column number, begins at 1
= 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}
| UnhelpfulLoc FastString -- Just a general indication
\end{code}
\begin{code}
mkSrcLoc :: FastString -> Int -> Int -> 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
-- | Built-in "bad" 'SrcLoc' values for particular locations
noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc
mkGeneralSrcLoc :: FastString -> SrcLoc
mkGeneralSrcLoc = UnhelpfulLoc
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 (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,
-- to the next 8-char tabstop if it is a tab, and across by one
-- character in any other case
-- | 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 (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}
%************************************************************************
\end{code}
%************************************************************************
-- 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
-- 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 SrcLoc where
compare = cmpSrcLoc
+
+instance Ord RealSrcLoc where
+ compare = cmpRealSrcLoc
+
cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering
cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2
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)
= (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
ppr (SrcLoc src_path src_line src_col)
= getPprStyle $ \ sty ->
if userStyle sty || debugStyle sty then
hcat [text "{-# LINE ", int src_line, space,
char '\"', pprFastFilePath src_path, text " #-}"]
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
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"
instance Data SrcSpan where
-- don't traverse?
toConstr _ = abstractConstr "SrcSpan"
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. 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.
-}
= SrcSpanOneLine -- a common case: a single line
{ srcSpanFile :: !FastString,
srcSpanLine :: {-# UNPACK #-} !Int,
= SrcSpanOneLine -- a common case: a single line
{ srcSpanFile :: !FastString,
srcSpanLine :: {-# UNPACK #-} !Int,
srcSpanLine :: {-# UNPACK #-} !Int,
srcSpanCol :: {-# UNPACK #-} !Int
}
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
| UnhelpfulSpan !FastString -- Just a general indication
-- also used to indicate an empty span
-- | Create a 'SrcSpan' corresponding to a single point
srcLocSpan :: SrcLoc -> SrcSpan
srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
-- | 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
-- | 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
| line1 == line2 = if col1 == col2
then SrcSpanPoint file line1 col1
else SrcSpanOneLine file line1 col1 col2
col2 = srcLocCol loc2
file = srcLocFile loc1
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
-- | 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
= if line_start == line_end
then if col_start == col_end
then SrcSpanPoint file line_start col_start
\begin{code}
-- | Test if a 'SrcSpan' is "good", i.e. has precise location information
isGoodSrcSpan :: SrcSpan -> Bool
\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 :: 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
--- | 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 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 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 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 SrcSpanOneLine{ srcSpanECol=c } = c
srcSpanEndCol SrcSpanMultiLine{ srcSpanECol=c } = c
srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c
-srcSpanEndCol _ = panic "SrcLoc.srcSpanEndCol"
-- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
srcSpanStart :: SrcSpan -> SrcLoc
-- | 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
-- | 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
-- | 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
(srcSpanEnd a `compare` srcSpanEnd b)
(srcSpanEnd a `compare` srcSpanEnd b)
-instance Outputable SrcSpan where
+instance Outputable RealSrcSpan where
ppr span
= getPprStyle $ \ sty ->
if userStyle sty || debugStyle sty then
ppr span
= getPprStyle $ \ sty ->
if userStyle sty || debugStyle sty then
+ pprUserRealSpan True span
else
hcat [text "{-# LINE ", int (srcSpanStartLine span), space,
char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"]
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 :: 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)
= hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
, int line, char ':', int start_col
, ppUnless (end_col - start_col <= 1)
-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 '-'
= hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
, parens (int sline <> char ',' <> int scol)
, char '-'
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)
, int line, char ':', int 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 ..."
-- ^ 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}
%************************************************************************
\end{code}
%************************************************************************
\begin{code}
-- | We attach SrcSpans to lots of things, so let's have a datatype for it.
\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)
deriving (Eq, Ord, Typeable, Data)
+type Located e = GenLocated SrcSpan e
+type RealLocated e = GenLocated RealSrcSpan e
+
+unLoc :: GenLocated l e -> e
-getLoc :: Located e -> SrcSpan
+getLoc :: GenLocated l e -> l
getLoc (L l _) = l
noLoc :: e -> Located e
getLoc (L l _) = l
noLoc :: e -> Located e
cmpLocated :: Ord a => Located a -> Located a -> Ordering
cmpLocated a b = unLoc a `compare` 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)
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}
%************************************************************************
\end{code}
%************************************************************************
`thenCmp`
(srcSpanEnd b `compare` srcSpanEnd a)
`thenCmp`
(srcSpanEnd b `compare` srcSpanEnd a)
-- | Determines whether a span encloses a given line and column index
spans :: SrcSpan -> (Int, Int) -> Bool
-- | 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
-- | Determines whether a span is enclosed by another one
isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other
-- -----------------------------------------------------------------------------
-- Lexer actions
-- -----------------------------------------------------------------------------
-- 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
begin :: Int -> Action
begin code _span _str _len = do pushLexState code; lexToken
setLine :: Int -> Action
setLine code span buf len = do
let line = parseUnsignedInteger buf len 10 octDecDigit
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
-- subtract one: the line number refers to the *following* line
-- trace ("setLine " ++ show line) $ do
popLexState
setFile :: Int -> Action
setFile code span buf len = do
let file = lexemeToFastString (stepOn buf) (len-2)
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
popLexState
pushLexState code
lexToken
cmmlex :: (Located CmmToken -> P a) -> P a
cmmlex cont = 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
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"
setLastToken span 0
return (L span CmmT_EOF)
AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error"
lexToken
AlexToken inp2@(end,buf2) len t -> do
setInput inp2
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
span `seq` setLastToken span len
t span buf len
-- Monad stuff
-- Stuff that Alex needs to know about our input type:
-- 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'
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (_,s) = prevChar s '\n'
showPass dflags "ParseCmm"
buf <- hGetStringBuffer filename
let
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.
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.
allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e)
isGoodSrcSpan' :: SrcSpan -> Bool
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 :: 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")
hpcSrcSpan :: SrcSpan
hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
import Outputable
import FastString
import Outputable
import FastString
-import SrcLoc ( Located(..), noLoc )
import Data.Data
\end{code}
import Data.Data
\end{code}
-- others:
import IfaceSyn ( IfaceBinding )
import Outputable
-- others:
import IfaceSyn ( IfaceBinding )
import Outputable
-import SrcLoc ( Located(..) )
import Module ( Module, ModuleName )
import FastString
import Module ( Module, ModuleName )
import FastString
-- ** Source locations
SrcLoc, pprDefnLoc,
-- ** Source locations
SrcLoc, pprDefnLoc,
- mkSrcLoc, isGoodSrcLoc, noSrcLoc,
srcLocFile, srcLocLine, srcLocCol,
SrcSpan,
mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
srcLocFile, srcLocLine, srcLocCol,
SrcSpan,
mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
srcSpanStartCol, srcSpanEndCol,
-- ** Located
srcSpanStartCol, srcSpanEndCol,
-- ** Located
+ GenLocated(..), Located,
-- *** Constructing Located
noLoc, mkGeneralLocated,
-- *** Constructing Located
noLoc, mkGeneralLocated,
getTokenStream :: GhcMonad m => Module -> m [Located Token]
getTokenStream mod = do
(sourceFile, source, flags) <- getModuleSourceAndFlags mod
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)
case lexTokenStream source startLoc flags of
POk _ ts -> return ts
PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
getRichTokenStream mod = do
(sourceFile, source, flags) <- getModuleSourceAndFlags mod
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)
case lexTokenStream source startLoc flags of
POk _ ts -> return $ addSourceToTokens startLoc source ts
PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
-- | Given a source location and a StringBuffer corresponding to this
-- location, return a rich token stream with the source associated to the
-- tokens.
-- | 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)
-> [(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
-- | Take a rich token stream such as produced from 'getRichTokenStream' and
-- insignificant whitespace.)
showRichTokenStream :: [(Located Token, String)] -> String
showRichTokenStream ts = go startLoc 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)
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
-- -----------------------------------------------------------------------------
-- Interactive evaluation
parser str dflags filename =
let
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
buf = stringToStringBuffer str
in
case unP Parser.parseModule (mkPState dflags buf loc) of
-> 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
-> 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
case unP parseHeader (mkPState dflags buf loc) of
PFailed span err -> parseError span err
POk pst rdr_module -> do
buf <- hGetStringBufferBlock handle blockSize
unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False
where
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
lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token]
lazyLexBuf handle state eof = do
_other -> do rest <- lazyLexBuf handle state' eof
return (t : rest)
_ | not eof -> getMore handle state
_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]
-- parser assumes an ITeof sentinel at the end
getMore :: Handle -> PState -> IO [Located Token]
getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
getToks dflags filename buf = lexAll (pragState dflags buf loc)
where
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'
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.
-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
Just b -> return b
Nothing -> liftIO $ hGetStringBuffer src_filename
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 ->
case unP parseModule (mkPState dflags buf loc) of
PFailed span err ->
liftIO $ showPass dflags "Parser"
let buf = stringToStringBuffer 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
case unP parser (mkPState dflags buf loc) of
import Maybes ( orElse, expectJust, catMaybes )
import Outputable
import BreakArray
import Maybes ( orElse, expectJust, catMaybes )
import Outputable
import BreakArray
-import SrcLoc ( SrcSpan, Located(..) )
import UniqFM ( lookupUFM, eltsUFM, emptyUFM )
import UniqSupply ( UniqSupply )
import FastString
import UniqFM ( lookupUFM, eltsUFM, emptyUFM )
import UniqSupply ( UniqSupply )
import FastString
-- definition, with some hand-coded bits.
--
-- Completely accurate information about token-spans within the source
-- definition, with some hand-coded bits.
--
-- Completely accurate information about token-spans within the source
--- file is maintained. Every token has a start and end SrcLoc attached to it.
+-- file is maintained. Every token has a start and end RealSrcLoc
+-- attached to it.
--
-----------------------------------------------------------------------------
--
-----------------------------------------------------------------------------
| ITparenEscape -- $(
| ITvarQuote -- '
| ITtyQuote -- ''
| ITparenEscape -- $(
| ITvarQuote -- '
| ITtyQuote -- ''
- | ITquasiQuote (FastString,FastString,SrcSpan) -- [:...|...|]
+ | ITquasiQuote (FastString,FastString,RealSrcSpan) -- [:...|...|]
-- Arrow notation extension
| ITproc
-- Arrow notation extension
| ITproc
-- -----------------------------------------------------------------------------
-- Lexer actions
-- -----------------------------------------------------------------------------
-- Lexer actions
-type Action = SrcSpan -> StringBuffer -> Int -> P (Located Token)
+type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token)
special :: Token -> Action
special tok span _buf _len = return (L span tok)
special :: Token -> Action
special tok span _buf _len = return (L span tok)
Layout prev_off : _ -> prev_off < offset
_ -> True
if isOK then pop_and open_brace span buf len
Layout prev_off : _ -> prev_off < offset
_ -> True
if isOK then pop_and open_brace span buf len
- else failSpanMsgP span (text "Missing block")
+ else failSpanMsgP (RealSrcSpan span) (text "Missing block")
pop_and :: Action -> Action
pop_and act span buf len = do _ <- popLexState
pop_and :: Action -> Action
pop_and act span buf len = do _ <- popLexState
nested comments require traversing by hand, they can't be parsed
using regular expressions.
-}
nested comments require traversing by hand, they can't be parsed
using regular expressions.
-}
-nested_comment :: P (Located Token) -> Action
+nested_comment :: P (RealLocated Token) -> Action
nested_comment cont span _str _len = do
input <- getInput
go "" (1::Int) input
nested_comment cont span _str _len = do
input <- getInput
go "" (1::Int) input
Just (_,_) -> go ('\123':commentAcc) input docType False
Just (c,input) -> go (c:commentAcc) input docType False
Just (_,_) -> go ('\123':commentAcc) input docType False
Just (c,input) -> go (c:commentAcc) input docType False
-withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (Located Token))
- -> P (Located Token)
+withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token))
+ -> P (RealLocated Token)
withLexedDocType lexDocComment = do
input@(AI _ buf) <- getInput
case prevChar buf ' ' of
withLexedDocType lexDocComment = do
input@(AI _ buf) <- getInput
case prevChar buf ' ' of
-- called afterwards, so it can just update the state.
docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
-- called afterwards, so it can just update the state.
docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
- SrcSpan -> P (Located Token)
+ RealSrcSpan -> P (RealLocated Token)
docCommentEnd input commentAcc docType buf span = do
setInput input
let (AI loc nextBuf) = input
comment = reverse commentAcc
docCommentEnd input commentAcc docType buf span = do
setInput input
let (AI loc nextBuf) = input
comment = reverse commentAcc
- span' = mkSrcSpan (srcSpanStart span) loc
+ span' = mkRealSrcSpan (realSrcSpanStart span) loc
last_len = byteDiff buf nextBuf
span `seq` setLastToken span' last_len
return (L span' (docType comment))
last_len = byteDiff buf nextBuf
span `seq` setLastToken span' last_len
return (L span' (docType comment))
-errBrace :: AlexInput -> SrcSpan -> P a
-errBrace (AI end _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'"
+errBrace :: AlexInput -> RealSrcSpan -> P a
+errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'"
open_brace, close_brace :: Action
open_brace span _str _len = do
open_brace, close_brace :: Action
open_brace span _str _len = do
varsym = sym ITvarsym
consym = sym ITconsym
varsym = sym ITvarsym
consym = sym ITconsym
-sym :: (FastString -> Token) -> SrcSpan -> StringBuffer -> Int
- -> P (Located Token)
+sym :: (FastString -> Token) -> RealSrcSpan -> StringBuffer -> Int
+ -> P (RealLocated Token)
sym con span buf len =
case lookupUFM reservedSymsFM fs of
Just (keyword,exts) -> do
sym con span buf len =
case lookupUFM reservedSymsFM fs of
Just (keyword,exts) -> do
setLine :: Int -> Action
setLine code span buf len = do
let line = parseUnsignedInteger buf len 10 octDecDigit
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
_ <- popLexState
pushLexState code
-- subtract one: the line number refers to the *following* line
_ <- popLexState
pushLexState code
setFile :: Int -> Action
setFile code span buf len = do
let file = lexemeToFastString (stepOn buf) (len-2)
setFile :: Int -> Action
setFile code span buf len = do
let file = lexemeToFastString (stepOn buf) (len-2)
- setAlrLastLoc noSrcSpan
- setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
+ setAlrLastLoc $ alrInitialLoc file
+ setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
_ <- popLexState
pushLexState code
lexToken
_ <- popLexState
pushLexState code
lexToken
+alrInitialLoc :: FastString -> RealSrcSpan
+alrInitialLoc file = mkRealSrcSpan loc loc
+ where -- This is a hack to ensure that the first line in a file
+ -- looks like it is after the initial location:
+ loc = mkRealSrcLoc file (-1) (-1)
-- -----------------------------------------------------------------------------
-- Options, includes and language pragmas.
-- -----------------------------------------------------------------------------
-- Options, includes and language pragmas.
start <- getSrcLoc
tok <- go [] input
end <- getSrcLoc
start <- getSrcLoc
tok <- go [] input
end <- getSrcLoc
- return (L (mkSrcSpan start end) tok)
+ return (L (mkRealSrcSpan start end) tok)
where go acc input
= if isString input "#-}"
then do setInput input
where go acc input
= if isString input "#-}"
then do setInput input
= case alexGetChar i of
Just (c,i') | c == x -> isString i' xs
_other -> False
= case alexGetChar i of
Just (c,i') | c == x -> isString i' xs
_other -> False
- err (AI end _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma"
+ err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma"
-- -----------------------------------------------------------------------------
-- -----------------------------------------------------------------------------
lex_string_tok span _buf _len = do
tok <- lex_string ""
end <- getSrcLoc
lex_string_tok span _buf _len = do
tok <- lex_string ""
end <- getSrcLoc
- return (L (mkSrcSpan (srcSpanStart span) end) tok)
+ return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok)
lex_string :: String -> P Token
lex_string s = do
lex_string :: String -> P Token
lex_string s = do
-- see if there's a trailing quote
lex_char_tok span _buf _len = do -- We've seen '
i1 <- getInput -- Look ahead to first character
-- see if there's a trailing quote
lex_char_tok span _buf _len = do -- We've seen '
i1 <- getInput -- Look ahead to first character
- let loc = srcSpanStart span
+ let loc = realSrcSpanStart span
case alexGetChar' i1 of
Nothing -> lit_error i1
case alexGetChar' i1 of
Nothing -> lit_error i1
th_exts <- extension thEnabled
if th_exts then do
setInput i2
th_exts <- extension thEnabled
if th_exts then do
setInput i2
- return (L (mkSrcSpan loc end2) ITtyQuote)
+ return (L (mkRealSrcSpan loc end2) ITtyQuote)
else lit_error i1
Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash
else lit_error i1
Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash
-- If TH is on, just parse the quote only
th_exts <- extension thEnabled
let (AI end _) = i1
-- If TH is on, just parse the quote only
th_exts <- extension thEnabled
let (AI end _) = i1
- if th_exts then return (L (mkSrcSpan loc end) ITvarQuote)
+ if th_exts then return (L (mkRealSrcSpan loc end) ITvarQuote)
-finish_char_tok :: SrcLoc -> Char -> P (Located Token)
+finish_char_tok :: RealSrcLoc -> Char -> P (RealLocated Token)
finish_char_tok loc ch -- We've already seen the closing quote
-- Just need to check for trailing #
= do magicHash <- extension magicHashEnabled
finish_char_tok loc ch -- We've already seen the closing quote
-- Just need to check for trailing #
= do magicHash <- extension magicHashEnabled
case alexGetChar' i of
Just ('#',i@(AI end _)) -> do
setInput i
case alexGetChar' i of
Just ('#',i@(AI end _)) -> do
setInput i
- return (L (mkSrcSpan loc end) (ITprimchar ch))
+ return (L (mkRealSrcSpan loc end) (ITprimchar ch))
- return (L (mkSrcSpan loc end) (ITchar ch))
+ return (L (mkRealSrcSpan loc end) (ITchar ch))
- return (L (mkSrcSpan loc end) (ITchar ch))
+ return (L (mkRealSrcSpan loc end) (ITchar ch))
isAny :: Char -> Bool
isAny c | c > '\x7f' = isPrint c
isAny :: Char -> Bool
isAny c | c > '\x7f' = isPrint c
quoteStart <- getSrcLoc
quote <- lex_quasiquote ""
end <- getSrcLoc
quoteStart <- getSrcLoc
quote <- lex_quasiquote ""
end <- getSrcLoc
- return (L (mkSrcSpan (srcSpanStart span) end)
+ return (L (mkRealSrcSpan (realSrcSpanStart span) end)
(ITquasiQuote (mkFastString quoter,
mkFastString (reverse quote),
(ITquasiQuote (mkFastString quoter,
mkFastString (reverse quote),
- mkSrcSpan quoteStart end)))
+ mkRealSrcSpan quoteStart end)))
lex_quasiquote :: String -> P String
lex_quasiquote s = do
lex_quasiquote :: String -> P String
lex_quasiquote s = do
warn :: DynFlag -> SDoc -> Action
warn option warning srcspan _buf _len = do
warn :: DynFlag -> SDoc -> Action
warn option warning srcspan _buf _len = do
- addWarning option srcspan warning
+ addWarning option (RealSrcSpan srcspan) warning
lexToken
warnThen :: DynFlag -> SDoc -> Action -> Action
warnThen option warning action srcspan buf len = do
lexToken
warnThen :: DynFlag -> SDoc -> Action -> Action
warnThen option warning action srcspan buf len = do
- addWarning option srcspan warning
+ addWarning option (RealSrcSpan srcspan) warning
action srcspan buf len
-- -----------------------------------------------------------------------------
action srcspan buf len
-- -----------------------------------------------------------------------------
buffer :: StringBuffer,
dflags :: DynFlags,
messages :: Messages,
buffer :: StringBuffer,
dflags :: DynFlags,
messages :: Messages,
- last_loc :: SrcSpan, -- pos of previous token
+ last_loc :: RealSrcSpan, -- pos of previous token
last_len :: !Int, -- len of previous token
last_len :: !Int, -- len of previous token
- loc :: SrcLoc, -- current loc (end of prev token + 1)
+ loc :: RealSrcLoc, -- current loc (end of prev token + 1)
extsBitmap :: !Int, -- bitmap that determines permitted extensions
context :: [LayoutContext],
lex_state :: [Int],
-- Used in the alternative layout rule:
-- These tokens are the next ones to be sent out. They are
-- just blindly emitted, without the rule looking at them again:
extsBitmap :: !Int, -- bitmap that determines permitted extensions
context :: [LayoutContext],
lex_state :: [Int],
-- Used in the alternative layout rule:
-- These tokens are the next ones to be sent out. They are
-- just blindly emitted, without the rule looking at them again:
- alr_pending_implicit_tokens :: [Located Token],
+ alr_pending_implicit_tokens :: [RealLocated Token],
-- This is the next token to be considered or, if it is Nothing,
-- we need to get the next token from the input stream:
-- This is the next token to be considered or, if it is Nothing,
-- we need to get the next token from the input stream:
- alr_next_token :: Maybe (Located Token),
+ alr_next_token :: Maybe (RealLocated Token),
-- This is what we consider to be the locatino of the last token
-- emitted:
-- This is what we consider to be the locatino of the last token
-- emitted:
- alr_last_loc :: SrcSpan,
+ alr_last_loc :: RealSrcSpan,
-- The stack of layout contexts:
alr_context :: [ALRContext],
-- Are we expecting a '{'? If it's Just, then the ALRLayout tells
-- The stack of layout contexts:
alr_context :: [ALRContext],
-- Are we expecting a '{'? If it's Just, then the ALRLayout tells
PFailed span err -> PFailed span err
failP :: String -> P a
PFailed span err -> PFailed span err
failP :: String -> P a
-failP msg = P $ \s -> PFailed (last_loc s) (text msg)
+failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
failMsgP :: String -> P a
failMsgP :: String -> P a
-failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg)
+failMsgP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
-failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a
-failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str)
+failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a
+failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
failSpanMsgP :: SrcSpan -> SDoc -> P a
failSpanMsgP span msg = P $ \_ -> PFailed span msg
failSpanMsgP :: SrcSpan -> SDoc -> P a
failSpanMsgP span msg = P $ \_ -> PFailed span msg
setExts :: (Int -> Int) -> P ()
setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } ()
setExts :: (Int -> Int) -> P ()
setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } ()
-setSrcLoc :: SrcLoc -> P ()
+setSrcLoc :: RealSrcLoc -> P ()
setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
+getSrcLoc :: P RealSrcLoc
getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
-setLastToken :: SrcSpan -> Int -> P ()
+setLastToken :: RealSrcSpan -> Int -> P ()
setLastToken loc len = P $ \s -> POk s {
last_loc=loc,
last_len=len
} ()
setLastToken loc len = P $ \s -> POk s {
last_loc=loc,
last_len=len
} ()
-data AlexInput = AI SrcLoc StringBuffer
+data AlexInput = AI RealSrcLoc StringBuffer
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (AI _ buf) = prevChar buf '\n'
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (AI _ buf) = prevChar buf '\n'
getLexState :: P Int
getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
getLexState :: P Int
getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
-popNextToken :: P (Maybe (Located Token))
+popNextToken :: P (Maybe (RealLocated Token))
popNextToken
= P $ \s@PState{ alr_next_token = m } ->
POk (s {alr_next_token = Nothing}) m
popNextToken
= P $ \s@PState{ alr_next_token = m } ->
POk (s {alr_next_token = Nothing}) m
([],Nothing) -> return impt
_other -> return True
([],Nothing) -> return impt
_other -> return True
-setAlrLastLoc :: SrcSpan -> P ()
+setAlrLastLoc :: RealSrcSpan -> P ()
setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()
setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()
-getAlrLastLoc :: P SrcSpan
+getAlrLastLoc :: P RealSrcSpan
getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l
getALRContext :: P [ALRContext]
getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l
getALRContext :: P [ALRContext]
setJustClosedExplicitLetBlock b
= P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()
setJustClosedExplicitLetBlock b
= P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()
-setNextToken :: Located Token -> P ()
+setNextToken :: RealLocated Token -> P ()
setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()
implicitTokenPending :: P Bool
setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()
implicitTokenPending :: P Bool
[] -> POk s False
_ -> POk s True
[] -> POk s False
_ -> POk s True
-popPendingImplicitToken :: P (Maybe (Located Token))
+popPendingImplicitToken :: P (Maybe (RealLocated Token))
popPendingImplicitToken
= P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
case ts of
[] -> POk s Nothing
(t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t)
popPendingImplicitToken
= P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
case ts of
[] -> POk s Nothing
(t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t)
-setPendingImplicitTokens :: [Located Token] -> P ()
+setPendingImplicitTokens :: [RealLocated Token] -> P ()
setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) ()
getAlrExpectingOCurly :: P (Maybe ALRLayout)
setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) ()
getAlrExpectingOCurly :: P (Maybe ALRLayout)
-- PState for parsing options pragmas
--
-- PState for parsing options pragmas
--
-pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState
+pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
pragState dynflags buf loc = (mkPState dynflags buf loc) {
lex_state = [bol, option_prags, 0]
}
-- create a parse state
--
pragState dynflags buf loc = (mkPState dynflags buf loc) {
lex_state = [bol, option_prags, 0]
}
-- create a parse state
--
-mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState
+mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
mkPState flags buf loc =
PState {
buffer = buf,
dflags = flags,
messages = emptyMessages,
mkPState flags buf loc =
PState {
buffer = buf,
dflags = flags,
messages = emptyMessages,
- last_loc = mkSrcSpan loc loc,
+ last_loc = mkRealSrcSpan loc loc,
last_len = 0,
loc = loc,
extsBitmap = fromIntegral bitmap,
last_len = 0,
loc = loc,
extsBitmap = fromIntegral bitmap,
lex_state = [bol, 0],
alr_pending_implicit_tokens = [],
alr_next_token = Nothing,
lex_state = [bol, 0],
alr_pending_implicit_tokens = [],
alr_next_token = Nothing,
- alr_last_loc = noSrcSpan,
+ alr_last_loc = alrInitialLoc (fsLit "<no file>"),
alr_context = [],
alr_expecting_ocurly = Nothing,
alr_justClosedExplicitLetBlock = False
alr_context = [],
alr_expecting_ocurly = Nothing,
alr_justClosedExplicitLetBlock = False
last_len = len, last_loc = last_loc }) ->
case ctx of
(_:tl) -> POk s{ context = tl } ()
last_len = len, last_loc = last_loc }) ->
case ctx of
(_:tl) -> POk s{ context = tl } ()
- [] -> PFailed last_loc (srcParseErr buf len)
+ [] -> PFailed (RealSrcSpan last_loc) (srcParseErr buf len)
-- Push a new layout context at the indentation of the last token read.
-- This is only used at the outer level of a module when the 'module'
-- Push a new layout context at the indentation of the last token read.
-- This is only used at the outer level of a module when the 'module'
srcParseFail :: P a
srcParseFail = P $ \PState{ buffer = buf, last_len = len,
last_loc = last_loc } ->
srcParseFail :: P a
srcParseFail = P $ \PState{ buffer = buf, last_len = len,
last_loc = last_loc } ->
- PFailed last_loc (srcParseErr buf len)
+ PFailed (RealSrcSpan last_loc) (srcParseErr buf len)
-- A lexical error is reported at a particular position in the source file,
-- not over a token range.
-- A lexical error is reported at a particular position in the source file,
-- not over a token range.
lexer cont = do
alr <- extension alternativeLayoutRule
let lexTokenFun = if alr then lexTokenAlr else lexToken
lexer cont = do
alr <- extension alternativeLayoutRule
let lexTokenFun = if alr then lexTokenAlr else lexToken
- tok@(L _span _tok__) <- lexTokenFun
- --trace ("token: " ++ show _tok__) $ do
- cont tok
+ (L span tok) <- lexTokenFun
+ --trace ("token: " ++ show tok) $ do
+ cont (L (RealSrcSpan span) tok)
-lexTokenAlr :: P (Located Token)
+lexTokenAlr :: P (RealLocated Token)
lexTokenAlr = do mPending <- popPendingImplicitToken
t <- case mPending of
Nothing ->
lexTokenAlr = do mPending <- popPendingImplicitToken
t <- case mPending of
Nothing ->
-alternativeLayoutRuleToken :: Located Token -> P (Located Token)
+alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token)
alternativeLayoutRuleToken t
= do context <- getALRContext
lastLoc <- getAlrLastLoc
alternativeLayoutRuleToken t
= do context <- getALRContext
lastLoc <- getAlrLastLoc
let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags
thisLoc = getLoc t
thisCol = srcSpanStartCol thisLoc
let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags
thisLoc = getLoc t
thisCol = srcSpanStartCol thisLoc
- newLine = (lastLoc == noSrcSpan)
- || (srcSpanStartLine thisLoc > srcSpanEndLine lastLoc)
+ newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc
case (unLoc t, context, mExpectingOCurly) of
-- This case handles a GHC extension to the original H98
-- layout rule...
case (unLoc t, context, mExpectingOCurly) of
-- This case handles a GHC extension to the original H98
-- layout rule...
(ITwhere, ALRLayout _ col : ls, _)
| newLine && thisCol == col && transitional ->
do addWarning Opt_WarnAlternativeLayoutRuleTransitional
(ITwhere, ALRLayout _ col : ls, _)
| newLine && thisCol == col && transitional ->
do addWarning Opt_WarnAlternativeLayoutRuleTransitional
(transitionalAlternativeLayoutWarning
"`where' clause at the same depth as implicit layout block")
setALRContext ls
(transitionalAlternativeLayoutWarning
"`where' clause at the same depth as implicit layout block")
setALRContext ls
(ITvbar, ALRLayout _ col : ls, _)
| newLine && thisCol == col && transitional ->
do addWarning Opt_WarnAlternativeLayoutRuleTransitional
(ITvbar, ALRLayout _ col : ls, _)
| newLine && thisCol == col && transitional ->
do addWarning Opt_WarnAlternativeLayoutRuleTransitional
(transitionalAlternativeLayoutWarning
"`|' at the same depth as implicit layout block")
setALRContext ls
(transitionalAlternativeLayoutWarning
"`|' at the same depth as implicit layout block")
setALRContext ls
topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls
topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b
topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls
topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b
-lexToken :: P (Located Token)
+lexToken :: P (RealLocated Token)
lexToken = do
inp@(AI loc1 buf) <- getInput
sc <- getLexState
exts <- getExts
case alexScanUser exts inp sc of
AlexEOF -> do
lexToken = do
inp@(AI loc1 buf) <- getInput
sc <- getLexState
exts <- getExts
case alexScanUser exts inp sc of
AlexEOF -> do
- let span = mkSrcSpan loc1 loc1
+ let span = mkRealSrcSpan loc1 loc1
setLastToken span 0
return (L span ITeof)
AlexError (AI loc2 buf) ->
setLastToken span 0
return (L span ITeof)
AlexError (AI loc2 buf) ->
lexToken
AlexToken inp2@(AI end buf2) _ t -> do
setInput inp2
lexToken
AlexToken inp2@(AI end buf2) _ t -> do
setInput inp2
- let span = mkSrcSpan loc1 end
+ let span = mkRealSrcSpan loc1 end
let bytes = byteDiff buf buf2
span `seq` setLastToken span bytes
t span buf bytes
let bytes = byteDiff buf buf2
span `seq` setLastToken span bytes
t span buf bytes
-reportLexError :: SrcLoc -> SrcLoc -> StringBuffer -> [Char] -> P a
+reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
reportLexError loc1 loc2 buf str
| atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
| otherwise =
reportLexError loc1 loc2 buf str
| atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
| otherwise =
then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
-lexTokenStream :: StringBuffer -> SrcLoc -> DynFlags -> ParseResult [Located Token]
+lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
lexTokenStream buf loc dflags = unP go initState
where dflags' = dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
initState = mkPState dflags' buf loc
lexTokenStream buf loc dflags = unP go initState
where dflags' = dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
initState = mkPState dflags' buf loc
)
import OccName ( varName, dataName, tcClsName, tvName )
import DataCon ( DataCon, dataConName )
)
import OccName ( varName, dataName, tcClsName, tvName )
import DataCon ( DataCon, dataConName )
-import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
- SrcSpan, combineLocs, srcLocFile,
- mkSrcLoc, mkSrcSpan )
import Module
import StaticFlags ( opt_SccProfilingOn, opt_Hpc )
import Type ( Kind, liftedTypeKind, unliftedTypeKind )
import Module
import StaticFlags ( opt_SccProfilingOn, opt_Hpc )
import Type ( Kind, liftedTypeKind, unliftedTypeKind )
: TH_QUASIQUOTE { let { loc = getLoc $1
; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1
; quoterId = mkUnqual varName quoter }
: 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 }
exp :: { LHsExpr RdrName }
: infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 }
where
pp_item :: (RdrName, HowInScope) -> SDoc
pp_item (rdr, Left loc) = quotes (ppr rdr) <+> -- Locally defined
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))
pp_item (rdr, Right is) = quotes (ppr rdr) <+> -- Imported
parens (ptext (sLit "imported from") <+> ppr (is_mod is))
import TcRnTypes
import HsSyn
import TcRnTypes
import HsSyn
-import SrcLoc ( Located(..) )
rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString)
rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString)
import Name ( Name, getName, isTyVarName )
import NameSet
import BasicTypes ( Boxity )
import Name ( Name, getName, isTyVarName )
import NameSet
import BasicTypes ( Boxity )
-import SrcLoc ( Located(..), unLoc )
\end{code}
%************************************************************************
\end{code}
%************************************************************************
; ifDOptM Opt_D_dump_minimal_imports $
printMinimalImports usage }
where
; 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}
-- Filter out the implicit Prelude import
-- which we do not want to bleat about
\end{code}
getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
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
addLocM :: (a -> TcM b) -> Located a -> TcM b
addLocM fn (L loc a) = setSrcSpan loc $ fn a
qReport False msg = addReport (text msg) empty
qLocation = do { m <- getModule
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
qReify v = reify v
qClassInstances = lookupClassInstances
import GhciMonad
import Outputable
import Util
import GhciMonad
import Outputable
import Util
-- ToDo: figure out whether we need these, and put something appropriate
-- into the GHC API instead
-- ToDo: figure out whether we need these, and put something appropriate
-- into the GHC API instead
let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo
let localNames = filter ((m==) . nameModule) names
mbTyThings <- mapM GHC.lookupName localNames
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)
| tyThing <- catMaybes mbTyThings
, let name = getName tyThing
, let exported = GHC.modInfoIsExportedName mInfo name
, let kind = tyThing2TagKind tyThing
, let loc = srcSpanStart (nameSrcSpan name)
+ , RealSrcLoc realLoc <- [loc]
-- get tag info, for later translation into Vim or Emacs style
-- 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))
tagInfo unqual exported kind name loc
= TagInfo exported kind
(showSDocForUser unqual $ pprOccName (nameOccName name))
let dflags = xopt_set dflags' Opt_AlternativeLayoutRule
st <- lift $ getGHCiState
let buf = stringToStringBuffer stmt
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
pstate = Lexer.mkPState dflags buf loc
case Lexer.unP goToEnd pstate of
(Lexer.POk _ False) -> return $ Just stmt
-- | Returns the span of the largest tick containing the srcspan given
enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
-- | 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
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 ()
return . head . sortBy leftmost_largest $ enclosing_spans
traceCmd :: String -> GHCi ()
| otherwise = do -- try parsing it as an identifier
wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
| 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) $
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
where
noCanDo n why = printForUser $
text "cannot set breakpoint on " <> ppr n <> text ": " <> why
ticks = arr ! line
starts_here = [ tick | tick@(_,span) <- ticks,
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
(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)
findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
-> Maybe (BreakIndex,SrcSpan)
is_correct_file span ]
is_correct_file span
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,
| 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.
-- For now, use ANSI bold on terminals that we know support it.
-- Otherwise, we add a line of carets under the active expression instead.
case mb_span of
Nothing ->
printForUser $ text "Not stopped at a breakpoint; nothing to list"
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"
do resumes <- GHC.getResumeContext
case resumes of
[] -> panic "No resumes"
list2 [arg] = do
wantNameFromInterpretedModule noCanDo arg $ \name -> do
let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
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)
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
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
noCanDo name $ text "can't find its location: " <>
ppr loc
where
[] -> panic "listModuleLine"
summ:_ -> do
let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
[] -> 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
-- | list a section of a source file around a particular SrcSpan.
-- If the highlight flag is True, also highlight the span using
-- 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.
-- 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
listAround span do_highlight = do
contents <- liftIO $ BS.readFile (unpackFS file)
let
mkTickArray ticks
= accumArray (flip (:)) [] (1, max_line)
[ (line, (nm,span)) | (nm,span) <- ticks,
mkTickArray ticks
= accumArray (flip (:)) [] (1, max_line)
[ (line, (nm,span)) | (nm,span) <- ticks,
- line <- srcSpanLines span ]
+ let span' = toRealSpan span,
+ line <- srcSpanLines span' ]
- 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 ]
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
lookupModule :: GHC.GhcMonad m => String -> m Module
lookupModule modName
setBreakFlag toggle array index
| toggle = GHC.setBreakOn array index
| otherwise = GHC.setBreakOff array index
setBreakFlag toggle array index
| toggle = GHC.setBreakOn array index
| otherwise = GHC.setBreakOff array index
projects / ghc-hetmet.git / commitdiff