X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRules.lhs;h=8af0a5379ec7ca84df2ca22c6607d54e427913b1;hb=6858f7c15fcf9efe9e6fdf22de34d0791b0f0c08;hp=ec9176134b19f16f31a5ba00f34e8a250d86b212;hpb=77a8c0dbd5c5ad90fe483cb9ddc2b6ef36d3f4d8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index ec91761..8af0a53 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -4,62 +4,84 @@ \section[TcRules]{Typechecking transformation rules} \begin{code} -module TcRules ( tcRules ) where +module TcRules ( tcIfaceRules, tcSourceRules ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..), HsTyVarBndr(..) ) +import HsSyn ( RuleDecl(..), RuleBndr(..) ) import CoreSyn ( CoreRule(..) ) -import RnHsSyn ( RenamedHsDecl ) +import RnHsSyn ( RenamedRuleDecl ) +import HscTypes ( PackageRuleBase ) import TcHsSyn ( TypecheckedRuleDecl, mkHsLet ) import TcMonad -import TcSimplify ( tcSimplifyToDicts, tcSimplifyAndCheck ) -import TcType ( zonkTcTypes, newTyVarTy ) -import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar ) -import TcMonoType ( tcHsSigType, tcHsTyVar, checkSigTyVars ) +import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck ) +import TcMType ( newTyVarTy ) +import TcType ( tyVarsOfTypes, openTypeKind ) +import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar, tcDelay ) +import TcMonoType ( kcHsSigTypes, tcHsSigType, UserTypeCtxt(..), tcScopedTyVars ) import TcExpr ( tcExpr ) -import TcEnv ( tcExtendLocalValEnv, newLocalId, - tcExtendTyVarEnv - ) -import Inst ( LIE, emptyLIE, plusLIEs, instToId ) -import Id ( idType, idName, mkVanillaId ) -import VarSet -import Type ( tyVarsOfTypes, openTypeKind ) -import Bag ( bagToList ) +import TcEnv ( RecTcEnv, tcExtendLocalValEnv, isLocalThing ) +import Rules ( extendRuleBase ) +import Inst ( LIE, plusLIEs, instToId ) +import Id ( idName, idType, mkLocalId ) +import Module ( Module ) +import List ( partition ) import Outputable -import Util \end{code} \begin{code} -tcRules :: [RenamedHsDecl] -> TcM s (LIE, [TypecheckedRuleDecl]) -tcRules decls = mapAndUnzipTc tcRule [rule | RuleD rule <- decls] `thenTc` \ (lies, rules) -> - returnTc (plusLIEs lies, rules) +tcIfaceRules :: RecTcEnv -> PackageRuleBase -> Module -> [RenamedRuleDecl] + -> TcM (PackageRuleBase, [TypecheckedRuleDecl]) +tcIfaceRules unf_env pkg_rule_base mod decls + = tcDelay unf_env doc [] ( + -- We need the recursive env because the built-in rules show up as + -- IfaceOut rules, sot they get typechecked by tcIfaceRules + 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 + doc = text "tcIfaceRules" + 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 -tcRule (IfaceRule name vars fun args rhs src_loc) +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 (emptyLIE, IfaceRuleOut fun' (Rule name vars' args' rhs')) + returnTc (IfaceRuleOut fun' (Rule name act vars' args' rhs')) -tcRule (IfaceRuleOut fun rule) +tcIfaceRule (IfaceRuleOut fun rule) -- Built-in rules come this way = tcVar fun `thenTc` \ fun' -> - returnTc (emptyLIE, IfaceRuleOut fun' rule) + returnTc (IfaceRuleOut fun' rule) -tcRule (HsRule name sig_tvs vars lhs rhs src_loc) +tcSourceRules :: [RenamedRuleDecl] -> TcM (LIE, [TypecheckedRuleDecl]) +tcSourceRules decls + = mapAndUnzipTc tcSourceRule decls `thenTc` \ (lies, decls') -> + returnTc (plusLIEs lies, decls') + +tcSourceRule (HsRule name act sig_tvs vars lhs rhs src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (ruleCtxt name) $ newTyVarTy openTypeKind `thenNF_Tc` \ rule_ty -> -- Deal with the tyvars mentioned in signatures - -- Yuk to the UserTyVar - mapNF_Tc (tcHsTyVar . UserTyVar) sig_tvs `thenNF_Tc` \ sig_tyvars -> - tcExtendTyVarEnv sig_tyvars ( + tcScopedTyVars sig_tvs (kcHsSigTypes sig_tys) ( -- Ditto forall'd variables - mapNF_Tc new_id vars `thenNF_Tc` \ ids -> + mapNF_Tc new_id vars `thenNF_Tc` \ ids -> tcExtendLocalValEnv [(idName id, id) | id <- ids] $ -- Now LHS and RHS @@ -70,12 +92,11 @@ tcRule (HsRule name sig_tvs vars lhs rhs src_loc) ) `thenTc` \ (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_` + tcSimplifyToDicts lhs_lie `thenTc` \ (lhs_dicts, lhs_binds) -> -- 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: @@ -87,30 +108,45 @@ 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 - zonkTcTypes (rule_ty : map idType tpl_ids) `thenNF_Tc` \ zonked_tys -> - let - tpl_tvs = tyVarsOfTypes zonked_tys + -- 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)) + -- + -- 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 = 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") tpl_tvs - lhs_dicts rhs_lie `thenTc` \ (lie', rhs_binds) -> + -- + -- + tcSimplifyInferCheck (text "tcRule") + forall_tvs + lhs_dicts rhs_lie `thenTc` \ (forall_tvs1, lie', rhs_binds) -> - returnTc (lie', HsRule name (varSetElems tpl_tvs) + returnTc (lie', HsRule name act forall_tvs1 (map RuleBndr tpl_ids) -- yuk (mkHsLet lhs_binds lhs') (mkHsLet rhs_binds rhs') src_loc) where - 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) + 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 (RuleSigCtxt var) rn_ty `thenTc` \ ty -> + returnNF_Tc (mkLocalId var ty) ruleCtxt name = ptext SLIT("When checking the transformation rule") <+> doubleQuotes (ptext name) \end{code} + + + +