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(..), HsTyVarBndr(..) )
12 import CoreSyn ( CoreRule(..) )
13 import RnHsSyn ( RenamedHsDecl )
14 import TcHsSyn ( TypecheckedRuleDecl, mkHsLet )
16 import TcSimplify ( tcSimplifyToDicts, tcSimplifyAndCheck )
17 import TcType ( zonkTcTypes, zonkTcTyVarToTyVar, newTyVarTy )
18 import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar )
19 import TcMonoType ( kcTyVarScope, kcHsSigType, tcHsSigType, newSigTyVars, checkSigTyVars )
20 import TcExpr ( tcExpr )
21 import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv )
22 import Inst ( LIE, emptyLIE, plusLIEs, instToId )
23 import Id ( idType, idName, mkVanillaId )
25 import Type ( tyVarsOfTypes, openTypeKind )
26 import Bag ( bagToList )
31 tcRules :: [RenamedHsDecl] -> TcM s (LIE, [TypecheckedRuleDecl])
32 tcRules decls = mapAndUnzipTc tcRule [rule | RuleD rule <- decls] `thenTc` \ (lies, rules) ->
33 returnTc (plusLIEs lies, rules)
35 tcRule (IfaceRule name vars fun args rhs src_loc)
36 = tcAddSrcLoc src_loc $
37 tcAddErrCtxt (ruleCtxt name) $
38 tcVar fun `thenTc` \ fun' ->
39 tcCoreLamBndrs vars $ \ vars' ->
40 mapTc tcCoreExpr args `thenTc` \ args' ->
41 tcCoreExpr rhs `thenTc` \ rhs' ->
42 returnTc (emptyLIE, IfaceRuleOut fun' (Rule name vars' args' rhs'))
44 tcRule (IfaceRuleOut fun rule)
45 = tcVar fun `thenTc` \ fun' ->
46 returnTc (emptyLIE, IfaceRuleOut fun' rule)
48 tcRule (HsRule name sig_tvs vars lhs rhs src_loc)
49 = tcAddSrcLoc src_loc $
50 tcAddErrCtxt (ruleCtxt name) $
51 newTyVarTy openTypeKind `thenNF_Tc` \ rule_ty ->
53 -- Deal with the tyvars mentioned in signatures
54 -- Yuk to the UserTyVar
55 kcTyVarScope (map UserTyVar sig_tvs)
56 (mapTc_ kcHsSigType sig_tys) `thenTc` \ sig_tv_kinds ->
57 newSigTyVars sig_tv_kinds `thenNF_Tc` \ sig_tyvars ->
58 tcExtendTyVarEnv sig_tyvars (
60 -- Ditto forall'd variables
61 mapNF_Tc new_id vars `thenNF_Tc` \ ids ->
62 tcExtendLocalValEnv [(idName id, id) | id <- ids] $
65 tcExpr lhs rule_ty `thenTc` \ (lhs', lhs_lie) ->
66 tcExpr rhs rule_ty `thenTc` \ (rhs', rhs_lie) ->
68 returnTc (ids, lhs', rhs', lhs_lie, rhs_lie)
69 ) `thenTc` \ (ids, lhs', rhs', lhs_lie, rhs_lie) ->
71 -- Check that LHS has no overloading at all
72 tcSimplifyToDicts lhs_lie `thenTc` \ (lhs_dicts, lhs_binds) ->
73 checkSigTyVars sig_tyvars emptyVarSet `thenTc_`
75 -- Gather the template variables and tyvars
77 tpl_ids = map instToId (bagToList lhs_dicts) ++ ids
79 -- IMPORTANT! We *quantify* over any dicts that appear in the LHS
81 -- a) The particular dictionary isn't important, because its value
82 -- depends only on the type
83 -- e.g gcd Int $fIntegralInt
84 -- Here we'd like to match against (gcd Int any_d) for any 'any_d'
86 -- b) We'd like to make available the dictionaries bound
87 -- on the LHS in the RHS, so quantifying over them is good
88 -- See the 'lhs_dicts' in tcSimplifyAndCheck for the RHS
91 -- Gather type variables to quantify over
92 -- and turn them into real TyVars (just as in TcBinds.tcBindWithSigs)
93 zonkTcTypes (rule_ty : map idType tpl_ids) `thenNF_Tc` \ zonked_tys ->
94 mapTc zonkTcTyVarToTyVar (varSetElems (tyVarsOfTypes zonked_tys)) `thenTc` \ tvs ->
96 -- RHS can be a bit more lenient. In particular,
97 -- we let constant dictionaries etc float outwards
98 tcSimplifyAndCheck (text "tcRule") (mkVarSet tvs)
99 lhs_dicts rhs_lie `thenTc` \ (lie', rhs_binds) ->
101 returnTc (lie', HsRule name tvs
102 (map RuleBndr tpl_ids) -- yuk
103 (mkHsLet lhs_binds lhs')
104 (mkHsLet rhs_binds rhs')
107 sig_tys = [t | RuleBndrSig _ t <- vars]
109 new_id (RuleBndr var) = newTyVarTy openTypeKind `thenNF_Tc` \ ty ->
110 returnNF_Tc (mkVanillaId var ty)
111 new_id (RuleBndrSig var rn_ty) = tcHsSigType rn_ty `thenTc` \ ty ->
112 returnNF_Tc (mkVanillaId var ty)
114 ruleCtxt name = ptext SLIT("When checking the transformation rule") <+>
115 doubleQuotes (ptext name)