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

diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index 303fd04..3fdedfb 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -7,12 +7,17 @@
 #include "HsVersions.h"
 
 module Name (
-	Module(..),
+	SYN_IE(Module),
+
+	OrigName(..), -- glorified pair
+	qualToOrigName, -- a Qual to an OrigName
 
 	RdrName(..),
+	preludeQual,
+	moduleNamePair,
 	isUnqual,
 	isQual,
-	isRdrLexCon,
+	isRdrLexCon, isRdrLexConOrSpecial,
 	appendRdr,
 	showRdr,
 	cmpRdr,
@@ -20,9 +25,10 @@ module Name (
 	Name,
 	Provenance,
 	mkLocalName, isLocalName, 
-	mkTopLevName, mkImportedName,
+	mkTopLevName, mkImportedName, oddlyImportedName,
 	mkImplicitName,	isImplicitName,
-	mkBuiltinName, mkCompoundName,
+	mkPrimitiveName, mkWiredInName,
+	mkCompoundName, mkCompoundName2,
 
 	mkFunTyConName, mkTupleDataConName, mkTupleTyConName,
 	mkTupNameStr,
@@ -31,39 +37,44 @@ module Name (
 	ExportFlag(..),
 	isExported{-overloaded-}, exportFlagOn{-not-},
 
-	nameUnique,
+	nameUnique, changeUnique,
 	nameOccName,
-	nameOrigName,
+--	nameOrigName, : not exported
 	nameExportFlag,
 	nameSrcLoc,
 	nameImpLocs,
 	nameImportFlag,
-	isLocallyDefinedName,
-	isPreludeDefinedName,
+	isLocallyDefinedName, isWiredInName,
 
-	origName, moduleOf, nameOf, moduleNamePair,
+	origName, moduleOf, nameOf,
 	getOccName, getExportFlag,
 	getSrcLoc, getImpLocs,
-	isLocallyDefined, isPreludeDefined,
-	getLocalName, ltLexical,
+	isLocallyDefined,
+	getLocalName,
 
 	isSymLexeme, pprSym, pprNonSym,
-	isLexCon, isLexVar, isLexId, isLexSym,
+	isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym,
 	isLexConId, isLexConSym, isLexVarId, isLexVarSym
     ) where
 
-import Ubiq
+IMP_Ubiq()
+IMPORT_1_3(Char(isUpper,isLower))
 
-import CStrings		( identToC, cSEP )
+import CmdLineOpts	( maybe_CompilingGhcInternals )
+import CStrings		( identToC, modnameToC, cSEP )
 import Outputable	( Outputable(..) )
 import PprStyle		( PprStyle(..), codeStyle )
-import PrelMods		( pRELUDE, pRELUDE_BUILTIN, fromPrelude )
+import PrelMods		( pRELUDE )
 import Pretty
-import SrcLoc		( mkBuiltinSrcLoc, mkUnknownSrcLoc )
+import SrcLoc		( mkBuiltinSrcLoc, mkUnknownSrcLoc, SrcLoc )
 import Unique		( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique,
 			  pprUnique, Unique
 			)
-import Util		( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic )
+import Util		( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic{-, pprTrace ToDo:rm-} )
+
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+#endif
 \end{code}
 
 %************************************************************************
@@ -75,10 +86,20 @@ import Util		( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic )
 \begin{code}
 type Module = FAST_STRING
 
+data OrigName = OrigName Module FAST_STRING
+
+qualToOrigName (Qual m n) = OrigName m n
+
 data RdrName
   = Unqual FAST_STRING
   | Qual   Module FAST_STRING
 
+preludeQual n = Qual pRELUDE n
+
+moduleNamePair (Qual m n) = (m, n)  -- we make *no* claim whether this
+				    -- constitutes an original name or
+				    -- an occurrence name, or anything else
+
 isUnqual (Unqual _) = True
 isUnqual (Qual _ _) = False
 
@@ -88,14 +109,20 @@ 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 = ASSERT(not (fromPrelude m))
-			   Qual m (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*
 
-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) 
+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 }
@@ -112,8 +139,14 @@ instance Ord3 RdrName where
 
 instance NamedThing RdrName where
     -- We're sorta faking it here
-    getName rdr_name
-      = Global u rdr_name prov ex [rdr_name]
+    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"
@@ -123,16 +156,46 @@ 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 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 '.']
+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
+
+pp_name2 sty pieces
+  = ppIntersperse sep (map pp_piece pieces)
+  where
+    sep = if codeStyle sty then ppPStr cSEP else ppChar '.'
 
