X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FSrcLoc.lhs;h=1a0198095985536eb691a2b060cacda485ba6449;hb=4623207393db41c970e713c326e9b54aa017dc3a;hp=a342c8968e9ca4846c4d1b44680ef4af3640db95;hpb=a80b845e7b007611032e7cb5d1a92e9224ff42da;p=ghc-hetmet.git diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index a342c89..1a01980 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -58,6 +58,7 @@ module SrcLoc ( -- ** Constructing Located noLoc, + mkGeneralLocated, -- ** Deconstructing Located getLoc, unLoc, @@ -71,7 +72,8 @@ module SrcLoc ( import Util import Outputable import FastString -import System.FilePath + +import Data.Bits \end{code} %************************************************************************ @@ -87,10 +89,7 @@ this is the obvious stuff: data SrcLoc = SrcLoc FastString -- A precise location (file name) {-# 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 - + {-# UNPACK #-} !Int -- column number, begins at 1 | UnhelpfulLoc FastString -- Just a general indication \end{code} @@ -127,19 +126,22 @@ srcLocFile _other = (fsLit " Int srcLocLine (SrcLoc _ l _) = l -srcLocLine _other = panic "srcLocLine: unknown line" +srcLocLine (UnhelpfulLoc s) = pprPanic "srcLocLine" (ftext s) -- | Raises an error when used on a "bad" 'SrcLoc' srcLocCol :: SrcLoc -> Int srcLocCol (SrcLoc _ _ c) = c -srcLocCol _other = panic "srcLocCol: unknown col" +srcLocCol (UnhelpfulLoc s) = pprPanic "srcLocCol" (ftext s) --- | Move the 'SrcLoc' down by one line if the character is a newline --- 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 (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 0 +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 +advanceSrcLoc loc _ = loc -- Better than nothing \end{code} %************************************************************************ @@ -166,9 +168,6 @@ cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2) = (s1 `compare` s2) `thenCmp` (l1 `compare` l2) `thenCmp` (c1 `compare` c2) 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 -> @@ -299,7 +298,7 @@ isGoodSrcSpan SrcSpanPoint{} = True isGoodSrcSpan _ = False isOneLineSpan :: SrcSpan -> Bool --- ^ True if the span is known to straddle more than one line. +-- ^ 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 @@ -398,38 +397,35 @@ instance Outputable SrcSpan where ppr span = getPprStyle $ \ sty -> if userStyle sty || debugStyle sty then - pprUserSpan span + pprUserSpan True 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 [ pprFastFilePath 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 [ pprFastFilePath 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 [ pprFastFilePath src_path, char ':', - int line, - char ':', int col +pprUserSpan :: Bool -> SrcSpan -> SDoc +pprUserSpan 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 + ] + + +pprUserSpan 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 (UnhelpfulSpan s) = ftext s +pprUserSpan show_path (SrcSpanPoint src_path line col) + = hcat [ ppWhen show_path $ (pprFastFilePath src_path <> colon) + , int line, char ':', int col ] + +pprUserSpan _ (UnhelpfulSpan s) = ftext s pprDefnLoc :: SrcSpan -> SDoc -- ^ Pretty prints information about the 'SrcSpan' in the style "defined at ..." @@ -457,6 +453,9 @@ 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) @@ -480,8 +479,8 @@ instance Functor Located where fmap f (L l e) = L l (f e) instance Outputable e => Outputable (Located e) where - ppr (L _ e) = ppr e - -- do we want to dump the span in debugSty mode? + ppr (L l e) = ifPprDebug (braces (pprUserSpan False l)) <> ppr e + -- Print spans without the file name etc \end{code} %************************************************************************