X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRules.lhs;h=4fc001714a4f8f34cb7978003d85ce88d692e5fe;hb=c2527e8dea810f1584609ad20408a38691131d28;hp=34aa3055106b3f8dafa367007b86b765b4084597;hpb=1c3601593186639f1086bc402582ff56fd3fe9f8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 34aa305..4fc0017 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -8,70 +8,52 @@ module TcRules ( tcRules ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..), HsTyVarBndr(..) ) -import CoreSyn ( CoreRule(..) ) -import RnHsSyn ( RenamedHsDecl ) -import TcHsSyn ( TypecheckedRuleDecl, mkHsLet ) -import TcMonad -import TcSimplify ( tcSimplifyToDicts, tcSimplifyAndCheck ) -import TcType ( zonkTcTypes, zonkTcTyVarToTyVar, newTyVarTy ) -import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar ) -import TcMonoType ( kcHsSigType, tcHsSigType, tcTyVars, checkSigTyVars ) -import TcExpr ( tcExpr ) -import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv ) -import Inst ( LIE, emptyLIE, plusLIEs, instToId ) -import Id ( idType, idName, mkVanillaId ) -import VarSet -import Type ( tyVarsOfTypes, openTypeKind ) -import Bag ( bagToList ) +import HsSyn ( RuleDecl(..), LRuleDecl, RuleBndr(..), collectRuleBndrSigTys, mkHsLet ) +import TcRnMonad +import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck ) +import TcMType ( newTyVarTy ) +import TcType ( tyVarsOfTypes, openTypeKind ) +import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddScopedTyVars ) +import TcExpr ( tcCheckRho ) +import TcEnv ( tcExtendLocalValEnv ) +import Inst ( instToId ) +import Id ( idType, mkLocalId ) +import Name ( Name ) +import SrcLoc ( noLoc, unLoc ) import Outputable \end{code} \begin{code} -tcRules :: [RenamedHsDecl] -> TcM (LIE, [TypecheckedRuleDecl]) -tcRules decls = mapAndUnzipTc tcRule [rule | RuleD rule <- decls] `thenTc` \ (lies, rules) -> - returnTc (plusLIEs lies, rules) - -tcRule (IfaceRule name vars fun args rhs src_loc) - = tcAddSrcLoc src_loc $ - tcAddErrCtxt (ruleCtxt name) $ - tcVar fun `thenTc` \ fun' -> - tcCoreLamBndrs vars $ \ vars' -> - mapTc tcCoreExpr args `thenTc` \ args' -> - tcCoreExpr rhs `thenTc` \ rhs' -> - returnTc (emptyLIE, IfaceRuleOut fun' (Rule name vars' args' rhs')) - -tcRule (IfaceRuleOut fun rule) - = tcVar fun `thenTc` \ fun' -> - returnTc (emptyLIE, IfaceRuleOut fun' rule) - -tcRule (HsRule name sig_tvs vars lhs rhs src_loc) - = tcAddSrcLoc src_loc $ - tcAddErrCtxt (ruleCtxt name) $ - newTyVarTy openTypeKind `thenNF_Tc` \ rule_ty -> +tcRules :: [LRuleDecl Name] -> TcM [LRuleDecl TcId] +tcRules decls = mappM (wrapLocM tcRule) decls + +tcRule :: RuleDecl Name -> TcM (RuleDecl TcId) +tcRule (HsRule name act vars lhs rhs) + = addErrCtxt (ruleCtxt name) $ + traceTc (ptext SLIT("---- Rule ------") + <+> ppr name) `thenM_` + newTyVarTy openTypeKind `thenM` \ rule_ty -> -- Deal with the tyvars mentioned in signatures - tcTyVars sig_tvs (mapTc_ kcHsSigType sig_tys) `thenTc` \ sig_tyvars -> - tcExtendTyVarEnv sig_tyvars ( + tcAddScopedTyVars (collectRuleBndrSigTys vars) ( -- Ditto forall'd variables - mapNF_Tc new_id vars `thenNF_Tc` \ ids -> - tcExtendLocalValEnv [(idName id, id) | id <- ids] $ + mappM new_id vars `thenM` \ ids -> + tcExtendLocalValEnv ids $ -- Now LHS and RHS - tcExpr lhs rule_ty `thenTc` \ (lhs', lhs_lie) -> - tcExpr rhs rule_ty `thenTc` \ (rhs', rhs_lie) -> + getLIE (tcCheckRho lhs rule_ty) `thenM` \ (lhs', lhs_lie) -> + getLIE (tcCheckRho rhs rule_ty) `thenM` \ (rhs', rhs_lie) -> - returnTc (sig_tyvars, ids, lhs', rhs', lhs_lie, rhs_lie) - ) `thenTc` \ (sig_tyvars, ids, lhs', rhs', lhs_lie, rhs_lie) -> + returnM (ids, lhs', rhs', lhs_lie, rhs_lie) + ) `thenM` \ (ids, lhs', rhs', lhs_lie, rhs_lie) -> -- Check that LHS has no overloading at all - tcSimplifyToDicts lhs_lie `thenTc` \ (lhs_dicts, lhs_binds) -> - checkSigTyVars sig_tyvars emptyVarSet `thenTc_` + getLIE (tcSimplifyToDicts lhs_lie) `thenM` \ (lhs_binds, lhs_dicts) -> -- Gather the template variables and tyvars let - tpl_ids = map instToId (bagToList lhs_dicts) ++ ids + tpl_ids = map instToId lhs_dicts ++ ids -- IMPORTANT! We *quantify* over any dicts that appear in the LHS -- Reason: @@ -83,31 +65,43 @@ tcRule (HsRule name sig_tvs vars lhs rhs src_loc) -- b) We'd like to make available the dictionaries bound -- on the LHS in the RHS, so quantifying over them is good -- See the 'lhs_dicts' in tcSimplifyAndCheck for the RHS - in - - -- Gather type variables to quantify over - -- and turn them into real TyVars (just as in TcBinds.tcBindWithSigs) - zonkTcTypes (rule_ty : map idType tpl_ids) `thenNF_Tc` \ zonked_tys -> - mapTc zonkTcTyVarToTyVar (varSetElems (tyVarsOfTypes zonked_tys)) `thenTc` \ tvs -> + -- We initially quantify over any tyvars free in *either* the rule + -- *or* the bound variables. The latter is important. Consider + -- ss (x,(y,z)) = (x,z) + -- RULE: forall v. fst (ss v) = fst v + -- The type of the rhs of the rule is just a, but v::(a,(b,c)) + -- + -- We also need to get the free tyvars of the LHS; but we do that + -- during zonking (see TcHsSyn.zonkRule) + -- + forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids) + in -- RHS can be a bit more lenient. In particular, -- we let constant dictionaries etc float outwards - tcSimplifyAndCheck (text "tcRule") (mkVarSet tvs) - lhs_dicts rhs_lie `thenTc` \ (lie', rhs_binds) -> - - returnTc (lie', HsRule name tvs - (map RuleBndr tpl_ids) -- yuk - (mkHsLet lhs_binds lhs') - (mkHsLet rhs_binds rhs') - src_loc) + -- + -- NB: tcSimplifyInferCheck zonks the forall_tvs, and + -- knocks out any that are constrained by the environment + tcSimplifyInferCheck (text "tcRule") + forall_tvs + lhs_dicts rhs_lie `thenM` \ (forall_tvs1, rhs_binds) -> + + returnM (HsRule name act + (map (RuleBndr . noLoc) (forall_tvs1 ++ tpl_ids)) -- yuk + (mkHsLet lhs_binds lhs') + (mkHsLet rhs_binds rhs')) where - sig_tys = [t | RuleBndrSig _ t <- vars] - - new_id (RuleBndr var) = newTyVarTy openTypeKind `thenNF_Tc` \ ty -> - returnNF_Tc (mkVanillaId var ty) - new_id (RuleBndrSig var rn_ty) = tcHsSigType rn_ty `thenTc` \ ty -> - returnNF_Tc (mkVanillaId var ty) + new_id (RuleBndr var) = newTyVarTy openTypeKind `thenM` \ ty -> + returnM (mkLocalId (unLoc var) ty) + new_id (RuleBndrSig var rn_ty) = tcHsSigType (RuleSigCtxt nl_var) rn_ty `thenM` \ ty -> + returnM (mkLocalId nl_var ty) + where + nl_var = unLoc var ruleCtxt name = ptext SLIT("When checking the transformation rule") <+> - doubleQuotes (ptext name) + doubleQuotes (ftext name) \end{code} + + + +