X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRules.lhs;h=25abd581898cfcbfb47e8f727ecdf78b726492b7;hb=84923cc7de2a93c22a2f72daf9ac863959efae13;hp=c7e951f343fa17a9d0e3de1bc9ae6fb87a9f2fca;hpb=5a8a219c131b56c75dbb3110da3ab5ae3715ff66;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs
index c7e951f..25abd58 100644
--- a/compiler/typecheck/TcRules.lhs
+++ b/compiler/typecheck/TcRules.lhs
@@ -1,25 +1,27 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The AQUA Project, Glasgow University, 1993-1998
 %
-\section[TcRules]{Typechecking transformation rules}
+
+TcRules: Typechecking transformation rules
 
 \begin{code}
 module TcRules ( tcRules ) where
 
 #include "HsVersions.h"
 
-import HsSyn		( RuleDecl(..), LRuleDecl, RuleBndr(..), mkHsDictLet )
+import HsSyn
 import TcRnMonad
-import TcSimplify	( tcSimplifyRuleLhs, tcSimplifyInferCheck )
-import TcMType		( newFlexiTyVarTy, zonkQuantifiedTyVar, tcSkolSigTyVars )
-import TcType		( tyVarsOfTypes, openTypeKind, SkolemInfo(..), substTyWith, mkTyVarTys )
-import TcHsType		( UserTypeCtxt(..), tcHsPatSigType )
-import TcExpr		( tcMonoExpr )
-import TcEnv		( tcExtendIdEnv, tcExtendTyVarEnv )
-import Inst		( instToId )
-import Id		( idType, mkLocalId )
-import Name		( Name )
-import SrcLoc		( noLoc, unLoc )
+import TcSimplify
+import TcMType
+import TcType
+import TcHsType
+import TcExpr
+import TcEnv
+import Inst
+import Id
+import Name
+import SrcLoc
 import Outputable
 \end{code}
 
@@ -76,14 +78,13 @@ tcRule (HsRule name act vars lhs fv_lhs rhs fv_rhs)
 	--
 	-- NB: tcSimplifyInferCheck zonks the forall_tvs, and 
 	--     knocks out any that are constrained by the environment
-    tcSimplifyInferCheck (text "tcRule")
+    getInstLoc (SigOrigin (RuleSkol name))	`thenM` \ loc -> 
+    tcSimplifyInferCheck loc
 			 forall_tvs
 			 lhs_dicts rhs_lie	`thenM` \ (forall_tvs1, rhs_binds) ->
-    mappM zonkQuantifiedTyVar forall_tvs1 	`thenM` \ forall_tvs2 ->
-	-- This zonk is exactly the same as the one in TcBinds.tcBindWithSigs
 
     returnM (HsRule name act
-		    (map (RuleBndr . noLoc) (forall_tvs2 ++ tpl_ids))	-- yuk
+		    (map (RuleBndr . noLoc) (forall_tvs1 ++ tpl_ids))	-- yuk
 		    (mkHsDictLet lhs_binds lhs') fv_lhs
 		    (mkHsDictLet rhs_binds rhs') fv_rhs)
 
@@ -98,7 +99,7 @@ tcRuleBndrs (RuleBndrSig var rn_ty : vars) thing_inside
 --  e.g 	x :: a->a
 --  The tyvar 'a' is brought into scope first, just as if you'd written
 --		a::*, x :: a->a
-  = do	{ let ctxt = RuleSigCtxt (unLoc var)
+  = do	{ let ctxt = FunSigCtxt (unLoc var)
 	; (tyvars, ty) <- tcHsPatSigType ctxt rn_ty
 	; let skol_tvs = tcSkolSigTyVars (SigSkol ctxt) tyvars
 	      id_ty = substTyWith tyvars (mkTyVarTys skol_tvs) ty