-isTopLevId (Id _ _ (TopLevId _) _ _) = True
-isTopLevId other = False
-
-isImportedId (Id _ _ (ImportedId _) _ _) = True
-isImportedId other = False
-
-isBottomingId (Id _ _ _ _ info) = panic "isBottomingId not implemented"
- -- LATER: bottomIsGuaranteed (getInfo info)
-
-isSysLocalId (Id _ _ (SysLocalId _ _) _ _) = True
-isSysLocalId other = False
-
-isSpecPragmaId (Id _ _ (SpecPragmaId _ _ _) _ _) = True
-isSpecPragmaId other = False
-
-isMethodSelId (Id _ _ (MethodSelId _ _) _ _) = True
-isMethodSelId _ = False
-
-isDefaultMethodId (Id _ _ (DefaultMethodId _ _ _) _ _) = True
-isDefaultMethodId other = False
-
-isDefaultMethodId_maybe (Id _ _ (DefaultMethodId cls clsop err) _ _)
- = Just (cls, clsop, err)
-isDefaultMethodId_maybe other = Nothing
-
-isDictFunId (Id _ _ (DictFunId _ _ _ _) _ _) = True
-isDictFunId other = False
-
-isConstMethodId (Id _ _ (ConstMethodId _ _ _ _ _) _ _) = True
-isConstMethodId other = False
-
-isConstMethodId_maybe (Id _ _ (ConstMethodId cls ty clsop _ _) _ _)
- = Just (cls, ty, clsop)
-isConstMethodId_maybe other = Nothing
-
-isSuperDictSelId_maybe (Id _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
-isSuperDictSelId_maybe other_id = Nothing
-
-isWorkerId (Id _ _ (WorkerId _) _ _) = True
-isWorkerId other = False
-
-{-LATER:
-isWrapperId id = workerExists (getIdStrictness id)
--}
-\end{code}
-
-\begin{code}
-{-LATER:
-pprIdInUnfolding :: IdSet -> Id -> Pretty
-
-pprIdInUnfolding in_scopes v
- = let
- v_ty = idType v
- in
- -- local vars first:
- if v `elementOfUniqSet` in_scopes then
- pprUnique (getItsUnique v)
-
- -- ubiquitous Ids with special syntax:
- else if v == nilDataCon then
- ppPStr SLIT("_NIL_")
- else if isTupleCon v then
- ppBeside (ppPStr SLIT("_TUP_")) (ppInt (getDataConArity v))
-
- -- ones to think about:
- else
- let
- (Id _ _ v_details _ _) = v
- in
- 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
- DataConId _ _ _ _ _ _ _ -> pp_full_name
-
- -- class-ish things: class already recorded as "mentioned"
- SuperDictSelId c sc
- -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
- MethodSelId c o
- -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
- DefaultMethodId c o _
- -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
-
- -- instance-ish things: should we try to figure out
- -- *exactly* which extra instances have to be exported? (ToDo)
- DictFunId c t _ _
- -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
- ConstMethodId c t o _ _
- -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
-
- -- specialisations and workers
- SpecId unspec ty_maybes _
- -> let
- pp = pprIdInUnfolding in_scopes unspec
- in
- ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
- ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
- ppRbrack]
-
- WorkerId unwrkr
- -> let
- pp = pprIdInUnfolding in_scopes unwrkr
- in
- ppBeside (ppPStr SLIT("_WRKR_ ")) pp
-
- -- anything else? we're nae interested
- other_id -> panic "pprIdInUnfolding:mystery Id"
- where
- ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
-
- pp_full_name
- = let
- (m_str, n_str) = getOrigName v
-
- pp_n =
- if isAvarop n_str || isAconop n_str then
- ppBesides [ppLparen, ppPStr n_str, ppRparen]
- else
- ppPStr n_str
- in
- if fromPreludeCore v then
- pp_n
- else
- ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
-
- pp_class :: Class -> Pretty
- pp_class_op :: ClassOp -> Pretty
- pp_type :: Type -> Pretty
- pp_ty_maybe :: Maybe Type -> Pretty
-
- pp_class clas = ppr ppr_Unfolding clas
- pp_class_op op = ppr ppr_Unfolding op
-
- pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
-
- pp_ty_maybe Nothing = ppPStr SLIT("_N_")
- pp_ty_maybe (Just t) = pp_type t
--}
-\end{code}
-
-@whatsMentionedInId@ ferrets out the types/classes/instances on which
-this @Id@ depends. If this Id is to appear in an interface, then
-those entities had Jolly Well be in scope. Someone else up the
-call-tree decides that.
-
-\begin{code}
-{-LATER:
-whatsMentionedInId
- :: IdSet -- Ids known to be in scope
- -> Id -- Id being processed
- -> (Bag Id, Bag TyCon, Bag Class) -- mentioned Ids/TyCons/etc.
-
-whatsMentionedInId in_scopes v
- = let
- v_ty = idType v
-
- (tycons, clss)
- = getMentionedTyConsAndClassesFromType v_ty
-
- result0 id_bag = (id_bag, tycons, clss)
-
- result1 ids tcs cs
- = (ids `unionBags` unitBag v, -- we add v to "mentioned"...
- tcs `unionBags` tycons,
- cs `unionBags` clss)
- in
- -- local vars first:
- if v `elementOfUniqSet` in_scopes then
- result0 emptyBag -- v not added to "mentioned"
-
- -- ones to think about:
- else
- let
- (Id _ _ v_details _ _) = v
- in
- case v_details of
- -- specialisations and workers
- SpecId unspec ty_maybes _
- -> let
- (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
- in
- result1 ids2 tcs2 cs2
-
- WorkerId unwrkr
- -> let
- (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
- in
- result1 ids2 tcs2 cs2
-
- anything_else -> result0 (unitBag v) -- v is added to "mentioned"
--}
-\end{code}
-
-Tell them who my wrapper function is.
-\begin{code}
-{-LATER:
-myWrapperMaybe :: Id -> Maybe Id
-
-myWrapperMaybe (Id _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
-myWrapperMaybe other_id = Nothing
--}
-\end{code}
-
-\begin{code}
-unfoldingUnfriendlyId -- return True iff it is definitely a bad
- :: Id -- idea to export an unfolding that
- -> 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)
- = --pprTrace "unfriendly1:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
- naughty_DictFunId dfun
- --)
-
-unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _)
- = --pprTrace "unfriendly2:" (ppCat [ppr PprDebug d, ppr PprDebug 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 _ _ False _) = False -- came from outside; must be OK
-naughty_DictFunId (DictFunId _ ty _ _)
- = not (isGroundTy ty)
--}
-\end{code}