2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[TcRules]{Typechecking transformation rules}
7 module TcRules ( tcRules ) where
9 #include "HsVersions.h"
11 import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..), HsTyVar(..) )
12 import HsCore ( UfRuleBody(..) )
13 import RnHsSyn ( RenamedHsDecl )
14 import TcHsSyn ( TypecheckedRuleDecl, mkHsLet )
16 import TcSimplify ( tcSimplifyToDicts, tcSimplifyAndCheck )
17 import TcType ( zonkTcTypes, newTyVarTy_OpenKind )
18 import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar )
19 import TcMonoType ( tcHsType, tcHsTyVar, checkSigTyVars )
20 import TcExpr ( tcExpr )
21 import TcEnv ( tcExtendLocalValEnv, newLocalId,
24 import Inst ( LIE, emptyLIE, plusLIEs, instToId )
25 import Id ( idType, idName, mkVanillaId )
27 import Type ( tyVarsOfTypes )
28 import Bag ( bagToList )
34 tcRules :: [RenamedHsDecl] -> TcM s (LIE, [TypecheckedRuleDecl])
35 tcRules decls = mapAndUnzipTc tcRule [rule | RuleD rule <- decls] `thenTc` \ (lies, rules) ->
36 returnTc (plusLIEs lies, rules)
38 tcRule (IfaceRuleDecl fun (UfRuleBody name vars args rhs) src_loc)
39 = tcAddSrcLoc src_loc $
40 tcAddErrCtxt (ruleCtxt name) $
41 tcVar fun `thenTc` \ fun' ->
42 tcCoreLamBndrs vars $ \ vars' ->
43 mapTc tcCoreExpr args `thenTc` \ args' ->
44 tcCoreExpr rhs `thenTc` \ rhs' ->
45 returnTc (emptyLIE, IfaceRuleDecl fun' (CoreRuleBody name vars' args' rhs') src_loc)
47 tcRule (RuleDecl name sig_tvs vars lhs rhs src_loc)
48 = tcAddSrcLoc src_loc $
49 tcAddErrCtxt (ruleCtxt name) $
50 newTyVarTy_OpenKind `thenNF_Tc` \ rule_ty ->
52 -- Deal with the tyvars mentioned in signatures
53 -- Yuk to the UserTyVar
54 mapNF_Tc (tcHsTyVar . UserTyVar) sig_tvs `thenNF_Tc` \ sig_tyvars ->
55 tcExtendTyVarEnv sig_tyvars (
57 -- Ditto forall'd variables
58 mapNF_Tc new_id vars `thenNF_Tc` \ ids ->
59 tcExtendLocalValEnv [(idName id, id) | id <- ids] $
62 tcExpr lhs rule_ty `thenTc` \ (lhs', lhs_lie) ->
63 tcExpr rhs rule_ty `thenTc` \ (rhs', rhs_lie) ->
65 returnTc (ids, lhs', rhs', lhs_lie, rhs_lie)
66 ) `thenTc` \ (ids, lhs', rhs', lhs_lie, rhs_lie) ->
68 -- Check that LHS has no overloading at all
69 tcSimplifyToDicts lhs_lie `thenTc` \ (lhs_dicts, lhs_binds) ->
70 checkSigTyVars sig_tyvars `thenTc_`
72 -- Gather the template variables and tyvars
74 tpl_ids = map instToId (bagToList lhs_dicts) ++ ids
77 -- Gather type variables to quantify over
78 zonkTcTypes (rule_ty : map idType tpl_ids) `thenNF_Tc` \ zonked_tys ->
80 tpl_tvs = tyVarsOfTypes zonked_tys
83 -- RHS can be a bit more lenient. In particular,
84 -- we let constant dictionaries etc float outwards
85 tcSimplifyAndCheck (text "tcRule") tpl_tvs
86 lhs_dicts rhs_lie `thenTc` \ (lie', rhs_binds) ->
88 returnTc (lie', RuleDecl name (varSetElems tpl_tvs)
89 (map RuleBndr tpl_ids) -- yuk
90 (mkHsLet lhs_binds lhs')
91 (mkHsLet rhs_binds rhs')
94 new_id (RuleBndr var) = newTyVarTy_OpenKind `thenNF_Tc` \ ty ->
95 returnNF_Tc (mkVanillaId var ty)
96 new_id (RuleBndrSig var rn_ty) = tcHsType rn_ty `thenTc` \ ty ->
97 returnNF_Tc (mkVanillaId var ty)
99 ruleCtxt name = ptext SLIT("When checking the transformation rule") <+>
100 doubleQuotes (ptext name)