X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRules.lhs;h=69d462b468bccc8b96dceac7e4f9580e0d99e32f;hb=6339f4b081ea645bbba52d2c8a2dd38713b9ef2a;hp=da8fda7cdce36ecec441a2eb6923769de16154a1;hpb=2ecf1c9f639dc75f1078e88c2e551116923f742a;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs
index da8fda7..69d462b 100644
--- a/ghc/compiler/typecheck/TcRules.lhs
+++ b/ghc/compiler/typecheck/TcRules.lhs
@@ -4,43 +4,42 @@
 \section[TcRules]{Typechecking transformation rules}
 
 \begin{code}
-module TcRules ( tcRules ) where
+module TcRules ( tcIfaceRules, tcSourceRules ) where
 
 #include "HsVersions.h"
 
-import HsSyn		( HsDecl(..), RuleDecl(..), RuleBndr(..) )
+import HsSyn		( RuleDecl(..), RuleBndr(..) )
 import CoreSyn		( CoreRule(..) )
-import RnHsSyn		( RenamedHsDecl, RenamedRuleDecl )
+import RnHsSyn		( RenamedRuleDecl )
 import HscTypes		( PackageRuleBase )
 import TcHsSyn		( TypecheckedRuleDecl, mkHsLet )
 import TcMonad
-import TcSimplify	( tcSimplifyToDicts, tcSimplifyAndCheck )
-import TcType		( zonkTcTypes, zonkTcTyVarToTyVar, newTyVarTy )
+import TcSimplify	( tcSimplifyToDicts, tcSimplifyInferCheck )
+import TcType		( zonkTcTyVarToTyVar, newTyVarTy )
 import TcIfaceSig	( tcCoreExpr, tcCoreLamBndrs, tcVar )
 import TcMonoType	( kcHsSigType, tcHsSigType, tcTyVars, checkSigTyVars )
 import TcExpr		( tcExpr )
 import TcEnv		( tcExtendLocalValEnv, tcExtendTyVarEnv, isLocalThing )
 import Rules		( extendRuleBase )
-import Inst		( LIE, emptyLIE, plusLIEs, instToId )
-import Id		( idType, idName, mkVanillaId )
+import Inst		( LIE, plusLIEs, instToId )
+import Id		( idName, mkVanillaId )
 import Module		( Module )
 import VarSet
-import Type		( tyVarsOfTypes, openTypeKind )
-import Bag		( bagToList )
+import Type		( tyVarsOfType, openTypeKind )
 import List		( partition )
 import Outputable
 \end{code}
 
 \begin{code}
-tcRules :: PackageRuleBase -> Module -> [RenamedHsDecl] 
-	-> TcM (PackageRuleBase, LIE, [TypecheckedRuleDecl])
-tcRules pkg_rule_base mod decls 
-  = mapAndUnzipTc tcRule [rule | RuleD rule <- decls]	`thenTc` \ (lies, new_rules) ->
+tcIfaceRules :: PackageRuleBase -> Module -> [RenamedRuleDecl] 
+	     -> TcM (PackageRuleBase, [TypecheckedRuleDecl])
+tcIfaceRules pkg_rule_base mod decls 
+  = mapTc tcIfaceRule decls		`thenTc` \ 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)
+    returnTc (new_rule_base, local_rules)
   where
     add rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
 
@@ -49,18 +48,27 @@ tcRules pkg_rule_base mod decls
     is_local (IfaceRuleOut n _) = isLocalThing mod n
     is_local other		= True
 
-tcRule :: RenamedRuleDecl -> TcM (LIE, TypecheckedRuleDecl)
+tcIfaceRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl
   -- No zonking necessary!
-tcRule (IfaceRule name vars fun args rhs src_loc)
+tcIfaceRule rule@(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, IfaceRuleOut fun' (Rule name vars' args' rhs'))
+    let
+	new_rule :: TypecheckedRuleDecl
+	new_rule = IfaceRuleOut fun' (Rule name vars' args' rhs')
+    in
+    returnTc new_rule
 
-tcRule (HsRule name sig_tvs vars lhs rhs src_loc)
+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)
   = tcAddSrcLoc src_loc 				$
     tcAddErrCtxt (ruleCtxt name)			$
     newTyVarTy openTypeKind				`thenNF_Tc` \ rule_ty ->
@@ -81,12 +89,12 @@ tcRule (HsRule name sig_tvs vars lhs rhs src_loc)
     )						`thenTc` \ (sig_tyvars, ids, lhs', rhs', lhs_lie, rhs_lie) ->
 
 		-- Check that LHS has no overloading at all
-    tcSimplifyToDicts lhs_lie				`thenTc` \ (lhs_dicts, lhs_binds) ->
-    checkSigTyVars sig_tyvars emptyVarSet		`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
+	tpl_ids = map instToId lhs_dicts ++ ids
 
 	-- IMPORTANT!  We *quantify* over any dicts that appear in the LHS
 	-- Reason: 
@@ -100,16 +108,13 @@ tcRule (HsRule name sig_tvs vars lhs rhs src_loc)
 	--	   See the 'lhs_dicts' in tcSimplifyAndCheck for the RHS
     in
 
-	-- Gather type variables to quantify over
-	-- 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") (mkVarSet tvs)
-		       lhs_dicts rhs_lie		`thenTc` \ (lie', rhs_binds) ->
+    tcSimplifyInferCheck (text "tcRule")
+			 (varSetElems (tyVarsOfType rule_ty))
+			 lhs_dicts rhs_lie	`thenTc` \ (forall_tvs', lie', rhs_binds) ->
 
+    mapTc zonkTcTyVarToTyVar forall_tvs'		`thenTc` \ tvs ->
     returnTc (lie', HsRule	name tvs
 				(map RuleBndr tpl_ids)	-- yuk
 				(mkHsLet lhs_binds lhs')