module IfaceSyn (
module IfaceType, -- Re-export all this
- IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
+ IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
IfaceExpr(..), IfaceAlt, IfaceNote(..),
IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
IfaceInfoItem(..), IfaceRule(..), IfaceInst(..),
+ -- Misc
+ visibleIfConDecls,
+
-- Converting things to IfaceSyn
tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule,
eqIfDecl, eqIfInst, eqIfRule,
-- Pretty printing
- pprIfaceExpr, pprIfaceDecl
+ pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead
) where
#include "HsVersions.h"
import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..),
arityInfo, cafInfo, newStrictnessInfo,
workerInfo, unfoldingInfo, inlinePragInfo )
-import TyCon ( TyCon, ArgVrcs, DataConDetails(..), isRecursiveTyCon, isForeignTyCon,
+import TyCon ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon,
isSynTyCon, isNewTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
isTupleTyCon, tupleTyConBoxity,
tyConHasGenerics, tyConArgVrcs, tyConTheta, getSynTyConDefn,
- tyConArity, tyConTyVars, tyConDataConDetails, tyConExtName )
+ tyConArity, tyConTyVars, algTyConRhs, tyConExtName )
import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks,
- dataConTyCon )
+ dataConTyCon, dataConIsInfix )
import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon )
import OccName ( OccName, OccEnv, lookupOccEnv, emptyOccEnv,
lookupOccEnv, extendOccEnv, emptyOccEnv,
OccSet, unionOccSets, unitOccSet )
import Name ( Name, NamedThing(..), getOccName, nameOccName, nameModuleName, isExternalName )
+import NameSet ( NameSet, elemNameSet )
import Module ( ModuleName )
import CostCentre ( CostCentre, pprCostCentreCore )
import Literal ( Literal )
import ForeignCall ( ForeignCall )
import TysPrim ( alphaTyVars )
-import BasicTypes ( Arity, Activation(..), StrictnessMark, NewOrData(..),
+import BasicTypes ( Arity, Activation(..), StrictnessMark,
RecFlag(..), boolToRecFlag, Boxity(..),
tupleParens )
import Outputable
ifType :: IfaceType,
ifIdInfo :: IfaceIdInfo }
- | IfaceData { ifND :: NewOrData,
- ifCtxt :: IfaceContext, -- Context
+ | IfaceData { ifCtxt :: IfaceContext, -- Context
ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
- ifCons :: DataConDetails IfaceConDecl,
+ ifCons :: IfaceConDecls, -- Includes new/data info
ifRec :: RecFlag, -- Recursive or not?
ifVrcs :: ArgVrcs,
ifGeneric :: Bool -- True <=> generic converter functions available
-- Just False => ordinary polymorphic default method
-- Just True => generic default method
+data IfaceConDecls
+ = IfAbstractTyCon -- No info
+ | IfDataTyCon [IfaceConDecl] -- data type decls
+ | IfNewTyCon IfaceConDecl -- newtype decls
+
+visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
+visibleIfConDecls IfAbstractTyCon = []
+visibleIfConDecls (IfDataTyCon cs) = cs
+visibleIfConDecls (IfNewTyCon c) = [c]
+
data IfaceConDecl
= IfaceConDecl OccName -- Constructor name
+ Bool -- True <=> declared infix
[IfaceTvBndr] -- Existental tyvars
IfaceContext -- Existential context
[IfaceType] -- Arg types
data IfaceIdInfo
= NoInfo -- When writing interface file without -O
| HasInfo [IfaceInfoItem] -- Has info, and here it is
- | DiscardedInfo -- HasInfo in the .hi file, but discarded
- -- when it was read in
--- Here's why we need this NoInfo/DiscardedInfo stuff
+
+-- Here's a tricky case:
-- * Compile with -O module A, and B which imports A.f
-- * Change function f in A, and recompile without -O
--- * If we read in A.hi and discard IdInfo, the
--- new (empty) IdInfo for f looks like the
--- old (discarded) IdInfo for f
--- => no new version # for f
--- * But that might mean that we fail to recompile B, when
--- actually we should
---
--- * We also want to ensure that if A.hi was *already* compiled
--- without -O we *don't* then recompile B
---
--- When we discard IdInfo on *reading* we make it into DiscardedInfo
--- On *writing* we make it NoInfo
--- DiscardedInfo is never written into a file
+-- * When we read in old A.hi we read in its IdInfo (as a thunk)
+-- (In earlier GHCs we used to drop IdInfo immediately on reading,
+-- but we do not do that now. Instead it's discarded when the
+-- ModIface is read into the various decl pools.)
+-- * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *)
+-- and so gives a new version.
data IfaceInfoItem
= HsArity Arity
| HsStrictness StrictSig
| HsUnfold Activation IfaceExpr
| HsNoCafRefs
- | HsWorker OccName Arity -- Worker, if any see IdInfo.WorkerInfo
- -- for why we want arity here.
+ | HsWorker IfaceExtName Arity -- Worker, if any see IdInfo.WorkerInfo
+ -- for why we want arity here.
+ -- NB: we need IfaceExtName (not just OccName) because the worker
+ -- can simplify to a function in another module.
-- NB: Specialisations and rules come in separately and are
-- only later attached to the Id. Partial reason: some are orphans.
= hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, ifVrcs = vrcs})
- = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars)
+ = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
4 (vcat [equals <+> ppr mono_ty,
pprVrcs vrcs])
-pprIfaceDecl (IfaceData {ifND = new_or_data, ifCtxt = context, ifName = tycon, ifGeneric = gen,
+pprIfaceDecl (IfaceData {ifCtxt = context, ifName = tycon, ifGeneric = gen,
ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifVrcs = vrcs})
- = hang (ppr new_or_data <+> pp_decl_head context tycon tyvars)
+ = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls condecls])
+ where
+ pp_nd = case condecls of
+ IfAbstractTyCon -> ptext SLIT("data")
+ IfDataTyCon _ -> ptext SLIT("data")
+ IfNewTyCon _ -> ptext SLIT("newtype")
pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec})
- = hang (ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds)
+ = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
4 (vcat [pprVrcs vrcs,
pprRec isrec,
sep (map ppr sigs)])
instance Outputable IfaceClassOp where
ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
-pp_decl_head :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
-pp_decl_head context thing tyvars
+pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
+pprIfaceDeclHead context thing tyvars
= hsep [pprIfaceContext context, ppr thing, pprIfaceTvBndrs tyvars]
-pp_condecls Unknown = ptext SLIT("{- abstract -}")
-pp_condecls (DataCons cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))
+pp_condecls IfAbstractTyCon = ptext SLIT("{- abstract -}")
+pp_condecls (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))
+pp_condecls (IfNewTyCon c) = equals <+> ppr c
instance Outputable IfaceConDecl where
- ppr (IfaceConDecl name ex_tvs ex_ctxt arg_tys strs fields)
+ ppr (IfaceConDecl name is_infix ex_tvs ex_ctxt arg_tys strs fields)
= pprIfaceForAllPart ex_tvs ex_ctxt $
sep [ppr name <+> sep (map pprParendIfaceType arg_tys),
+ if is_infix then ptext SLIT("Infix") else empty,
if null strs then empty
else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
if null fields then empty
------------------
instance Outputable IfaceIdInfo where
- ppr NoInfo = empty
- ppr DiscardedInfo = ptext SLIT("<discarded>")
- ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}")
+ ppr NoInfo = empty
+ ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}")
ppr_hs_info (HsUnfold prag unf) = sep [ptext SLIT("Unfolding: ") <> ppr prag,
parens (pprIfaceExpr noParens unf)]
\begin{code}
-tyThingToIfaceDecl :: Bool -> (TyCon -> Bool)
+tyThingToIfaceDecl :: Bool
+ -> NameSet -- Tycons and classes to export abstractly
-> (Name -> IfaceExtName) -> TyThing -> IfaceDecl
tyThingToIfaceDecl discard_id_info _ ext (AnId id)
= IfaceId { ifName = getOccName id,
toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2)
-tyThingToIfaceDecl _ discard_data_cons ext (ATyCon tycon)
+tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon)
| isSynTyCon tycon
= IfaceSyn { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
ifSynRhs = toIfaceType ext syn_ty }
| isAlgTyCon tycon
- = IfaceData { ifND = new_or_data,
- ifCtxt = toIfaceContext ext (tyConTheta tycon),
+ = IfaceData { ifCtxt = toIfaceContext ext (tyConTheta tycon),
ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
- ifCons = ifaceConDecls (tyConDataConDetails tycon),
+ ifCons = ifaceConDecls (algTyConRhs tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifVrcs = tyConArgVrcs tycon,
ifGeneric = tyConHasGenerics tycon }
| isPrimTyCon tycon || isFunTyCon tycon
-- Needed in GHCi for ':info Int#', for example
- = IfaceData { ifND = DataType,
- ifCtxt = [],
+ = IfaceData { ifCtxt = [],
ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars),
- ifCons = Unknown,
+ ifCons = IfAbstractTyCon,
ifGeneric = False,
ifRec = NonRecursive,
ifVrcs = tyConArgVrcs tycon }
where
tyvars = tyConTyVars tycon
(_, syn_ty) = getSynTyConDefn tycon
- new_or_data | isNewTyCon tycon = NewType
- | otherwise = DataType
-
- ifaceConDecls _ | discard_data_cons tycon = Unknown
- ifaceConDecls Unknown = Unknown
- ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs)
+ abstract = getName tycon `elemNameSet` abstract_tcs
+
+ ifaceConDecls _ | abstract = IfAbstractTyCon
+ ifaceConDecls (NewTyCon con _ _) = IfNewTyCon (ifaceConDecl con)
+ ifaceConDecls (DataTyCon cons _) = IfDataTyCon (map ifaceConDecl cons)
+ ifaceConDecls AbstractTyCon = IfAbstractTyCon
+ -- The last case should never happen when we are generating an
+ -- interface file (we're exporting this thing, so it's locally defined
+ -- and should not be abstract). But tyThingToIfaceDecl is also used
+ -- in TcRnDriver for GHCi, when browsing a module, in which case the
+ -- AbstractTyCon case is perfectly sensible.
ifaceConDecl data_con
= IfaceConDecl (getOccName (dataConName data_con))
+ (dataConIsInfix data_con)
(toIfaceTvBndrs ex_tyvars)
(toIfaceContext ext ex_theta)
(map (toIfaceType ext) arg_tys)
field_labels = dataConFieldLabels data_con
strict_marks = dataConStrictMarks data_con
- -- This case only happens in the call to ifaceThing in InteractiveUI
- -- Otherwise DataCons are filtered out in ifaceThing_acc
-tyThingToIfaceDecl _ _ ext (ADataCon dc)
- = IfaceId { ifName = getOccName dc,
- ifType = toIfaceType ext full_ty,
- ifIdInfo = NoInfo }
- where
- (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig dc
-
- -- The "stupid context" isn't part of the wrapper-Id type
- -- (for better or worse -- see note in DataCon.lhs), so we
- -- have to make it up here
- full_ty = mkSigmaTy (tvs ++ ex_tvs) (stupid_theta ++ ex_theta)
- (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tvs)))
+tyThingToIfaceDecl dis abstr ext (ADataCon dc)
+ = pprPanic "toIfaceDecl" (ppr dc)
+
--------------------------
-dfunToIfaceInst :: ModuleName -> DFunId -> IfaceInst
-dfunToIfaceInst mod dfun_id
- = IfaceInst { ifDFun = getOccName dfun_id,
+dfunToIfaceInst :: DFunId -> IfaceInst
+dfunToIfaceInst dfun_id
+ = IfaceInst { ifDFun = nameOccName dfun_name,
ifInstHead = toIfaceType (mkLhsNameFn mod) tidy_ty }
where
+ dfun_name = idName dfun_id
+ mod = nameModuleName dfun_name
(tvs, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
head_ty = mkForAllTys tvs (mkPredTy (mkClassPred cls tys))
-- No need to record the instance context;
has_worker = case work_info of { HasWorker _ _ -> True; other -> False }
wrkr_hsinfo = case work_info of
HasWorker work_id wrap_arity ->
- Just (HsWorker (getOccName work_id) wrap_arity)
+ Just (HsWorker (ext (idName work_id)) wrap_arity)
NoWorker -> Nothing
------------ Unfolding --------------
coreRuleToIfaceRule mod ext (id, Rule name act bndrs args rhs)
= IfaceRule { ifRuleName = name, ifActivation = act,
ifRuleBndrs = map (toIfaceBndr ext) bndrs,
- ifRuleHead = ext (getName id),
+ ifRuleHead = ext (idName id),
ifRuleArgs = map (toIfaceExpr (mkLhsNameFn mod)) args,
-- Use LHS name-fn for the args
ifRuleRhs = toIfaceExpr ext rhs }
eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
= bool (ifName d1 == ifName d2 &&
- ifND d1 == ifND d2 &&
ifRec d1 == ifRec d2 &&
ifVrcs d1 == ifVrcs d2 &&
ifGeneric d1 == ifGeneric d2) &&&
eq_ifaceExpr env rhs1 rhs2)
eqIfRule _ _ = NotEqual
-eq_hsCD env (DataCons c1) (DataCons c2) = eqListBy (eq_ConDecl env) c1 c2
-eq_hsCD env Unknown Unknown = Equal
-eq_hsCD env d1 d2 = NotEqual
+eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) = eqListBy (eq_ConDecl env) c1 c2
+eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2
+eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal
+eq_hsCD env d1 d2 = NotEqual
-eq_ConDecl env (IfaceConDecl n1 tvs1 cxt1 args1 ss1 lbls1)
- (IfaceConDecl n2 tvs2 cxt2 args2 ss2 lbls2)
- = bool (n1 == n2 && ss1 == ss2 && lbls1 == lbls2) &&&
+eq_ConDecl env (IfaceConDecl n1 inf1 tvs1 cxt1 args1 ss1 lbls1)
+ (IfaceConDecl n2 inf2 tvs2 cxt2 args2 ss2 lbls2)
+ = bool (n1 == n2 && inf1 == inf2 && ss1 == ss2 && lbls1 == lbls2) &&&
eq_ifTvBndrs env tvs1 tvs2 (\ env ->
eq_ifContext env cxt1 cxt2 &&&
eq_ifTypes env args1 args2)
\begin{code}
-----------------
eqIfIdInfo NoInfo NoInfo = Equal
-eqIfIdInfo DiscardedInfo DiscardedInfo = Equal -- Should not happen?
eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
eqIfIdInfo i1 i2 = NotEqual
eq_item (HsStrictness s1) (HsStrictness s2) = bool (s1 == s2)
eq_item (HsUnfold a1 u1) (HsUnfold a2 u2) = bool (a1 == a2) &&& eq_ifaceExpr emptyEqEnv u1 u2
eq_item HsNoCafRefs HsNoCafRefs = Equal
-eq_item (HsWorker occ1 a1) (HsWorker occ2 a2) = bool (a1==a2 && occ1==occ2)
+eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2)
eq_item _ _ = NotEqual
-----------------
projects / ghc-hetmet.git / blobdiff