showId,
pprIdInUnfolding,
+ nmbrId,
+
-- "Environments" keyed off of Ids, and sets of Ids
IdEnv(..),
lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
import TyLoop -- for paranoia checking
import Bag
-import Class ( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
+import Class ( classOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
import CStrings ( identToC, cSEP )
import IdInfo
import Maybes ( maybeToBool )
import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
isLocallyDefinedName, isPreludeDefinedName,
- nameOrigName,
- isAvarop, isAconop, getLocalName,
+ mkTupleDataConName, mkCompoundName,
+ isLexSym, isLexSpecialSym, getLocalName,
isLocallyDefined, isPreludeDefined,
- getOrigName, getOccName,
+ getOccName, moduleNamePair, origName, nameOf,
isExported, ExportFlag(..),
RdrName(..), Name
)
-import FieldLabel ( fieldLabelName, FieldLabel{-instances-} )
+import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} )
import PragmaInfo ( PragmaInfo(..) )
-import PrelMods ( pRELUDE_BUILTIN )
+import PprEnv -- ( NmbrM(..), NmbrEnv(..) )
import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
+ nmbrType, nmbrTyVar,
GenType, GenTyVar
)
import PprStyle
import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
import UniqFM
import UniqSet -- practically all of it
-import UniqSupply ( getBuiltinUniques )
-import Unique ( mkTupleDataConUnique, pprUnique, showUnique,
+import Unique ( getBuiltinUniques, pprUnique, showUnique,
+ incrUnique,
Unique{-instance Ord3-}
)
import Util ( mapAccumL, nOfThem, zipEqual,
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 && not (isLexSpecialSym n_str) then
ppBesides [ppLparen, ppPStr n_str, ppRparen]
else
ppPStr n_str
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]
[SLIT("sdsel")] ++ c_bits ++ sc_bits }}
MethodSelId clas op ->
- case (getOrigName clas) of { (c_mod, c_name) ->
- case (getClassOpString op) of { op_name ->
+ case (moduleNamePair clas) of { (c_mod, c_name) ->
+ case (classOpString op) of { op_name ->
if isPreludeDefined clas
then [op_name]
else [c_mod, c_name, op_name]
} }
DefaultMethodId clas op _ ->
- case (getOrigName clas) of { (c_mod, c_name) ->
- case (getClassOpString op) of { op_name ->
+ case (moduleNamePair clas) of { (c_mod, c_name) ->
+ case (classOpString 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]
[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 (classOpString o) of { o_name ->
case (if isPreludeDefined c
then [c_name]
else [c_mod, c_name]) of { c_bits ->
get_fullname_pieces :: Name -> [FAST_STRING]
get_fullname_pieces n
- = BIND (nameOrigName n) _TO_ (mod, name) ->
+ = case (moduleNamePair n) of { (mod, name) ->
if isPreludeDefinedName n
then [name]
- else [mod, name]
- BEND
+ else [mod, name] }
\end{code}
%************************************************************************
\begin{code}
mkSuperDictSelId u c sc ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info
-mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
+mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
mkDictFunId u c ity full_ty from_here mod info
(tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
tyvar_tys = mkTyVarTys tyvars
in
- BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
+ case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
mkUnfolding EssentialUnfolding -- for data constructors
(mkLam tyvars (dict_vars ++ vars) plain_Con)
- BEND
+ }
mk_uf_bits tvs ctxt arg_tys tycon
= let
-- the "context" and "arg_tys" have TyVarTemplates in them, so
-- we instantiate those types to have the right TyVars in them
-- instead.
- BIND (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
- _TO_ inst_dict_tys ->
- BIND (map (instantiateTauTy inst_env) arg_tys) _TO_ inst_arg_tys ->
+ case (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
+ of { inst_dict_tys ->
+ case (map (instantiateTauTy inst_env) arg_tys) of { inst_arg_tys ->
-- We can only have **ONE** call to mkTemplateLocals here;
-- otherwise, we get two blobs of locals w/ mixed-up Uniques
-- (Mega-Sigh) [ToDo]
- BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars ->
+ case (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) of { all_vars ->
- BIND (splitAt (length ctxt) all_vars) _TO_ (dict_vars, vars) ->
+ case (splitAt (length ctxt) all_vars) of { (dict_vars, vars) ->
(tyvars, dict_vars, vars)
- BEND BEND BEND BEND
+ }}}}
where
-- these are really dubious Types, but they are only to make the
-- binders for the lambdas for tossed-away dicts.
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
(tyvars, dict_vars, vars) = mk_uf_bits arity
tyvar_tys = mkTyVarTys tyvars
in
- BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
-
+ case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
mkUnfolding
EssentialUnfolding -- data constructors
- (mkLam tyvars (dict_vars ++ vars) plain_Con)
- BEND
+ (mkLam tyvars (dict_vars ++ vars) plain_Con) }
mk_uf_bits arity
- = BIND (mkTemplateLocals tyvar_tys) _TO_ vars ->
- (tyvars, [], vars)
- BEND
+ = case (mkTemplateLocals tyvar_tys) of { vars ->
+ (tyvars, [], vars) }
where
tyvar_tmpls = take arity alphaTyVars
(_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
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, classOpString op)
get (SpecId unspec ty_maybes _)
- = BIND getOrigName unspec _TO_ (mod, unspec_nm) ->
- BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
+ = case moduleNamePair unspec of { (mod, unspec_nm) ->
+ case specMaybeTysSuffix ty_maybes of { tys_suffix ->
(mod,
unspec_nm _APPEND_
(if not (toplevelishId unspec)
then showUnique u
else tys_suffix)
- )
- BEND BEND
+ ) }}
get (WorkerId unwrkr)
- = BIND getOrigName unwrkr _TO_ (mod, unwrkr_nm) ->
+ = case moduleNamePair unwrkr of { (mod, unwrkr_nm) ->
(mod,
unwrkr_nm _APPEND_
(if not (toplevelishId unwrkr)
then showUnique u
else SLIT(".wrk"))
- )
- BEND
+ ) }
get other_details
-- the remaining internally-generated flavours of
-- Ids really do not have meaningful "original name" stuff,
-- but we need to make up something (usually for debugging output)
- = BIND (getIdNamePieces True this_id) _TO_ (piece1:pieces) ->
- BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces ->
- (_NIL_, _CONCAT_ (piece1 : dotted_pieces))
- BEND BEND
+ = case (getIdNamePieces True this_id) of { (piece1:pieces) ->
+ case [ _CONS_ '.' p | p <- pieces ] of { dotted_pieces ->
+ (_NIL_, _CONCAT_ (piece1 : dotted_pieces)) }}
-}
\end{code}
isEmptyIdSet = isEmptyUniqSet
mkIdSet = mkUniqSet
\end{code}
+
+\begin{code}
+addId, nmbrId :: Id -> NmbrM Id
+
+addId id@(Id u ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
+ = case (lookupUFM_Directly idenv u) of
+ Just xx -> _trace "addId: already in map!" $
+ (nenv, xx)
+ Nothing ->
+ if toplevelishId id then
+ _trace "addId: can't add toplevelish!" $
+ (nenv, id)
+ else -- alloc a new unique for this guy
+ -- and add an entry in the idenv
+ -- NB: *** KNOT-TYING ***
+ let
+ nenv_plus_id = NmbrEnv (incrUnique ui) ut uu
+ (addToUFM_Directly idenv u new_id)
+ tvenv uvenv
+
+ (nenv2, new_ty) = nmbrType ty nenv_plus_id
+ (nenv3, new_det) = nmbr_details det nenv2
+
+ new_id = Id ui new_ty new_det prag info
+ in
+ (nenv3, new_id)
+
+nmbrId id@(Id u ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
+ = case (lookupUFM_Directly idenv u) of
+ Just xx -> (nenv, xx)
+ Nothing ->
+ if not (toplevelishId id) then
+ _trace "nmbrId: lookup failed" $
+ (nenv, id)
+ else
+ let
+ (nenv2, new_ty) = nmbrType ty nenv
+ (nenv3, new_det) = nmbr_details det nenv2
+
+ new_id = Id u new_ty new_det prag info
+ in
+ (nenv3, new_id)
+
+------------
+nmbr_details :: IdDetails -> NmbrM IdDetails
+
+nmbr_details (DataConId n tag marks fields tvs theta arg_tys tc)
+ = mapNmbr nmbrTyVar tvs `thenNmbr` \ new_tvs ->
+ mapNmbr nmbrField fields `thenNmbr` \ new_fields ->
+ mapNmbr nmbr_theta theta `thenNmbr` \ new_theta ->
+ mapNmbr nmbrType arg_tys `thenNmbr` \ new_arg_tys ->
+ returnNmbr (DataConId n tag marks new_fields new_tvs new_theta new_arg_tys tc)
+ where
+ nmbr_theta (c,t)
+ = --nmbrClass c `thenNmbr` \ new_c ->
+ nmbrType t `thenNmbr` \ new_t ->
+ returnNmbr (c, new_t)
+
+ -- ToDo:add more cases as needed
+nmbr_details other_details = returnNmbr other_details
+
+------------
+nmbrField (FieldLabel n ty tag)
+ = nmbrType ty `thenNmbr` \ new_ty ->
+ returnNmbr (FieldLabel n new_ty tag)
+\end{code}
projects / ghc-hetmet.git / blobdiff