X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FName.lhs;h=ddfae908caa61d0f261493f01ff1e99bc340e8bd;hb=a237946da277f10bd3d223e5926d118044d24194;hp=2c176ec1813b22443be6eb0c17de4ade7944f7b5;hpb=b4255f2c320f852d7dfb0afc0bc9f64765aece0c;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 2c176ec..ddfae90 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -1,204 +1,519 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[Name]{@Name@: to transmit name info from renamer to typechecker} \begin{code} -#include "HsVersions.h" - module Name ( - Module(..), - - RdrName(..), - isUnqual, - isQual, - isConopRdr, - appendRdr, - rdrToOrig, - showRdr, - cmpRdr, - - Name, - Provenance, - mkLocalName, isLocalName, - mkTopLevName, mkImportedName, - mkImplicitName, isImplicitName, - mkBuiltinName, - - mkFunTyConName, mkTupleDataConName, mkTupleTyConName, - - NamedThing(..), -- class - ExportFlag(..), isExported, - - nameUnique, - nameOrigName, - nameOccName, - nameExportFlag, - nameSrcLoc, - isLocallyDefinedName, - isPreludeDefinedName, - - getOrigName, getOccName, getExportFlag, - getSrcLoc, isLocallyDefined, isPreludeDefined, - getLocalName, getOrigNameRdr, ltLexical, - - isOpLexeme, pprOp, pprNonOp, - isConop, isAconop, isAvarid, isAvarop + -- Re-export the OccName stuff + module OccName, + + -- The Name type + Name, -- Abstract + mkLocalName, mkImportedLocalName, mkSysLocalName, mkCCallName, + mkTopName, mkIPName, + mkDerivedName, mkGlobalName, mkKnownKeyGlobal, + mkWiredInIdName, mkWiredInTyConName, + mkUnboundName, isUnboundName, + + maybeWiredInIdName, maybeWiredInTyConName, + isWiredInName, hashName, + + nameUnique, setNameUnique, setNameProvenance, getNameProvenance, setNameImportReason, + tidyTopName, + nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule, toRdrName, + + isUserExportedName, isUserImportedName, isUserImportedExplicitlyName, + maybeUserImportedFrom, + nameSrcLoc, isLocallyDefinedName, isDllName, + + isSystemName, isLocalName, isGlobalName, isExternallyVisibleName, + isTyVarName, + + -- Environment + NameEnv, mkNameEnv, + emptyNameEnv, unitNameEnv, nameEnvElts, + extendNameEnv_C, extendNameEnv, + plusNameEnv, plusNameEnv_C, extendNameEnv, extendNameEnvList, + lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, elemNameEnv, + + + -- Provenance + Provenance(..), ImportReason(..), pprProvenance, + ExportFlag(..), PrintUnqualified, + pprNameProvenance, hasBetterProv, + + -- Class NamedThing and overloaded friends + NamedThing(..), + getSrcLoc, isLocallyDefined, getOccString, toRdrName ) where -import Ubiq - -import CStrings ( identToC, cSEP ) -import Outputable ( Outputable(..) ) -import PprStyle ( PprStyle(..), codeStyle ) -import PrelMods ( pRELUDE, pRELUDE_BUILTIN ) -import Pretty -import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc ) -import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique, - pprUnique, Unique - ) -import Util ( thenCmp, _CMP_STRING_, nOfThem, panic ) +#include "HsVersions.h" + +import {-# SOURCE #-} Var ( Id, setIdName ) +import {-# SOURCE #-} TyCon ( TyCon, setTyConName ) + +import OccName -- All of it +import Module ( Module, moduleName, pprModule, mkVanillaModule, isLocalModule ) +import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule ) +import CmdLineOpts ( opt_Static, opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) + +import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc ) +import Unique ( Unique, Uniquable(..), u2i, hasKey, pprUnique ) +import PrelNames ( unboundKey ) +import Maybes ( expectJust ) +import UniqFM +import Outputable +import GlaExts \end{code} + %************************************************************************ %* * -\subsection[RdrName]{The @RdrName@ datatype; names read from files} +\subsection[Name-datatype]{The @Name@ datatype, and name construction} %* * %************************************************************************ + +\begin{code} +data Name = Name { + n_sort :: NameSort, -- What sort of name it is + n_uniq :: Unique, + n_occ :: OccName, -- Its occurrence name + n_prov :: Provenance -- How it was made + } + +data NameSort + = Local + | Global Module + | WiredInId Module Id + | WiredInTyCon Module TyCon +\end{code} + +Things with a @Global@ name are given C static labels, so they finally +appear in the .o file's symbol table. They appear in the symbol table +in the form M.n. If originally-local things have this property they +must be made @Global@ first. \begin{code} -type Module = FAST_STRING +mkLocalName :: Unique -> OccName -> SrcLoc -> Name +mkLocalName uniq occ loc = Name { n_uniq = uniq, n_sort = Local, n_occ = occ, + n_prov = LocalDef loc NotExported } + -- 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 + -- * the insides of the compiler don't care: they use the Unique + -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the + -- uniques if you get confused + -- * for interface files we tidyCore first, which puts the uniques + -- into the print name (see setNameVisibility below) + +mkImportedLocalName :: Unique -> OccName -> SrcLoc -> Name + -- Just the same as mkLocalName, except the provenance is different + -- Reason: this flags the name as one that came in from an interface file. + -- This is useful when trying to decide which of two type variables + -- should 'win' when unifying them. + -- NB: this is only for non-top-level names, so we use ImplicitImport +mkImportedLocalName uniq occ loc = Name { n_uniq = uniq, n_sort = Local, n_occ = occ, + n_prov = NonLocalDef ImplicitImport True } + + +mkGlobalName :: Unique -> Module -> OccName -> Provenance -> Name +mkGlobalName uniq mod occ prov = Name { n_uniq = uniq, n_sort = Global mod, + n_occ = occ, n_prov = prov } + + +mkKnownKeyGlobal :: RdrName -> Unique -> Name +mkKnownKeyGlobal rdr_name uniq + = mkGlobalName uniq (mkVanillaModule (rdrNameModule rdr_name)) + (rdrNameOcc rdr_name) + systemProvenance + +mkSysLocalName :: Unique -> UserFS -> Name +mkSysLocalName uniq fs = Name { n_uniq = uniq, n_sort = Local, + n_occ = mkSrcVarOcc fs, n_prov = systemProvenance } + +mkCCallName :: Unique -> EncodedString -> Name + -- The encoded string completely describes the ccall +mkCCallName uniq str = Name { n_uniq = uniq, n_sort = Local, + n_occ = mkCCallOcc str, + n_prov = NonLocalDef ImplicitImport True } + +mkTopName :: Unique -> Module -> FAST_STRING -> Name + -- Make a top-level name; make it Global if top-level + -- things should be externally visible; Local otherwise + -- This chap is only used *after* the tidyCore phase + -- Notably, it is used during STG lambda lifting + -- + -- We have to make sure that the name is globally unique + -- and we don't have tidyCore to help us. So we append + -- the unique. Hack! Hack! +mkTopName uniq mod fs + = Name { n_uniq = uniq, + n_sort = mk_top_sort mod, + n_occ = mkSrcVarOcc (_PK_ ((_UNPK_ fs) ++ show uniq)), + n_prov = LocalDef noSrcLoc NotExported } + +mkIPName :: Unique -> OccName -> Name +mkIPName uniq occ + = Name { n_uniq = uniq, + n_sort = Local, + n_occ = occ, + -- ZZ is this an appropriate provinence? + n_prov = SystemProv } + +------------------------- Wired in names ------------------------- + +mkWiredInIdName :: Unique -> Module -> OccName -> Id -> Name +mkWiredInIdName uniq mod occ id = Name { n_uniq = uniq, n_sort = WiredInId mod id, + n_occ = occ, n_prov = SystemProv } + +mkWiredInTyConName :: Unique -> Module -> OccName -> TyCon -> Name +mkWiredInTyConName uniq mod occ tycon + = Name { n_uniq = uniq, n_sort = WiredInTyCon mod tycon, + n_occ = occ, n_prov = SystemProv } + + +--------------------------------------------------------------------- +mkDerivedName :: (OccName -> OccName) + -> Name -- Base name + -> Unique -- New unique + -> Name -- Result is always a value name + +mkDerivedName f name uniq = name {n_uniq = uniq, n_occ = f (n_occ name)} + +-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly +-- during compiler debugging. +mkUnboundName :: RdrName -> Name +mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc + +isUnboundName :: Name -> Bool +isUnboundName name = name `hasKey` unboundKey +\end{code} -data RdrName = Unqual FAST_STRING - | Qual Module FAST_STRING +\begin{code} +-- When we renumber/rename things, we need to be +-- 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 uniq = name {n_uniq = uniq} + +setNameOcc :: Name -> OccName -> Name + -- Give the thing a new OccName, *and* + -- record that it's no longer a sys-local + -- This is used by the tidy-up pass +setNameOcc name occ = name {n_occ = occ} + +setNameModule :: Name -> Module -> Name +setNameModule name mod = name {n_sort = set (n_sort name)} + where + set (Global _) = Global mod + set (WiredInId _ id) = WiredInId mod id + set (WiredInTyCon _ tycon) = WiredInTyCon mod tycon +\end{code} -isUnqual (Unqual _) = True -isUnqual (Qual _ _) = False -isQual (Unqual _) = False -isQual (Qual _ _) = True +%************************************************************************ +%* * +\subsection{Setting provenance and visibility +%* * +%************************************************************************ -isConopRdr (Unqual n) = isConop n -isConopRdr (Qual m n) = isConop n +tidyTopName is applied to top-level names in the final program -appendRdr (Unqual n) str = Unqual (n _APPEND_ str) -appendRdr (Qual m n) str = Qual m (n _APPEND_ str) +For top-level things, it globalises Local names + (if all top-level things should be visible) + and localises non-exported Global names + (if only exported things should be visible) -rdrToOrig (Unqual n) = (pRELUDE, n) -rdrToOrig (Qual m n) = (m, n) +In all cases except an exported global, it gives it a new occurrence name. -cmpRdr (Unqual n1) (Unqual n2) = _CMP_STRING_ n1 n2 -cmpRdr (Unqual n1) (Qual m2 n2) = LT_ -cmpRdr (Qual m1 n1) (Unqual n2) = GT_ -cmpRdr (Qual m1 n1) (Qual m2 n2) = thenCmp (_CMP_STRING_ m1 m2) (_CMP_STRING_ n1 n2) +The "visibility" here concerns whether the .o file's symbol table +mentions the thing; if so, it needs a module name in its symbol. +The Global things are "visible" and the Local ones are not -instance Eq RdrName where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } +Why should things be "visible"? Certainly they must be if they +are exported. But also: -instance Ord RdrName where - a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } +(a) In certain (prelude only) modules we split up the .hc file into + lots of separate little files, which are separately compiled by the C + compiler. That gives lots of little .o files. The idea is that if + you happen to mention one of them you don't necessarily pull them all + in. (Pulling in a piece you don't need can be v bad, because it may + mention other pieces you don't need either, and so on.) + + Sadly, splitting up .hc files means that local names (like s234) are + now globally visible, which can lead to clashes between two .hc + files. So unlocaliseWhatnot goes through making all the local things + into global things, essentially by giving them full names so when they + are printed they'll have their module name too. Pretty revolting + really. -instance Ord3 RdrName where - cmp = cmpRdr +(b) When optimisation is on we want to make all the internal + top-level defns externally visible -instance NamedThing RdrName where - -- We're sorta faking it here - getName rdr_name - = Global u rdr_name prov ex [rdr_name] - where - u = panic "NamedThing.RdrName:Unique" - prov = panic "NamedThing.RdrName:Provenance" - ex = panic "NamedThing.RdrName:ExportFlag" +\begin{code} +tidyTopName :: Module -> TidyOccEnv -> Name -> (TidyOccEnv, Name) +tidyTopName mod env name + = (env', name') + where + (env', occ') = tidyOccName env (n_occ name) -instance Outputable RdrName where - ppr sty (Unqual n) = pp_name sty n - ppr sty (Qual m n) = ppBeside (pp_mod sty m) (pp_name sty n) + name' = Name { n_uniq = n_uniq name, n_sort = mk_top_sort mod, + n_occ = occ', n_prov = LocalDef noSrcLoc NotExported } -pp_mod PprInterface m = ppNil -pp_mod PprForC m = ppBesides [identToC m, ppPStr cSEP] -pp_mod (PprForAsm False _) m = ppBesides [identToC m, ppPStr cSEP] -pp_mod (PprForAsm True _) m = ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP] -pp_mod _ m = ppBesides [ppPStr m, ppChar '.'] +mk_top_sort mod | all_toplev_ids_visible = Global mod + | otherwise = Local -pp_name sty n | codeStyle sty = identToC n - | otherwise = ppPStr n +all_toplev_ids_visible = + not opt_OmitInterfacePragmas || -- Pragmas can make them visible + opt_EnsureSplittableC -- Splitting requires visiblilty +\end{code} -showRdr sty rdr = ppShow 100 (ppr sty rdr) + +\begin{code} +setNameProvenance :: Name -> Provenance -> Name + -- setNameProvenance used to only change the provenance of + -- Implicit-provenance things, but that gives bad error messages + -- for names defined twice in the same module, so I changed it to + -- set the provenance of *any* global (SLPJ Jun 97) +setNameProvenance name prov = name {n_prov = prov} + +getNameProvenance :: Name -> Provenance +getNameProvenance name = n_prov name + +setNameImportReason :: Name -> ImportReason -> Name +setNameImportReason name reason + = name { n_prov = new_prov } + where + -- It's important that we don't do the pattern matching + -- in the top-level clause, else we get a black hole in + -- the renamer. Rather a yukky constraint. There's only + -- one call, in RnNames + old_prov = n_prov name + new_prov = case old_prov of + NonLocalDef _ omit -> NonLocalDef reason omit + other -> old_prov \end{code} + %************************************************************************ %* * -\subsection[Name-datatype]{The @Name@ datatype} +\subsection{Provenance and export info} %* * %************************************************************************ \begin{code} -data Name - = Local Unique - FAST_STRING - SrcLoc - - | Global Unique - RdrName -- original name; Unqual => prelude - Provenance -- where it came from - ExportFlag -- is it exported? - [RdrName] -- ordered occurrence names (usually just one); - -- first may be *un*qual. - data Provenance - = LocalDef SrcLoc -- locally defined; give its source location + = LocalDef -- Defined locally + SrcLoc -- Defn site + ExportFlag -- Whether it's exported + + | NonLocalDef -- Defined non-locally + ImportReason + PrintUnqualified + + | SystemProv -- Either (a) a system-generated local with + -- a v short name OccName + -- or (b) a known-key global which should have a proper + -- provenance attached by the renamer +\end{code} - | Imported SrcLoc -- imported; give the *original* source location - -- [SrcLoc] -- any import source location(s) +Sys-provs are only used internally. When the compiler generates (say) +a fresh desguar variable it always calls it "ds", and of course it gets +a fresh unique. But when printing -ddump-xx dumps, we must print it with +its unique, because there'll be a lot of "ds" variables. - | Implicit - | Builtin -\end{code} +Names with SystemProv differ in the following ways: + a) locals have unique attached when printing dumps + b) unifier eliminates sys tyvars in favour of user provs where possible + c) renamer replaces SystemProv with a better one + +Before anything gets printed in interface files or output code, it's +fed through a 'tidy' processor, which zaps the OccNames to have +unique names; and converts all sys-locals to user locals +If any desugarer sys-locals have survived that far, they get changed to +"ds1", "ds2", etc. \begin{code} -mkLocalName = Local +data ImportReason + = UserImport Module SrcLoc Bool -- Imported from module M on line L + -- Note the M may well not be the defining module + -- for this thing! + -- The Bool is true iff the thing was named *explicitly* in the import spec, + -- rather than being imported as part of a group; e.g. + -- import B + -- import C( T(..) ) + -- Here, everything imported by B, and the constructors of T + -- are not named explicitly; only T is named explicitly. + -- This info is used when warning of unused names. + + | ImplicitImport -- Imported implicitly for some other reason + + +type PrintUnqualified = Bool -- True <=> the unqualified name of this thing is + -- in scope in this module, so print it + -- unqualified in error messages + +data ExportFlag = Exported | NotExported +\end{code} -mkTopLevName u orig locn exp occs = Global u orig (LocalDef locn) exp occs -mkImportedName u orig locn exp occs = Global u orig (Imported locn) exp occs +Something is "Exported" if it may be mentioned by another module without +warning. The crucial thing about Exported things is that they must +never be dropped as dead code, even if they aren't used in this module. +Furthermore, being Exported means that we can't see all call sites of the thing. -mkImplicitName :: Unique -> RdrName -> Name -mkImplicitName u o = Global u o Implicit NotExported [] +Exported things include: -mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name -mkBuiltinName u m n = Global u (Unqual n) Builtin NotExported [] + - explicitly exported Ids, including data constructors, + class method selectors -mkFunTyConName - = mkBuiltinName funTyConKey pRELUDE_BUILTIN SLIT("->") -mkTupleDataConName arity - = mkBuiltinName (mkTupleDataConUnique arity) pRELUDE_BUILTIN (mk_tup_name arity) -mkTupleTyConName arity - = mkBuiltinName (mkTupleTyConUnique arity) pRELUDE_BUILTIN (mk_tup_name arity) + - dfuns from instance decls -mk_tup_name 0 = SLIT("()") -mk_tup_name 1 = panic "Name.mk_tup_name: 1 ???" -mk_tup_name 2 = SLIT("(,)") -- not strictly necessary -mk_tup_name 3 = SLIT("(,,)") -- ditto -mk_tup_name 4 = SLIT("(,,,)") -- ditto -mk_tup_name n - = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")") +Being Exported is *not* the same as finally appearing in the .o file's +symbol table. For example, a local Id may be mentioned in an Exported +Id's unfolding in the interface file, in which case the local Id goes +out too. - -- ToDo: what about module ??? - -- ToDo: exported when compiling builtin ??? -isLocalName (Local _ _ _) = True -isLocalName _ = False +\begin{code} +systemProvenance :: Provenance +systemProvenance = SystemProv + +-- pprNameProvenance is used in error messages to say where a name came from +pprNameProvenance :: Name -> SDoc +pprNameProvenance name = pprProvenance (getNameProvenance name) + +pprProvenance :: Provenance -> SDoc +pprProvenance SystemProv = ptext SLIT("System") +pprProvenance (LocalDef loc _) = ptext SLIT("defined at") <+> ppr loc +pprProvenance (NonLocalDef ImplicitImport _) + = ptext SLIT("implicitly imported") +pprProvenance (NonLocalDef (UserImport mod loc _) _) + = ptext SLIT("imported from") <+> ppr mod <+> ptext SLIT("at") <+> ppr loc +\end{code} -isImplicitName (Global _ _ Implicit _ _) = True -isImplicitName _ = False -isBuiltinName (Global _ _ Builtin _ _) = True -isBuiltinName _ = False -\end{code} +%************************************************************************ +%* * +\subsection{Predicates and selectors} +%* * +%************************************************************************ +\begin{code} +nameUnique :: Name -> Unique +nameOccName :: Name -> OccName +nameModule :: Name -> Module +nameSrcLoc :: Name -> SrcLoc +isLocallyDefinedName :: Name -> Bool +isUserExportedName :: Name -> Bool +isWiredInName :: Name -> Bool +isLocalName :: Name -> Bool +isGlobalName :: Name -> Bool +isExternallyVisibleName :: Name -> Bool + + + +hashName :: Name -> Int +hashName name = IBOX( u2i (nameUnique name) ) + +nameUnique name = n_uniq name +nameOccName name = n_occ name + +nameModule name = + case n_sort name of + Local -> pprPanic "nameModule" (ppr name) + x -> nameSortModule x + +nameSortModule (Global mod) = mod +nameSortModule (WiredInId mod _) = mod +nameSortModule (WiredInTyCon mod _) = mod + +nameRdrName :: Name -> RdrName +-- Makes a qualified name for top-level (Global) names, whether locally defined or not +-- and an unqualified name just for Locals +nameRdrName (Name { n_sort = Local, n_occ = occ }) = mkRdrUnqual occ +nameRdrName (Name { n_sort = sort, n_occ = occ }) = mkRdrQual (moduleName (nameSortModule sort)) occ + +ifaceNameRdrName :: Name -> RdrName +-- Makes a qualified naem for imported things, +-- and an unqualified one for local things +ifaceNameRdrName n | isLocallyDefined n = mkRdrUnqual (nameOccName n) + | otherwise = mkRdrQual (moduleName (nameModule n)) (nameOccName n) + +isUserExportedName (Name { n_prov = LocalDef _ Exported }) = True +isUserExportedName other = False + +isUserImportedExplicitlyName (Name { n_prov = NonLocalDef (UserImport _ _ explicit) _ }) = explicit +isUserImportedExplicitlyName other = False + +isUserImportedName (Name { n_prov = NonLocalDef (UserImport _ _ _) _ }) = True +isUserImportedName other = False + +maybeUserImportedFrom (Name { n_prov = NonLocalDef (UserImport m _ _) _ }) = Just m +maybeUserImportedFrom other = Nothing + +isDllName :: Name -> Bool + -- Does this name refer to something in a different DLL? +isDllName nm = not opt_Static && + not (isLocallyDefinedName nm) && +-- isLocallyDefinedName test is needed because nameModule won't work on local names + not (isLocalModule (nameModule nm)) + +nameSrcLoc name = provSrcLoc (n_prov name) + +provSrcLoc (LocalDef loc _) = loc +provSrcLoc (NonLocalDef (UserImport _ loc _) _) = loc +provSrcLoc other = noSrcLoc + +isLocallyDefinedName (Name {n_sort = Local}) = True -- Local (might have SystemProv) +isLocallyDefinedName (Name {n_prov = LocalDef _ _}) = True -- Global, but defined here +isLocallyDefinedName other = False -- Other + +-- Things the compiler "knows about" are in some sense +-- "imported". When we are compiling the module where +-- the entities are defined, we need to be able to pick +-- them out, often in combination with isLocallyDefined. +isWiredInName (Name {n_sort = WiredInTyCon _ _}) = True +isWiredInName (Name {n_sort = WiredInId _ _}) = True +isWiredInName _ = False + +maybeWiredInIdName :: Name -> Maybe Id +maybeWiredInIdName (Name {n_sort = WiredInId _ id}) = Just id +maybeWiredInIdName other = Nothing + +maybeWiredInTyConName :: Name -> Maybe TyCon +maybeWiredInTyConName (Name {n_sort = WiredInTyCon _ tc}) = Just tc +maybeWiredInTyConName other = Nothing + + +isLocalName (Name {n_sort = Local}) = True +isLocalName _ = False + +isGlobalName (Name {n_sort = Local}) = False +isGlobalName other = True + +isTyVarName :: Name -> Bool +isTyVarName name = isTvOcc (nameOccName name) + +-- Global names are by definition those that are visible +-- outside the module, *as seen by the linker*. Externally visible +-- does not mean visible at the source level (that's isExported). +isExternallyVisibleName name = isGlobalName name + +hasBetterProv :: Name -> Name -> Bool +-- Choose +-- a local thing over an imported thing +-- a user-imported thing over a non-user-imported thing +-- an explicitly-imported thing over an implicitly imported thing +hasBetterProv n1 n2 + = case (n_prov n1, n_prov n2) of + (LocalDef _ _, _ ) -> True + (NonLocalDef (UserImport _ _ True) _, _ ) -> True + (NonLocalDef (UserImport _ _ _ ) _, NonLocalDef ImplicitImport _) -> True + other -> False + +isSystemName (Name {n_prov = SystemProv}) = True +isSystemName other = False +\end{code} %************************************************************************ @@ -208,130 +523,152 @@ isBuiltinName _ = False %************************************************************************ \begin{code} -cmpName n1 n2 = c n1 n2 - where - c (Local u1 _ _) (Local u2 _ _) = cmp u1 u2 - c (Global u1 _ _ _ _) (Global u2 _ _ _ _) = cmp u1 u2 - - c other_1 other_2 -- the tags *must* be different - = let tag1 = tag_Name n1 - tag2 = tag_Name n2 - in - if tag1 _LT_ tag2 then LT_ else GT_ - - tag_Name (Local _ _ _) = (ILIT(1) :: FAST_INT) - tag_Name (Global _ _ _ _ _) = ILIT(2) +cmpName n1 n2 = n_uniq n1 `compare` n_uniq n2 \end{code} \begin{code} instance Eq Name where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } instance Ord Name where - a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } - -instance Ord3 Name where - cmp = cmpName + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmpName a b instance Uniquable Name where - uniqueOf = nameUnique + getUnique = nameUnique instance NamedThing Name where getName n = n \end{code} -\begin{code} -nameUnique (Local u _ _) = u -nameUnique (Global u _ _ _ _) = u -nameOrigName (Local _ n _) = (panic "NamedThing.Local.nameOrigName", n) -nameOrigName (Global _ orig _ _ _) = rdrToOrig orig - -nameOccName (Local _ n _) = Unqual n -nameOccName (Global _ orig _ _ [] ) = orig -nameOccName (Global _ orig _ _ occs) = head occs - -nameExportFlag (Local _ _ _) = NotExported -nameExportFlag (Global _ _ _ exp _) = exp - -nameSrcLoc (Local _ _ loc) = loc -nameSrcLoc (Global _ _ (LocalDef loc) _ _) = loc -nameSrcLoc (Global _ _ (Imported loc) _ _) = loc -nameSrcLoc (Global _ _ Implicit _ _) = mkUnknownSrcLoc -nameSrcLoc (Global _ _ Builtin _ _) = mkBuiltinSrcLoc - -isLocallyDefinedName (Local _ _ _) = True -isLocallyDefinedName (Global _ _ (LocalDef _) _ _) = True -isLocallyDefinedName (Global _ _ (Imported _) _ _) = False -isLocallyDefinedName (Global _ _ Implicit _ _) = False -isLocallyDefinedName (Global _ _ Builtin _ _) = False - -isPreludeDefinedName (Local _ n _) = False -isPreludeDefinedName (Global _ orig _ _ _) = isUnqual orig -\end{code} +%************************************************************************ +%* * +\subsection{Name environment} +%* * +%************************************************************************ \begin{code} -instance Outputable Name where -#ifdef DEBUG - ppr PprDebug (Local u n _) = pp_debug u (ppPStr n) - ppr PprDebug (Global u o _ _ _) = pp_debug u (ppr PprDebug o) -#endif - ppr sty (Local u n _) = pp_name sty n - ppr PprForUser (Global u o _ _ [] ) = ppr PprForUser o - ppr PprForUser (Global u o _ _ occs) = ppr PprForUser (head occs) - ppr PprShowAll (Global u o prov exp occs) = pp_all o prov exp occs - ppr sty (Global u o _ _ _) = ppr sty o - -pp_debug uniq thing - = ppBesides [thing, ppStr "{-", pprUnique uniq, ppStr "-}" ] - -pp_all orig prov exp occs - = ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp] - -pp_exp NotExported = ppNil -pp_exp ExportAll = ppPStr SLIT("/EXP(..)") -pp_exp ExportAbs = ppPStr SLIT("/EXP") - -pp_prov Implicit = ppPStr SLIT("/IMPLICIT") -pp_prov Builtin = ppPStr SLIT("/BUILTIN") -pp_prov _ = ppNil +type NameEnv a = UniqFM a -- Domain is Name + +emptyNameEnv :: NameEnv a +mkNameEnv :: [(Name,a)] -> NameEnv a +nameEnvElts :: NameEnv a -> [a] +extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a +extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a +plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a +plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a +extendNameEnvList:: NameEnv a -> [(Name,a)] -> NameEnv a +delFromNameEnv :: NameEnv a -> Name -> NameEnv a +elemNameEnv :: Name -> NameEnv a -> Bool +unitNameEnv :: Name -> a -> NameEnv a +lookupNameEnv :: NameEnv a -> Name -> Maybe a +lookupNameEnv_NF :: NameEnv a -> Name -> a +mapNameEnv :: (a->b) -> NameEnv a -> NameEnv b + +emptyNameEnv = emptyUFM +mkNameEnv = listToUFM +nameEnvElts = eltsUFM +extendNameEnv_C = addToUFM_C +extendNameEnv = addToUFM +plusNameEnv = plusUFM +plusNameEnv_C = plusUFM_C +extendNameEnvList= addListToUFM +delFromNameEnv = delFromUFM +elemNameEnv = elemUFM +mapNameEnv = mapUFM +unitNameEnv = unitUFM + +lookupNameEnv = lookupUFM +lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupUFM env n) \end{code} + %************************************************************************ %* * -\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype} +\subsection{Pretty printing} %* * %************************************************************************ -The export flag @ExportAll@ means `export all there is', so there are -times when it is attached to a class or data type which has no -ops/constructors (if the class/type was imported abstractly). In -fact, @ExportAll@ is attached to everything except to classes/types -which are being {\em exported} abstractly, regardless of how they were -imported. - \begin{code} -data ExportFlag - = ExportAll -- export with all constructors/methods - | ExportAbs -- export abstractly - | NotExported - -isExported a - = case (getExportFlag a) of - NotExported -> False - _ -> True - -#ifdef USE_ATTACK_PRAGMAS -{-# SPECIALIZE isExported :: Class -> Bool #-} -{-# SPECIALIZE isExported :: Id -> Bool #-} -{-# SPECIALIZE isExported :: TyCon -> Bool #-} -#endif +instance Outputable Name where + -- When printing interfaces, all Locals have been given nice print-names + ppr name = pprName name + +pprName (Name {n_sort = Local, n_uniq = uniq, n_occ = occ, n_prov = prov}) + -- Locals + = getPprStyle $ \ sty -> + if codeStyle sty then + pprUnique uniq -- When printing in code we required all names to + -- be globally unique; for example, we use this identifier + -- for the closure name. So we just print the unique alone. + else + pprOccName occ <> pp_local_extra sty uniq + where + sys_local = case prov of + SystemProv -> True + other -> False + + pp_local_extra sty uniq + | sys_local = underscore <> pprUnique uniq -- Must print uniques for sys_locals + | debugStyle sty = text "{-" <> pprUnique uniq <> text "-}" + | otherwise = empty + + +pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ, n_prov = prov}) + -- Globals, and wired in things + = getPprStyle $ \ sty -> + if codeStyle sty then + ppr mod <> underscore <> ppr occ + else + pp_mod_dot sty <> ppr occ <> pp_global_debug sty uniq prov + where + mod = nameSortModule sort + + pp_mod_dot sty + = case prov of + SystemProv -> pp_qual mod user_sty + -- Hack alert! Omit the qualifier on SystemProv things in user style + -- I claim such SystemProv things will also be WiredIn things. + -- We can't get the omit flag right + -- on wired in tycons etc (sigh) so we just leave it out in user style, + -- and hope that leaving it out isn't too consfusing. + -- (e.g. if the programmer hides Bool and redefines it. If so, use -dppr-debug.) + + LocalDef _ _ -> pp_qual mod (user_sty || iface_sty) + + NonLocalDef (UserImport imp_mod _ _) omit + | user_sty -> pp_qual imp_mod omit + | otherwise -> pp_qual mod False + NonLocalDef ImplicitImport omit -> pp_qual mod (user_sty && omit) + where + user_sty = userStyle sty + iface_sty = ifaceStyle sty + + pp_qual mod omit_qual + | omit_qual = empty + | otherwise = pprModule mod <> dot + + pp_global_debug sty uniq prov + | debugStyle sty = hcat [text "{-", pprUnique uniq, prov_p prov, text "-}"] + | otherwise = empty + + prov_p prov | opt_PprStyle_NoPrags = empty + | otherwise = comma <> pp_prov prov + +pp_prov (LocalDef _ Exported) = char 'x' +pp_prov (LocalDef _ NotExported) = char 'l' +pp_prov (NonLocalDef ImplicitImport _) = char 'j' +pp_prov (NonLocalDef (UserImport _ _ True ) _) = char 'I' -- Imported by name +pp_prov (NonLocalDef (UserImport _ _ False) _) = char 'i' -- Imported by .. +pp_prov SystemProv = char 's' \end{code} + %************************************************************************ %* * \subsection{Overloaded functions related to Names} @@ -340,131 +677,24 @@ isExported a \begin{code} class NamedThing a where - getName :: a -> Name + getOccName :: a -> OccName + getName :: a -> Name + + getOccName n = nameOccName (getName n) -- Default method \end{code} \begin{code} -getOrigName :: NamedThing a => a -> (Module, FAST_STRING) -getOccName :: NamedThing a => a -> RdrName -getExportFlag :: NamedThing a => a -> ExportFlag getSrcLoc :: NamedThing a => a -> SrcLoc isLocallyDefined :: NamedThing a => a -> Bool -isPreludeDefined :: NamedThing a => a -> Bool +getOccString :: NamedThing a => a -> String +toRdrName :: NamedThing a => a -> RdrName -getOrigName = nameOrigName . getName -getOccName = nameOccName . getName -getExportFlag = nameExportFlag . getName getSrcLoc = nameSrcLoc . getName isLocallyDefined = isLocallyDefinedName . getName -isPreludeDefined = isPreludeDefinedName . getName - -getLocalName :: (NamedThing a) => a -> FAST_STRING -getLocalName = snd . getOrigName - -getOrigNameRdr :: (NamedThing a) => a -> RdrName -getOrigNameRdr n | isPreludeDefined n = Unqual str - | otherwise = Qual mod str - where - (mod,str) = getOrigName n -\end{code} - -@ltLexical@ is used for sorting things into lexicographical order, so -as to canonicalize interfaces. [Regular @(<)@ should be used for fast -comparison.] - -\begin{code} -a `ltLexical` b - = BIND isLocallyDefined a _TO_ a_local -> - BIND isLocallyDefined b _TO_ b_local -> - BIND getOrigName a _TO_ (a_mod, a_name) -> - BIND getOrigName b _TO_ (b_mod, b_name) -> - if a_local || b_local then - a_name < b_name -- can't compare module names - else - case _CMP_STRING_ a_mod b_mod of - LT_ -> True - EQ_ -> a_name < b_name - GT__ -> False - BEND BEND BEND BEND - -#ifdef USE_ATTACK_PRAGMAS -{-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-} -{-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-} -{-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-} -#endif -\end{code} - -These functions test strings to see if they fit the lexical categories -defined in the Haskell report. Normally applied as in e.g. @isConop -(getLocalName foo)@ - -\begin{code} -isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool - -isConop cs - | _NULL_ cs = False - | c == '_' = isConop (_TAIL_ cs) -- allow for leading _'s - | otherwise = isUpper c || c == ':' - || c == '[' || c == '(' -- [] () and (,,) come is as Conop strings !!! - || isUpperISO c - where - c = _HEAD_ cs - -isAconop cs - | _NULL_ cs = False - | otherwise = c == ':' - where - c = _HEAD_ cs - -isAvarid cs - | _NULL_ cs = False - | c == '_' = isAvarid (_TAIL_ cs) -- allow for leading _'s - | isLower c = True - | isLowerISO c = True - | otherwise = False - where - c = _HEAD_ cs - -isAvarop cs - | _NULL_ cs = False - | isLower c = False - | isUpper c = False - | c `elem` "!#$%&*+./<=>?@\\^|~-" = True - | isSymbolISO c = True - | otherwise = False - where - c = _HEAD_ cs - -isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf]) -isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c -isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c +getOccString x = occNameString (getOccName x) +toRdrName = ifaceNameRdrName . getName \end{code} -And one ``higher-level'' interface to those: - \begin{code} -isOpLexeme :: NamedThing a => a -> Bool - -isOpLexeme v - = let str = snd (getOrigName v) in isAvarop str || isAconop str - --- print `vars`, (op) correctly -pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty - -pprOp sty var - = if isOpLexeme var - then ppr sty var - else ppBesides [ppChar '`', ppr sty var, ppChar '`'] - -pprNonOp sty var - = if isOpLexeme var - then ppBesides [ppLparen, ppr sty var, ppRparen] - else ppr sty var - -#ifdef USE_ATTACK_PRAGMAS -{-# SPECIALIZE isOpLexeme :: Id -> Bool #-} -{-# SPECIALIZE pprNonOp :: PprStyle -> Id -> Pretty #-} -{-# SPECIALIZE pprNonOp :: PprStyle -> TyCon -> Pretty #-} -{-# SPECIALIZE pprOp :: PprStyle -> Id -> Pretty #-} -#endif +{-# SPECIALIZE isLocallyDefined :: Name -> Bool #-} \end{code}