X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FName.lhs;h=3fdedfbd8ca2201db850066edb414e28dd77f7f9;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=c809a493dae4756bdd4574ab786455c53a766118;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index c809a49..3fdedfb 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -7,138 +7,326 @@
 #include "HsVersions.h"
 
 module Name (
-	-- things for the Name NON-abstract type
-	Name(..),
-
-	isTyConName, isClassName, isClassOpName,
-	isUnboundName, invisibleName,
-
-	getTagFromClassOpName, getSynNameArity,
-
-	getNameShortName, getNameFullName
-
+	SYN_IE(Module),
+
+	OrigName(..), -- glorified pair
+	qualToOrigName, -- a Qual to an OrigName
+
+	RdrName(..),
+	preludeQual,
+	moduleNamePair,
+	isUnqual,
+	isQual,
+	isRdrLexCon, isRdrLexConOrSpecial,
+	appendRdr,
+	showRdr,
+	cmpRdr,
+
+	Name,
+	Provenance,
+	mkLocalName, isLocalName, 
+	mkTopLevName, mkImportedName, oddlyImportedName,
+	mkImplicitName,	isImplicitName,
+	mkPrimitiveName, mkWiredInName,
+	mkCompoundName, mkCompoundName2,
+
+	mkFunTyConName, mkTupleDataConName, mkTupleTyConName,
+	mkTupNameStr,
+
+	NamedThing(..), -- class
+	ExportFlag(..),
+	isExported{-overloaded-}, exportFlagOn{-not-},
+
+	nameUnique, changeUnique,
+	nameOccName,
+--	nameOrigName, : not exported
+	nameExportFlag,
+	nameSrcLoc,
+	nameImpLocs,
+	nameImportFlag,
+	isLocallyDefinedName, isWiredInName,
+
+	origName, moduleOf, nameOf,
+	getOccName, getExportFlag,
+	getSrcLoc, getImpLocs,
+	isLocallyDefined,
+	getLocalName,
+
+	isSymLexeme, pprSym, pprNonSym,
+	isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym,
+	isLexConId, isLexConSym, isLexVarId, isLexVarSym
     ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq()
+IMPORT_1_3(Char(isUpper,isLower))
 
-import NameLoop		-- break Name/Id loop, Name/PprType/Id loop
-
-import NameTypes
-import Outputable	( ExportFlag(..) )
+import CmdLineOpts	( maybe_CompilingGhcInternals )
+import CStrings		( identToC, modnameToC, cSEP )
+import Outputable	( Outputable(..) )
+import PprStyle		( PprStyle(..), codeStyle )
+import PrelMods		( pRELUDE )
 import Pretty
-import PprStyle		( PprStyle(..) )
-import SrcLoc		( mkBuiltinSrcLoc, mkUnknownSrcLoc )
-import TyCon		( TyCon, synTyConArity )
-import TyVar		( GenTyVar )
-import Unique		( pprUnique, Unique )
-import Util		( panic, panic#, pprPanic )
+import SrcLoc		( mkBuiltinSrcLoc, mkUnknownSrcLoc, SrcLoc )
+import Unique		( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique,
+			  pprUnique, Unique
+			)
+import Util		( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic{-, pprTrace ToDo:rm-} )
+
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+#endif
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[Name-datatype]{The @Name@ datatype}
+\subsection[RdrName]{The @RdrName@ datatype; names read from files}
 %*									*
 %************************************************************************
 
 \begin{code}
-data Name
-  = Short	    Unique	-- Local ids and type variables
-		    ShortName
-
-	-- Nano-prelude things; truly wired in.
-	-- Includes all type constructors and their associated data constructors
-  | WiredInTyCon    TyCon
-  | WiredInVal	    Id
-
-  | TyConName	    Unique	-- TyCons other than Prelude ones; need to
-		    FullName	-- separate these because we want to pin on
-		    Arity	-- their arity.
-		    Bool        -- False <=> `type',
-				-- True <=> `data' or `newtype'
-		    [Name]	-- List of user-visible data constructors;
-				-- NB: for `data' types only.
-				-- Used in checking import/export lists.
-
-  | ClassName	    Unique
-		    FullName
-		    [Name]	-- List of class methods; used for checking
-				-- import/export lists.
-
-  | ValName	    Unique	-- Top level id
-		    FullName
-
-  | ClassOpName	    Unique
-		    Name	-- Name associated w/ the defined class
-				-- (can get unique and export info, etc., from this)
-		    FAST_STRING	-- The class operation
-		    Int		-- Unique tag within the class
-
-	-- Miscellaneous
-  | Unbound	    FAST_STRING	-- Placeholder for a name which isn't in scope
-				-- Used only so that the renamer can carry on after
-				-- finding an unbound identifier.
-				-- The string is grabbed from the unbound name, for
-				-- debugging information only.
-\end{code}
+type Module = FAST_STRING
 
-These @is..@ functions are used in the renamer to check that (eg) a tycon
-is seen in a context which demands one.
+data OrigName = OrigName Module FAST_STRING
 
-\begin{code}
-isTyConName, isClassName, isUnboundName :: Name -> Bool
+qualToOrigName (Qual m n) = OrigName m n
 
-isTyConName (TyConName _ _ _ _ _) = True
-isTyConName (WiredInTyCon _)	  = True
-isTyConName other		  = False
+data RdrName
+  = Unqual FAST_STRING
+  | Qual   Module FAST_STRING
 
-isClassName (ClassName _ _ _) = True
-isClassName other	      = False
+preludeQual n = Qual pRELUDE n
 
-isUnboundName (Unbound _) = True
-isUnboundName other	  = False
-\end{code}
+moduleNamePair (Qual m n) = (m, n)  -- we make *no* claim whether this
+				    -- constitutes an original name or
+				    -- an occurrence name, or anything else
 
-@isClassOpName@ is a little cleverer: it checks to see whether the
-class op comes from the correct class.
+isUnqual (Unqual _) = True
+isUnqual (Qual _ _) = False
 
-\begin{code}
-isClassOpName :: Name	-- The name of the class expected for this op
-	      -> Name	-- The name of the thing which should be a class op
-	      -> Bool
+isQual (Unqual _) = False
+isQual (Qual _ _) = True
+
+isRdrLexCon (Unqual n) = isLexCon n
+isRdrLexCon (Qual m n) = isLexCon n
+
+isRdrLexConOrSpecial (Unqual n) = isLexCon n || isLexSpecialSym n
+isRdrLexConOrSpecial (Qual m n) = isLexCon n || isLexSpecialSym n
+
+appendRdr (Unqual n) str = Unqual (n _APPEND_ str)
+appendRdr (Qual m n) str = Qual m (n _APPEND_ str)
+
+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) = _CMP_STRING_ n1 n2 `thenCmp` _CMP_STRING_ m1 m2
+				   -- always compare module-names *second*
+
+cmpOrig (OrigName m1 n1) (OrigName m2 n2)
+  = _CMP_STRING_ n1 n2 `thenCmp` _CMP_STRING_ m1 m2 -- again; module-names *second*
+
+instance Eq RdrName where
+    a == b = case (a `cmp` b) of { EQ_ -> True;  _ -> False }
+    a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
+
+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  }
+
+instance Ord3 RdrName where
+    cmp = cmpRdr
+
+instance NamedThing RdrName where
+    -- We're sorta faking it here
+    getName (Unqual n)
+      = Local u n True locn
+      where
+	u    = panic "NamedThing.RdrName:Unique1"
+	locn = panic "NamedThing.RdrName:locn"
+
+    getName rdr_name@(Qual m n)
+      = Global u m (Left n) prov ex [rdr_name]
+      where
+	u    = panic "NamedThing.RdrName:Unique"
+	prov = panic "NamedThing.RdrName:Provenance"
+	ex   = panic "NamedThing.RdrName:ExportFlag"
+
+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)
+
+pp_mod sty m
+  = case sty of
+      PprForC		-> pp_code
+      PprForAsm False _ -> pp_code
+      PprForAsm True  _ -> ppBeside (ppPStr cSEP) pp_code
+      _			-> ppBeside (ppPStr m)    (ppChar '.')
+  where
+    pp_code = ppBeside (ppPStr (modnameToC m)) (ppPStr cSEP)
+
+pp_name sty n = (if codeStyle sty then identToC else ppPStr) n
 
-isClassOpName (ClassName uniq1 _ _) (ClassOpName _ (ClassName uniq2 _ _) _ _)
-  = uniq1 == uniq2
-isClassOpName other_class other_op = False
+pp_name2 sty pieces
+  = ppIntersperse sep (map pp_piece pieces)
+  where
+    sep = if codeStyle sty then ppPStr cSEP else ppChar '.'
+
+    pp_piece (Left (OrigName m n)) = ppBeside (pp_mod sty m) (pp_name sty n)
+    pp_piece (Right n)		   = pp_name sty n
+
+showRdr sty rdr = ppShow 100 (ppr sty rdr)
+
+-------------------------
+instance Eq OrigName where
+    a == b = case (a `cmp` b) of { EQ_ -> True;  _ -> False }
+    a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
+
+instance Ord OrigName 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 OrigName where
+    cmp = cmpOrig
+
+instance NamedThing OrigName where -- faking it
+    getName (OrigName m n) = getName (Qual m n)
+
+instance Outputable OrigName where -- ditto
+    ppr sty (OrigName m n) = ppr sty (Qual m n)
 \end{code}
 
-A Name is ``invisible'' if the user has no business seeing it; e.g., a
-data-constructor for an abstract data type (but whose constructors are
-known because of a pragma).
-\begin{code}
-invisibleName :: Name -> Bool
+%************************************************************************
+%*									*
+\subsection[Name-datatype]{The @Name@ datatype}
+%*									*
+%************************************************************************
 
-invisibleName (TyConName _ n _ _ _) = invisibleFullName n
-invisibleName (ClassName _ n _)     = invisibleFullName n
-invisibleName (ValName   _ n)	    = invisibleFullName n
-invisibleName _			    = False
+\begin{code}
+data Name
+  = Local    Unique
+             FAST_STRING
+	     Bool	-- True <=> emphasize Unique when
+			-- printing; this is just an esthetic thing...
+             SrcLoc
+
+  | Global   Unique
+             Module	-- original name
+	     (Either
+		FAST_STRING -- just an ordinary M.n name... or...
+		([Either OrigName FAST_STRING]))
+			    -- "dot" these bits of name together...
+             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)
+
+  | Implicit
+  | Primitive		-- really and truly primitive thing (not
+			-- definable in Haskell)
+  | WiredIn  Bool	-- something defined in Haskell; True <=>
+			-- definition is in the module in question;
+			-- this probably comes from the -fcompiling-prelude=...
+			-- flag.
 \end{code}
 
 \begin{code}
-getTagFromClassOpName :: Name -> Int
-getTagFromClassOpName (ClassOpName _ _ _ tag)  = tag
+mkLocalName = Local
 
-getSynNameArity :: Name -> Maybe Arity
-getSynNameArity (TyConName _ _ arity False{-syn-} _) = Just arity
-getSynNameArity (WiredInTyCon tycon)	             = synTyConArity tycon
-getSynNameArity other_name			     = Nothing
+mkTopLevName   u (OrigName m n) locn exp occs = Global u m (Left n) (LocalDef locn) exp occs
+mkImportedName u (OrigName m n) imp locn imp_locs exp occs = Global u m (Left n) (Imported imp locn imp_locs) exp occs
 
-getNameShortName :: Name -> ShortName
-getNameShortName (Short _ sn) = sn
+mkImplicitName :: Unique -> OrigName -> Name
+mkImplicitName u (OrigName m n) = Global u m (Left n) Implicit NotExported []
 
-getNameFullName :: Name -> FullName
-getNameFullName n = get_nm "getNameFullName" n
-\end{code}
+mkPrimitiveName :: Unique -> OrigName -> Name
+mkPrimitiveName u (OrigName m n)  = Global u m (Left n) Primitive NotExported []
 
+mkWiredInName :: Unique -> OrigName -> ExportFlag -> Name
+mkWiredInName u (OrigName m n) exp
+  = Global u m (Left n) (WiredIn from_here) exp []
+  where
+    from_here
+      = case maybe_CompilingGhcInternals of
+          Nothing  -> False
+	  Just mod -> mod == _UNPK_ m
+
+mkCompoundName :: Unique
+	       -> Module
+	       -> FAST_STRING	-- indicates what kind of compound thing it is (e.g., "sdsel")
+	       -> [Either OrigName FAST_STRING]	-- "dot" these names together
+	       -> Name		-- from which we get provenance, etc....
+	       -> Name		-- result!
+
+mkCompoundName u m str ns (Local _ _ _ locn) -- these arise for workers...
+  = Local u str True{-emph uniq-} locn
+
+mkCompoundName u m str ns (Global _ _ _ prov exp _)
+  = Global u m (Right (Right str : ns)) prov exp []
+
+glue = glue1
+glue1 (Left (OrigName m n):ns) = m : _CONS_ '.' n : glue2 ns
+glue1 (Right n            :ns) = n 		  : glue2 ns
+glue2 []		       = []
+glue2 (Left (OrigName m n):ns) = _CONS_ '.' m : _CONS_ '.' n : glue2 ns
+glue2 (Right n            :ns) = _CONS_ '.' n		     : glue2 ns
+
+-- this ugly one is used for instance-y things
+mkCompoundName2 :: Unique
+		-> Module
+		-> FAST_STRING	-- indicates what kind of compound thing it is
+		-> [Either OrigName FAST_STRING] -- "dot" these names together
+		-> Bool		-- True <=> defined in this module
+		-> SrcLoc	
+		-> Name		-- result!
+
+mkCompoundName2 u m str ns from_here locn
+  = Global u m (Right (Right str : ns))
+	     (if from_here then LocalDef locn else Imported ExportAll locn [])
+	     ExportAll{-instances-}
+	     []
+
+mkFunTyConName
+  = mkPrimitiveName funTyConKey		       (OrigName pRELUDE SLIT("->"))
+mkTupleDataConName arity
+  = mkWiredInName (mkTupleDataConUnique arity) (OrigName pRELUDE (mkTupNameStr arity)) ExportAll
+mkTupleTyConName   arity
+  = mkWiredInName (mkTupleTyConUnique   arity) (OrigName pRELUDE (mkTupNameStr arity)) ExportAll
+
+mkTupNameStr 0 = SLIT("()")
+mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
+mkTupNameStr 2 = _PK_ "(,)"   -- not strictly necessary
+mkTupNameStr 3 = _PK_ "(,,)"  -- ditto
+mkTupNameStr 4 = _PK_ "(,,,)" -- ditto
+mkTupNameStr n
+  = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
+
+	-- ToDo: what about module ???
+	-- ToDo: exported when compiling builtin ???
+
+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.
+oddlyImportedName (Global _ _ _ Primitive   _ _) = True
+oddlyImportedName (Global _ _ _ (WiredIn _) _ _) = True
+oddlyImportedName _				 = False
+
+isImplicitName (Global _ _ _ Implicit _ _) = True
+isImplicitName _ 		           = False
+\end{code}
 
 %************************************************************************
 %*									*
@@ -149,32 +337,10 @@ getNameFullName n = get_nm "getNameFullName" n
 \begin{code}
 cmpName n1 n2 = c n1 n2
   where
-    c (Short u1 _)	     (Short u2 _)		= cmp u1 u2
-			      
-    c (WiredInTyCon tc1)     (WiredInTyCon tc2)		= cmp tc1 tc2
-    c (WiredInVal   id1)     (WiredInVal   id2)		= cmp id1 id2
-			      
-    c (TyConName u1 _ _ _ _) (TyConName u2 _ _ _ _) 	= cmp u1 u2
-    c (ClassName u1 _ _)     (ClassName u2 _ _)		= cmp u1 u2
-    c (ValName   u1 _)	     (ValName   u2 _)		= cmp u1 u2
-			      
-    c (ClassOpName u1 _ _ _) (ClassOpName u2 _ _ _)	= cmp u1 u2
-    c (Unbound a)	     (Unbound b)		= panic# "Eq.Name.Unbound"
-
-    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 (Short _ _)		= (ILIT(1) :: FAST_INT)
-    tag_Name (WiredInTyCon _)		= ILIT(2)
-    tag_Name (WiredInVal _)		= ILIT(3)
-    tag_Name (TyConName _ _ _ _ _)	= ILIT(7)
-    tag_Name (ClassName _ _ _)		= ILIT(8)
-    tag_Name (ValName _ _)		= ILIT(9)
-    tag_Name (ClassOpName _ _ _ _)	= ILIT(10)
-    tag_Name (Unbound _)		= ILIT(11)
+    c (Local  u1 _ _ _)     (Local  u2 _ _ _)     = cmp u1 u2
+    c (Local   _ _ _ _)	    _			  = LT_
+    c (Global u1 _ _ _ _ _) (Global u2 _ _ _ _ _) = cmp u1 u2
+    c (Global  _ _ _ _ _ _) _			  = GT_
 \end{code}
 
 \begin{code}
@@ -190,106 +356,274 @@ instance Ord Name where
 
 instance Ord3 Name where
     cmp = cmpName
-\end{code}
 
-\begin{code}
+instance Uniquable Name where
+    uniqueOf = nameUnique
+
 instance NamedThing Name where
-    getExportFlag (Short _ _)		= NotExported
-    getExportFlag (WiredInTyCon _)	= NotExported -- compiler always know about these
-    getExportFlag (WiredInVal _)	= NotExported
-    getExportFlag (ClassOpName _ c _ _) = getExportFlag c
-    getExportFlag other			= getExportFlag (get_nm "getExportFlag" other)
-
-    isLocallyDefined (Short _ _)	   = True
-    isLocallyDefined (WiredInTyCon _)	   = False
-    isLocallyDefined (WiredInVal _)	   = False
-    isLocallyDefined (ClassOpName _ c _ _) = isLocallyDefined c
-    isLocallyDefined other		   = isLocallyDefined (get_nm "isLocallyDefined" other)
-
-    getOrigName (Short _ sn)		= getOrigName sn
-    getOrigName (WiredInTyCon tc)	= getOrigName tc
-    getOrigName (WiredInVal id)		= getOrigName id
-    getOrigName (ClassOpName _ c op _)	= (fst (getOrigName c), op)
-    getOrigName other			= getOrigName (get_nm "getOrigName" other)
-
-    getOccurrenceName (Short _ sn)	   = getOccurrenceName sn
-    getOccurrenceName (WiredInTyCon tc)    = getOccurrenceName tc
-    getOccurrenceName (WiredInVal id)	   = getOccurrenceName id
-    getOccurrenceName (ClassOpName _ _ op _) = op
-    getOccurrenceName (Unbound s)	   =  s _APPEND_ SLIT("<unbound>")
-    getOccurrenceName other		   = getOccurrenceName (get_nm "getOccurrenceName" other)
-
-    getInformingModules thing = panic "getInformingModule:Name"
-
-    getSrcLoc (Short _ sn)	   = getSrcLoc sn
-    getSrcLoc (WiredInTyCon tc)    = mkBuiltinSrcLoc
-    getSrcLoc (WiredInVal id)	   = mkBuiltinSrcLoc
-    getSrcLoc (ClassOpName _ c _ _)  = getSrcLoc c
-    getSrcLoc (Unbound _)	   = mkUnknownSrcLoc
-    getSrcLoc other		   = getSrcLoc (get_nm "getSrcLoc" other)
-
-    getItsUnique (Short		u _)	   = u
-    getItsUnique (WiredInTyCon	t)	   = getItsUnique t
-    getItsUnique (WiredInVal	i)	   = getItsUnique i
-    getItsUnique (TyConName 	u _ _ _ _) = u
-    getItsUnique (ClassName 	u _ _)	   = u
-    getItsUnique (ValName 	u _)	   = u
-    getItsUnique (ClassOpName 	u _ _ _)   = u
-
-    fromPreludeCore (WiredInTyCon _)	   = True
-    fromPreludeCore (WiredInVal _)	   = True
-    fromPreludeCore (ClassOpName _ c _ _)  = fromPreludeCore c
-    fromPreludeCore other		   = False
+    getName n = n
 \end{code}
 
-A useful utility; most emphatically not for export! (but see
-@getNameFullName@...):
 \begin{code}
-get_nm :: String -> Name -> FullName
-
-get_nm msg (TyConName _ n _ _ _) = n
-get_nm msg (ClassName _ n _)	 = n
-get_nm msg (ValName   _ n)	 = n
+nameUnique (Local  u _ _ _)     = u
+nameUnique (Global u _ _ _ _ _) = u
+
+-- 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 b l)    u = Local u n b l
+changeUnique (Global   _ m n p e os) u = Global u m n p e os
+
+nameOrigName msg (Global _ m (Left  n) _ _ _) = OrigName m n
+nameOrigName msg (Global _ m (Right n) _ _ _) = let str = _CONCAT_ (glue n) in
+						--pprTrace ("nameOrigName:"++msg) (ppPStr str) $
+						OrigName m str
 #ifdef DEBUG
-get_nm msg other = pprPanic ("get_nm:"++msg) (ppr PprShowAll other)
--- If match failure, probably on a ClassOpName or Unbound :-(
+nameOrigName msg (Local  _ n _ _)     = panic ("nameOrigName:Local:"++msg++":"++ _UNPK_ n)
 #endif
+
+nameOccName (Local  _ n _ _)	     = Unqual n
+nameOccName (Global _ m (Left  n) _ _ []  )  = Qual m n
+nameOccName (Global _ m (Right n) _ _ []  )  =  let str = _CONCAT_ (glue n) in
+						--pprTrace "nameOccName:" (ppPStr str) $
+						Qual m str
+nameOccName (Global _ m (Left  _) _ _ (o:_)) = o
+nameOccName (Global _ m (Right _) _ _ (o:_)) = panic "nameOccName:compound name"
+
+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 _ _ _ Primitive          _ _) = mkBuiltinSrcLoc
+nameSrcLoc (Global _ _ _ (WiredIn _)        _ _) = 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 _ _ _ Primitive          _ _) = ExportAll
+nameImportFlag (Global _ _ _ (WiredIn _)        _ _) = ExportAll
+
+isLocallyDefinedName (Local  _ _ _ _)	            	    = True
+isLocallyDefinedName (Global _ _ _ (LocalDef _)        _ _) = True
+isLocallyDefinedName (Global _ _ _ (Imported _ _ _)    _ _) = False
+isLocallyDefinedName (Global _ _ _ Implicit            _ _) = False
+isLocallyDefinedName (Global _ _ _ Primitive           _ _) = False
+isLocallyDefinedName (Global _ _ _ (WiredIn from_here) _ _) = from_here
+
+isWiredInName (Global _ _ _ (WiredIn _) _ _) = True
+isWiredInName _				     = False
 \end{code}
 
 \begin{code}
 instance Outputable Name where
-#ifdef DEBUG
-    ppr PprDebug (Short u s)	    = pp_debug u s
+    ppr sty (Local u n emph_uniq _)
+      | codeStyle sty = pprUnique u
+      | emph_uniq     = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"]
+      | otherwise     = ppBesides [ppPStr n, ppStr "{-", pprUnique u, ppStr "-}"]
 
-    ppr PprDebug (TyConName u n _ _ _) = pp_debug u n
-    ppr PprDebug (ClassName u n _)     = pp_debug u n
-    ppr PprDebug (ValName u n)         = pp_debug u n
-#endif
-    ppr sty (Short u s)		  = ppr sty s
-
-    ppr sty (WiredInTyCon tc)	  = ppr sty tc
-    ppr sty (WiredInVal   id)	  = ppr sty id
-
-    ppr sty (TyConName u n a b c) = ppr sty n
-    ppr sty (ClassName u n c)	  = ppr sty n
-    ppr sty (ValName   u n)	  = ppr sty n
-
-    ppr sty (ClassOpName u c s i)
-      = let
-	    ps = ppPStr s
-	in
-	case sty of
-	  PprForUser   -> ps
-	  PprInterface -> ps
-	  PprDebug     -> ps
-	  other	       -> ppBesides [ps, ppChar '{',
-				       ppSep [pprUnique u,
-					      ppStr "op", ppInt i,
-					      ppStr "cls", ppr sty c],
-				       ppChar '}']
-
-    ppr sty (Unbound s) = ppStr ("*UNBOUND*"++ _UNPK_ s)
-
-pp_debug uniq thing
-  = ppBesides [ppr PprDebug thing, ppStr "{-", pprUnique uniq, ppStr "-}" ]
+    ppr PprDebug   (Global   u m (Left  n) _ _ _) = ppBesides [pp_mod PprDebug m, pp_name  PprDebug n, ppStr "{-", pprUnique u, ppStr "-}"]
+    ppr PprDebug   (Global   u m (Right n) _ _ _) = ppBesides [pp_mod PprDebug m, pp_name2 PprDebug n, ppStr "{-", pprUnique u, ppStr "-}"]
+
+    ppr PprForUser (Global   u m (Left  n) _ _ []  ) = ppBeside (pp_mod PprForUser m) (pp_name  PprForUser n)
+    ppr PprForUser (Global   u m (Right n) _ _ []  ) = ppBeside (pp_mod PprForUser m) (pp_name2 PprForUser n)
+    ppr PprForUser (Global   u m (Left  _) _ _ occs) = ppr PprForUser (head occs)
+
+-- LATER:?
+--  ppr PprShowAll (Global   u m n prov exp occs) = pp_all (Qual m n) prov exp occs
+
+    ppr sty (Global u m (Left  n) _ _ _) = ppBeside (pp_mod sty m) (pp_name  sty n)
+    ppr sty (Global u m (Right n) _ _ _) = ppBeside (pp_mod sty m) (pp_name2 sty n)
+
+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 Primitive   = ppPStr SLIT("/PRIMITIVE")
+pp_prov (WiredIn _) = ppPStr SLIT("/WIREDIN")
+pp_prov _           = ppNil
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
+%*									*
+%************************************************************************
+
+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
+
+-- Be very wary about using "isExported"; perhaps you
+-- really mean "externallyVisibleId"?
+
+isExported a = exportFlagOn (getExportFlag a)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Overloaded functions related to Names}
+%*									*
+%************************************************************************
+
+\begin{code}
+class NamedThing a where
+    getName :: a -> Name
+\end{code}
+
+\begin{code}
+origName	    :: NamedThing a => String -> a -> OrigName
+moduleOf	    :: OrigName -> Module
+nameOf		    :: OrigName -> FAST_STRING
+
+getOccName	    :: NamedThing a => a -> RdrName
+getLocalName	    :: NamedThing a => a -> FAST_STRING
+getExportFlag	    :: NamedThing a => a -> ExportFlag
+getSrcLoc	    :: NamedThing a => a -> SrcLoc
+getImpLocs	    :: NamedThing a => a -> [SrcLoc]
+isLocallyDefined    :: NamedThing a => a -> Bool
+
+origName str n	    = nameOrigName str (getName n)
+
+moduleOf (OrigName m n) = m
+nameOf   (OrigName m n) = n
+
+getLocalName n
+  = case (getName n) of
+      Local  _ n _ _	         -> n
+      Global _ m (Left  n) _ _ _ -> n
+      Global _ m (Right n) _ _ _ -> let str = _CONCAT_ (glue n) in
+				    -- pprTrace "getLocalName:" (ppPStr str) $
+				    str
+
+getOccName	    = nameOccName  	   . getName
+getExportFlag	    = nameExportFlag	   . getName
+getSrcLoc	    = nameSrcLoc	   . getName
+getImpLocs	    = nameImpLocs	   . getName
+isLocallyDefined    = isLocallyDefinedName . getName
+\end{code}
+
+\begin{code}
+{-# SPECIALIZE getLocalName
+	:: Name     -> FAST_STRING
+	 , OrigName -> FAST_STRING
+	 , RdrName  -> FAST_STRING
+	 , RnName   -> FAST_STRING
+  #-}
+{-# SPECIALIZE isLocallyDefined
+	:: Name	    -> Bool
+	 , RnName   -> Bool
+  #-}
+{-# SPECIALIZE origName
+	:: String -> Name     -> OrigName
+	 , String -> RdrName  -> OrigName
+	 , String -> RnName   -> OrigName
+  #-}
+\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
+  | otherwise	= isUpper c || isUpperISO c
+  where					
+    c = _HEAD_ cs
+
+isLexVarId cs
+  | _NULL_ cs	 = False
+  | 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
+\end{code}
+
+And one ``higher-level'' interface to those:
+
+\begin{code}
+isSymLexeme :: NamedThing a => a -> Bool
+
+isSymLexeme v
+  = let str = getLocalName v in isLexSym str
+
+-- print `vars`, (op) correctly
+pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
+
+pprSym sty var
+  = let
+	str = getLocalName 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
 \end{code}