X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FName.lhs;h=de8a3a32b55602916f07908cba5e061d9b8632a6;hp=cf212aee29065220b5f2ac998d84d50fce1e3194;hb=34c8d0312071f7d0f4d221a997d3408c653ef9e5;hpb=703a9c113f4770958d659411011456742cd695a6 diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index cf212ae..de8a3a3 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,25 +63,32 @@ module Name ( NamedThing(..), getSrcLoc, getSrcSpan, getOccString, - pprInfixName, pprPrefixName, + pprInfixName, pprPrefixName, pprModulePrefix, + getNameDepth, setNameDepth, -- 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 import FastTypes import FastString import Outputable import Data.Array +import Data.Data +import Data.Word ( Word32 ) \end{code} %************************************************************************ @@ -105,6 +112,12 @@ data Name = Name { -- (and real!) space leaks, due to the fact that we don't look at -- the SrcLoc in a Name all that often. +setNameDepth :: Int -> Name -> Name +setNameDepth depth name = name { n_occ = setOccNameDepth depth (n_occ name) } + +getNameDepth :: Name -> Int +getNameDepth name = getOccNameDepth $ n_occ name + data NameSort = External Module @@ -247,6 +260,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 @@ -269,7 +287,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 @@ -351,6 +369,14 @@ instance Uniquable Name where instance NamedThing Name where getName n = n + +INSTANCE_TYPEABLE0(Name,nameTc,"Name") + +instance Data Name where + -- don't traverse? + toConstr _ = abstractConstr "Name" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Name" \end{code} %************************************************************************ @@ -367,7 +393,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} %************************************************************************ @@ -395,30 +421,23 @@ 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 | codeStyle sty = pprUnique uniq | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), pprUnique uniq]) - | dumpStyle sty = ppr_occ_name occ <> char '_' <> pprUnique uniq + | dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq -- For debug dumps, we're not necessarily dumping -- tidied code, so we need to print the uniques. | otherwise = ppr_occ_name occ -- User style @@ -427,13 +446,35 @@ pprInternal sty uniq occ pprSystem :: PprStyle -> Unique -> OccName -> SDoc pprSystem sty uniq occ | codeStyle sty = pprUnique uniq - | debugStyle sty = ppr_occ_name occ <> char '_' <> pprUnique uniq + | debugStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq <> braces (pprNameSpaceBrief (occNameSpace occ)) - | otherwise = ppr_occ_name occ <> char '_' <> pprUnique uniq + | otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq -- If the tidy phase hasn't run, the OccName -- 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 +ppr_underscore_unique uniq + | opt_SuppressUniques = empty + | otherwise = char '_' <> pprUnique uniq + ppr_occ_name :: OccName -> SDoc ppr_occ_name occ = ftext (occNameFS occ) -- Don't use pprOccName; instead, just print the string of the OccName;