X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=49fded9a59becb86e5ee89158c0020dfaac912d1;hp=950021e9863748f49c39852059e7b85ed61cb699;hb=86add45dbfb6f962b65e371143dd467ae783f9e7;hpb=94c24b443bc6cbad197feeab7de926f1fc713ea0 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 950021e..49fded9 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -67,14 +67,6 @@ data IfaceDecl ifRec :: RecFlag, -- Recursive or not? 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 ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) -- Just <=> instance of family -- Invariant: @@ -235,12 +227,13 @@ data IfaceExpr = IfaceLcl IfLclName | IfaceExt IfExtName | IfaceType IfaceType - | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted - | IfaceLam IfaceBndr IfaceExpr - | IfaceApp IfaceExpr IfaceExpr - | IfaceCase IfaceExpr IfLclName IfaceType [IfaceAlt] - | IfaceLet IfaceBinding IfaceExpr - | IfaceNote IfaceNote IfaceExpr + | IfaceCo IfaceType -- We re-use IfaceType for coercions + | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted + | IfaceLam IfaceBndr IfaceExpr + | IfaceApp IfaceExpr IfaceExpr + | IfaceCase IfaceExpr IfLclName [IfaceAlt] + | IfaceLet IfaceBinding IfaceExpr + | IfaceNote IfaceNote IfaceExpr | IfaceCast IfaceExpr IfaceCoercion | IfaceLit Literal | IfaceFCall ForeignCall IfaceType @@ -472,11 +465,11 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars) 4 (dcolon <+> ppr kind) -pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, +pprIfaceDecl (IfaceData {ifName = tycon, ifCtxt = context, ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifFamInst = mbFamInst}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) - 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls, + 4 (vcat [pprRec isrec, pp_condecls tycon condecls, pprFamily mbFamInst]) where pp_nd = case condecls of @@ -496,10 +489,6 @@ pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, pprRec :: RecFlag -> SDoc pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec -pprGen :: Bool -> SDoc -pprGen True = ptext (sLit "Generics: yes") -pprGen False = ptext (sLit "Generics: no") - pprFamily :: Maybe (IfaceTyCon, [IfaceType]) -> SDoc pprFamily Nothing = ptext (sLit "FamilyInstance: none") pprFamily (Just famInst) = ptext (sLit "FamilyInstance:") <+> ppr famInst @@ -600,6 +589,7 @@ pprIfaceExpr _ (IfaceLit l) = ppr l pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) pprIfaceExpr _ (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix) pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty +pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceType co pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (interpp'SP as) @@ -612,17 +602,17 @@ pprIfaceExpr add_par i@(IfaceLam _ _) collect bs (IfaceLam b e) = collect (b:bs) e collect bs e = (reverse bs, e) -pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)]) - = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty - <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") - <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, - pprIfaceExpr noParens rhs <+> char '}']) +pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) + = add_par (sep [ptext (sLit "case") + <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") + <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, + pprIfaceExpr noParens rhs <+> char '}']) -pprIfaceExpr add_par (IfaceCase scrut bndr ty alts) - = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty - <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") - <+> ppr bndr <+> char '{', - nest 2 (sep (map ppr_alt alts)) <+> char '}']) +pprIfaceExpr add_par (IfaceCase scrut bndr alts) + = add_par (sep [ptext (sLit "case") + <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") + <+> ppr bndr <+> char '{', + nest 2 (sep (map ppr_alt alts)) <+> char '}']) pprIfaceExpr _ (IfaceCast expr co) = sep [pprParendIfaceExpr expr, @@ -798,6 +788,8 @@ freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTvBndr tv &&& freeNamesIfType t freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t +freeNamesIfType (IfaceCoConApp tc ts) = + freeNamesIfCo tc &&& fnList freeNamesIfType ts freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet freeNamesIfTvBndrs = fnList freeNamesIfTvBndr @@ -840,16 +832,16 @@ freeNamesIfExpr :: IfaceExpr -> NameSet freeNamesIfExpr (IfaceExt v) = unitNameSet v freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty +freeNamesIfExpr (IfaceCo co) = freeNamesIfType co freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfType co freeNamesIfExpr (IfaceNote _n r) = freeNamesIfExpr r -freeNamesIfExpr (IfaceCase s _ ty alts) - = freeNamesIfExpr s +freeNamesIfExpr (IfaceCase s _ alts) + = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts - &&& freeNamesIfType ty where fn_alt (_con,_bs,r) = freeNamesIfExpr r @@ -875,6 +867,10 @@ freeNamesIfTc (IfaceTc tc) = unitNameSet tc -- ToDo: shouldn't we include IfaceIntTc & co.? freeNamesIfTc _ = emptyNameSet +freeNamesIfCo :: IfaceCoCon -> NameSet +freeNamesIfCo (IfaceCoAx tc) = unitNameSet tc +freeNamesIfCo _ = emptyNameSet + freeNamesIfRule :: IfaceRule -> NameSet freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f , ifRuleArgs = es, ifRuleRhs = rhs })