X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FName.lhs;h=a2b42a278eb153468268c1cdc97ffe6130480b21;hp=cba20f5c7844c4e0512bf14fcb79a17f9d10b600;hb=0b4324456e472d15a3a124f56387486f71cb765d;hpb=8b072e93c055a73eb5c495cb129ea1737b925a8d diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index cba20f5..a2b42a2 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -37,7 +37,7 @@ module Name ( BuiltInSyntax(..), -- ** Creating 'Name's - mkInternalName, mkSystemName, + mkInternalName, mkSystemName, mkDerivedInternalName, mkSystemVarName, mkSysTvName, mkFCallName, mkIPName, mkTickBoxOpName, @@ -63,18 +63,21 @@ module Name ( NamedThing(..), getSrcLoc, getSrcSpan, getOccString, - pprInfixName, pprPrefixName, + pprInfixName, pprPrefixName, pprModulePrefix, -- Re-export the OccName stuff module OccName ) where +#include "Typeable.h" + import {-# SOURCE #-} TypeRep( TyThing ) import OccName import Module import SrcLoc import Unique +import Util import Maybes import Binary import StaticFlags @@ -83,6 +86,8 @@ import FastString import Outputable import Data.Array +import Data.Data +import Data.Word ( Word32 ) \end{code} %************************************************************************ @@ -101,6 +106,7 @@ data Name = Name { --(note later when changing Int# -> FastInt: is that still true about UNPACK?) n_loc :: !SrcSpan -- Definition site } + deriving Typeable -- NOTE: we make the n_loc field strict to eliminate some potential -- (and real!) space leaks, due to the fact that we don't look at @@ -248,6 +254,11 @@ mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq, n_sort = Inter -- * for interface files we tidyCore first, which puts the uniques -- into the print name (see setNameVisibility below) +mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name +mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) + = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal + , n_occ = derive_occ occ, n_loc = loc } + -- | Create a name which definitely originates in the given module mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name mkExternalName uniq mod occ loc @@ -270,7 +281,7 @@ mkSystemVarName :: Unique -> FastString -> Name mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) mkSysTvName :: Unique -> FastString -> Name -mkSysTvName uniq fs = mkSystemName uniq (mkOccNameFS tvName fs) +mkSysTvName uniq fs = mkSystemName uniq (mkOccNameFS tvName fs) -- | Make a name for a foreign call mkFCallName :: Unique -> String -> Name @@ -352,6 +363,12 @@ instance Uniquable Name where instance NamedThing Name where getName n = n + +instance Data Name where + -- don't traverse? + toConstr _ = abstractConstr "Name" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Name" \end{code} %************************************************************************ @@ -368,7 +385,7 @@ instance Binary Name where get bh = do i <- get bh - return $! (ud_symtab (getUserData bh) ! i) + return $! (ud_symtab (getUserData bh) ! fromIntegral (i::Word32)) \end{code} %************************************************************************ @@ -396,23 +413,16 @@ pprName (Name {n_sort = sort, n_uniq = u, n_occ = occ}) 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 + | 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, - pprNameSpaceBrief (occNameSpace occ), - pprUnique uniq]) - | BuiltInSyntax <- is_builtin = ppr_occ_name occ - -- never qualify builtin syntax - | 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 + | debugStyle sty = ppr mod <> dot <> ppr_occ_name occ + <> 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 + | otherwise = pprModulePrefix sty mod occ <> ppr_occ_name occ pprInternal :: PprStyle -> Unique -> OccName -> SDoc pprInternal sty uniq occ @@ -435,6 +445,21 @@ pprSystem sty uniq occ -- is unlikely to be informative (like 's'), -- so print the unique + +pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc +-- Print the "M." part of a name, based on whether it's in scope or not +-- See Note [Printing original names] in HscTypes +pprModulePrefix sty mod occ + | opt_SuppressModulePrefixes = empty + + | otherwise + = case qualName sty mod occ of -- See Outputable.QualifyName: + NameQual modname -> ppr modname <> dot -- Name is in scope + NameNotInScope1 -> ppr mod <> dot -- Not in scope + NameNotInScope2 -> ppr (modulePackageId mod) <> colon -- Module not in + <> ppr (moduleName mod) <> dot -- scope eithber + _otherwise -> empty + ppr_underscore_unique :: Unique -> SDoc -- Print an underscore separating the name from its unique -- But suppress it if we aren't printing the uniques anyway @@ -455,12 +480,14 @@ 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 +pprNameLoc name = case nameSrcSpan name of + RealSrcSpan s -> + pprDefnLoc s + UnhelpfulSpan _ + | isInternalName name || isSystemName name -> + ptext (sLit "") + | otherwise -> + ptext (sLit "Defined in ") <> ppr (nameModule name) \end{code} %************************************************************************