-pp_name sty n | codeStyle sty = identToC n
-              | otherwise     = ppPStr n	      
+    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}
 
 %************************************************************************
@@ -145,76 +208,126 @@ showRdr sty rdr = ppShow 100 (ppr sty rdr)
 data Name
   = Local    Unique
              FAST_STRING
+	     Bool	-- True <=> emphasize Unique when
+			-- printing; this is just an esthetic thing...
              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.
+             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)
+  = 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
-  | Builtin
+  | 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}
 mkLocalName = Local
 
-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
+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
 
-mkImplicitName :: Unique -> RdrName -> Name
-mkImplicitName u o = Global u o Implicit NotExported []
+mkImplicitName :: Unique -> OrigName -> Name
+mkImplicitName u (OrigName m n) = Global u m (Left n) Implicit NotExported []
 
-mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name
-mkBuiltinName u m n = Global u (Unqual n) Builtin NotExported []
+mkPrimitiveName :: Unique -> OrigName -> Name
+mkPrimitiveName u (OrigName m n)  = Global u m (Left n) Primitive NotExported []
 
-mkCompoundName :: Unique -> [FAST_STRING] -> Name
-mkCompoundName u ns
-  = Global u (Unqual{-???-} (_CONCAT_ (dotify ns))) Builtin{--} NotExported []
+mkWiredInName :: Unique -> OrigName -> ExportFlag -> Name
+mkWiredInName u (OrigName m n) exp
+  = Global u m (Left n) (WiredIn from_here) exp []
   where
-    dotify []  = []
-    dotify [n] = [n]
-    dotify (n:ns) = n : (map (_CONS_ '.') ns)
+    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
-  = mkBuiltinName funTyConKey		       pRELUDE_BUILTIN SLIT("->")
+  = mkPrimitiveName funTyConKey		       (OrigName pRELUDE SLIT("->"))
 mkTupleDataConName arity
-  = mkBuiltinName (mkTupleDataConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity)
+  = mkWiredInName (mkTupleDataConUnique arity) (OrigName pRELUDE (mkTupNameStr arity)) ExportAll
 mkTupleTyConName   arity
-  = mkBuiltinName (mkTupleTyConUnique   arity) pRELUDE_BUILTIN (mkTupNameStr arity)
+  = mkWiredInName (mkTupleTyConUnique   arity) (OrigName pRELUDE (mkTupNameStr arity)) ExportAll
 
 mkTupNameStr 0 = SLIT("()")
 mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
-mkTupNameStr 2 = SLIT("(,)")   -- not strictly necessary
-mkTupNameStr 3 = SLIT("(,,)")  -- ditto
-mkTupNameStr 4 = SLIT("(,,,)") -- ditto
+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
+isLocalName (Local _ _ _ _) = True
+isLocalName _ 		    = False
 
-isImplicitName (Global _ _ Implicit _ _) = True
-isImplicitName _ 		         = 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
 
-isBuiltinName  (Global _ _ Builtin  _ _) = True
-isBuiltinName  _ 		         = False
+isImplicitName (Global _ _ _ Implicit _ _) = True
+isImplicitName _ 		           = False
 \end{code}
 
-
-
 %************************************************************************
 %*									*
 \subsection[Name-instances]{Instance declarations}
@@ -224,17 +337,10 @@ 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 _ _ _)     = cmp u1 u2
+    c (Local   _ _ _ _)	    _			  = LT_
+    c (Global u1 _ _ _ _ _) (Global u2 _ _ _ _ _) = cmp u1 u2
+    c (Global  _ _ _ _ _ _) _			  = GT_
 \end{code}
 
 \begin{code}
@@ -259,62 +365,81 @@ instance NamedThing Name where
 \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
+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
+nameOrigName msg (Local  _ n _ _)     = panic ("nameOrigName:Local:"++msg++":"++ _UNPK_ n)
+#endif
 
