TcRules.lhs 4.97 KB
Newer Older
1
2
3
4
5
6
%
% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[TcRules]{Typechecking transformation rules}

\begin{code}
7
module TcRules ( tcIfaceRules, tcSourceRules ) where
8
9
10

#include "HsVersions.h"

11
import HsSyn		( RuleDecl(..), RuleBndr(..) )
12
import CoreSyn		( CoreRule(..) )
13
import RnHsSyn		( RenamedRuleDecl )
14
import HscTypes		( PackageRuleBase )
15
16
import TcHsSyn		( TypecheckedRuleDecl, mkHsLet )
import TcMonad
17
import TcSimplify	( tcSimplifyToDicts, tcSimplifyInferCheck )
18
19
import TcMType		( newTyVarTy )
import TcType		( tyVarsOfTypes, openTypeKind )
20
import TcIfaceSig	( tcCoreExpr, tcCoreLamBndrs, tcVar )
21
import TcMonoType	( kcHsSigTypes, tcHsSigType, UserTypeCtxt(..), tcScopedTyVars )
22
import TcExpr		( tcExpr )
23
import TcEnv		( tcExtendLocalValEnv, isLocalThing )
24
import Rules		( extendRuleBase )
25
import Inst		( LIE, plusLIEs, instToId )
26
import Id		( idName, idType, mkLocalId )
27
import Module		( Module )
28
import List		( partition )
29
30
31
32
import Outputable
\end{code}

\begin{code}
33
34
35
36
tcIfaceRules :: PackageRuleBase -> Module -> [RenamedRuleDecl] 
	     -> TcM (PackageRuleBase, [TypecheckedRuleDecl])
tcIfaceRules pkg_rule_base mod decls 
  = mapTc tcIfaceRule decls		`thenTc` \ new_rules ->
37
38
39
40
    let
	(local_rules, imported_rules) = partition is_local new_rules
	new_rule_base = foldl add pkg_rule_base imported_rules
    in
41
    returnTc (new_rule_base, local_rules)
42
  where
43
    add rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
44

45
46
	-- When relinking this module from its interface-file decls
	-- we'll have IfaceRules that are in fact local to this module
47
    is_local (IfaceRuleOut n _) = isLocalThing mod n
48
49
    is_local other		= True

50
tcIfaceRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl
51
  -- No zonking necessary!
52
tcIfaceRule rule@(IfaceRule name vars fun args rhs src_loc)
53
54
55
56
57
58
  = tcAddSrcLoc src_loc 		$
    tcAddErrCtxt (ruleCtxt name)	$
    tcVar fun				`thenTc` \ fun' ->
    tcCoreLamBndrs vars			$ \ vars' ->
    mapTc tcCoreExpr args		`thenTc` \ args' ->
    tcCoreExpr rhs			`thenTc` \ rhs' ->
59
60
61
62
63
    let
	new_rule :: TypecheckedRuleDecl
	new_rule = IfaceRuleOut fun' (Rule name vars' args' rhs')
    in
    returnTc new_rule
64
65
66
67
68
69
70

tcSourceRules :: [RenamedRuleDecl] -> TcM (LIE, [TypecheckedRuleDecl])
tcSourceRules decls
  = mapAndUnzipTc tcSourceRule decls	`thenTc` \ (lies, decls') ->
    returnTc (plusLIEs lies, decls')

tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc)
71
72
  = tcAddSrcLoc src_loc 				$
    tcAddErrCtxt (ruleCtxt name)			$
73
    newTyVarTy openTypeKind				`thenNF_Tc` \ rule_ty ->
74
75

	-- Deal with the tyvars mentioned in signatures
76
    tcScopedTyVars sig_tvs (kcHsSigTypes sig_tys) 	(
77
78

		-- Ditto forall'd variables
79
	mapNF_Tc new_id vars					`thenNF_Tc` \ ids ->
80
81
82
83
84
85
	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) ->
	
86
87
	returnTc (ids, lhs', rhs', lhs_lie, rhs_lie)
    )						`thenTc` \ (ids, lhs', rhs', lhs_lie, rhs_lie) ->
88
89

		-- Check that LHS has no overloading at all
90
    tcSimplifyToDicts lhs_lie			`thenTc` \ (lhs_dicts, lhs_binds) ->
91
92
93

	-- Gather the template variables and tyvars
    let
94
	tpl_ids = map instToId lhs_dicts ++ ids
95
96
97
98
99
100
101
102
103
104
105

	-- 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
106
107
108
109
110
111
112
113
114
115
116

	-- 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.
117
	forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids)
118
119
120
121
    in

	-- RHS can be a bit more lenient.  In particular,
	-- we let constant dictionaries etc float outwards
122
123
	--
	-- 
124
    tcSimplifyInferCheck (text "tcRule")
125
126
			 forall_tvs
			 lhs_dicts rhs_lie	`thenTc` \ (forall_tvs1, lie', rhs_binds) ->
127

128
    returnTc (lie', HsRule	name forall_tvs1
129
130
131
132
133
				(map RuleBndr tpl_ids)	-- yuk
				(mkHsLet lhs_binds lhs')
				(mkHsLet rhs_binds rhs')
				src_loc)
  where
134
135
    sig_tys = [t | RuleBndrSig _ t <- vars]

136
    new_id (RuleBndr var) 	   = newTyVarTy openTypeKind			`thenNF_Tc` \ ty ->
137
		          	     returnNF_Tc (mkLocalId var ty)
138
    new_id (RuleBndrSig var rn_ty) = tcHsSigType (RuleSigCtxt var) rn_ty	`thenTc` \ ty ->
139
				     returnNF_Tc (mkLocalId var ty)
140
141
142
143

ruleCtxt name = ptext SLIT("When checking the transformation rule") <+> 
		doubleQuotes (ptext name)
\end{code}
144
145
146
147