-\begin{code}
-instance Outputable ty => Outputable (GenId ty) where
- ppr sty id = pprId sty id
-
--- and a SPECIALIZEd one:
-instance Outputable {-Id, i.e.:-}(GenId Type) where
- ppr sty id = pprId sty id
-
-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):
-\begin{code}
-pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
-
-pprId other_sty id
- = let
- pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id
-
- for_code
- = let
- pieces_to_print -- maybe use Unique only
- = if isSysLocalId id then tail pieces else pieces
- in
- ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print)
- in
- case other_sty of
- PprForC -> for_code
- PprForAsm _ _ -> for_code
- PprInterface -> ppr other_sty occur_name
- PprForUser -> ppr other_sty occur_name
- PprUnfolding -> qualified_name pieces
- PprDebug -> qualified_name pieces
- PprShowAll -> ppBesides [qualified_name pieces,
- (ppCat [pp_uniq id,
- ppPStr SLIT("{-"),
- ppr other_sty (idType id),
- ppIdInfo other_sty (unsafeGenId2Id id) True
- (\x->x) nullIdEnv (getIdInfo id),
- ppPStr SLIT("-}") ])]
- where
- occur_name = getOccName id `appendRdr`
- (if not (isSysLocalId id)
- then SLIT("")
- else SLIT(".") _APPEND_ (showUnique (idUnique id)))
-
- qualified_name pieces
- = ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id)
-
- pp_uniq (Id _ _ (PreludeId _) _ _) = ppNil -- no uniq to add
- pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = ppNil
- pp_uniq (Id _ _ (TupleConId _ _) _ _) = ppNil
- pp_uniq (Id _ _ (LocalId _ _) _ _) = ppNil -- uniq printed elsewhere
- pp_uniq (Id _ _ (SysLocalId _ _) _ _) = ppNil
- pp_uniq (Id _ _ (SpecPragmaId _ _ _) _ _) = ppNil
- pp_uniq (Id _ _ (InstId _ _) _ _) = ppNil
- pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (idUnique other_id), ppPStr SLIT("-}")]
-
- -- print PprDebug Ids with # afterwards if they are of primitive type.
- pp_ubxd pretty = pretty
-
-{- LATER: applying isPrimType restricts type
- pp_ubxd pretty = if isPrimType (idType id)
- then ppBeside pretty (ppChar '#')
- else pretty
--}
-
-\end{code}
-
-\begin{code}
-idUnique (Id u _ _ _ _) = u
-
-instance Uniquable (GenId ty) where
- uniqueOf = idUnique
-
-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 (DataConId n _ _ _ _ _ _ _) = n
- get (TupleConId n _) = 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
-the @Uniques@ out of local @Ids@ given to it.
-
-%************************************************************************
-%* *
-\subsection{@IdEnv@s and @IdSet@s}
-%* *
-%************************************************************************
-
-\begin{code}
-type IdEnv elt = UniqFM elt
-
-nullIdEnv :: IdEnv a
-
-mkIdEnv :: [(GenId ty, a)] -> IdEnv a
-unitIdEnv :: GenId ty -> a -> IdEnv a
-addOneToIdEnv :: IdEnv a -> GenId ty -> a -> IdEnv a
-growIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
-growIdEnvList :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
-
-delManyFromIdEnv :: IdEnv a -> [GenId ty] -> IdEnv a
-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
-rngIdEnv :: IdEnv a -> [a]
-
-isNullIdEnv :: IdEnv a -> Bool
-lookupIdEnv :: IdEnv a -> GenId ty -> Maybe a
-lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
-\end{code}
-
-\begin{code}
-addOneToIdEnv = addToUFM
-combineIdEnvs = plusUFM_C
-delManyFromIdEnv = delListFromUFM
-delOneFromIdEnv = delFromUFM
-growIdEnv = plusUFM
-lookupIdEnv = lookupUFM
-mapIdEnv = mapUFM
-mkIdEnv = listToUFM
-nullIdEnv = emptyUFM
-rngIdEnv = eltsUFM
-unitIdEnv = unitUFM
-
-growIdEnvList env pairs = plusUFM env (listToUFM pairs)
-isNullIdEnv env = sizeUFM env == 0
-lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
-
--- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
--- modify function, and put it back.
-
-modifyIdEnv env mangle_fn key
- = case (lookupIdEnv env key) of
- Nothing -> env
- Just xx -> addOneToIdEnv env key (mangle_fn xx)
-\end{code}
-
-\begin{code}
-type GenIdSet ty = UniqSet (GenId ty)
-type IdSet = UniqSet (GenId Type)
-
-emptyIdSet :: GenIdSet ty
-intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
-unionIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
-unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
-idSetToList :: GenIdSet ty -> [GenId ty]
-unitIdSet :: GenId ty -> GenIdSet ty
-addOneToIdSet :: GenIdSet ty -> GenId ty -> GenIdSet ty
-elementOfIdSet :: GenId ty -> GenIdSet ty -> Bool
-minusIdSet :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
-isEmptyIdSet :: GenIdSet ty -> Bool
-mkIdSet :: [GenId ty] -> GenIdSet ty
-
-emptyIdSet = emptyUniqSet
-unitIdSet = unitUniqSet
-addOneToIdSet = addOneToUniqSet
-intersectIdSets = intersectUniqSets
-unionIdSets = unionUniqSets
-unionManyIdSets = unionManyUniqSets
-idSetToList = uniqSetToList
-elementOfIdSet = elementOfUniqSet
-minusIdSet = minusUniqSet
-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)