X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FSrcLoc.lhs;h=7e432518639dffbf559dac8a2e15774c7db3f480;hb=7df9b88b9e0565f438f16d8005526ffda80a1dbe;hp=8e91e3adec003e9dab36744e7be6f38fde6dae06;hpb=3b1438a9757639d7f37f10e1237e2369ca0ebe4a;p=ghc-hetmet.git diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index 8e91e3a..7e43251 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -3,13 +3,6 @@ % \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module SrcLoc ( SrcLoc, -- Abstract @@ -45,11 +38,10 @@ module SrcLoc ( leftmost_smallest, leftmost_largest, rightmost, spans, isSubspanOf ) where -#include "HsVersions.h" - import Util import Outputable import FastString +import System.FilePath \end{code} %************************************************************************ @@ -63,8 +55,8 @@ this is the obvious stuff: \begin{code} data SrcLoc = SrcLoc FastString -- A precise location (file name) - !Int -- line number, begins at 1 - !Int -- column number, begins at 0 + {-# UNPACK #-} !Int -- line number, begins at 1 + {-# UNPACK #-} !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 @@ -79,31 +71,35 @@ data SrcLoc Things to make 'em: \begin{code} +mkSrcLoc :: FastString -> Int -> Int -> SrcLoc mkSrcLoc x line col = SrcLoc x line col -noSrcLoc = UnhelpfulLoc FSLIT("") -generatedSrcLoc = UnhelpfulLoc FSLIT("") -interactiveSrcLoc = UnhelpfulLoc FSLIT("") + +noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc +noSrcLoc = UnhelpfulLoc (fsLit "") +generatedSrcLoc = UnhelpfulLoc (fsLit "") +interactiveSrcLoc = UnhelpfulLoc (fsLit "") mkGeneralSrcLoc :: FastString -> SrcLoc mkGeneralSrcLoc = UnhelpfulLoc +isGoodSrcLoc :: SrcLoc -> Bool isGoodSrcLoc (SrcLoc _ _ _) = True -isGoodSrcLoc other = False +isGoodSrcLoc _other = False srcLocFile :: SrcLoc -> FastString srcLocFile (SrcLoc fname _ _) = fname -srcLocFile other = FSLIT(" Int -srcLocLine (SrcLoc _ l c) = l -srcLocLine other = panic "srcLocLine: unknown line" +srcLocLine (SrcLoc _ l _) = l +srcLocLine _other = panic "srcLocLine: unknown line" srcLocCol :: SrcLoc -> Int -srcLocCol (SrcLoc _ l c) = c -srcLocCol other = panic "srcLocCol: unknown col" +srcLocCol (SrcLoc _ _ c) = c +srcLocCol _other = panic "srcLocCol: unknown col" advanceSrcLoc :: SrcLoc -> Char -> SrcLoc -advanceSrcLoc (SrcLoc f l c) '\n' = SrcLoc f (l + 1) 0 +advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 0 advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) advanceSrcLoc loc _ = loc -- Better than nothing \end{code} @@ -118,30 +114,34 @@ 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 Ord SrcLoc where compare = cmpSrcLoc - + +cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2 -cmpSrcLoc (UnhelpfulLoc _) other = LT +cmpSrcLoc (UnhelpfulLoc _) _other = LT cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2) = (s1 `compare` s2) `thenCmp` (l1 `compare` l2) `thenCmp` (c1 `compare` c2) -cmpSrcLoc (SrcLoc _ _ _) other = GT +cmpSrcLoc (SrcLoc _ _ _) _other = GT + +pprFastFilePath :: FastString -> SDoc +pprFastFilePath path = text $ normalise $ unpackFS path instance Outputable SrcLoc 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 " #-}"] + 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 " #-}"] ppr (UnhelpfulLoc s) = ftext s \end{code} @@ -165,30 +165,35 @@ span of (1,1)-(1,1) is zero characters long. -} data SrcSpan = 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 } - | UnhelpfulSpan FastString -- Just a general indication + | UnhelpfulSpan !FastString -- Just a general indication -- also used to indicate an empty span +#ifdef DEBUG + deriving (Eq, Show) -- Show is used by Lexer.x, becuase we + -- derive Show for Token +#else deriving Eq +#endif -- We want to order SrcSpans first by the start point, then by the end point. instance Ord SrcSpan where @@ -196,12 +201,14 @@ instance Ord SrcSpan where (srcSpanStart a `compare` srcSpanStart b) `thenCmp` (srcSpanEnd a `compare` srcSpanEnd b) -noSrcSpan = UnhelpfulSpan FSLIT("") -wiredInSrcSpan = UnhelpfulSpan FSLIT("") +noSrcSpan, wiredInSrcSpan :: SrcSpan +noSrcSpan = UnhelpfulSpan (fsLit "") +wiredInSrcSpan = UnhelpfulSpan (fsLit "") mkGeneralSrcSpan :: FastString -> SrcSpan mkGeneralSrcSpan = UnhelpfulSpan +isGoodSrcSpan :: SrcSpan -> Bool isGoodSrcSpan SrcSpanOneLine{} = True isGoodSrcSpan SrcSpanMultiLine{} = True isGoodSrcSpan SrcSpanPoint{} = True @@ -226,6 +233,9 @@ isOneLineSpan s -- They are for internal use only -- Urk! Some are needed for Lexer.x; see comment in export list +srcSpanStartLine, srcSpanEndLine, srcSpanStartCol, srcSpanEndCol + :: SrcSpan -> Int + srcSpanStartLine SrcSpanOneLine{ srcSpanLine=l } = l srcSpanStartLine SrcSpanMultiLine{ srcSpanSLine=l } = l srcSpanStartLine SrcSpanPoint{ srcSpanLine=l } = l @@ -247,6 +257,8 @@ srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c srcSpanEndCol _ = panic "SrcLoc.srcSpanEndCol" -------------------------------------------------------- +srcSpanStart, srcSpanEnd :: SrcSpan -> SrcLoc + srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str srcSpanStart s = mkSrcLoc (srcSpanFile s) (srcSpanStartLine s) @@ -279,8 +291,8 @@ mkSrcSpan loc1 loc2 combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan -- Assumes the 'file' part is the same in both -combineSrcSpans (UnhelpfulSpan str) r = r -- this seems more useful -combineSrcSpans l (UnhelpfulSpan str) = l +combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful +combineSrcSpans l (UnhelpfulSpan _) = l combineSrcSpans start end = case line1 `compare` line2 of EQ -> case col1 `compare` col2 of @@ -299,21 +311,22 @@ combineSrcSpans start end pprDefnLoc :: SrcSpan -> SDoc -- "defined at ..." pprDefnLoc loc - | isGoodSrcSpan loc = ptext SLIT("Defined at") <+> ppr loc + | isGoodSrcSpan loc = ptext (sLit "Defined at") <+> ppr loc | otherwise = ppr loc instance Outputable SrcSpan 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 " #-}"] + pprUserSpan span + else + hcat [text "{-# LINE ", int (srcSpanStartLine span), space, + char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"] +pprUserSpan :: SrcSpan -> SDoc pprUserSpan (SrcSpanOneLine src_path line start_col end_col) - = hcat [ ftext src_path, char ':', + = hcat [ pprFastFilePath src_path, char ':', int line, char ':', int start_col ] @@ -324,7 +337,7 @@ pprUserSpan (SrcSpanOneLine src_path line start_col end_col) else char '-' <> int (end_col-1) pprUserSpan (SrcSpanMultiLine src_path sline scol eline ecol) - = hcat [ ftext src_path, char ':', + = hcat [ pprFastFilePath src_path, char ':', parens (int sline <> char ',' <> int scol), char '-', parens (int eline <> char ',' <> @@ -332,7 +345,7 @@ pprUserSpan (SrcSpanMultiLine src_path sline scol eline ecol) ] pprUserSpan (SrcSpanPoint src_path line col) - = hcat [ ftext src_path, char ':', + = hcat [ pprFastFilePath src_path, char ':', int line, char ':', int col ] @@ -377,7 +390,7 @@ instance Functor Located where fmap f (L l e) = L l (f e) instance Outputable e => Outputable (Located e) where - ppr (L span e) = ppr e + ppr (L _ e) = ppr e -- do we want to dump the span in debugSty mode? \end{code}