X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Ftypecheck%2FTcRules.lhs;h=2909910a0192f071db6477e42fbfaa2421f865e9;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hp=b14c2c94499f7feef61035c2168846aa47d04352;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs
index b14c2c9..2909910 100644
--- a/compiler/typecheck/TcRules.lhs
+++ b/compiler/typecheck/TcRules.lhs
@@ -1,25 +1,34 @@
 %
+% (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}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module TcRules ( tcRules ) where
 
 #include "HsVersions.h"
 
-import HsSyn		( RuleDecl(..), LRuleDecl, RuleBndr(..), mkHsDictLet )
+import HsSyn
 import TcRnMonad
-import TcSimplify	( tcSimplifyToDicts, 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}
 
@@ -43,7 +52,7 @@ tcRule (HsRule name act vars lhs fv_lhs rhs fv_rhs)
     )				`thenM` \ (ids, lhs', rhs', lhs_lie, rhs_lie) ->
 
 		-- Check that LHS has no overloading at all
-    getLIE (tcSimplifyToDicts lhs_lie)	`thenM` \ (lhs_binds, lhs_dicts) ->
+    tcSimplifyRuleLhs lhs_lie	`thenM` \ (lhs_dicts, lhs_binds) ->
 
 	-- Gather the template variables and tyvars
     let
@@ -76,17 +85,16 @@ 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)
-  where
+
 
 tcRuleBndrs [] thing_inside = thing_inside []
 tcRuleBndrs (RuleBndr var : vars) thing_inside
@@ -98,7 +106,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