X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FSrcLoc.lhs;h=06f8ec8c27ca1b121f931f8e12e265490dcb54e1;hp=0789693287deac6c9f6f8e6259adbbe484e86e7c;hb=94bf0d3604ff0d2ecab246924af712bdd1c29a40;hpb=6e5eafac797562bc2a72068dd27f19adc75bdb41 diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index 0789693..06f8ec8 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, @@ -68,9 +69,14 @@ module SrcLoc ( spans, isSubspanOf ) where +#include "Typeable.h" + import Util import Outputable import FastString + +import Data.Bits +import Data.Data \end{code} %************************************************************************ @@ -86,10 +92,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} @@ -126,19 +129,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} %************************************************************************ @@ -159,11 +165,11 @@ instance Ord SrcLoc where cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2 -cmpSrcLoc (UnhelpfulLoc _) _other = LT +cmpSrcLoc (UnhelpfulLoc _) (SrcLoc _ _ _) = GT +cmpSrcLoc (SrcLoc _ _ _) (UnhelpfulLoc _) = 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 instance Outputable SrcLoc where ppr (SrcLoc src_path src_line src_col) @@ -178,6 +184,14 @@ instance Outputable SrcLoc where char '\"', pprFastFilePath src_path, text " #-}"] ppr (UnhelpfulLoc s) = ftext s + +INSTANCE_TYPEABLE0(SrcSpan,srcSpanTc,"SrcSpan") + +instance Data SrcSpan where + -- don't traverse? + toConstr _ = abstractConstr "SrcSpan" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "SrcSpan" \end{code} %************************************************************************ @@ -295,7 +309,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 @@ -394,38 +408,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 ..." @@ -443,6 +454,7 @@ pprDefnLoc loc \begin{code} -- | We attach SrcSpans to lots of things, so let's have a datatype for it. data Located e = L SrcSpan e + deriving (Eq, Ord, Typeable, Data) unLoc :: Located e -> e unLoc (L _ e) = e @@ -453,6 +465,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) @@ -476,8 +491,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} %************************************************************************