2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[TcRules]{Typechecking transformation rules}
7 module TcRules ( tcIfaceRules, tcSourceRules ) where
9 #include "HsVersions.h"
11 import HsSyn ( RuleDecl(..), RuleBndr(..) )
12 import CoreSyn ( CoreRule(..) )
13 import RnHsSyn ( RenamedRuleDecl )
14 import HscTypes ( PackageRuleBase )
15 import TcHsSyn ( TypecheckedRuleDecl, mkHsLet )
17 import TcSimplify ( tcSimplifyToDicts, tcSimplifyAndCheck )
18 import TcType ( zonkTcTypes, zonkTcTyVarToTyVar, newTyVarTy )
19 import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar )
20 import TcMonoType ( kcHsSigType, tcHsSigType, tcTyVars, checkSigTyVars )
21 import TcExpr ( tcExpr )
22 import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv, isLocalThing )
23 import Rules ( extendRuleBase )
24 import Inst ( LIE, plusLIEs, instToId )
25 import Id ( idType, idName, mkVanillaId )
26 import Module ( Module )
28 import Type ( tyVarsOfTypes, openTypeKind )
29 import Bag ( bagToList )
30 import List ( partition )
35 tcIfaceRules :: PackageRuleBase -> Module -> [RenamedRuleDecl]
36 -> TcM (PackageRuleBase, [TypecheckedRuleDecl])
37 tcIfaceRules pkg_rule_base mod decls
38 = mapTc tcIfaceRule decls `thenTc` \ new_rules ->
40 (local_rules, imported_rules) = partition is_local new_rules
41 new_rule_base = foldl add pkg_rule_base imported_rules
43 returnTc (new_rule_base, local_rules)
45 add rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
47 -- When relinking this module from its interface-file decls
48 -- we'll have IfaceRules that are in fact local to this module
49 is_local (IfaceRuleOut n _) = isLocalThing mod n
52 tcIfaceRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl
53 -- No zonking necessary!
54 tcIfaceRule (IfaceRule name vars fun args rhs src_loc)
55 = tcAddSrcLoc src_loc $
56 tcAddErrCtxt (ruleCtxt name) $
57 tcVar fun `thenTc` \ fun' ->
58 tcCoreLamBndrs vars $ \ vars' ->
59 mapTc tcCoreExpr args `thenTc` \ args' ->
60 tcCoreExpr rhs `thenTc` \ rhs' ->
61 returnTc (IfaceRuleOut fun' (Rule name vars' args' rhs'))
64 tcSourceRules :: [RenamedRuleDecl] -> TcM (LIE, [TypecheckedRuleDecl])
66 = mapAndUnzipTc tcSourceRule decls `thenTc` \ (lies, decls') ->
67 returnTc (plusLIEs lies, decls')
69 tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc)
70 = tcAddSrcLoc src_loc $
71 tcAddErrCtxt (ruleCtxt name) $
72 newTyVarTy openTypeKind `thenNF_Tc` \ rule_ty ->
74 -- Deal with the tyvars mentioned in signatures
75 tcTyVars sig_tvs (mapTc_ kcHsSigType sig_tys) `thenTc` \ sig_tyvars ->
76 tcExtendTyVarEnv sig_tyvars (
78 -- Ditto forall'd variables
79 mapNF_Tc new_id vars `thenNF_Tc` \ ids ->
80 tcExtendLocalValEnv [(idName id, id) | id <- ids] $
83 tcExpr lhs rule_ty `thenTc` \ (lhs', lhs_lie) ->
84 tcExpr rhs rule_ty `thenTc` \ (rhs', rhs_lie) ->
86 returnTc (sig_tyvars, ids, lhs', rhs', lhs_lie, rhs_lie)
87 ) `thenTc` \ (sig_tyvars, ids, lhs', rhs', lhs_lie, rhs_lie) ->
89 -- Check that LHS has no overloading at all
90 tcSimplifyToDicts lhs_lie `thenTc` \ (lhs_dicts, lhs_binds) ->
91 checkSigTyVars sig_tyvars emptyVarSet `thenTc_`
93 -- Gather the template variables and tyvars
95 tpl_ids = map instToId (bagToList lhs_dicts) ++ ids
97 -- IMPORTANT! We *quantify* over any dicts that appear in the LHS
99 -- a) The particular dictionary isn't important, because its value
100 -- depends only on the type
101 -- e.g gcd Int $fIntegralInt
102 -- Here we'd like to match against (gcd Int any_d) for any 'any_d'
104 -- b) We'd like to make available the dictionaries bound
105 -- on the LHS in the RHS, so quantifying over them is good
106 -- See the 'lhs_dicts' in tcSimplifyAndCheck for the RHS
109 -- Gather type variables to quantify over
110 -- and turn them into real TyVars (just as in TcBinds.tcBindWithSigs)
111 zonkTcTypes (rule_ty : map idType tpl_ids) `thenNF_Tc` \ zonked_tys ->
112 mapTc zonkTcTyVarToTyVar (varSetElems (tyVarsOfTypes zonked_tys)) `thenTc` \ tvs ->
114 -- RHS can be a bit more lenient. In particular,
115 -- we let constant dictionaries etc float outwards
116 tcSimplifyAndCheck (text "tcRule") (mkVarSet tvs)
117 lhs_dicts rhs_lie `thenTc` \ (lie', rhs_binds) ->
119 returnTc (lie', HsRule name tvs
120 (map RuleBndr tpl_ids) -- yuk
121 (mkHsLet lhs_binds lhs')
122 (mkHsLet rhs_binds rhs')
125 sig_tys = [t | RuleBndrSig _ t <- vars]
127 new_id (RuleBndr var) = newTyVarTy openTypeKind `thenNF_Tc` \ ty ->
128 returnNF_Tc (mkVanillaId var ty)
129 new_id (RuleBndrSig var rn_ty) = tcHsSigType rn_ty `thenTc` \ ty ->
130 returnNF_Tc (mkVanillaId var ty)
132 ruleCtxt name = ptext SLIT("When checking the transformation rule") <+>
133 doubleQuotes (ptext name)