X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FName.lhs;h=aa253cf87843e07daff5ed8d8634b7f43cc340d6;hb=7df9b88b9e0565f438f16d8005526ffda80a1dbe;hp=feda0b1009f90282f4327da611eac591ae7b0457;hpb=49c98d143c382a1341e1046f5ca00819a25691ba;p=ghc-hetmet.git diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index feda0b1..aa253cf 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -15,6 +15,7 @@ module Name ( mkInternalName, mkSystemName, mkSystemVarName, mkSysTvName, mkFCallName, mkIPName, + mkTickBoxOpName, mkExternalName, mkWiredInName, nameUnique, setNameUnique, @@ -22,7 +23,7 @@ module Name ( tidyNameOcc, hashName, localiseName, - nameSrcLoc, + nameSrcLoc, nameSrcSpan, pprNameLoc, isSystemName, isInternalName, isExternalName, isTyVarName, isTyConName, isWiredInName, isBuiltInSyntax, @@ -31,11 +32,9 @@ module Name ( -- Class NamedThing and overloaded friends NamedThing(..), - getSrcLoc, getOccString + getSrcLoc, getSrcSpan, getOccString ) where -#include "HsVersions.h" - import {-# SOURCE #-} TypeRep( TyThing ) import OccName @@ -46,11 +45,11 @@ import Unique import Maybes import Binary import FastMutInt +import FastTypes import FastString import Outputable import Data.IORef -import GHC.Exts import Data.Array \end{code} @@ -64,8 +63,9 @@ import Data.Array data Name = Name { n_sort :: NameSort, -- What sort of name it is n_occ :: !OccName, -- Its occurrence name - n_uniq :: Int#, -- UNPACK doesn't work, recursive type - n_loc :: !SrcLoc -- Definition site + n_uniq :: FastInt, -- UNPACK doesn't work, recursive type +--(note later when changing Int# -> FastInt: is that still true about UNPACK?) + n_loc :: !SrcSpan -- Definition site } -- NOTE: we make the n_loc field strict to eliminate some potential @@ -126,10 +126,12 @@ nameUnique :: Name -> Unique nameOccName :: Name -> OccName nameModule :: Name -> Module nameSrcLoc :: Name -> SrcLoc +nameSrcSpan :: Name -> SrcSpan -nameUnique name = mkUniqueGrimily (I# (n_uniq name)) +nameUnique name = mkUniqueGrimily (iBox (n_uniq name)) nameOccName name = n_occ name -nameSrcLoc name = n_loc name +nameSrcLoc name = srcSpanStart (n_loc name) +nameSrcSpan name = n_loc name \end{code} \begin{code} @@ -140,25 +142,27 @@ isSystemName :: Name -> Bool isWiredInName :: Name -> Bool isWiredInName (Name {n_sort = WiredIn _ _ _}) = True -isWiredInName other = False +isWiredInName _ = False wiredInNameTyThing_maybe :: Name -> Maybe TyThing wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing -wiredInNameTyThing_maybe other = Nothing +wiredInNameTyThing_maybe _ = Nothing +isBuiltInSyntax :: Name -> Bool isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True -isBuiltInSyntax other = False +isBuiltInSyntax _ = False isExternalName (Name {n_sort = External _}) = True isExternalName (Name {n_sort = WiredIn _ _ _}) = True -isExternalName other = False +isExternalName _ = False isInternalName name = not (isExternalName name) nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr name) +nameModule_maybe :: Name -> Maybe Module nameModule_maybe (Name { n_sort = External mod}) = Just mod nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod -nameModule_maybe name = Nothing +nameModule_maybe _ = Nothing nameIsLocalOrFrom from name | isExternalName name = from == nameModule name @@ -171,7 +175,7 @@ isTyConName :: Name -> Bool isTyConName name = isTcOcc (nameOccName name) isSystemName (Name {n_sort = System}) = True -isSystemName other = False +isSystemName _ = False \end{code} @@ -182,8 +186,8 @@ isSystemName other = False %************************************************************************ \begin{code} -mkInternalName :: Unique -> OccName -> SrcLoc -> Name -mkInternalName uniq occ loc = Name { n_uniq = getKey# uniq, n_sort = Internal, n_occ = occ, n_loc = loc } +mkInternalName :: Unique -> OccName -> SrcSpan -> Name +mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal, n_occ = occ, n_loc = loc } -- NB: You might worry that after lots of huffing and -- puffing we might end up with two local names with distinct -- uniques, but the same OccName. Indeed we can, but that's ok @@ -193,21 +197,21 @@ mkInternalName uniq occ loc = Name { n_uniq = getKey# uniq, n_sort = Internal, n -- * for interface files we tidyCore first, which puts the uniques -- into the print name (see setNameVisibility below) -mkExternalName :: Unique -> Module -> OccName -> SrcLoc -> Name +mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name mkExternalName uniq mod occ loc - = Name { n_uniq = getKey# uniq, n_sort = External mod, + = Name { n_uniq = getKeyFastInt uniq, n_sort = External mod, n_occ = occ, n_loc = loc } mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name mkWiredInName mod occ uniq thing built_in - = Name { n_uniq = getKey# uniq, + = Name { n_uniq = getKeyFastInt uniq, n_sort = WiredIn mod thing built_in, - n_occ = occ, n_loc = wiredInSrcLoc } + n_occ = occ, n_loc = wiredInSrcSpan } mkSystemName :: Unique -> OccName -> Name -mkSystemName uniq occ = Name { n_uniq = getKey# uniq, n_sort = System, - n_occ = occ, n_loc = noSrcLoc } +mkSystemName uniq occ = Name { n_uniq = getKeyFastInt uniq, n_sort = System, + n_occ = occ, n_loc = noSrcSpan } mkSystemVarName :: Unique -> FastString -> Name mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) @@ -217,15 +221,20 @@ mkSysTvName uniq fs = mkSystemName uniq (mkOccNameFS tvName fs) mkFCallName :: Unique -> String -> Name -- The encoded string completely describes the ccall -mkFCallName uniq str = Name { n_uniq = getKey# uniq, n_sort = Internal, - n_occ = mkVarOcc str, n_loc = noSrcLoc } +mkFCallName uniq str = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal, + n_occ = mkVarOcc str, n_loc = noSrcSpan } + +mkTickBoxOpName :: Unique -> String -> Name +mkTickBoxOpName uniq str + = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal, + n_occ = mkVarOcc str, n_loc = noSrcSpan } mkIPName :: Unique -> OccName -> Name mkIPName uniq occ - = Name { n_uniq = getKey# uniq, + = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal, n_occ = occ, - n_loc = noSrcLoc } + n_loc = noSrcSpan } \end{code} \begin{code} @@ -233,7 +242,7 @@ mkIPName uniq occ -- able to change a Name's Unique to match the cached -- one in the thing it's the name of. If you know what I mean. setNameUnique :: Name -> Unique -> Name -setNameUnique name uniq = name {n_uniq = getKey# uniq} +setNameUnique name uniq = name {n_uniq = getKeyFastInt uniq} tidyNameOcc :: Name -> OccName -> Name -- We set the OccName of a Name when tidying @@ -254,8 +263,11 @@ localiseName n = n { n_sort = Internal } %************************************************************************ \begin{code} -hashName :: Name -> Int -hashName name = getKey (nameUnique name) +hashName :: Name -> Int -- ToDo: should really be Word +hashName name = getKey (nameUnique name) + 1 + -- The +1 avoids keys with lots of zeros in the ls bits, which + -- interacts badly with the cheap and cheerful multiplication in + -- hashExpr \end{code} @@ -266,7 +278,8 @@ hashName name = getKey (nameUnique name) %************************************************************************ \begin{code} -cmpName n1 n2 = I# (n_uniq n1) `compare` I# (n_uniq n2) +cmpName :: Name -> Name -> Ordering +cmpName n1 n2 = iBox (n_uniq n1) `compare` iBox (n_uniq n2) \end{code} \begin{code} @@ -329,30 +342,37 @@ instance Outputable Name where instance OutputableBndr Name where pprBndr _ name = pprName name -pprName name@(Name {n_sort = sort, n_uniq = u#, n_occ = occ}) +pprName :: Name -> SDoc +pprName (Name {n_sort = sort, n_uniq = u, n_occ = occ}) = getPprStyle $ \ sty -> case sort of WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin External mod -> pprExternal sty uniq mod occ False UserSyntax System -> pprSystem sty uniq occ Internal -> pprInternal sty uniq occ - where uniq = mkUniqueGrimily (I# u#) + where uniq = mkUniqueGrimily (iBox u) +pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc pprExternal sty uniq mod occ is_wired is_builtin | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ -- In code style, always qualify -- ToDo: maybe we could print all wired-in things unqualified -- in code style, to reduce symbol table bloat? | debugStyle sty = ppr mod <> dot <> ppr_occ_name occ - <> braces (hsep [if is_wired then ptext SLIT("(w)") else empty, + <> braces (hsep [if is_wired then ptext (sLit "(w)") else empty, pprNameSpaceBrief (occNameSpace occ), pprUnique uniq]) | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- never qualify builtin syntax - | Just mod <- qualName sty mod occ = ppr mod <> dot <> ppr_occ_name occ - -- the PrintUnqualified tells us how to qualify this Name, if at all + | NameQual modname <- qual_name = ppr modname <> dot <> ppr_occ_name occ + -- see HscTypes.mkPrintUnqualified and Outputable.QualifyName: + | NameNotInScope1 <- qual_name = ppr mod <> dot <> ppr_occ_name occ + | NameNotInScope2 <- qual_name = ppr (modulePackageId mod) <> char ':' <> + ppr (moduleName mod) <> dot <> ppr_occ_name occ | otherwise = ppr_occ_name occ + where qual_name = qualName sty mod occ +pprInternal :: PprStyle -> Unique -> OccName -> SDoc pprInternal sty uniq occ | codeStyle sty = pprUnique uniq | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), @@ -363,6 +383,7 @@ pprInternal sty uniq occ | otherwise = ppr_occ_name occ -- User style -- Like Internal, except that we only omit the unique in Iface style +pprSystem :: PprStyle -> Unique -> OccName -> SDoc pprSystem sty uniq occ | codeStyle sty = pprUnique uniq | debugStyle sty = ppr_occ_name occ <> char '_' <> pprUnique uniq @@ -372,13 +393,25 @@ pprSystem sty uniq occ -- is unlikely to be informative (like 's'), -- so print the unique +ppr_occ_name :: OccName -> SDoc ppr_occ_name occ = ftext (occNameFS occ) -- Don't use pprOccName; instead, just print the string of the OccName; -- we print the namespace in the debug stuff above -- In code style, we Z-encode the strings. The results of Z-encoding each FastString are -- cached behind the scenes in the FastString implementation. +ppr_z_occ_name :: OccName -> SDoc ppr_z_occ_name occ = ftext (zEncodeFS (occNameFS occ)) + +-- Prints (if mod information is available) "Defined at " or +-- "Defined in " information for a Name. +pprNameLoc :: Name -> SDoc +pprNameLoc name + | isGoodSrcSpan loc = pprDefnLoc loc + | isInternalName name || isSystemName name + = ptext (sLit "") + | otherwise = ptext (sLit "Defined in ") <> ppr (nameModule name) + where loc = nameSrcSpan name \end{code} %************************************************************************ @@ -397,9 +430,11 @@ class NamedThing a where \begin{code} getSrcLoc :: NamedThing a => a -> SrcLoc +getSrcSpan :: NamedThing a => a -> SrcSpan getOccString :: NamedThing a => a -> String getSrcLoc = nameSrcLoc . getName +getSrcSpan = nameSrcSpan . getName getOccString = occNameString . getOccName \end{code}