X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=b48d5e2d60f1a06adcf2cdbde053bc0b3151490c;hb=2f51f1402e6869c0f049ffbe7b019bf6ab80558f;hp=adbd61f788cba4f3d5eebd4bc8e5570d06a5070c;hpb=7b0181919416d8f04324575b7e17031ca692f5b0;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index adbd61f..b48d5e2 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, - 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 ) @@ -129,7 +128,7 @@ import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) ) import UniqFM import UniqSet -- practically all of it import UniqSupply ( getBuiltinUniques ) -import Unique ( mkTupleDataConUnique, pprUnique, showUnique, +import Unique ( pprUnique, showUnique, Unique{-instance Ord3-} ) import Util ( mapAccumL, nOfThem, zipEqual, @@ -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,10 +1008,10 @@ 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" @@ -1021,8 +1020,8 @@ getIdNamePieces show_uniqs id 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 +1034,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 +1042,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 +1060,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 +1090,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] @@ -1409,8 +1408,8 @@ mkTupleCon :: Arity -> Id mkTupleCon arity = Id unique ty (TupleConId n arity) NoPragmaInfo tuplecon_info where - n = panic "mkTupleCon: its Name (Id)" - unique = mkTupleDataConUnique arity + n = mkTupleDataConName arity + unique = uniqueOf n ty = mkSigmaTy tyvars [] (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys)) tycon = mkTupleTyCon arity @@ -1800,24 +1799,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 +1827,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)