X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=7815d7d0ba5fe4b47ff07d4518439b1fc63c83c4;hb=4250d64191132fd493985549eda5ca05b82a663f;hp=8018ad2c992ce525cd3075d518c133de7f83142f;hpb=b4255f2c320f852d7dfb0afc0bc9f64765aece0c;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 8018ad2..7815d7d 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -103,16 +103,15 @@ import IdInfo
 import Maybes		( maybeToBool )
 import Name		( appendRdr, nameUnique, mkLocalName, isLocalName,
 			  isLocallyDefinedName, isPreludeDefinedName,
-			  nameOrigName, mkTupleDataConName,
-			  isAvarop, isAconop, getLocalName,
+			  mkTupleDataConName, mkCompoundName,
+			  isLexSym, getLocalName,
 			  isLocallyDefined, isPreludeDefined,
-			  getOrigName, getOccName,
+			  getOccName, moduleNamePair, origName, nameOf, 
 			  isExported, ExportFlag(..),
 			  RdrName(..), Name
 			)
 import FieldLabel	( fieldLabelName, FieldLabel{-instances-} )
 import PragmaInfo	( PragmaInfo(..) )
-import PrelMods		( pRELUDE_BUILTIN )
 import PprType		( getTypeString, typeMaybeString, specMaybeTysSuffix,
 			  GenType, GenTyVar
 			)
@@ -654,10 +653,10 @@ pprIdInUnfolding in_scopes v
 
     pp_full_name
       = let
-	    (m_str, n_str) = getOrigName v
+	    (m_str, n_str) = moduleNamePair v
 
 	    pp_n =
-	      if isAvarop n_str || isAconop n_str then
+	      if isLexSym n_str then
 		  ppBesides [ppLparen, ppPStr n_str, ppRparen]
 	      else
 		  ppPStr n_str
@@ -1009,20 +1008,24 @@ getIdNamePieces show_uniqs id
   get (Id u _ details _ _)
     = case details of
       DataConId n _ _ _ _ _ _ _ ->
-	case (nameOrigName n) of { (mod, name) ->
+	case (moduleNamePair n) of { (mod, name) ->
 	if isPreludeDefinedName n then [name] else [mod, name] }
 
-      TupleConId n _ -> [snd (nameOrigName n)]
+      TupleConId n _ -> [nameOf (origName n)]
 
-      RecordSelId lbl -> panic "getIdNamePieces:RecordSelId"
+      RecordSelId lbl ->
+	let n = fieldLabelName lbl
+        in
+	case (moduleNamePair n) of { (mod, name) ->
+	if isPreludeDefinedName n then [name] else [mod, name] }
 
       ImportedId n -> get_fullname_pieces n
       PreludeId  n -> get_fullname_pieces n
       TopLevId   n -> get_fullname_pieces n
 
       SuperDictSelId c sc ->
-	case (getOrigName c)	of { (c_mod, c_name) ->
-	case (getOrigName sc)	of { (sc_mod, sc_name) ->
+	case (moduleNamePair c)	of { (c_mod, c_name) ->
+	case (moduleNamePair sc)	of { (sc_mod, sc_name) ->
 	let
 	    c_bits = if isPreludeDefined c
 		     then [c_name]
@@ -1035,7 +1038,7 @@ getIdNamePieces show_uniqs id
 	[SLIT("sdsel")] ++ c_bits ++ sc_bits  }}
 
       MethodSelId clas op ->
-	case (getOrigName clas)	of { (c_mod, c_name) ->
+	case (moduleNamePair clas)	of { (c_mod, c_name) ->
 	case (getClassOpString op)	of { op_name ->
 	if isPreludeDefined clas
 	then [op_name]
@@ -1043,14 +1046,14 @@ getIdNamePieces show_uniqs id
 	} }
 
       DefaultMethodId clas op _ ->
-	case (getOrigName clas)		of { (c_mod, c_name) ->
+	case (moduleNamePair clas)		of { (c_mod, c_name) ->
 	case (getClassOpString op)	of { op_name ->
 	if isPreludeDefined clas
 	then [SLIT("defm"), op_name]
 	else [SLIT("defm"), c_mod, c_name, op_name] }}
 
       DictFunId c ty _ _ ->
-	case (getOrigName c)	    of { (c_mod, c_name) ->
+	case (moduleNamePair c)	    of { (c_mod, c_name) ->
 	let
 	    c_bits = if isPreludeDefined c
 		     then [c_name]
@@ -1061,7 +1064,7 @@ getIdNamePieces show_uniqs id
 	[SLIT("dfun")] ++ c_bits ++ ty_bits }
 
       ConstMethodId c ty o _ _ ->
-	case (getOrigName c)	    of { (c_mod, c_name) ->
+	case (moduleNamePair c)	    of { (c_mod, c_name) ->
 	case (getTypeString ty)	    of { ty_bits ->
 	case (getClassOpString o)   of { o_name ->
 	case (if isPreludeDefined c
@@ -1091,7 +1094,7 @@ getIdNamePieces show_uniqs id
 
 get_fullname_pieces :: Name -> [FAST_STRING]
 get_fullname_pieces n
-  = BIND (nameOrigName n) _TO_ (mod, name) ->
+  = BIND (moduleNamePair n) _TO_ (mod, name) ->
     if isPreludeDefinedName n
     then [name]
     else [mod, name]
@@ -1800,24 +1803,24 @@ instance NamedThing (GenId ty) where
     getName this_id@(Id u _ details _ _)
       = get details
       where
-	get (LocalId      n _)  = n
-	get (SysLocalId   n _)  = n
-	get (SpecPragmaId n _ _)= n
-	get (ImportedId   n)	= n
-	get (PreludeId    n)	= n
-	get (TopLevId     n)	= n
-	get (InstId       n _)  = n
+	get (LocalId      n _)  	= n
+	get (SysLocalId   n _)  	= n
+	get (SpecPragmaId n _ _)	= n
+	get (ImportedId   n)		= n
+	get (PreludeId    n)		= n
+	get (TopLevId     n)		= n
+	get (InstId       n _)  	= n
 	get (DataConId n _ _ _ _ _ _ _) = n
-	get (TupleConId n _)	= n
-	get (RecordSelId l)	= getName l
---	get _ = pprPanic "Id.Id.NamedThing.getName:" (pprId PprDebug this_id)
+	get (TupleConId n _)		= n
+	get (RecordSelId l)		= getName l
+	get _				= mkCompoundName u (getIdNamePieces False{-no Uniques-} this_id)
 
 {- LATER:
-	get (MethodSelId c op)	= case (getOrigName c) of -- ToDo; better ???
-				    (mod, _) -> (mod, getClassOpString op)
+	get (MethodSelId c op)	= case (moduleOf (origName c)) of -- ToDo; better ???
+				    mod -> (mod, getClassOpString op)
 
 	get (SpecId unspec ty_maybes _)
-	  = BIND getOrigName unspec	      _TO_ (mod, unspec_nm) ->
+	  = BIND moduleNamePair unspec	      _TO_ (mod, unspec_nm) ->
 	    BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
 	    (mod,
 	     unspec_nm _APPEND_
@@ -1828,7 +1831,7 @@ instance NamedThing (GenId ty) where
 	    BEND BEND
 
 	get (WorkerId unwrkr)
-	  = BIND getOrigName unwrkr	_TO_ (mod, unwrkr_nm) ->
+	  = BIND moduleNamePair unwrkr	_TO_ (mod, unwrkr_nm) ->
 	    (mod,
 	     unwrkr_nm _APPEND_
 		(if not (toplevelishId unwrkr)