X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRules.lhs;h=da8fda7cdce36ecec441a2eb6923769de16154a1;hb=47eef4b5780f0a5b5a37847097842daebd0f9285;hp=f52bba1a76e4fea58f6dc0d8abbec0eaa5abd757;hpb=69e14f75a4b031e489b7774914e5a176409cea78;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index f52bba1..da8fda7 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -8,94 +8,125 @@ module TcRules ( tcRules ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..), HsTyVar(..) ) -import HsCore ( UfRuleBody(..) ) -import RnHsSyn ( RenamedHsDecl ) +import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..) ) +import CoreSyn ( CoreRule(..) ) +import RnHsSyn ( RenamedHsDecl, RenamedRuleDecl ) +import HscTypes ( PackageRuleBase ) import TcHsSyn ( TypecheckedRuleDecl, mkHsLet ) import TcMonad -import TcSimplify ( tcSimplifyRuleLhs, tcSimplifyAndCheck ) -import TcType ( zonkTcTypes, newTyVarTy_OpenKind ) +import TcSimplify ( tcSimplifyToDicts, tcSimplifyAndCheck ) +import TcType ( zonkTcTypes, zonkTcTyVarToTyVar, newTyVarTy ) import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar ) -import TcMonoType ( tcHsType, tcHsTyVar, checkSigTyVars ) +import TcMonoType ( kcHsSigType, tcHsSigType, tcTyVars, checkSigTyVars ) import TcExpr ( tcExpr ) -import TcEnv ( tcExtendLocalValEnv, newLocalId, - tcExtendTyVarEnv - ) +import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv, isLocalThing ) +import Rules ( extendRuleBase ) import Inst ( LIE, emptyLIE, plusLIEs, instToId ) import Id ( idType, idName, mkVanillaId ) +import Module ( Module ) import VarSet -import Type ( tyVarsOfTypes ) +import Type ( tyVarsOfTypes, openTypeKind ) import Bag ( bagToList ) +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) +tcRules :: PackageRuleBase -> Module -> [RenamedHsDecl] + -> TcM (PackageRuleBase, LIE, [TypecheckedRuleDecl]) +tcRules pkg_rule_base mod decls + = mapAndUnzipTc tcRule [rule | RuleD rule <- decls] `thenTc` \ (lies, 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, plusLIEs lies, local_rules) + where + add rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule) -tcRule (IfaceRuleDecl fun (UfRuleBody name vars args rhs) src_loc) + -- 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 :: RenamedRuleDecl -> TcM (LIE, TypecheckedRuleDecl) + -- No zonking necessary! +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, IfaceRuleDecl fun' (CoreRuleBody name vars' args' rhs') src_loc) + returnTc (emptyLIE, IfaceRuleOut fun' (Rule name vars' args' rhs')) -tcRule (RuleDecl name sig_tvs vars lhs rhs src_loc) +tcRule (HsRule name sig_tvs vars lhs rhs src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (ruleCtxt name) $ - newTyVarTy_OpenKind `thenNF_Tc` \ rule_ty -> + 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 ( + tcTyVars sig_tvs (mapTc_ kcHsSigType sig_tys) `thenTc` \ sig_tyvars -> + tcExtendTyVarEnv sig_tyvars ( -- 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 tcExpr lhs rule_ty `thenTc` \ (lhs', lhs_lie) -> tcExpr rhs rule_ty `thenTc` \ (rhs', rhs_lie) -> - returnTc (ids, lhs', rhs', lhs_lie, rhs_lie) - ) `thenTc` \ (ids, lhs', rhs', lhs_lie, rhs_lie) -> + returnTc (sig_tyvars, ids, lhs', rhs', lhs_lie, rhs_lie) + ) `thenTc` \ (sig_tyvars, ids, lhs', rhs', lhs_lie, rhs_lie) -> -- Check that LHS has no overloading at all - tcSimplifyRuleLhs lhs_lie `thenTc` \ (lhs_dicts, lhs_binds) -> - checkSigTyVars sig_tyvars `thenTc_` + tcSimplifyToDicts lhs_lie `thenTc` \ (lhs_dicts, lhs_binds) -> + checkSigTyVars sig_tyvars emptyVarSet `thenTc_` -- Gather the template variables and tyvars let tpl_ids = map instToId (bagToList lhs_dicts) ++ ids + + -- IMPORTANT! We *quantify* over any dicts that appear in the LHS + -- Reason: + -- a) The particular dictionary isn't important, because its value + -- depends only on the type + -- e.g gcd Int $fIntegralInt + -- Here we'd like to match against (gcd Int any_d) for any 'any_d' + -- + -- 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 - in + -- 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 -> -- RHS can be a bit more lenient. In particular, -- we let constant dictionaries etc float outwards - tcSimplifyAndCheck (text "tcRule") tpl_tvs + tcSimplifyAndCheck (text "tcRule") (mkVarSet tvs) lhs_dicts rhs_lie `thenTc` \ (lie', rhs_binds) -> - returnTc (lie', RuleDecl name (varSetElems tpl_tvs) + returnTc (lie', HsRule name tvs (map RuleBndr tpl_ids) -- yuk (mkHsLet lhs_binds lhs') (mkHsLet rhs_binds rhs') src_loc) where - new_id (RuleBndr var) = newTyVarTy_OpenKind `thenNF_Tc` \ ty -> + 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) = tcHsType rn_ty `thenTc` \ ty -> + new_id (RuleBndrSig var rn_ty) = tcHsSigType rn_ty `thenTc` \ ty -> returnNF_Tc (mkVanillaId var ty) ruleCtxt name = ptext SLIT("When checking the transformation rule") <+> doubleQuotes (ptext name) \end{code} + + + +