X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FSrcLoc.lhs;h=377a8c872d839be40af4099f82c817d2ba47a741;hb=9541ef3440f89f5f275509b1cc64fb9c498dcf73;hp=20bc49a65effee2debab81350227aa5a0537bdf5;hpb=f844835e45ee7e5fc0b05f8c68f73cfe4a23cf94;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index 20bc49a..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 % %************************************************************************ %* * @@ -8,27 +8,31 @@ %************************************************************************ \begin{code} -#include "HsVersions.h" - -module SrcLoc {- ( +module SrcLoc ( SrcLoc, -- Abstract - mkSrcLoc, - noSrcLoc, isNoSrcLoc, -- "I'm sorry, I haven't a clue" - - mkIfaceSrcLoc, -- Unknown place in an interface - -- (this one can die eventually ToDo) + mkSrcLoc, isGoodSrcLoc, isWiredInLoc, + noSrcLoc, -- "I'm sorry, I haven't a clue" + advanceSrcLoc, - mkBuiltinSrcLoc, -- Something wired into the compiler + importedSrcLoc, -- Unknown place in an interface + wiredInSrcLoc, -- Something wired into the compiler + generatedSrcLoc, -- Code generated within the compiler - mkGeneratedSrcLoc -- Code generated within the compiler - ) -} where + srcLocFile, -- return the file name part + srcLocLine, -- return the line part + srcLocCol, -- return the column part + ) where -IMP_Ubiq() +#include "HsVersions.h" +import Util ( thenCmp ) import Outputable -import Pretty +import FastString ( unpackFS ) +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 + = 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 - | SrcLoc FAST_STRING -- A precise location - FAST_INT + | UnhelpfulSrcLoc FastString -- Just a general indication - | UnhelpfulSrcLoc FAST_STRING -- 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,15 +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 + +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} %************************************************************************ @@ -80,21 +123,45 @@ isNoSrcLoc other = False %************************************************************************ \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 sty (SrcLoc src_file src_line) - | userStyle sty - = hcat [ ptext src_file, char ':', text (show IBOX(src_line)) ] - - | otherwise - = hcat [text "{-# LINE ", text (show IBOX(src_line)), space, - char '\"', ptext src_file, text " #-}"] - ppr sty (UnhelpfulSrcLoc s) = ptext s - - ppr sty NoSrcLoc = text "" + ppr (SrcLoc src_path src_line src_col) + = getPprStyle $ \ sty -> + if userStyle sty || debugStyle sty then + hcat [ ftext src_path, char ':', + int (iBox src_line) + {- TODO: char ':', int (iBox src_col) -} + ] + else + hcat [text "{-# LINE ", int (iBox src_line), space, + char '\"', ftext src_path, text " #-}"] + where + src_file = unpackFS src_path -- Leave the directory prefix intact, + -- so emacs can find the file + + ppr (UnhelpfulSrcLoc s) = ftext s + ppr WiredInLoc = ptext SLIT("") \end{code} - -{- - = hcat [ptext SLIT("{-# LINE "), text (show IBOX(src_line)), space, - char '"', ptext src_file, ptext SLIT(" #-}")] - --ptext SLIT("\" #-}")] --}