eqIfDecl, eqIfInst, eqIfRule,
-- Pretty printing
- pprIfaceExpr, pprIfaceDecl
+ pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead
) where
#include "HsVersions.h"
tyConHasGenerics, tyConArgVrcs, tyConTheta, getSynTyConDefn,
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,
data IfaceConDecl
= IfaceConDecl OccName -- Constructor name
+ Bool -- True <=> declared infix
[IfaceTvBndr] -- Existental tyvars
IfaceContext -- Existential context
[IfaceType] -- Arg types
= 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 {ifCtxt = context, ifName = tycon, ifGeneric = gen,
ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifVrcs = vrcs})
- = hang (pp_nd <+> 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
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 IfAbstractTyCon = ptext SLIT("{- abstract -}")
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
ifaceConDecls _ | abstract = IfAbstractTyCon
ifaceConDecls (NewTyCon con _ _) = IfNewTyCon (ifaceConDecl con)
ifaceConDecls (DataTyCon cons _) = IfDataTyCon (map ifaceConDecl cons)
- ifaceConDecls AbstractTyCon = pprPanic "ifaceConDecls" (ppr tycon)
- -- We're exporting this thing, so it's locally defined and should not be abstract
+ 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;
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)
projects / ghc-hetmet.git / blobdiff