\begin{code}
#include "HsVersions.h"
-module Id {- (
- GenId, Id(..), -- Abstract
- StrictnessMark(..), -- An enumaration
- ConTag(..), DictVar(..), DictFun(..), DataCon(..),
+module Id (
+ -- TYPES
+ GenId(..), -- *naughtily* used in some places (e.g., TcHsSyn)
+ SYN_IE(Id), IdDetails,
+ StrictnessMark(..),
+ SYN_IE(ConTag), fIRST_TAG,
+ SYN_IE(DataCon), SYN_IE(DictFun), SYN_IE(DictVar),
-- CONSTRUCTION
- mkSysLocal, mkUserLocal,
- mkSpecPragmaId,
- mkSpecId, mkSameSpecCon,
- selectIdInfoForSpecId,
- mkTemplateLocals,
- mkImported, mkPreludeId,
- mkDataCon, mkTupleCon,
+ mkConstMethodId,
+ mkDataCon,
+ mkDefaultMethodId,
+ mkDictFunId,
mkIdWithNewUniq,
- mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId,
- mkConstMethodId, getConstMethodId,
-
- updateIdType,
- mkId, mkDictFunId, mkInstId,
+ mkImported,
+ mkInstId,
+ mkMethodSelId,
+ mkRecordSelId,
+ mkSuperDictSelId,
+ mkSysLocal,
+ mkTemplateLocals,
+ mkTupleCon,
+ mkUserId,
+ mkUserLocal,
mkWorkerId,
- localiseId,
- -- DESTRUCTION
+ -- MANGLING
+ unsafeGenId2Id,
+
+ -- DESTRUCTION (excluding pragmatic info)
+ idPrimRep,
idType,
- getIdInfo, replaceIdInfo,
- getPragmaInfo,
- idPrimRep, getInstIdModule,
- getMentionedTyConsAndClassesFromId,
+ idUnique,
- dataConTag, dataConStrictMarks,
- dataConSig, dataConArgTys,
- dataConTyCon, dataConArity,
+ dataConArgTys,
+ dataConArity,
+ dataConNumFields,
dataConFieldLabels,
+ dataConRawArgTys,
+ dataConSig,
+ dataConStrictMarks,
+ dataConTag,
+ dataConTyCon,
recordSelectorFieldLabel,
-- PREDICATES
- isDataCon, isTupleCon,
- isSpecId_maybe, isSpecPragmaId_maybe,
- toplevelishId, externallyVisibleId,
- isTopLevId, isWorkerId, isWrapperId,
- isImportedId, isSysLocalId,
- isBottomingId,
- isMethodSelId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
- isDictFunId,
---??? isInstId_maybe,
- isConstMethodId_maybe,
+ cmpEqDataCon,
+ cmpId,
cmpId_withSpecDataCon,
- myWrapperMaybe,
- whatsMentionedInId,
- unfoldingUnfriendlyId, -- ToDo: rm, eventually
+ externallyVisibleId,
+ idHasNoFreeTyVars,
idWantsToBeINLINEd,
--- dataConMentionsNonPreludeTyCon,
+ isBottomingId,
+ isConstMethodId,
+ isConstMethodId_maybe,
+ isDataCon,
+ isDefaultMethodId,
+ isDefaultMethodId_maybe,
+ isDictFunId,
+ isImportedId,
+ isMethodSelId,
+ isNullaryDataCon,
+ isSpecPragmaId,
+ isSuperDictSelId_maybe,
+ isSysLocalId,
+ isTopLevId,
+ isTupleCon,
+ isWorkerId,
+ isWrapperId,
+ toplevelishId,
+ unfoldingUnfriendlyId,
-- SUBSTITUTION
- applySubstToId, applyTypeEnvToId,
--- not exported: apply_to_Id, -- please don't use this, generally
-
- -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
- getIdArity, addIdArity,
- getIdDemandInfo, addIdDemandInfo,
- getIdSpecialisation, addIdSpecialisation,
- getIdStrictness, addIdStrictness,
- getIdUnfolding, addIdUnfolding,
- getIdUpdateInfo, addIdUpdateInfo,
- getIdArgUsageInfo, addIdArgUsageInfo,
- getIdFBTypeInfo, addIdFBTypeInfo,
- -- don't export the types, lest OptIdInfo be dragged in!
-
- -- MISCELLANEOUS
- unlocaliseId,
- fIRST_TAG,
- showId,
- pprIdInUnfolding,
-
+ applyTypeEnvToId,
+ apply_to_Id,
+
+ -- PRINTING and RENUMBERING
+ addId,
+ nmbrDataCon,
nmbrId,
+ pprId,
+ showId,
- -- "Environments" keyed off of Ids, and sets of Ids
- IdEnv(..),
- lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
- growIdEnv, growIdEnvList, isNullIdEnv, addOneToIdEnv,
- delOneFromIdEnv, delManyFromIdEnv, modifyIdEnv, combineIdEnvs,
- rngIdEnv, mapIdEnv,
-
- -- and to make the interface self-sufficient...
- GenIdSet(..), IdSet(..)
- )-} where
+ -- Specialialisation
+ getIdSpecialisation,
+ addIdSpecialisation,
-import Ubiq
-import IdLoop -- for paranoia checking
-import TyLoop -- for paranoia checking
+ -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
+ addIdArity,
+ addIdDemandInfo,
+ addIdStrictness,
+ addIdUpdateInfo,
+ getIdArity,
+ getIdDemandInfo,
+ getIdInfo,
+ getIdStrictness,
+ getIdUnfolding,
+ getIdUpdateInfo,
+ getPragmaInfo,
+ replaceIdInfo,
+
+ -- IdEnvs AND IdSets
+ SYN_IE(IdEnv), SYN_IE(GenIdSet), SYN_IE(IdSet),
+ addOneToIdEnv,
+ addOneToIdSet,
+ combineIdEnvs,
+ delManyFromIdEnv,
+ delOneFromIdEnv,
+ elementOfIdSet,
+ emptyIdSet,
+ growIdEnv,
+ growIdEnvList,
+ idSetToList,
+ intersectIdSets,
+ isEmptyIdSet,
+ isNullIdEnv,
+ lookupIdEnv,
+ lookupNoFailIdEnv,
+ mapIdEnv,
+ minusIdSet,
+ mkIdEnv,
+ mkIdSet,
+ modifyIdEnv,
+ modifyIdEnv_Directly,
+ nullIdEnv,
+ rngIdEnv,
+ unionIdSets,
+ unionManyIdSets,
+ unitIdEnv,
+ unitIdSet
+ ) where
+
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop) -- for paranoia checking
+IMPORT_DELOOPER(TyLoop) -- for paranoia checking
import Bag
-import Class ( classOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
-import CStrings ( identToC, cSEP )
+import Class ( classOpString, SYN_IE(Class), GenClass, SYN_IE(ClassOp), GenClassOp )
import IdInfo
import Maybes ( maybeToBool )
import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
- isLocallyDefinedName, isPreludeDefinedName,
+ isLocallyDefinedName,
mkTupleDataConName, mkCompoundName, mkCompoundName2,
- isLexSym, isLexSpecialSym, getLocalName,
- isLocallyDefined, isPreludeDefined, changeUnique,
- getOccName, moduleNamePair, origName, nameOf,
+ isLexSym, isLexSpecialSym,
+ isLocallyDefined, changeUnique,
+ getOccName, origName, moduleOf,
isExported, ExportFlag(..),
RdrName(..), Name
)
import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} )
import PragmaInfo ( PragmaInfo(..) )
-import PprEnv -- ( NmbrM(..), NmbrEnv(..) )
+import PprEnv -- ( SYN_IE(NmbrM), NmbrEnv(..) )
import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
nmbrType, nmbrTyVar,
GenType, GenTyVar
)
import PprStyle
import Pretty
+import MatchEnv ( MatchEnv )
import SrcLoc ( mkBuiltinSrcLoc )
import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
- applyTyCon, isPrimType, instantiateTy,
+ applyTyCon, instantiateTy,
tyVarsOfType, applyTypeEnvToTy, typePrimRep,
- GenType, ThetaType(..), TauType(..), Type(..)
+ GenType, SYN_IE(ThetaType), SYN_IE(TauType), SYN_IE(Type)
)
-import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
+import TyVar ( alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) )
import UniqFM
import UniqSet -- practically all of it
import Unique ( getBuiltinUniques, pprUnique, showUnique,
| ImportedId -- Global name (Imported or Implicit); Id imported from an interface
- | PreludeId -- Global name (Builtin); Builtin prelude Ids
-
| TopLevId -- Global name (LocalDef); Top-level in the orig source pgm
-- (not moved there by transformations).
-- The "a" is irrelevant. As it is too painful to
-- actually do comparisons that way, we kindly supply
-- a Unique for that purpose.
- (Maybe Module) -- module where instance came from; Nothing => Prelude
+ Module -- module where instance came from
-- see below
| ConstMethodId -- A method which depends only on the type of the
Class -- Uniquely identified by:
Type -- (class, type, classop) triple
ClassOp
- (Maybe Module) -- module where instance came from; Nothing => Prelude
+ Module -- module where instance came from
| InstId -- An instance of a dictionary, class operation,
-- or overloaded value (Local name)
their @IdInfo@).
%----------------------------------------------------------------------
-\item[@PreludeId@:] ToDo
-
-%----------------------------------------------------------------------
\item[@TopLevId@:] These are values defined at the top-level in this
module; i.e., those which {\em might} be exported (hence, a
@Name@). It does {\em not} include those which are moved to the
chk (TupleConId _) = True
chk (RecordSelId _) = True
chk ImportedId = True
- chk PreludeId = True
chk TopLevId = True -- NB: see notes
chk (SuperDictSelId _ _) = True
chk (MethodSelId _ _) = True
chk (TupleConId _) = True
chk (RecordSelId _) = True
chk ImportedId = True
- chk PreludeId = True
chk TopLevId = True
chk (SuperDictSelId _ _) = True
chk (MethodSelId _ _) = True
isWorkerId (Id _ _ _ (WorkerId _) _ _) = True
isWorkerId other = False
-{-LATER:
isWrapperId id = workerExists (getIdStrictness id)
--}
\end{code}
\begin{code}
case v_details of
-- these ones must have been exported by their original module
ImportedId -> pp_full_name
- PreludeId -> pp_full_name
-- these ones' exportedness checked later...
TopLevId -> pp_full_name
pp_full_name
= let
- (m_str, n_str) = moduleNamePair v
+ (OrigName m_str n_str) = origName "Id:ppr_Unfolding" v
pp_n =
if isLexSym n_str && not (isLexSpecialSym n_str) then
-> Bool -- mentions this Id. Reason: it cannot
-- possibly be seen in another module.
-unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
-{-LATER:
-
-unfoldingUnfriendlyId id
- | not (externallyVisibleId id) -- that settles that...
- = True
-
-unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper) _ _)
- = class_thing wrapper
- where
- -- "class thing": If we're going to use this worker Id in
- -- an interface, we *have* to be able to untangle the wrapper's
- -- strictness when reading it back in. At the moment, this
- -- is not always possible: in precisely those cases where
- -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
-
- class_thing (Id _ _ _ (SuperDictSelId _ _) _ _) = True
- class_thing (Id _ _ _ (MethodSelId _ _) _ _) = True
- class_thing (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
- class_thing other = False
-
-unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _)) _ _) _ _)
- -- a SPEC of a DictFunId can end up w/ gratuitous
- -- TyVar(Templates) in the i/face; only a problem
- -- if -fshow-pragma-name-errs; but we can do without the pain.
- -- A HACK in any case (WDP 94/05/02)
- = naughty_DictFunId dfun
-
-unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _) _ _)
- = naughty_DictFunId dfun -- similar deal...
-
-unfoldingUnfriendlyId other_id = False -- is friendly in all other cases
-
-naughty_DictFunId :: IdDetails -> Bool
- -- True <=> has a TyVar(Template) in the "type" part of its "name"
-
-naughty_DictFunId (DictFunId _ _ _) = panic "False" -- came from outside; must be OK
-naughty_DictFunId (DictFunId _ ty _)
- = not (isGroundTy ty)
--}
+unfoldingUnfriendlyId id = not (externallyVisibleId id)
\end{code}
@externallyVisibleId@: is it true that another module might be
externallyVisibleId id@(Id _ _ _ details _ _)
= if isLocallyDefined id then
- toplevelishId id && isExported id && not (weird_datacon details)
+ toplevelishId id && (isExported id || isDataCon id)
+ -- NB: the use of "isExported" is most dodgy;
+ -- We may eventually move to a situation where
+ -- every Id is "externallyVisible", even if the
+ -- module system's namespace control renders it
+ -- "not exported".
else
- not (weird_tuplecon details)
+ True
-- if visible here, it must be visible elsewhere, too.
- where
- -- If it's a DataCon, it's not enough to know it (meaning
- -- its TyCon) is exported; we need to know that it might
- -- be visible outside. Consider:
- --
- -- data Foo a = Mumble | BigFoo a WeirdLocalType
- --
- -- We can't tell the outside world *anything* about Foo, because
- -- of WeirdLocalType; but we need to know this when asked if
- -- "Mumble" is externally visible...
-
-{- LATER: if at all:
- weird_datacon (DataConId _ _ _ _ _ _ tycon)
- = maybeToBool (maybePurelyLocalTyCon tycon)
--}
- weird_datacon not_a_datacon_therefore_not_weird = False
-
- weird_tuplecon (TupleConId arity)
- = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
- weird_tuplecon _ = False
\end{code}
\begin{code}
-- type might be wrong, but it hardly matters
-- at this stage (just before printing C) ToDo
where
- name = getLocalName name
+ name = nameOf (origName "Id.unlocaliseId" name)
full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
unlocaliseId mod other_id = Nothing
\begin{code}
mkSuperDictSelId u c sc ty info
- = Id u n ty (SuperDictSelId c sc) NoPragmaInfo info
- where
- cname = getName c -- we get other info out of here
-
- n = mkCompoundName u SLIT("sdsel") [origName cname, origName sc] cname
+ = mk_classy_id (SuperDictSelId c sc) SLIT("sdsel") (Left (origName "mkSuperDictSelId" sc)) u c ty info
-mkMethodSelId u c op ty info
- = Id u n ty (MethodSelId c op) NoPragmaInfo info
- where
- cname = getName c -- we get other info out of here
+mkMethodSelId u rec_c op ty info
+ = mk_classy_id (MethodSelId rec_c op) SLIT("meth") (Right (classOpString op)) u rec_c ty info
- n = mkCompoundName u SLIT("meth") [origName cname, Unqual (classOpString op)] cname
+mkDefaultMethodId u rec_c op gen ty info
+ = mk_classy_id (DefaultMethodId rec_c op gen) SLIT("defm") (Right (classOpString op)) u rec_c ty info
-mkDefaultMethodId u c op gen ty info
- = Id u n ty (DefaultMethodId c op gen) NoPragmaInfo info
+mk_classy_id details str op_str u rec_c ty info
+ = Id u n ty details NoPragmaInfo info
where
- cname = getName c -- we get other info out of here
+ cname = getName rec_c -- we get other info out of here
+ cname_orig = origName "mk_classy_id" cname
+ cmod = moduleOf cname_orig
- n = mkCompoundName u SLIT("defm") [origName cname, Unqual (classOpString op)] cname
+ n = mkCompoundName u cmod str [Left cname_orig, op_str] cname
mkDictFunId u c ity full_ty from_here locn mod info
= Id u n full_ty (DictFunId c ity mod) NoPragmaInfo info
where
- n = mkCompoundName2 u SLIT("dfun") [origName c] (getTypeString ity) from_here locn
+ n = mkCompoundName2 u mod SLIT("dfun") (Left (origName "mkDictFunId" c) : renum_type_string full_ty ity) from_here locn
mkConstMethodId u c op ity full_ty from_here locn mod info
= Id u n full_ty (ConstMethodId c ity op mod) NoPragmaInfo info
where
- n = mkCompoundName2 u SLIT("const") [origName c, Unqual (classOpString op)] (getTypeString ity) from_here locn
+ n = mkCompoundName2 u mod SLIT("const") (Left (origName "mkConstMethodId" c) : Right (classOpString op) : renum_type_string full_ty ity) from_here locn
+
+renum_type_string full_ty ity
+ = initNmbr (
+ nmbrType full_ty `thenNmbr` \ _ -> -- so all the tyvars get added to renumbering...
+ nmbrType ity `thenNmbr` \ rn_ity ->
+ returnNmbr (getTypeString rn_ity)
+ )
mkWorkerId u unwrkr ty info
= Id u n ty (WorkerId unwrkr) NoPragmaInfo info
where
unwrkr_name = getName unwrkr
+ unwrkr_orig = origName "mkWorkerId" unwrkr_name
+ umod = moduleOf unwrkr_orig
- n = mkCompoundName u SLIT("wrk") [origName unwrkr_name] unwrkr_name
+ n = mkCompoundName u umod SLIT("wrk") [Left unwrkr_orig] unwrkr_name
mkInstId u ty name = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo
\begin{code}
mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info
-mkPreludeId n ty info = Id (nameUnique n) n ty PreludeId NoPragmaInfo info
{-LATER:
updateIdType :: Id -> Type -> Id
mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
mkSysLocal str uniq ty loc
- = Id uniq (mkLocalName uniq str loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
+ = Id uniq (mkLocalName uniq str True{-emph uniq-} loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
mkUserLocal str uniq ty loc
- = Id uniq (mkLocalName uniq str loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
+ = Id uniq (mkLocalName uniq str False{-emph name-} loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
-- mkUserId builds a local or top-level Id, depending on the name given
mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
getIdInfo (Id _ _ _ _ _ info) = info
getPragmaInfo (Id _ _ _ _ info _) = info
-{-LATER:
replaceIdInfo :: Id -> IdInfo -> Id
-replaceIdInfo (Id u n ty _ details) info = Id u n ty info details
+replaceIdInfo (Id u n ty details pinfo _) info = Id u n ty details pinfo info
+{-LATER:
selectIdInfoForSpecId :: Id -> IdInfo
selectIdInfoForSpecId unspec
= ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
\begin{code}
getIdArity :: Id -> ArityInfo
-getIdArity (Id _ _ _ _ _ id_info) = getInfo id_info
+getIdArity id@(Id _ _ _ _ _ id_info)
+ = --ASSERT( not (isDataCon id))
+ getInfo id_info
+
+dataConArity, dataConNumFields :: DataCon -> Int
-dataConArity :: DataCon -> Int
dataConArity id@(Id _ _ _ _ _ id_info)
= ASSERT(isDataCon id)
case (arityMaybe (getInfo id_info)) of
- Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
Just i -> i
+ Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
+
+dataConNumFields id
+ = ASSERT(isDataCon id)
+ case (dataConSig id) of { (_, _, arg_tys, _) ->
+ length arg_tys }
+
+isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience
addIdArity :: Id -> Int -> Id
addIdArity (Id u n ty details pinfo info) arity
n
type_of_constructor
(DataConId data_con_tag stricts fields tvs ctxt args_tys tycon)
- NoPragmaInfo
+ IWantToBeINLINEd -- Always inline constructors if possible
datacon_info
data_con_tag = position_within fIRST_TAG data_con_family
`addInfo` mkArityInfo arity
--ToDo: `addInfo` specenv
- arity = length args_tys
+ arity = length ctxt + length args_tys
unfolding
= noInfo_UF
dataConStrictMarks (Id _ _ _ (TupleConId arity) _ _)
= nOfThem arity NotMarkedStrict
+dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
+dataConRawArgTys con = case (dataConSig con) of { (_,_, arg_tys,_) -> arg_tys }
+
dataConArgTys :: DataCon
-> [Type] -- Instantiated at these types
-> [Type] -- Needs arguments of these types
%************************************************************************
@getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
-and generates an @UnfoldingDetails@ for its unfolding. The @Ids@ and
-@TyVars@ don't really have to be new, because we are only producing a
-template.
+and generates an @Unfolding@. The @Ids@ and @TyVars@ don't really
+have to be new, because we are only producing a template.
ToDo: what if @DataConId@'s type has a context (haven't thought about it
--WDP)?
present.)
\begin{code}
-getIdUnfolding :: Id -> UnfoldingDetails
+getIdUnfolding :: Id -> Unfolding
getIdUnfolding (Id _ _ _ _ _ info) = getInfo_UF info
{-LATER:
-addIdUnfolding :: Id -> UnfoldingDetails -> Id
+addIdUnfolding :: Id -> Unfolding -> Id
addIdUnfolding id@(Id u n ty info details) unfold_details
= ASSERT(
case (isLocallyDefined id, unfold_details) of
- (_, NoUnfoldingDetails) -> True
+ (_, NoUnfolding) -> True
(True, IWantToBeINLINEd _) -> True
(False, IWantToBeINLINEd _) -> False -- v bad
(False, _) -> True
\end{code}
\begin{code}
-{- LATER:
getIdSpecialisation :: Id -> SpecEnv
getIdSpecialisation (Id _ _ _ _ _ info) = getInfo info
addIdSpecialisation :: Id -> SpecEnv -> Id
addIdSpecialisation (Id u n ty details prags info) spec_info
= Id u n ty details prags (info `addInfo` spec_info)
--}
\end{code}
Strictness: we snaffle the info out of the IdInfo.
cmp = cmpId
instance Eq (GenId ty) where
- a == b = case cmpId a b of { EQ_ -> True; _ -> False }
- a /= b = case cmpId a b of { EQ_ -> False; _ -> True }
+ a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
instance Ord (GenId ty) where
- a <= b = case cmpId a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case cmpId a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
- _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+ 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 }
+ _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
\end{code}
@cmpId_withSpecDataCon@ ensures that any spectys are taken into
showId :: PprStyle -> Id -> String
showId sty id = ppShow 80 (pprId sty id)
-
--- [used below]
--- for DictFuns (instances) and const methods (instance code bits we
--- can call directly): exported (a) if *either* the class or
--- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both*
--- class and tycon are from PreludeCore [non-std, but convenient]
--- *and* the thing was defined in this module.
-
-instance_export_flag :: Class -> Type -> Bool -> ExportFlag
-
-instance_export_flag clas inst_ty from_here
- = panic "Id:instance_export_flag"
-{-LATER
- = if instanceIsExported clas inst_ty from_here
- then ExportAll
- else NotExported
--}
\end{code}
Default printing code (not used for interfaces):
instance NamedThing (GenId ty) where
getName this_id@(Id u n _ details _ _) = n
-{- OLD:
- = get details
- where
- get (LocalId _) = n
- get (SysLocalId _) = n
- get (SpecPragmaId _ _) = n
- get ImportedId = n
- get PreludeId = n
- get TopLevId = n
- get (InstId n _) = n
- get (DataConId _ _ _ _ _ _ _) = n
- get (TupleConId _) = n
- get (RecordSelId l) = getName l
- get _ = mkCompoundName u (getIdNamePieces False{-no Uniques-} this_id)
--}
-{- LATER:
- get (MethodSelId c op) = case (moduleOf (origName c)) of -- ToDo; better ???
- mod -> (mod, classOpString op)
-
- get (SpecId unspec ty_maybes _)
- = 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)
- ) }}
-
- get (WorkerId unwrkr)
- = case moduleNamePair unwrkr of { (mod, unwrkr_nm) ->
- (mod,
- unwrkr_nm _APPEND_
- (if not (toplevelishId unwrkr)
- then showUnique u
- else SLIT(".wrk"))
- ) }
-
- 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)
-
- = case (getIdNamePieces True this_id) of { (piece1:pieces) ->
- case [ _CONS_ '.' p | p <- pieces ] of { dotted_pieces ->
- (_NIL_, _CONCAT_ (piece1 : dotted_pieces)) }}
--}
\end{code}
Note: The code generator doesn't carry a @UniqueSupply@, so it uses
delOneFromIdEnv :: IdEnv a -> GenId ty -> IdEnv a
combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b
-modifyIdEnv :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
+modifyIdEnv :: (a -> a) -> IdEnv a -> GenId ty -> IdEnv a
rngIdEnv :: IdEnv a -> [a]
isNullIdEnv :: IdEnv a -> Bool
-- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
-- modify function, and put it back.
-modifyIdEnv env mangle_fn key
+modifyIdEnv mangle_fn env key
= case (lookupIdEnv env key) of
Nothing -> env
Just xx -> addOneToIdEnv env key (mangle_fn xx)
+
+modifyIdEnv_Directly mangle_fn env key
+ = case (lookupUFM_Directly env key) of
+ Nothing -> env
+ Just xx -> addToUFM_Directly env key (mangle_fn xx)
\end{code}
\begin{code}
\end{code}
\begin{code}
-addId, nmbrId :: Id -> NmbrM Id
+addId, nmbrId, nmbrDataCon :: Id -> NmbrM Id
addId id@(Id u n 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!" $
+ Just xx -> trace "addId: already in map!" $
(nenv, xx)
Nothing ->
if toplevelishId id then
- _trace "addId: can't add toplevelish!" $
+ trace "addId: can't add toplevelish!" $
(nenv, id)
else -- alloc a new unique for this guy
-- and add an entry in the idenv
Just xx -> (nenv, xx)
Nothing ->
if not (toplevelishId id) then
- _trace "nmbrId: lookup failed" $
+ trace "nmbrId: lookup failed" $
(nenv, id)
else
let
in
(nenv3, new_id)
+ -- used when renumbering TyCons to produce data decls...
+nmbrDataCon id@(Id _ _ _ (TupleConId _) _ _) nenv
+ = (nenv, id) -- nothing to do for tuples
+
+nmbrDataCon id@(Id u n ty (DataConId tag marks fields tvs theta arg_tys tc) prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
+ = case (lookupUFM_Directly idenv u) of
+ Just xx -> trace "nmbrDataCon: in env???\n" (nenv, xx)
+ Nothing ->
+ let
+ (nenv2, new_fields) = (mapNmbr nmbrField fields) nenv
+ (nenv3, new_arg_tys) = (mapNmbr nmbrType arg_tys) nenv2
+
+ new_det = DataConId tag marks new_fields (bottom "tvs") (bottom "theta") new_arg_tys tc
+ new_id = Id u n (bottom "ty") new_det prag info
+ in
+ (nenv3, new_id)
+ where
+ bottom msg = panic ("nmbrDataCon"++msg)
+
------------
nmbr_details :: IdDetails -> NmbrM IdDetails
projects / ghc-hetmet.git / blobdiff