-nameSrcLoc (Local  _ _ loc)	               = loc
-nameSrcLoc (Global _ _ (LocalDef loc)     _ _) = loc
-nameSrcLoc (Global _ _ (Imported _ loc _) _ _) = loc
-nameSrcLoc (Global _ _ Implicit           _ _) = mkUnknownSrcLoc
-nameSrcLoc (Global _ _ Builtin            _ _) = mkBuiltinSrcLoc
+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 _ _ 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
+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 (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
+    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   (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
 
-pp_debug uniq thing
-  = ppBesides [thing, ppStr "{-", pprUnique uniq, ppStr "-}" ]
+    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]
@@ -323,9 +448,10 @@ 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
+pp_prov Implicit    = ppPStr SLIT("/IMPLICIT")
+pp_prov Primitive   = ppPStr SLIT("/PRIMITIVE")
+pp_prov (WiredIn _) = ppPStr SLIT("/WIREDIN")
+pp_prov _           = ppNil
 \end{code}
 
 %************************************************************************
@@ -350,13 +476,10 @@ data ExportFlag
 exportFlagOn NotExported = False
 exportFlagOn _		 = True
 
-isExported a = exportFlagOn (getExportFlag a)
+-- Be very wary about using "isExported"; perhaps you
+-- really mean "externallyVisibleId"?
 
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isExported :: Class -> Bool #-}
-{-# SPECIALIZE isExported :: Id -> Bool #-}
-{-# SPECIALIZE isExported :: TyCon -> Bool #-}
-#endif
+isExported a = exportFlagOn (getExportFlag a)
 \end{code}
 
 %************************************************************************
@@ -371,10 +494,9 @@ class NamedThing a where
 \end{code}
 
 \begin{code}
-origName	    :: NamedThing a => a -> RdrName
-moduleOf	    :: RdrName -> Module
-nameOf		    :: RdrName -> FAST_STRING
-moduleNamePair	    :: NamedThing a => a -> (Module, FAST_STRING)
+origName	    :: NamedThing a => String -> a -> OrigName
+moduleOf	    :: OrigName -> Module
+nameOf		    :: OrigName -> FAST_STRING
 
 getOccName	    :: NamedThing a => a -> RdrName
 getLocalName	    :: NamedThing a => a -> FAST_STRING
@@ -382,40 +504,43 @@ getExportFlag	    :: NamedThing a => a -> ExportFlag
 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
 
-moduleOf (Unqual n) = pRELUDE
-moduleOf (Qual m n) = m
+origName str n	    = nameOrigName str (getName n)
 
-nameOf (Unqual n)   = n
-nameOf (Qual m n)   = n
+moduleOf (OrigName m n) = m
+nameOf   (OrigName m n) = n
 
-getLocalName	    = nameOf . origName
+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
-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
+{-# 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
@@ -423,7 +548,8 @@ defined in the Haskell report.  Normally applied as in e.g. @isCon
 (getLocalName foo)@.
 
 \begin{code}
-isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool
+isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
+ isLexVarId, isLexVarSym, isLexSpecialSym :: FAST_STRING -> Bool
 
 isLexCon cs = isLexConId  cs || isLexConSym cs
 isLexVar cs = isLexVarId  cs || isLexVarSym cs
@@ -435,24 +561,22 @@ 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 == '('	-- (), (,), (,,), ...
+  | otherwise	= c  == ':'
+--	       || c  == '('	-- (), (,), (,,), ...
 	       || cs == SLIT("->")
-	       || cs == SLIT("[]")
+--	       || cs == SLIT("[]")
   where
     c = _HEAD_ cs
 
@@ -460,7 +584,14 @@ isLexVarSym cs
   | _NULL_ cs = False
   | otherwise = isSymbolASCII c
 	     || isSymbolISO c
-	     || c == '('	-- (), (,), (,,), ...
+--	     || c  == '('	-- (), (,), (,,), ...
+--	     || cs == SLIT("[]")
+  where
+    c = _HEAD_ cs
+
+isLexSpecialSym cs
+  | _NULL_ cs = False
+  | otherwise = c  == '('	-- (), (,), (,,), ...
 	     || cs == SLIT("[]")
   where
     c = _HEAD_ cs
@@ -478,25 +609,21 @@ And one ``higher-level'' interface to those:
 isSymLexeme :: NamedThing a => a -> Bool
 
 isSymLexeme v
-  = let str = nameOf (origName v) in isLexSym str
+  = let str = getLocalName v in isLexSym str
 
 -- print `vars`, (op) correctly
 pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
 
 pprSym sty var
-  = if isSymLexeme 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 ppBesides [ppLparen, ppr sty var, ppRparen]
+    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
 \end{code}