X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRules.lhs;h=d78003b487a278921f20c142a294cda36b4305ba;hb=0cf6f8c36250e64b5b2bdf0bd6ed10e71984becc;hp=cf2f5b006578d0fd37d9f4ee5abb5a82be4551ea;hpb=a170160cc21678c30ca90696d4ae0fc1155f25bf;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index cf2f5b0..d78003b 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -4,77 +4,46 @@ \section[TcRules]{Typechecking transformation rules} \begin{code} -module TcRules ( tcIfaceRules, tcSourceRules ) where +module TcRules ( tcRules ) where #include "HsVersions.h" -import HsSyn ( RuleDecl(..), RuleBndr(..), collectRuleBndrSigTys ) -import CoreSyn ( CoreRule(..) ) -import RnHsSyn ( RenamedRuleDecl ) -import TcHsSyn ( TypecheckedRuleDecl, mkHsLet ) -import TcMonad +import HsSyn ( RuleDecl(..), LRuleDecl, RuleBndr(..), mkHsLet ) +import TcRnMonad import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck ) -import TcMType ( newTyVarTy ) +import TcMType ( newTyFlexiVarTy, zonkQuantifiedTyVar ) import TcType ( tyVarsOfTypes, openTypeKind ) -import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar ) -import TcMonoType ( tcHsSigType, UserTypeCtxt(..), tcAddScopedTyVars ) -import TcExpr ( tcMonoExpr ) -import TcEnv ( tcExtendLocalValEnv, tcLookupId ) -import Inst ( LIE, plusLIEs, emptyLIE, instToId ) +import TcHsType ( UserTypeCtxt(..), tcHsPatSigType ) +import TcExpr ( tcCheckRho ) +import TcEnv ( tcExtendIdEnv, tcExtendTyVarEnv ) +import Inst ( instToId ) import Id ( idType, mkLocalId ) +import Name ( Name ) +import SrcLoc ( noLoc, unLoc ) import Outputable \end{code} \begin{code} -tcIfaceRules :: [RenamedRuleDecl] -> TcM [TypecheckedRuleDecl] -tcIfaceRules decls = mapTc tcIfaceRule decls - -tcIfaceRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl - -- No zonking necessary! -tcIfaceRule (IfaceRule name act 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 (IfaceRuleOut fun' (Rule name act vars' args' rhs')) - -tcIfaceRule (IfaceRuleOut fun rule) -- Built-in rules come this way - = tcVar fun `thenTc` \ fun' -> - returnTc (IfaceRuleOut fun' rule) - -tcSourceRules :: [RenamedRuleDecl] -> TcM (LIE, [TypecheckedRuleDecl]) -tcSourceRules decls - = mapAndUnzipTc tcSourceRule decls `thenTc` \ (lies, decls') -> - returnTc (plusLIEs lies, decls') - -tcSourceRule (IfaceRuleOut fun rule) -- Built-in rules come this way - -- if they are from the module being compiled - = tcLookupId fun `thenTc` \ fun' -> - returnTc (emptyLIE, IfaceRuleOut fun' rule) - -tcSourceRule (HsRule name act 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 - -- Deal with the tyvars mentioned in signatures - tcAddScopedTyVars (collectRuleBndrSigTys vars) ( +tcRule :: RuleDecl Name -> TcM (RuleDecl TcId) +tcRule (HsRule name act vars lhs rhs) + = addErrCtxt (ruleCtxt name) $ + traceTc (ptext SLIT("---- Rule ------") + <+> ppr name) `thenM_` + newTyFlexiVarTy openTypeKind `thenM` \ rule_ty -> - -- Ditto forall'd variables - mapNF_Tc new_id vars `thenNF_Tc` \ ids -> - tcExtendLocalValEnv ids $ - + -- Deal with the tyvars mentioned in signatures + tcRuleBndrs vars (\ ids -> -- Now LHS and RHS - tcMonoExpr lhs rule_ty `thenTc` \ (lhs', lhs_lie) -> - tcMonoExpr rhs rule_ty `thenTc` \ (rhs', rhs_lie) -> - - returnTc (ids, lhs', rhs', lhs_lie, rhs_lie) - ) `thenTc` \ (ids, lhs', rhs', lhs_lie, rhs_lie) -> + getLIE (tcCheckRho lhs rule_ty) `thenM` \ (lhs', lhs_lie) -> + getLIE (tcCheckRho rhs rule_ty) `thenM` \ (rhs', 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) -> + getLIE (tcSimplifyToDicts lhs_lie) `thenM` \ (lhs_binds, lhs_dicts) -> -- Gather the template variables and tyvars let @@ -97,34 +66,43 @@ tcSourceRule (HsRule name act vars lhs rhs src_loc) -- RULE: forall v. fst (ss v) = fst v -- The type of the rhs of the rule is just a, but v::(a,(b,c)) -- - -- It's still conceivable that there may be type variables mentioned - -- in the LHS, but not in the type of the lhs, nor in the binders. - -- They'll get zapped to (), but that's over-constraining really. - -- Let's see if we get a problem. + -- 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 -- - -- + -- 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 `thenTc` \ (forall_tvs1, lie', rhs_binds) -> - - returnTc (lie', HsRule name act - (map RuleBndr (forall_tvs1 ++ tpl_ids)) -- yuk - (mkHsLet lhs_binds lhs') - (mkHsLet rhs_binds rhs') - src_loc) + lhs_dicts rhs_lie `thenM` \ (forall_tvs1, rhs_binds) -> + mappM zonkQuantifiedTyVar forall_tvs1 `thenM` \ forall_tvs2 -> + -- This zonk is exactly the same as the one in TcBinds.tcBindWithSigs + + returnM (HsRule name act + (map (RuleBndr . noLoc) (forall_tvs2 ++ tpl_ids)) -- yuk + (mkHsLet lhs_binds lhs') + (mkHsLet rhs_binds rhs')) where - new_id (RuleBndr var) = newTyVarTy openTypeKind `thenNF_Tc` \ ty -> - returnNF_Tc (mkLocalId var ty) - new_id (RuleBndrSig var rn_ty) = tcHsSigType (RuleSigCtxt var) rn_ty `thenTc` \ ty -> - returnNF_Tc (mkLocalId var ty) + +tcRuleBndrs [] thing_inside = thing_inside [] +tcRuleBndrs (RuleBndr var : vars) thing_inside + = do { ty <- newTyFlexiVarTy openTypeKind + ; let id = mkLocalId (unLoc var) ty + ; tcExtendIdEnv [id] $ + tcRuleBndrs vars (\ids -> thing_inside (id:ids)) } +tcRuleBndrs (RuleBndrSig var rn_ty : vars) thing_inside + = do { (tyvars, ty) <- tcHsPatSigType (RuleSigCtxt (unLoc var)) rn_ty + ; let id = mkLocalId (unLoc var) ty + ; tcExtendTyVarEnv tyvars $ + tcExtendIdEnv [id] $ + tcRuleBndrs vars (\ids -> thing_inside (id:ids)) } ruleCtxt name = ptext SLIT("When checking the transformation rule") <+> - doubleQuotes (ptext name) + doubleQuotes (ftext name) \end{code}