X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=0d649fb6138730c919496fda15b8929624704678;hp=0801f10e1241c696ba0fc5bbae2d5544c11cf505;hb=e8a591c1a3dbdeccec2dd2aacccd7435004b0d51;hpb=30080d13aa518e200709906c90a3f0d28cf1c123 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 0801f10..0d649fb 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -38,7 +38,6 @@ import IfaceType import NewDemand ( StrictSig, pprIfaceStrictSig ) import TcType ( deNoteType ) import Class ( FunDep, DefMeth, pprFundeps ) -import TyCon ( ArgVrcs ) import OccName ( OccName, parenSymOcc, occNameFS, OccSet, unionOccSets, unitOccSet ) import UniqFM ( UniqFM, emptyUFM, addToUFM, lookupUFM ) @@ -76,17 +75,18 @@ data IfaceDecl ifCtxt :: IfaceContext, -- The "stupid theta" ifCons :: IfaceConDecls, -- Includes new/data info ifRec :: RecFlag, -- Recursive or not? - ifVrcs :: ArgVrcs, ifGadtSyntax :: Bool, -- True <=> declared using GADT syntax ifGeneric :: Bool -- True <=> generic converter functions available } -- We need this for imported data decls, since the -- imported modules may have been compiled with -- different flags to the current compilation unit - | IfaceSyn { ifName :: OccName, -- Type constructor - ifTyVars :: [IfaceTvBndr], -- Type variables - ifVrcs :: ArgVrcs, - ifSynRhs :: IfaceType -- synonym expansion + | IfaceSyn { ifName :: OccName, -- Type constructor + ifTyVars :: [IfaceTvBndr], -- Type variables + ifOpenSyn :: Bool, -- Is an open family? + ifSynRhs :: IfaceType -- Type for an ordinary + -- synonym and kind for an + -- open family } | IfaceClass { ifCtxt :: IfaceContext, -- Context... @@ -94,8 +94,7 @@ data IfaceDecl ifTyVars :: [IfaceTvBndr], -- Type variables ifFDs :: [FunDep FastString], -- Functional dependencies ifSigs :: [IfaceClassOp], -- Method signatures - ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive? - ifVrcs :: ArgVrcs -- ... and what are its argument variances ... + ifRec :: RecFlag -- Is newtype/datatype associated with the class recursive? } | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET @@ -108,11 +107,15 @@ data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType data IfaceConDecls = IfAbstractTyCon -- No info + | IfOpenDataTyCon -- Open data family + | IfOpenNewTyCon -- Open newtype family | IfDataTyCon [IfaceConDecl] -- data type decls | IfNewTyCon IfaceConDecl -- newtype decls visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] visibleIfConDecls IfAbstractTyCon = [] +visibleIfConDecls IfOpenDataTyCon = [] +visibleIfConDecls IfOpenNewTyCon = [] visibleIfConDecls (IfDataTyCon cs) = cs visibleIfConDecls (IfNewTyCon c) = [c] @@ -199,7 +202,7 @@ data IfaceNote = IfaceSCC CostCentre | IfaceCoreNote String type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr) - -- Note: OccName, not IfaceBndr (and same with the case binder) + -- Note: FastString, not IfaceBndr (and same with the case binder) -- We reconstruct the kind/type of the thing from the context -- thus saving bulk in interface files @@ -233,30 +236,35 @@ pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info}) pprIfaceDecl (IfaceForeign {ifName = tycon}) = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon] -pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, ifVrcs = vrcs}) +pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, + ifOpenSyn = False, ifSynRhs = mono_ty}) = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars) - 4 (vcat [equals <+> ppr mono_ty, - pprVrcs vrcs]) + 4 (equals <+> ppr mono_ty) + +pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, + ifOpenSyn = True, ifSynRhs = mono_ty}) + = hang (ptext SLIT("type family") <+> pprIfaceDeclHead [] tycon tyvars) + 4 (dcolon <+> ppr mono_ty) pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, ifTyVars = tyvars, ifCons = condecls, - ifRec = isrec, ifVrcs = vrcs}) + ifRec = isrec}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) - 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls tycon condecls]) + 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls]) where pp_nd = case condecls of IfAbstractTyCon -> ptext SLIT("data") + IfOpenDataTyCon -> ptext SLIT("data family") IfDataTyCon _ -> ptext SLIT("data") IfNewTyCon _ -> ptext SLIT("newtype") + IfOpenNewTyCon -> ptext SLIT("newtype family") pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, - ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec}) + ifFDs = fds, ifSigs = sigs, ifRec = isrec}) = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds) - 4 (vcat [pprVrcs vrcs, - pprRec isrec, + 4 (vcat [pprRec isrec, sep (map ppr sigs)]) -pprVrcs vrcs = ptext SLIT("Variances") <+> ppr vrcs pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec pprGen True = ptext SLIT("Generics: yes") pprGen False = ptext SLIT("Generics: no") @@ -269,7 +277,9 @@ pprIfaceDeclHead context thing tyvars = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), pprIfaceTvBndrs tyvars] pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}") +pp_condecls tc IfOpenNewTyCon = empty pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c +pp_condecls tc IfOpenDataTyCon = empty pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map (pprIfaceConDecl tc) cs)) @@ -288,7 +298,8 @@ pprIfaceConDecl tc main_payload = ppr name <+> dcolon <+> pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) (ppr con_tau) - eq_ctxt = [(IfaceEqPred (IfaceTyVar tv) ty) | (tv,ty) <- eq_spec] + eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty) + | (tv,ty) <- eq_spec] con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app]) tc_app = IfaceTyConApp (IfaceTc (LocalTop tc)) [IfaceTyVar tv | (tv,_) <- univ_tvs] @@ -513,7 +524,6 @@ eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {}) eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) = bool (ifName d1 == ifName d2 && ifRec d1 == ifRec d2 && - ifVrcs d1 == ifVrcs d2 && ifGadtSyntax d1 == ifGadtSyntax d2 && ifGeneric d1 == ifGeneric d2) &&& eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> @@ -532,8 +542,7 @@ eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {}) eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {}) = bool (ifName d1 == ifName d2 && - ifRec d1 == ifRec d2 && - ifVrcs d1 == ifVrcs d2) &&& + ifRec d1 == ifRec d2) &&& eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&& @@ -564,6 +573,8 @@ eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2 eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal +eq_hsCD env IfOpenDataTyCon IfOpenDataTyCon = Equal +eq_hsCD env IfOpenNewTyCon IfOpenNewTyCon = Equal eq_hsCD env d1 d2 = NotEqual eq_ConDecl env c1 c2