X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRules.lhs;h=3925c6def3e535048aa4b0972a7c3d94a546c7b4;hp=83ec995f953e0030c0b43388a5651c2f25a32f47;hb=HEAD;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516 diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs index 83ec995..3925c6d 100644 --- a/compiler/typecheck/TcRules.lhs +++ b/compiler/typecheck/TcRules.lhs @@ -17,7 +17,6 @@ import TcHsType import TcExpr import TcEnv import Id -import Var ( Var ) import Name import VarSet import SrcLoc @@ -57,8 +56,8 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) ; (lhs', lhs_lie, rhs', rhs_lie, rule_ty) <- tcExtendTyVarEnv tv_bndrs $ tcExtendIdEnv id_bndrs $ - do { ((lhs', rule_ty), lhs_lie) <- getConstraints (tcInferRho lhs) - ; (rhs', rhs_lie) <- getConstraints (tcMonoExpr rhs rule_ty) + do { ((lhs', rule_ty), lhs_lie) <- captureConstraints (tcInferRho lhs) + ; (rhs', rhs_lie) <- captureConstraints (tcMonoExpr rhs rule_ty) ; return (lhs', lhs_lie, rhs', rhs_lie, rule_ty) } ; (lhs_dicts, lhs_ev_binds, rhs_ev_binds) @@ -89,9 +88,10 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) -- Now figure out what to quantify over -- c.f. TcSimplify.simplifyInfer - ; zonked_forall_tvs <- zonkTcTyVarsAndFV (varSetElems forall_tvs) + ; zonked_forall_tvs <- zonkTcTyVarsAndFV forall_tvs ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked - ; qtvs <- zonkQuantifiedTyVars (varSetElems (zonked_forall_tvs `minusVarSet` gbl_tvs)) + ; qtvs <- zonkQuantifiedTyVars $ + varSetElems (zonked_forall_tvs `minusVarSet` gbl_tvs) ; return (HsRule name act (map (RuleBndr . noLoc) (qtvs ++ tpl_ids)) -- yuk @@ -111,7 +111,7 @@ tcRuleBndrs (RuleBndrSig var rn_ty : rule_bndrs) -- a::*, x :: a->a = do { let ctxt = FunSigCtxt (unLoc var) ; (tyvars, ty) <- tcHsPatSigType ctxt rn_ty - ; let skol_tvs = tcSkolSigTyVars (SigSkol ctxt) tyvars + ; let skol_tvs = tcSuperSkolTyVars tyvars id_ty = substTyWith tyvars (mkTyVarTys skol_tvs) ty id = mkLocalId (unLoc var) id_ty