X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FName.lhs;h=ac47387290345745293d1b4295d3b797aca41770;hb=d3e697b8d842bd43329d470f2bc424a6dcb88d89;hp=2a44651a5dd996a27d9c1e80157fc9ed969a303c;hpb=f01a8e8c9c53bfb5ab3393ed3457ebf25390efa1;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 2a44651..ac47387 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -4,215 +4,395 @@ \section[Name]{@Name@: to transmit name info from renamer to typechecker} \begin{code} -#include "HsVersions.h" - module Name ( - Module(..), - - RdrName(..), - isUnqual, - isQual, - isRdrLexCon, - appendRdr, - showRdr, - cmpRdr, - - Name, - Provenance, - mkLocalName, isLocalName, - mkTopLevName, mkImportedName, - mkImplicitName, isImplicitName, - mkBuiltinName, mkCompoundName, - - mkFunTyConName, mkTupleDataConName, mkTupleTyConName, - mkTupNameStr, - - NamedThing(..), -- class - ExportFlag(..), - isExported{-overloaded-}, exportFlagOn{-not-}, - - nameUnique, - nameOccName, - nameOrigName, - nameExportFlag, - nameSrcLoc, - nameImpLocs, - nameImportFlag, + -- Re-export the Module type + Module, + pprModule, moduleString, + + -- The OccName type + OccName(..), + pprOccName, occNameString, occNameFlavour, + isTvOcc, isTCOcc, isVarOcc, prefixOccName, + uniqToOccName, + + -- The Name type + Name, -- Abstract + mkLocalName, mkSysLocalName, + + mkCompoundName, mkGlobalName, + + mkWiredInIdName, mkWiredInTyConName, + maybeWiredInIdName, maybeWiredInTyConName, + isWiredInName, + + nameUnique, changeUnique, setNameProvenance, getNameProvenance, + setNameVisibility, + nameOccName, nameString, nameModule, + + isExportedName, nameSrcLoc, isLocallyDefinedName, - isPreludeDefinedName, - origName, moduleOf, nameOf, moduleNamePair, - getOccName, getExportFlag, - getSrcLoc, getImpLocs, - isLocallyDefined, isPreludeDefined, - getLocalName, ltLexical, + isLocalName, - isSymLexeme, pprSym, pprNonSym, - isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym, - isLexConId, isLexConSym, isLexVarId, isLexVarSym + pprNameProvenance, + + -- Sets of Names + NameSet, + emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets, + minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet, isEmptyNameSet, + + -- Misc + Provenance(..), pprProvenance, + ExportFlag(..), + PrintUnqualified, + + -- Class NamedThing and overloaded friends + NamedThing(..), + modAndOcc, isExported, + getSrcLoc, isLocallyDefined, getOccString ) where -import Ubiq +#include "HsVersions.h" + +import {-# SOURCE #-} Id ( Id ) +import {-# SOURCE #-} TyCon ( TyCon ) + +import CStrings ( identToC ) +import CmdLineOpts ( opt_PprStyle_All, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) +import BasicTypes ( Module, IfaceFlavour(..), moduleString, pprModule ) -import CStrings ( identToC, cSEP ) -import Outputable ( Outputable(..) ) -import PprStyle ( PprStyle(..), codeStyle ) -import PrelMods ( pRELUDE, pRELUDE_BUILTIN, fromPrelude ) -import Pretty -import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc ) -import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique, - pprUnique, Unique +import Lex ( isLexConId ) +import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc ) +import Unique ( pprUnique, showUnique, Unique, Uniquable(..) ) +import UniqSet ( UniqSet(..), emptyUniqSet, unitUniqSet, unionUniqSets, uniqSetToList, + isEmptyUniqSet, unionManyUniqSets, minusUniqSet, mkUniqSet, + elementOfUniqSet, addListToUniqSet, addOneToUniqSet ) -import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic ) +import UniqFM ( UniqFM ) +import Outputable +\end{code} + + +%************************************************************************ +%* * +\subsection[Name-pieces-datatypes]{The @OccName@ datatypes} +%* * +%************************************************************************ + +\begin{code} +data OccName = VarOcc FAST_STRING -- Variables and data constructors + | TvOcc FAST_STRING -- Type variables + | TCOcc FAST_STRING -- Type constructors and classes + +pprOccName :: OccName -> SDoc +pprOccName n = getPprStyle $ \ sty -> + if codeStyle sty + then identToC (occNameString n) + else ptext (occNameString n) + +occNameString :: OccName -> FAST_STRING +occNameString (VarOcc s) = s +occNameString (TvOcc s) = s +occNameString (TCOcc s) = s + +prefixOccName :: FAST_STRING -> OccName -> OccName +prefixOccName prefix (VarOcc s) = VarOcc (prefix _APPEND_ s) +prefixOccName prefix (TvOcc s) = TvOcc (prefix _APPEND_ s) +prefixOccName prefix (TCOcc s) = TCOcc (prefix _APPEND_ s) + +-- occNameFlavour is used only to generate good error messages, so it doesn't matter +-- that the VarOcc case isn't mega-efficient. We could have different Occ constructors for +-- data constructors and values, but that makes everything else a bit more complicated. +occNameFlavour :: OccName -> String +occNameFlavour (VarOcc s) | isLexConId s = "Data constructor" + | otherwise = "Value" +occNameFlavour (TvOcc s) = "Type variable" +occNameFlavour (TCOcc s) = "Type constructor or class" + +isVarOcc, isTCOcc, isTvOcc :: OccName -> Bool +isVarOcc (VarOcc s) = True +isVarOcc other = False + +isTvOcc (TvOcc s) = True +isTvOcc other = False + +isTCOcc (TCOcc s) = True +isTCOcc other = False + +instance Eq OccName where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + +instance Ord OccName where + 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 = cmpOcc a b + +(VarOcc s1) `cmpOcc` (VarOcc s2) = s1 `compare` s2 +(VarOcc s1) `cmpOcc` other2 = LT + +(TvOcc s1) `cmpOcc` (VarOcc s2) = GT +(TvOcc s1) `cmpOcc` (TvOcc s2) = s1 `compare` s2 +(TvOcc s1) `cmpOcc` other = LT + +(TCOcc s1) `cmpOcc` (TCOcc s2) = s1 `compare` s2 +(TCOcc s1) `cmpOcc` other = GT + +instance Outputable OccName where + ppr = pprOccName \end{code} + %************************************************************************ %* * -\subsection[RdrName]{The @RdrName@ datatype; names read from files} +\subsection[Name-datatype]{The @Name@ datatype, and name construction} %* * %************************************************************************ + +\begin{code} +data Name + = Local Unique + OccName + SrcLoc + + | Global Unique + Module -- The defining module + OccName -- Its name in that module + Provenance -- How it was defined +\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 +data Provenance + = NoProvenance + + | LocalDef -- Defined locally + SrcLoc -- Defn site + ExportFlag -- Whether it's exported + + | NonLocalDef -- Defined non-locally + SrcLoc -- Defined non-locally; src-loc gives defn site + IfaceFlavour -- Whether the defn site is an .hi-boot file or not + PrintUnqualified + + | WiredInTyCon TyCon -- There's a wired-in version + | WiredInId Id -- ...ditto... + +type PrintUnqualified = Bool -- True <=> the unqualified name of this thing is + -- in scope in this module, so print it unqualified + -- in error messages +\end{code} + +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. + +Exported things include: + - explicitly exported Ids, including data constructors, class method selectors + - dfuns from instance decls + +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. + +\begin{code} +data ExportFlag = Exported | NotExported +\end{code} + +\begin{code} +mkLocalName :: Unique -> OccName -> SrcLoc -> Name +mkLocalName = Local + +mkGlobalName :: Unique -> Module -> OccName -> Provenance -> Name +mkGlobalName = Global -data RdrName - = Unqual FAST_STRING - | Qual Module FAST_STRING +mkSysLocalName :: Unique -> FAST_STRING -> SrcLoc -> Name +mkSysLocalName uniq str loc = Local uniq (VarOcc str) loc -isUnqual (Unqual _) = True -isUnqual (Qual _ _) = False +mkWiredInIdName :: Unique -> Module -> FAST_STRING -> Id -> Name +mkWiredInIdName uniq mod occ id + = Global uniq mod (VarOcc occ) (WiredInId id) -isQual (Unqual _) = False -isQual (Qual _ _) = True +mkWiredInTyConName :: Unique -> Module -> FAST_STRING -> TyCon -> Name +mkWiredInTyConName uniq mod occ tycon + = Global uniq mod (TCOcc occ) (WiredInTyCon tycon) -isRdrLexCon (Unqual n) = isLexCon n -isRdrLexCon (Qual m n) = isLexCon n -appendRdr (Unqual n) str = Unqual (n _APPEND_ str) -appendRdr (Qual m n) str = ASSERT(not (fromPrelude m)) - Qual m (n _APPEND_ str) +mkCompoundName :: (FAST_STRING -> FAST_STRING) -- Occurrence-name modifier + -> Unique -- New unique + -> Name -- Base name (must be a Global) + -> Name -- Result is always a value 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) +mkCompoundName str_fn uniq (Global _ mod occ prov) + = Global uniq mod new_occ prov + where + new_occ = VarOcc (str_fn (occNameString occ)) -- Always a VarOcc -instance Eq RdrName where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } +mkCompoundName str_fn uniq (Local _ occ loc) + = Local uniq (VarOcc (str_fn (occNameString occ))) loc + + +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 (Global uniq mod occ _) prov = Global uniq mod occ prov +setNameProvenance other_name prov = other_name + +getNameProvenance :: Name -> Provenance +getNameProvenance (Global uniq mod occ prov) = prov +getNameProvenance (Local uniq occ locn) = LocalDef locn NotExported + +-- 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. +changeUnique (Local _ n l) u = Local u n l +changeUnique (Global _ mod occ prov) u = Global u mod occ prov +\end{code} + +setNameVisibility is applied to names in the final program + +The Maybe Module argument is (Just mod) for top-level values, +and Nothing for all others (local values and type variables) + +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) + +For nested things it localises Global names. + +In all cases except an exported global, it gives it a new occurrence name. + +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 + +Why should things be "visible"? Certainly they must be if they +are exported. But also: + +(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. + +(b) When optimisation is on we want to make all the internal + top-level defns externally visible + +\begin{code} +setNameVisibility :: Maybe Module -> Unique -> Name -> Name -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 } +setNameVisibility maybe_mod occ_uniq name@(Global uniq mod occ (LocalDef loc NotExported)) + | not all_toplev_ids_visible || not_top_level maybe_mod + = Local uniq (uniqToOccName occ_uniq) loc -- Localise Global name -instance Ord3 RdrName where - cmp = cmpRdr +setNameVisibility maybe_mod occ_uniq name@(Global _ _ _ _) + = name -- Otherwise don't fiddle with Global -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" +setNameVisibility (Just mod) occ_uniq (Local uniq occ loc) + | all_toplev_ids_visible + = Global uniq mod -- Globalise Local name + (uniqToOccName occ_uniq) + (LocalDef loc NotExported) -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) +setNameVisibility maybe_mod occ_uniq (Local uniq occ loc) + = Local uniq (uniqToOccName occ_uniq) loc -- New OccName for Local -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 '.'] +uniqToOccName uniq = VarOcc (_PK_ ('$':showUnique uniq)) + -- The "$" is to make sure that this OccName is distinct from all user-defined ones -pp_name sty n | codeStyle sty = identToC n - | otherwise = ppPStr n +not_top_level (Just m) = False +not_top_level Nothing = True -showRdr sty rdr = ppShow 100 (ppr sty rdr) +all_toplev_ids_visible = not opt_OmitInterfacePragmas || -- Pragmas can make them visible + opt_EnsureSplittableC -- Splitting requires visiblilty \end{code} %************************************************************************ %* * -\subsection[Name-datatype]{The @Name@ datatype} +\subsection{Predicates and selectors} %* * %************************************************************************ \begin{code} -data Name - = Local Unique - FAST_STRING - SrcLoc +nameUnique :: Name -> Unique +nameModAndOcc :: Name -> (Module, OccName) -- Globals only +nameOccName :: Name -> OccName +nameModule :: Name -> Module +nameString :: Name -> FAST_STRING -- A.b form +nameSrcLoc :: Name -> SrcLoc +isLocallyDefinedName :: Name -> Bool +isExportedName :: Name -> Bool +isWiredInName :: Name -> Bool +isLocalName :: Name -> Bool - | 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 - | Imported ExportFlag -- how it was imported - SrcLoc -- *original* source location - [SrcLoc] -- any import source location(s) +nameUnique (Local u _ _) = u +nameUnique (Global u _ _ _) = u - | Implicit - | Builtin -\end{code} +nameOccName (Local _ occ _) = occ +nameOccName (Global _ _ occ _) = occ -\begin{code} -mkLocalName = Local +nameModule (Global _ mod occ _) = mod -mkTopLevName u orig locn exp occs = Global u orig (LocalDef locn) exp occs -mkImportedName u orig imp locn imp_locs exp occs = Global u orig (Imported imp locn imp_locs) exp occs +nameModAndOcc (Global _ mod occ _) = (mod,occ) -mkImplicitName :: Unique -> RdrName -> Name -mkImplicitName u o = Global u o Implicit NotExported [] +nameString (Local _ occ _) = occNameString occ +nameString (Global _ mod occ _) = mod _APPEND_ SLIT(".") _APPEND_ occNameString occ -mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name -mkBuiltinName u m n = Global u (Unqual n) Builtin NotExported [] +isExportedName (Global _ _ _ (LocalDef _ Exported)) = True +isExportedName other = False -mkCompoundName :: Unique -> [FAST_STRING] -> Name -mkCompoundName u ns - = Global u (Unqual{-???-} (_CONCAT_ (dotify ns))) Builtin{--} NotExported [] - where - dotify [] = [] - dotify [n] = [n] - dotify (n:ns) = n : (map (_CONS_ '.') ns) - -mkFunTyConName - = mkBuiltinName funTyConKey pRELUDE_BUILTIN SLIT("->") -mkTupleDataConName arity - = mkBuiltinName (mkTupleDataConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity) -mkTupleTyConName arity - = mkBuiltinName (mkTupleTyConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity) - -mkTupNameStr 0 = SLIT("()") -mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???" -mkTupNameStr 2 = SLIT("(,)") -- not strictly necessary -mkTupNameStr 3 = SLIT("(,,)") -- ditto -mkTupNameStr 4 = SLIT("(,,,)") -- ditto -mkTupNameStr n - = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")") - - -- ToDo: what about module ??? - -- ToDo: exported when compiling builtin ??? +nameSrcLoc (Local _ _ loc) = loc +nameSrcLoc (Global _ _ _ (LocalDef loc _)) = loc +nameSrcLoc (Global _ _ _ (NonLocalDef loc _ _)) = loc +nameSrcLoc (Global _ _ _ (WiredInTyCon _)) = mkBuiltinSrcLoc +nameSrcLoc (Global _ _ _ (WiredInId _)) = mkBuiltinSrcLoc +nameSrcLoc other = noSrcLoc + +isLocallyDefinedName (Local _ _ _) = True +isLocallyDefinedName (Global _ _ _ (LocalDef _ _)) = True +isLocallyDefinedName other = False -isLocalName (Local _ _ _) = True -isLocalName _ = False +-- 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 (Global _ _ _ (WiredInTyCon _)) = True +isWiredInName (Global _ _ _ (WiredInId _)) = True +isWiredInName _ = False -isImplicitName (Global _ _ Implicit _ _) = True -isImplicitName _ = False +maybeWiredInIdName :: Name -> Maybe Id +maybeWiredInIdName (Global _ _ _ (WiredInId id)) = Just id +maybeWiredInIdName other = Nothing -isBuiltinName (Global _ _ Builtin _ _) = True -isBuiltinName _ = False -\end{code} +maybeWiredInTyConName :: Name -> Maybe TyCon +maybeWiredInTyConName (Global _ _ _ (WiredInTyCon tc)) = Just tc +maybeWiredInTyConName other = Nothing +isLocalName (Local _ _ _) = True +isLocalName _ = False +\end{code} + %************************************************************************ %* * @@ -223,32 +403,23 @@ 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) + c (Local u1 _ _) (Local u2 _ _) = compare u1 u2 + c (Local _ _ _) _ = LT + c (Global u1 _ _ _) (Global u2 _ _ _) = compare u1 u2 + c (Global _ _ _ _) _ = GT \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 @@ -257,106 +428,119 @@ instance NamedThing Name where getName n = n \end{code} -\begin{code} -nameUnique (Local u _ _) = u -nameUnique (Global u _ _ _ _) = u - -nameOrigName (Local _ n _) = Unqual n -nameOrigName (Global _ orig _ _ _) = orig -nameModuleNamePair (Local _ n _) = (panic "nameModuleNamePair", n) -nameModuleNamePair (Global _ (Unqual n) _ _ _) = (pRELUDE, n) -nameModuleNamePair (Global _ (Qual m n) _ _ _) = (m, n) -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 - -nameImpLocs (Global _ _ (Imported _ _ locs) _ _) = locs -nameImpLocs _ = [] - -nameImportFlag (Local _ _ _) = NotExported -nameImportFlag (Global _ _ (LocalDef _) _ _) = ExportAll -nameImportFlag (Global _ _ (Imported exp _ _) _ _) = exp -nameImportFlag (Global _ _ Implicit _ _) = ExportAll -nameImportFlag (Global _ _ Builtin _ _) = ExportAll - -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{Pretty printing} +%* * +%************************************************************************ \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 + -- When printing interfaces, all Locals have been given nice print-names + ppr name = pprName name + +pprName name + = getPprStyle $ \ sty -> + let + ppr (Local u n _) + | userStyle sty + || ifaceStyle sty = ptext (occNameString n) + | codeStyle sty = pprUnique u + | otherwise = hcat [ptext (occNameString n), ptext SLIT("_"), pprUnique u] + + ppr name@(Global u m n prov) + | codeStyle sty + = identToC (m _APPEND_ SLIT(".") _APPEND_ occNameString n) + + | otherwise + = hcat [pp_mod_dot, ptext (occNameString n), pp_debug sty name] + where + pp_mod_dot + = case prov of -- Omit home module qualifier if its in scope + LocalDef _ _ -> pp_qual dot (user_sty || iface_sty) + NonLocalDef _ hif omit -> pp_qual (pp_hif hif) (omit && user_sty) + WiredInTyCon _ -> pp_qual dot user_sty -- Hack: omit qualifers on wired in things + WiredInId _ -> pp_qual dot user_sty -- in user style only + NoProvenance -> pp_qual dot False + + pp_qual sep omit_qual + | omit_qual = empty + | otherwise = pprModule m <> sep + + dot = text "." + pp_hif HiFile = dot -- Vanilla case + pp_hif HiBootFile = text "!" -- M!t indicates a name imported from a .hi-boot interface + + user_sty = userStyle sty + iface_sty = ifaceStyle sty + in + ppr name + + +pp_debug sty (Global uniq m n prov) + | debugStyle sty = hcat [text "{-", pprUnique uniq, prov_p, text "-}"] + | otherwise = empty + where + prov_p | opt_PprStyle_All = comma <> pp_prov prov + | otherwise = empty + +pp_prov (LocalDef _ Exported) = char 'x' +pp_prov (LocalDef _ NotExported) = char 'l' +pp_prov (NonLocalDef _ _ _) = char 'n' +pp_prov (WiredInTyCon _) = char 'W' +pp_prov (WiredInId _) = char 'w' +pp_prov NoProvenance = char '?' + +-- pprNameProvenance is used in error messages to say where a name came from +pprNameProvenance :: Name -> SDoc +pprNameProvenance (Local _ _ loc) = pprProvenance (LocalDef loc NotExported) +pprNameProvenance (Global _ _ _ prov) = pprProvenance prov + +pprProvenance :: Provenance -> SDoc +pprProvenance (LocalDef loc _) = ptext SLIT("Locally defined at") <+> ppr loc +pprProvenance (NonLocalDef loc _ _) = ptext SLIT("Non-locally defined at") <+> ppr loc +pprProvenance (WiredInTyCon tc) = ptext SLIT("Wired-in tycon") +pprProvenance (WiredInId id) = ptext SLIT("Wired-in id") +pprProvenance NoProvenance = ptext SLIT("No provenance") \end{code} + %************************************************************************ %* * -\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype} +\subsection[Sets of names} %* * %************************************************************************ -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 (tycons/classes only) - | NotExported - -exportFlagOn NotExported = False -exportFlagOn _ = True +type NameSet = UniqSet Name +emptyNameSet :: NameSet +unitNameSet :: Name -> NameSet +addListToNameSet :: NameSet -> [Name] -> NameSet +addOneToNameSet :: NameSet -> Name -> NameSet +mkNameSet :: [Name] -> NameSet +unionNameSets :: NameSet -> NameSet -> NameSet +unionManyNameSets :: [NameSet] -> NameSet +minusNameSet :: NameSet -> NameSet -> NameSet +elemNameSet :: Name -> NameSet -> Bool +nameSetToList :: NameSet -> [Name] +isEmptyNameSet :: NameSet -> Bool + +isEmptyNameSet = isEmptyUniqSet +emptyNameSet = emptyUniqSet +unitNameSet = unitUniqSet +mkNameSet = mkUniqSet +addListToNameSet = addListToUniqSet +addOneToNameSet = addOneToUniqSet +unionNameSets = unionUniqSets +unionManyNameSets = unionManyUniqSets +minusNameSet = minusUniqSet +elemNameSet = elementOfUniqSet +nameSetToList = uniqSetToList +\end{code} -isExported a = exportFlagOn (getExportFlag a) -#ifdef USE_ATTACK_PRAGMAS -{-# SPECIALIZE isExported :: Class -> Bool #-} -{-# SPECIALIZE isExported :: Id -> Bool #-} -{-# SPECIALIZE isExported :: TyCon -> Bool #-} -#endif -\end{code} %************************************************************************ %* * @@ -366,147 +550,28 @@ isExported a = exportFlagOn (getExportFlag a) \begin{code} class NamedThing a where - getName :: a -> Name + getOccName :: a -> OccName -- Even RdrNames can do this! + getName :: a -> Name + + getOccName n = nameOccName (getName n) -- Default method \end{code} \begin{code} -origName :: NamedThing a => a -> RdrName -moduleOf :: RdrName -> Module -nameOf :: RdrName -> FAST_STRING -moduleNamePair :: NamedThing a => a -> (Module, FAST_STRING) - -getOccName :: NamedThing a => a -> RdrName -getLocalName :: NamedThing a => a -> FAST_STRING -getExportFlag :: NamedThing a => a -> ExportFlag +modAndOcc :: NamedThing a => a -> (Module, OccName) getSrcLoc :: NamedThing a => a -> SrcLoc -getImpLocs :: NamedThing a => a -> [SrcLoc] isLocallyDefined :: NamedThing a => a -> Bool -isPreludeDefined :: NamedThing a => a -> Bool - --- ToDo: specialise for RdrNames? -origName = nameOrigName . getName -moduleNamePair = nameModuleNamePair . getName +isExported :: NamedThing a => a -> Bool +getOccString :: NamedThing a => a -> String -moduleOf (Unqual n) = pRELUDE -moduleOf (Qual m n) = m - -nameOf (Unqual n) = n -nameOf (Qual m n) = n - -getLocalName = nameOf . origName - -getOccName = nameOccName . getName -getExportFlag = nameExportFlag . getName +modAndOcc = nameModAndOcc . getName +isExported = isExportedName . getName getSrcLoc = nameSrcLoc . getName -getImpLocs = nameImpLocs . getName isLocallyDefined = isLocallyDefinedName . getName -isPreludeDefined = isPreludeDefinedName . getName -\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 = origName a < origName b - -#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. @isCon -(getLocalName foo)@. - -\begin{code} -isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, - isLexVarId, isLexVarSym, isLexSpecialSym :: FAST_STRING -> Bool - -isLexCon cs = isLexConId cs || isLexConSym cs -isLexVar cs = isLexVarId cs || isLexVarSym cs - -isLexId cs = isLexConId cs || isLexVarId cs -isLexSym cs = isLexConSym cs || isLexVarSym cs - -------------- - -isLexConId cs - | _NULL_ cs = False - | c == '_' = isLexConId (_TAIL_ cs) -- allow for leading _'s - | otherwise = isUpper c || isUpperISO c - where - c = _HEAD_ cs - -isLexVarId cs - | _NULL_ cs = False - | c == '_' = isLexVarId (_TAIL_ cs) -- allow for leading _'s - | otherwise = isLower c || isLowerISO c - where - c = _HEAD_ cs - -isLexConSym cs - | _NULL_ cs = False - | otherwise = c == ':' --- || c == '(' -- (), (,), (,,), ... - || cs == SLIT("->") --- || cs == SLIT("[]") - where - c = _HEAD_ cs - -isLexVarSym cs - | _NULL_ cs = False - | otherwise = isSymbolASCII c - || isSymbolISO c --- || c == '(' -- (), (,), (,,), ... --- || cs == SLIT("[]") - where - c = _HEAD_ cs - -isLexSpecialSym cs - | _NULL_ cs = False - | otherwise = c == '(' -- (), (,), (,,), ... - || cs == SLIT("[]") - where - c = _HEAD_ cs - -------------- -isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" -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 = _UNPK_ (occNameString (getOccName x)) \end{code} -And one ``higher-level'' interface to those: - \begin{code} -isSymLexeme :: NamedThing a => a -> Bool - -isSymLexeme v - = let str = nameOf (origName v) in isLexSym str - --- print `vars`, (op) correctly -pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty - -pprSym sty var - = let - str = nameOf (origName var) - in - if isLexSym str && not (isLexSpecialSym str) - then ppr sty var - else ppBesides [ppChar '`', ppr sty var, ppChar '`'] - -pprNonSym sty var - = if isSymLexeme var - then ppParens (ppr sty var) - else ppr sty var - -#ifdef USE_ATTACK_PRAGMAS -{-# SPECIALIZE isSymLexeme :: Id -> Bool #-} -{-# SPECIALIZE pprNonSym :: PprStyle -> Id -> Pretty #-} -{-# SPECIALIZE pprNonSym :: PprStyle -> TyCon -> Pretty #-} -{-# SPECIALIZE pprSym :: PprStyle -> Id -> Pretty #-} -#endif +{-# SPECIALIZE isLocallyDefined + :: Name -> Bool + #-} \end{code}