X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FSrcLoc.lhs;h=22ab915b22df35c57aa4d9393451ffb59d3e4663;hp=2dc6c48415c17a7d54eb8cd8c540ea2b5da3bb0a;hb=b2bd63f99d643f6b3eb30bb72bb9ae26d4183252;hpb=8eb5a108434cbe0af52650444a2fac9d55d2a491 diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index 2dc6c48..22ab915 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -1,50 +1,84 @@ % -% (c) The University of Glasgow, 1992-2003 +% (c) The University of Glasgow, 1992-2006 % -%************************************************************************ -%* * -\section[SrcLoc]{The @SrcLoc@ type} -%* * -%************************************************************************ \begin{code} +-- | This module contains types that relate to the positions of things +-- in source files, and allow tagging of those things with locations module SrcLoc ( - SrcLoc, -- Abstract + -- * SrcLoc + RealSrcLoc, -- Abstract + SrcLoc(..), - mkSrcLoc, isGoodSrcLoc, mkGeneralSrcLoc, - noSrcLoc, -- "I'm sorry, I haven't a clue" - advanceSrcLoc, + -- ** Constructing SrcLoc + mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc, - importedSrcLoc, -- Unknown place in an interface - wiredInSrcLoc, -- Something wired into the compiler + noSrcLoc, -- "I'm sorry, I haven't a clue" generatedSrcLoc, -- Code generated within the compiler interactiveSrcLoc, -- Code from an interactive session + advanceSrcLoc, + + -- ** Unsafely deconstructing SrcLoc + -- These are dubious exports, because they crash on some inputs srcLocFile, -- return the file name part srcLocLine, -- return the line part srcLocCol, -- return the column part + + -- ** Misc. operations on SrcLoc pprDefnLoc, - SrcSpan, -- Abstract + -- * SrcSpan + RealSrcSpan, -- Abstract + SrcSpan(..), + + -- ** Constructing SrcSpan + mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan, noSrcSpan, - mkGeneralSrcSpan, - isGoodSrcSpan, isOneLineSpan, - mkSrcSpan, srcLocSpan, + wiredInSrcSpan, -- Something wired into the compiler + srcLocSpan, realSrcLocSpan, combineSrcSpans, + + -- ** Deconstructing SrcSpan srcSpanStart, srcSpanEnd, - - -- These are dubious exports, because they crash on some inputs, - -- used only in Lexer.x where we are sure what the Span looks like - srcSpanFile, srcSpanEndLine, srcSpanEndCol, - - Located(..), getLoc, unLoc, noLoc, eqLocated, cmpLocated, combineLocs, addCLoc + realSrcSpanStart, realSrcSpanEnd, + srcSpanFileName_maybe, + + -- ** Unsafely deconstructing SrcSpan + -- These are dubious exports, because they crash on some inputs + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, + srcSpanStartCol, srcSpanEndCol, + + -- ** Predicates on SrcSpan + isGoodSrcSpan, isOneLineSpan, + + -- * Located + Located, + RealLocated, + GenLocated(..), + + -- ** Constructing Located + noLoc, + mkGeneralLocated, + + -- ** Deconstructing Located + getLoc, unLoc, + + -- ** Combining and comparing Located values + eqLocated, cmpLocated, combineLocs, addCLoc, + leftmost_smallest, leftmost_largest, rightmost, + spans, isSubspanOf ) where -#include "HsVersions.h" +#include "Typeable.h" -import Util ( thenCmp ) +import Util import Outputable import FastString + +import Data.Bits +import Data.Data \end{code} %************************************************************************ @@ -56,62 +90,60 @@ import FastString We keep information about the {\em definition} point for each entity; this is the obvious stuff: \begin{code} -data SrcLoc +-- | Represents a single point within a file +data RealSrcLoc = SrcLoc FastString -- A precise location (file name) - !Int -- line number, begins at 1 - !Int -- column number, begins at 0 - -- Don't ask me why lines start at 1 and columns start at - -- zero. That's just the way it is, so there. --SDM - - | ImportedLoc String -- Module 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} -Note that an entity might be imported via more than one route, and -there could be more than one ``definition point'' --- in two or more -\tr{.hi} files. We deemed it probably-unworthwhile to cater for this -rare case. - %************************************************************************ %* * -\subsection[SrcLoc-access-fns]{Access functions for names} +\subsection[SrcLoc-access-fns]{Access functions} %* * %************************************************************************ -Things to make 'em: \begin{code} -mkSrcLoc x line col = SrcLoc x line col -noSrcLoc = UnhelpfulLoc FSLIT("") -generatedSrcLoc = UnhelpfulLoc FSLIT("") -wiredInSrcLoc = UnhelpfulLoc FSLIT("") -interactiveSrcLoc = UnhelpfulLoc FSLIT("") +mkSrcLoc :: FastString -> Int -> Int -> SrcLoc +mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) -mkGeneralSrcLoc :: FastString -> SrcLoc -mkGeneralSrcLoc = UnhelpfulLoc +mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc +mkRealSrcLoc x line col = SrcLoc x line col -importedSrcLoc :: String -> SrcLoc -importedSrcLoc mod_name = ImportedLoc mod_name +-- | Built-in "bad" 'SrcLoc' values for particular locations +noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc +noSrcLoc = UnhelpfulLoc (fsLit "") +generatedSrcLoc = UnhelpfulLoc (fsLit "") +interactiveSrcLoc = UnhelpfulLoc (fsLit "") -isGoodSrcLoc (SrcLoc _ _ _) = True -isGoodSrcLoc other = False +-- | Creates a "bad" 'SrcLoc' that has no detailed information about its location +mkGeneralSrcLoc :: FastString -> SrcLoc +mkGeneralSrcLoc = UnhelpfulLoc -srcLocFile :: SrcLoc -> FastString +-- | Gives the filename of the 'RealSrcLoc' +srcLocFile :: RealSrcLoc -> FastString srcLocFile (SrcLoc fname _ _) = fname -srcLocFile other = FSLIT(" Int -srcLocLine (SrcLoc _ l c) = l -srcLocLine other = panic "srcLocLine: unknown line" - -srcLocCol :: SrcLoc -> Int -srcLocCol (SrcLoc _ l c) = c -srcLocCol other = panic "srcLocCol: unknown col" -advanceSrcLoc :: SrcLoc -> Char -> SrcLoc -advanceSrcLoc (SrcLoc f l c) '\n' = SrcLoc f (l + 1) 0 +-- | Raises an error when used on a "bad" 'SrcLoc' +srcLocLine :: RealSrcLoc -> Int +srcLocLine (SrcLoc _ l _) = l + +-- | Raises an error when used on a "bad" 'SrcLoc' +srcLocCol :: RealSrcLoc -> Int +srcLocCol (SrcLoc _ _ c) = c + +-- | 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 :: RealSrcLoc -> Char -> RealSrcLoc +advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1 +advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (((((c - 1) `shiftR` 3) + 1) + `shiftL` 3) + 1) advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) -advanceSrcLoc loc _ = loc -- Better than nothing \end{code} %************************************************************************ @@ -124,41 +156,57 @@ advanceSrcLoc loc _ = loc -- Better than nothing -- SrcLoc is an instance of Ord so that we can sort error messages easily instance Eq SrcLoc where loc1 == loc2 = case loc1 `cmpSrcLoc` loc2 of - EQ -> True - other -> False + EQ -> True + _other -> False + +instance Eq RealSrcLoc where + loc1 == loc2 = case loc1 `cmpRealSrcLoc` loc2 of + EQ -> True + _other -> False instance Ord SrcLoc where compare = cmpSrcLoc -cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2 -cmpSrcLoc (UnhelpfulLoc _) other = LT +instance Ord RealSrcLoc where + compare = cmpRealSrcLoc -cmpSrcLoc (ImportedLoc _) (UnhelpfulLoc _) = GT -cmpSrcLoc (ImportedLoc m1) (ImportedLoc m2) = m1 `compare` m2 -cmpSrcLoc (ImportedLoc _) other = LT +cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering +cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2 +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) - = (s1 `compare` s2) `thenCmp` (l1 `cmpline` l2) `thenCmp` (c1 `cmpline` c2) - where - l1 `cmpline` l2 | l1 < l2 = LT - | l1 == l2 = EQ - | otherwise = GT -cmpSrcLoc (SrcLoc _ _ _) other = GT +cmpRealSrcLoc :: RealSrcLoc -> RealSrcLoc -> Ordering +cmpRealSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2) + = (s1 `compare` s2) `thenCmp` (l1 `compare` l2) `thenCmp` (c1 `compare` c2) -instance Outputable SrcLoc where +instance Outputable RealSrcLoc where ppr (SrcLoc src_path src_line src_col) = getPprStyle $ \ sty -> if userStyle sty || debugStyle sty then - hcat [ ftext src_path, char ':', - int src_line, - char ':', int src_col - ] - else - hcat [text "{-# LINE ", int src_line, space, - char '\"', ftext src_path, text " #-}"] - - ppr (ImportedLoc mod) = ptext SLIT("Defined in") <+> text mod + hcat [ pprFastFilePath src_path, char ':', + int src_line, + char ':', int src_col + ] + else + hcat [text "{-# LINE ", int src_line, space, + char '\"', pprFastFilePath src_path, text " #-}"] + +instance Outputable SrcLoc where + ppr (RealSrcLoc l) = ppr l ppr (UnhelpfulLoc s) = ftext s + +instance Data RealSrcSpan where + -- don't traverse? + toConstr _ = abstractConstr "RealSrcSpan" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "RealSrcSpan" + +instance Data SrcSpan where + -- don't traverse? + toConstr _ = abstractConstr "SrcSpan" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "SrcSpan" \end{code} %************************************************************************ @@ -174,188 +222,263 @@ by a pair of (line,column) coordinates, but in fact we optimise slightly by using more compact representations for single-line and zero-length spans, both of which are quite common. -The end position is defined to be the column *after* the end of the +The end position is defined to be the column /after/ the end of the span. That is, a span of (1,1)-(1,2) is one character long, and a span of (1,1)-(1,1) is zero characters long. -} -data SrcSpan +data RealSrcSpan = SrcSpanOneLine -- a common case: a single line - { srcSpanFile :: FastString, - srcSpanLine :: !Int, - srcSpanSCol :: !Int, - srcSpanECol :: !Int + { srcSpanFile :: !FastString, + srcSpanLine :: {-# UNPACK #-} !Int, + srcSpanSCol :: {-# UNPACK #-} !Int, + srcSpanECol :: {-# UNPACK #-} !Int } | SrcSpanMultiLine - { srcSpanFile :: FastString, - srcSpanSLine :: !Int, - srcSpanSCol :: !Int, - srcSpanELine :: !Int, - srcSpanECol :: !Int + { srcSpanFile :: !FastString, + srcSpanSLine :: {-# UNPACK #-} !Int, + srcSpanSCol :: {-# UNPACK #-} !Int, + srcSpanELine :: {-# UNPACK #-} !Int, + srcSpanECol :: {-# UNPACK #-} !Int } | SrcSpanPoint - { srcSpanFile :: FastString, - srcSpanLine :: !Int, - srcSpanCol :: !Int + { srcSpanFile :: !FastString, + srcSpanLine :: {-# UNPACK #-} !Int, + srcSpanCol :: {-# UNPACK #-} !Int } - - | ImportedSpan String -- Module name - - | UnhelpfulSpan FastString -- Just a general indication +#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 - deriving Eq - --- We want to order SrcSpans first by the start point, then by the end point. -instance Ord SrcSpan where - a `compare` b = - (srcSpanStart a `compare` srcSpanStart b) `thenCmp` - (srcSpanEnd a `compare` srcSpanEnd b) +#ifdef DEBUG + deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, becuase we + -- derive Show for Token +#else + deriving (Eq, Typeable) +#endif -noSrcSpan = UnhelpfulSpan FSLIT("") +-- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty +noSrcSpan, wiredInSrcSpan :: SrcSpan +noSrcSpan = UnhelpfulSpan (fsLit "") +wiredInSrcSpan = UnhelpfulSpan (fsLit "") +-- | Create a "bad" 'SrcSpan' that has not location information mkGeneralSrcSpan :: FastString -> SrcSpan mkGeneralSrcSpan = UnhelpfulSpan -isGoodSrcSpan SrcSpanOneLine{} = True -isGoodSrcSpan SrcSpanMultiLine{} = True -isGoodSrcSpan SrcSpanPoint{} = True -isGoodSrcSpan _ = False +-- | Create a 'SrcSpan' corresponding to a single point +srcLocSpan :: SrcLoc -> SrcSpan +srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str +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 +mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan +mkRealSrcSpan loc1 loc2 + | line1 == line2 = if col1 == col2 + then SrcSpanPoint file line1 col1 + else SrcSpanOneLine file line1 col1 col2 + | otherwise = SrcSpanMultiLine file line1 col1 line2 col2 + where + line1 = srcLocLine loc1 + line2 = srcLocLine loc2 + col1 = srcLocCol 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 +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 + else SrcSpanOneLine file line_start col_start col_end + else SrcSpanMultiLine file line_start col_start line_end col_end + where + (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) + (srcSpanStartLine span2, srcSpanStartCol span2) + (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) + (srcSpanEndLine span2, srcSpanEndCol span2) + file = srcSpanFile span1 +\end{code} + +%************************************************************************ +%* * +\subsection[SrcSpan-predicates]{Predicates} +%* * +%************************************************************************ + +\begin{code} +-- | Test if a 'SrcSpan' is "good", i.e. has precise location information +isGoodSrcSpan :: SrcSpan -> Bool +isGoodSrcSpan (RealSrcSpan _) = True +isGoodSrcSpan (UnhelpfulSpan _) = False isOneLineSpan :: SrcSpan -> Bool --- True if the span is known to straddle more than one line --- By default, it returns False -isOneLineSpan s - | isGoodSrcSpan s = srcSpanStartLine s == srcSpanEndLine s - | otherwise = False - --------------------------------------------------------- --- Don't export these four; --- they panic on Imported, Unhelpful. --- They are for internal use only --- Urk! Some are needed for Lexer.x; see comment in export list +-- ^ True if the span is known to straddle only one line. +-- For "bad" 'SrcSpan', it returns False +isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s +isOneLineSpan (UnhelpfulSpan _) = False + +\end{code} + +%************************************************************************ +%* * +\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions} +%* * +%************************************************************************ + +\begin{code} + +srcSpanStartLine :: RealSrcSpan -> Int +srcSpanEndLine :: RealSrcSpan -> Int +srcSpanStartCol :: RealSrcSpan -> Int +srcSpanEndCol :: RealSrcSpan -> Int srcSpanStartLine SrcSpanOneLine{ srcSpanLine=l } = l srcSpanStartLine SrcSpanMultiLine{ srcSpanSLine=l } = l srcSpanStartLine SrcSpanPoint{ srcSpanLine=l } = l -srcSpanStartLine _ = panic "SrcLoc.srcSpanStartLine" srcSpanEndLine SrcSpanOneLine{ srcSpanLine=l } = l srcSpanEndLine SrcSpanMultiLine{ srcSpanELine=l } = l srcSpanEndLine SrcSpanPoint{ srcSpanLine=l } = l -srcSpanEndLine _ = panic "SrcLoc.srcSpanEndLine" srcSpanStartCol SrcSpanOneLine{ srcSpanSCol=l } = l srcSpanStartCol SrcSpanMultiLine{ srcSpanSCol=l } = l srcSpanStartCol SrcSpanPoint{ srcSpanCol=l } = l -srcSpanStartCol _ = panic "SrcLoc.srcSpanStartCol" srcSpanEndCol SrcSpanOneLine{ srcSpanECol=c } = c srcSpanEndCol SrcSpanMultiLine{ srcSpanECol=c } = c srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c -srcSpanEndCol _ = panic "SrcLoc.srcSpanEndCol" --------------------------------------------------------- -srcSpanStart (ImportedSpan str) = ImportedLoc str +\end{code} + +%************************************************************************ +%* * +\subsection[SrcSpan-access-fns]{Access functions} +%* * +%************************************************************************ + +\begin{code} + +-- | 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 s = mkSrcLoc (srcSpanFile s) - (srcSpanStartLine s) - (srcSpanStartCol s) +srcSpanStart (RealSrcSpan s) = RealSrcLoc (realSrcSpanStart s) -srcSpanEnd (ImportedSpan str) = ImportedLoc str +-- | 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 s = - mkSrcLoc (srcSpanFile s) - (srcSpanEndLine s) - (srcSpanEndCol s) +srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s) -srcLocSpan :: SrcLoc -> SrcSpan -srcLocSpan (ImportedLoc str) = ImportedSpan str -srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str -srcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col +realSrcSpanStart :: RealSrcSpan -> RealSrcLoc +realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s) + (srcSpanStartLine s) + (srcSpanStartCol s) -mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan -mkSrcSpan (ImportedLoc str) _ = ImportedSpan str -mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str -mkSrcSpan _ (ImportedLoc str) = ImportedSpan str -mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str -mkSrcSpan loc1 loc2 - | line1 == line2 = if col1 == col2 - then SrcSpanPoint file line1 col1 - else SrcSpanOneLine file line1 col1 col2 - | otherwise = SrcSpanMultiLine file line1 col1 line2 col2 - where - line1 = srcLocLine loc1 - line2 = srcLocLine loc2 - col1 = srcLocCol loc1 - col2 = srcLocCol loc2 - file = srcLocFile loc1 +realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc +realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s) + (srcSpanEndLine s) + (srcSpanEndCol s) -combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan --- Assumes the 'file' part is the same in both -combineSrcSpans (ImportedSpan str) _ = ImportedSpan str -combineSrcSpans (UnhelpfulSpan str) r = r -- this seems more useful -combineSrcSpans _ (ImportedSpan str) = ImportedSpan str -combineSrcSpans l (UnhelpfulSpan str) = l -combineSrcSpans start end - = case line1 `compare` line2 of - EQ -> case col1 `compare` col2 of - EQ -> SrcSpanPoint file line1 col1 - LT -> SrcSpanOneLine file line1 col1 col2 - GT -> SrcSpanOneLine file line1 col2 col1 - LT -> SrcSpanMultiLine file line1 col1 line2 col2 - GT -> SrcSpanMultiLine file line2 col2 line1 col1 - where - line1 = srcSpanStartLine start - col1 = srcSpanStartCol start - line2 = srcSpanEndLine end - col2 = srcSpanEndCol end - file = srcSpanFile start - -pprDefnLoc :: SrcLoc -> SDoc --- "defined at ..." or "imported from ..." -pprDefnLoc loc - | isGoodSrcLoc loc = ptext SLIT("Defined at") <+> ppr loc - | otherwise = ppr loc +-- | Obtains the filename for a 'SrcSpan' if it is "good" +srcSpanFileName_maybe :: SrcSpan -> Maybe FastString +srcSpanFileName_maybe (RealSrcSpan s) = Just (srcSpanFile s) +srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing -instance Outputable SrcSpan where +\end{code} + +%************************************************************************ +%* * +\subsection[SrcSpan-instances]{Instances} +%* * +%************************************************************************ + +\begin{code} + +-- We want to order SrcSpans first by the start point, then by the end point. +instance Ord SrcSpan where + a `compare` b = + (srcSpanStart a `compare` srcSpanStart b) `thenCmp` + (srcSpanEnd a `compare` srcSpanEnd b) + + +instance Outputable RealSrcSpan where ppr span = getPprStyle $ \ sty -> if userStyle sty || debugStyle sty then - pprUserSpan span - else - hcat [text "{-# LINE ", int (srcSpanStartLine span), space, - char '\"', ftext (srcSpanFile span), text " #-}"] + pprUserRealSpan True span + else + hcat [text "{-# LINE ", int (srcSpanStartLine span), space, + char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"] - -pprUserSpan (SrcSpanOneLine src_path line start_col end_col) - = hcat [ ftext src_path, char ':', - int line, - char ':', int start_col - ] - <> if end_col - start_col <= 1 - then empty - -- for single-character or point spans, we just output the starting - -- column number - else char '-' <> int (end_col-1) - -pprUserSpan (SrcSpanMultiLine src_path sline scol eline ecol) - = hcat [ ftext src_path, char ':', - parens (int sline <> char ',' <> int scol), - char '-', - parens (int eline <> char ',' <> - if ecol == 0 then int ecol else int (ecol-1)) - ] - -pprUserSpan (SrcSpanPoint src_path line col) - = hcat [ ftext src_path, char ':', - int line, - char ':', int col +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 _ (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) + (char '-' <> int (end_col-1)) + -- For single-character or point spans, we just + -- output the starting column number + ] + + +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 '-' + , parens (int eline <> char ',' <> + if ecol == 0 then int ecol else int (ecol-1)) ] -pprUserSpan (ImportedSpan mod) = ptext SLIT("Defined in") <+> text mod -pprUserSpan (UnhelpfulSpan s) = ftext s +pprUserRealSpan show_path (SrcSpanPoint src_path line col) + = hcat [ ppWhen show_path $ (pprFastFilePath src_path <> colon) + , int line, char ':', int col ] + +pprDefnLoc :: RealSrcSpan -> SDoc +-- ^ Pretty prints information about the 'SrcSpan' in the style "defined at ..." +pprDefnLoc loc = ptext (sLit "Defined at") <+> ppr loc \end{code} %************************************************************************ @@ -366,35 +489,83 @@ pprUserSpan (UnhelpfulSpan s) = ftext s \begin{code} -- | We attach SrcSpans to lots of things, so let's have a datatype for it. -data Located e = L SrcSpan e +data GenLocated l e = L l e + deriving (Eq, Ord, Typeable, Data) -unLoc :: Located e -> e +type Located e = GenLocated SrcSpan e +type RealLocated e = GenLocated RealSrcSpan e + +unLoc :: GenLocated l e -> e unLoc (L _ e) = e -getLoc :: Located e -> SrcSpan +getLoc :: GenLocated l e -> l getLoc (L l _) = l noLoc :: e -> Located e noLoc e = L noSrcSpan e +mkGeneralLocated :: String -> e -> Located e +mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e + combineLocs :: Located a -> Located b -> SrcSpan combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) +-- | Combine locations from two 'Located' things and add them to a third thing addCLoc :: Located a -> Located b -> c -> Located c addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c -- not clear whether to add a general Eq instance, but this is useful sometimes: + +-- | Tests whether the two located things are equal eqLocated :: Eq a => Located a -> Located a -> Bool eqLocated a b = unLoc a == unLoc b --- not clear whether to add a general Eq instance, but this is useful sometimes: +-- not clear whether to add a general Ord instance, but this is useful sometimes: + +-- | Tests the ordering of the two located things cmpLocated :: Ord a => Located a -> Located a -> Ordering cmpLocated a b = unLoc a `compare` unLoc b -instance Functor Located where +instance Functor (GenLocated l) where fmap f (L l e) = L l (f e) -instance Outputable e => Outputable (Located e) where - ppr (L span e) = ppr e - -- do we want to dump the span in debugSty mode? +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} + +%************************************************************************ +%* * +\subsection{Ordering SrcSpans for InteractiveUI} +%* * +%************************************************************************ + +\begin{code} +-- | Alternative strategies for ordering 'SrcSpan's +leftmost_smallest, leftmost_largest, rightmost :: SrcSpan -> SrcSpan -> Ordering +rightmost = flip compare +leftmost_smallest = compare +leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b) + `thenCmp` + (srcSpanEnd b `compare` srcSpanEnd a) + +-- | Determines whether a span encloses a given line and column index +spans :: SrcSpan -> (Int, Int) -> Bool +spans (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 + -> SrcSpan -- ^ The span it may be enclosed by + -> Bool +isSubspanOf src parent + | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False + | otherwise = srcSpanStart parent <= srcSpanStart src && + srcSpanEnd parent >= srcSpanEnd src + \end{code}