X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypecheck%2FTcRules.lhs;h=a26faa87f1a6bb7668d206dfae4c057ffea387e3;hb=f5fbd41ca7f30e0f8db3f7b280a044d5af138428;hp=1e37d8cd17e970984823bd864c83b5c1b5b7af2c;hpb=c7e7bc25c21e28651194d9d37a53a8820932fba7;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 1e37d8c..a26faa8 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -4,91 +4,74 @@ \section[TcRules]{Typechecking transformation rules} \begin{code} -module TcRules ( tcIfaceRules, tcSourceRules ) where +module TcRules ( tcRules ) where #include "HsVersions.h" -import HsSyn ( RuleDecl(..), RuleBndr(..) ) +import HsSyn ( RuleDecl(..), RuleBndr(..), collectRuleBndrSigTys ) import CoreSyn ( CoreRule(..) ) import RnHsSyn ( RenamedRuleDecl ) -import HscTypes ( PackageRuleBase ) import TcHsSyn ( TypecheckedRuleDecl, mkHsLet ) -import TcMonad +import TcRnMonad import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck ) -import TcType ( zonkTcTyVarToTyVar, newTyVarTy ) -import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar ) -import TcMonoType ( kcHsSigTypes, tcHsSigType, tcScopedTyVars, checkSigTyVars ) -import TcExpr ( tcExpr ) -import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv, isLocalThing ) -import Rules ( extendRuleBase ) -import Inst ( LIE, plusLIEs, instToId ) -import Id ( idName, idType, mkLocalId ) -import Module ( Module ) -import VarSet -import Type ( tyVarsOfTypes, openTypeKind ) -import List ( partition ) +import TcMType ( newTyVarTy ) +import TcUnify ( Expected(..) ) +import TcType ( tyVarsOfTypes, openTypeKind ) +import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs ) +import TcMonoType ( tcHsSigType, UserTypeCtxt(..), tcAddScopedTyVars ) +import TcExpr ( tcCheckRho ) +import TcEnv ( tcExtendLocalValEnv, tcLookupGlobalId, tcLookupId ) +import Inst ( instToId ) +import Id ( idType, mkLocalId ) import Outputable \end{code} \begin{code} -tcIfaceRules :: PackageRuleBase -> Module -> [RenamedRuleDecl] - -> TcM (PackageRuleBase, [TypecheckedRuleDecl]) -tcIfaceRules pkg_rule_base mod decls - = mapTc tcIfaceRule decls `thenTc` \ new_rules -> - let - (local_rules, imported_rules) = partition is_local new_rules - new_rule_base = foldl add pkg_rule_base imported_rules - in - returnTc (new_rule_base, local_rules) - where - add rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule) - - -- When relinking this module from its interface-file decls - -- we'll have IfaceRules that are in fact local to this module - is_local (IfaceRuleOut n _) = isLocalThing mod n - is_local other = True - -tcIfaceRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl - -- No zonking necessary! -tcIfaceRule rule@(IfaceRule name vars fun args rhs src_loc) - = tcAddSrcLoc src_loc $ - tcAddErrCtxt (ruleCtxt name) $ - tcVar fun `thenTc` \ fun' -> +tcRules :: [RenamedRuleDecl] -> TcM [TypecheckedRuleDecl] +tcRules decls = mappM tcRule decls + +tcRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl +tcRule (IfaceRule name act vars fun args rhs src_loc) + = addSrcLoc src_loc $ + addErrCtxt (ruleCtxt name) $ + tcLookupGlobalId fun `thenM` \ fun' -> tcCoreLamBndrs vars $ \ vars' -> - mapTc tcCoreExpr args `thenTc` \ args' -> - tcCoreExpr rhs `thenTc` \ rhs' -> - let - new_rule :: TypecheckedRuleDecl - new_rule = IfaceRuleOut fun' (Rule name vars' args' rhs') - in - returnTc new_rule - -tcSourceRules :: [RenamedRuleDecl] -> TcM (LIE, [TypecheckedRuleDecl]) -tcSourceRules decls - = mapAndUnzipTc tcSourceRule decls `thenTc` \ (lies, decls') -> - returnTc (plusLIEs lies, decls') - -tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc) - = tcAddSrcLoc src_loc $ - tcAddErrCtxt (ruleCtxt name) $ - newTyVarTy openTypeKind `thenNF_Tc` \ rule_ty -> + mappM tcCoreExpr args `thenM` \ args' -> + tcCoreExpr rhs `thenM` \ rhs' -> + returnM (IfaceRuleOut fun' (Rule name act vars' args' rhs')) + +tcRule (IfaceRuleOut fun rule) -- Built-in rules, and only built-in rules, + -- come this way. Usually IfaceRuleOut is only + -- used for the *output* of the type checker + = tcLookupId fun `thenM` \ fun' -> + -- NB: tcLookupId, not tcLookupGlobalId + -- Reason: when compiling GHC.Base, where eqString is defined, + -- we'll get the builtin rule for eqString, but eqString + -- will be in the *local* type environment. + -- Seems like a bit of a hack + returnM (IfaceRuleOut fun' rule) + +tcRule (HsRule name act vars lhs rhs src_loc) + = addSrcLoc src_loc $ + addErrCtxt (ruleCtxt name) $ + newTyVarTy openTypeKind `thenM` \ rule_ty -> -- Deal with the tyvars mentioned in signatures - tcScopedTyVars sig_tvs (kcHsSigTypes sig_tys) ( + 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 (ids, lhs', rhs', lhs_lie, rhs_lie) - ) `thenTc` \ (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) -> + getLIE (tcSimplifyToDicts lhs_lie) `thenM` \ (lhs_binds, lhs_dicts) -> -- Gather the template variables and tyvars let @@ -111,36 +94,33 @@ tcSourceRule (HsRule name sig_tvs 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. - forall_tvs = varSetElems (tyVarsOfTypes (rule_ty : map idType tpl_ids)) + -- 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) -> + lhs_dicts rhs_lie `thenM` \ (forall_tvs1, rhs_binds) -> - returnTc (lie', HsRule name forall_tvs1 - (map RuleBndr tpl_ids) -- yuk - (mkHsLet lhs_binds lhs') - (mkHsLet rhs_binds rhs') - src_loc) + returnM (HsRule name act + (map RuleBndr (forall_tvs1 ++ tpl_ids)) -- yuk + (mkHsLet lhs_binds lhs') + (mkHsLet rhs_binds rhs') + src_loc) where - sig_tys = [t | RuleBndrSig _ t <- vars] - - new_id (RuleBndr var) = newTyVarTy openTypeKind `thenNF_Tc` \ ty -> - returnNF_Tc (mkLocalId var ty) - new_id (RuleBndrSig var rn_ty) = tcHsSigType rn_ty `thenTc` \ ty -> - returnNF_Tc (mkLocalId var ty) + new_id (RuleBndr var) = newTyVarTy openTypeKind `thenM` \ ty -> + returnM (mkLocalId var ty) + new_id (RuleBndrSig var rn_ty) = tcHsSigType (RuleSigCtxt var) rn_ty `thenM` \ ty -> + returnM (mkLocalId var ty) ruleCtxt name = ptext SLIT("When checking the transformation rule") <+> - doubleQuotes (ptext name) + doubleQuotes (ftext name) \end{code}