X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FSrcLoc.lhs;h=377a8c872d839be40af4099f82c817d2ba47a741;hb=9541ef3440f89f5f275509b1cc64fb9c498dcf73;hp=cfd42a6f641a845d6d116e9e1908f5d318788ba2;hpb=9dd6e1c216993624a2cd74b62ca0f0569c02c26b;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index cfd42a6..377a8c8 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % %************************************************************************ %* * @@ -11,24 +11,28 @@ module SrcLoc ( SrcLoc, -- Abstract - mkSrcLoc, - noSrcLoc, isNoSrcLoc, -- "I'm sorry, I haven't a clue" + mkSrcLoc, isGoodSrcLoc, isWiredInLoc, + noSrcLoc, -- "I'm sorry, I haven't a clue" + advanceSrcLoc, - mkIfaceSrcLoc, -- Unknown place in an interface - -- (this one can die eventually ToDo) + importedSrcLoc, -- Unknown place in an interface + wiredInSrcLoc, -- Something wired into the compiler + generatedSrcLoc, -- Code generated within the compiler - mkBuiltinSrcLoc, -- Something wired into the compiler - - mkGeneratedSrcLoc, -- Code generated within the compiler - - incSrcLine + srcLocFile, -- return the file name part + srcLocLine, -- return the line part + srcLocCol, -- return the column part ) where #include "HsVersions.h" +import Util ( thenCmp ) import Outputable import FastString ( unpackFS ) -import GlaExts ( Int(..), Int#, (+#) ) +import FastTypes +import FastString + +import GLAEXTS ( (+#), quotInt# ) \end{code} %************************************************************************ @@ -41,12 +45,31 @@ We keep information about the {\em definition} point for each entity; this is the obvious stuff: \begin{code} data SrcLoc - = NoSrcLoc - - | SrcLoc FAST_STRING -- A precise location (file name) - FAST_INT - - | UnhelpfulSrcLoc FAST_STRING -- Just a general indication + = WiredInLoc -- Used exclusively for Ids and TyCons + -- that are totally wired in to the + -- compiler. That supports the + -- occasionally-useful predicate + -- isWiredInName + + | SrcLoc FastString -- A precise location (file name) + FastInt -- line + FastInt -- column + + | UnhelpfulSrcLoc FastString -- Just a general indication + +{- +data SrcSpan + = WiredInSpan + + -- A precise source file span + | SrcSpan FastString -- file name + FastInt -- beginning line + FastInt -- beginning column + FastInt -- end line + FastInt -- end column + + | UnhelpfulSrcSpan FastString -- Just a general indication +-} \end{code} Note that an entity might be imported via more than one route, and @@ -62,19 +85,35 @@ rare case. Things to make 'em: \begin{code} -noSrcLoc = NoSrcLoc -mkSrcLoc x IBOX(y) = SrcLoc x y +mkSrcLoc x line col = SrcLoc x (iUnbox line) (iUnbox col) +wiredInSrcLoc = WiredInLoc +noSrcLoc = UnhelpfulSrcLoc FSLIT("") +importedSrcLoc = UnhelpfulSrcLoc FSLIT("") +generatedSrcLoc = UnhelpfulSrcLoc FSLIT("") + +isGoodSrcLoc (SrcLoc _ _ _) = True +isGoodSrcLoc other = False -mkIfaceSrcLoc = UnhelpfulSrcLoc SLIT("") -mkBuiltinSrcLoc = UnhelpfulSrcLoc SLIT("") -mkGeneratedSrcLoc = UnhelpfulSrcLoc SLIT("") +isWiredInLoc WiredInLoc = True +isWiredInLoc other = False -isNoSrcLoc NoSrcLoc = True -isNoSrcLoc other = False +srcLocFile :: SrcLoc -> FastString +srcLocFile (SrcLoc fname _ _) = fname -incSrcLine :: SrcLoc -> SrcLoc -incSrcLine (SrcLoc s l) = SrcLoc s (l +# 1#) -incSrcLine loc = loc +srcLocLine :: SrcLoc -> Int +srcLocLine (SrcLoc _ l c) = iBox l + +srcLocCol :: SrcLoc -> Int +srcLocCol (SrcLoc _ l c) = iBox c + +advanceSrcLoc :: SrcLoc -> Char -> SrcLoc +advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (tab c) +advanceSrcLoc (SrcLoc f l c) '\n' = SrcLoc f (l +# 1#) 0# +advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c +# 1#) + +-- Advance to the next tab stop. Tabs are at column positions 0, 8, 16, etc. +tab :: FastInt -> FastInt +tab c = (c `quotInt#` 8# +# 1#) *# 8# \end{code} %************************************************************************ @@ -84,26 +123,45 @@ incSrcLine loc = loc %************************************************************************ \begin{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 + EQ -> True + other -> False + +instance Ord SrcLoc where + compare = cmpSrcLoc + +cmpSrcLoc WiredInLoc WiredInLoc = EQ +cmpSrcLoc WiredInLoc other = LT + +cmpSrcLoc (UnhelpfulSrcLoc s1) (UnhelpfulSrcLoc s2) = s1 `compare` s2 +cmpSrcLoc (UnhelpfulSrcLoc s1) other = GT + +cmpSrcLoc (SrcLoc _ _ _) WiredInLoc = GT +cmpSrcLoc (SrcLoc _ _ _) (UnhelpfulSrcLoc _) = LT +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 + instance Outputable SrcLoc where - ppr (SrcLoc src_path src_line) + ppr (SrcLoc src_path src_line src_col) = getPprStyle $ \ sty -> - if userStyle sty then - hcat [ text src_file, char ':', int IBOX(src_line) ] + if userStyle sty || debugStyle sty then + hcat [ ftext src_path, char ':', + int (iBox src_line) + {- TODO: char ':', int (iBox src_col) -} + ] else - if debugStyle sty then - hcat [ ptext src_path, char ':', int IBOX(src_line) ] - else - hcat [text "{-# LINE ", int IBOX(src_line), space, - char '\"', ptext src_path, text " #-}"] + hcat [text "{-# LINE ", int (iBox src_line), space, + char '\"', ftext src_path, text " #-}"] where - src_file = remove_directory_prefix (unpackFS src_path) - - remove_directory_prefix path = case break (== '/') path of - (filename, []) -> filename - (prefix, slash : rest) -> ASSERT( slash == '/' ) - remove_directory_prefix rest - - ppr (UnhelpfulSrcLoc s) = ptext s + src_file = unpackFS src_path -- Leave the directory prefix intact, + -- so emacs can find the file - ppr NoSrcLoc = text "" + ppr (UnhelpfulSrcLoc s) = ftext s + ppr WiredInLoc = ptext SLIT("") \end{code}