X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRules.lhs;h=4fc001714a4f8f34cb7978003d85ce88d692e5fe;hb=c2527e8dea810f1584609ad20408a38691131d28;hp=f4d8a855c5d7366b075e19df4f664fea140c3f16;hpb=dd214d28a58f10af4355c887674ea692aff37efe;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs
index f4d8a85..4fc0017 100644
--- a/ghc/compiler/typecheck/TcRules.lhs
+++ b/ghc/compiler/typecheck/TcRules.lhs
@@ -4,80 +4,52 @@
 \section[TcRules]{Typechecking transformation rules}
 
 \begin{code}
-module TcRules ( tcIfaceRules, tcSourceRules ) where
+module TcRules ( tcRules ) where
 
 #include "HsVersions.h"
 
-import HsSyn		( RuleDecl(..), RuleBndr(..), collectRuleBndrSigTys )
-import CoreSyn		( CoreRule(..) )
-import RnHsSyn		( RenamedRuleDecl )
-import HscTypes		( PackageRuleBase )
-import TcHsSyn		( TypecheckedRuleDecl, mkHsLet )
-import TcMonad
+import HsSyn		( RuleDecl(..), LRuleDecl, RuleBndr(..), collectRuleBndrSigTys, mkHsLet )
+import TcRnMonad
 import TcSimplify	( tcSimplifyToDicts, tcSimplifyInferCheck )
 import TcMType		( newTyVarTy )
 import TcType		( tyVarsOfTypes, openTypeKind )
-import TcIfaceSig	( tcCoreExpr, tcCoreLamBndrs, tcVar, tcDelay )
-import TcMonoType	( tcHsSigType, UserTypeCtxt(..), tcAddScopedTyVars )
-import TcExpr		( tcExpr )
-import TcEnv		( RecTcEnv, tcExtendLocalValEnv, isLocalThing, tcLookupId )
-import Inst		( LIE, plusLIEs, emptyLIE, instToId )
-import Id		( idName, idType, mkLocalId )
-import Module		( Module )
-import List		( partition )
+import TcHsType		( tcHsSigType, UserTypeCtxt(..), tcAddScopedTyVars )
+import TcExpr		( tcCheckRho )
+import TcEnv		( tcExtendLocalValEnv )
+import Inst		( instToId )
+import Id		( idType, mkLocalId )
+import Name		( Name )
+import SrcLoc		( noLoc, unLoc )
 import Outputable
 \end{code}
 
 \begin{code}
-tcIfaceRules :: [RenamedRuleDecl] -> TcM [TypecheckedRuleDecl]
-tcIfaceRules decls = mapTc tcIfaceRule decls
-
-tcIfaceRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl
-  -- No zonking necessary!
-tcIfaceRule (IfaceRule name act 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 (IfaceRuleOut fun' (Rule name act vars' args' rhs'))
-
-tcIfaceRule (IfaceRuleOut fun rule)	-- Built-in rules come this way
-  = tcVar fun				`thenTc` \ fun' ->
-    returnTc (IfaceRuleOut fun' rule)   
-
-tcSourceRules :: [RenamedRuleDecl] -> TcM (LIE, [TypecheckedRuleDecl])
-tcSourceRules decls
-  = mapAndUnzipTc tcSourceRule decls	`thenTc` \ (lies, decls') ->
-    returnTc (plusLIEs lies, decls')
-
-tcSourceRule (IfaceRuleOut fun rule)	-- Built-in rules come this way
-					-- if they are from the module being compiled
-  = tcLookupId fun			`thenTc` \ fun' ->
-    returnTc (emptyLIE, IfaceRuleOut fun' rule)   
-
-tcSourceRule (HsRule name act vars lhs rhs src_loc)
-  = tcAddSrcLoc src_loc 				$
-    tcAddErrCtxt (ruleCtxt name)			$
-    newTyVarTy openTypeKind				`thenNF_Tc` \ rule_ty ->
+tcRules :: [LRuleDecl Name] -> TcM [LRuleDecl TcId]
+tcRules decls = mappM (wrapLocM tcRule) decls
+
+tcRule :: RuleDecl Name -> TcM (RuleDecl TcId)
+tcRule (HsRule name act vars lhs rhs)
+  = addErrCtxt (ruleCtxt name)			$
+    traceTc (ptext SLIT("---- Rule ------")
+		 <+> ppr name)			`thenM_` 
+    newTyVarTy openTypeKind			`thenM` \ rule_ty ->
 
 	-- Deal with the tyvars mentioned in signatures
     tcAddScopedTyVars (collectRuleBndrSigTys vars) (
 
 		-- Ditto forall'd variables
-	mapNF_Tc new_id vars					`thenNF_Tc` \ ids ->
-	tcExtendLocalValEnv [(idName id, id) | id <- ids]	$
+	mappM new_id vars			`thenM` \ ids ->
+	tcExtendLocalValEnv ids			$
 	
 		-- Now LHS and RHS
-	tcExpr lhs rule_ty					`thenTc` \ (lhs', lhs_lie) ->
-	tcExpr rhs rule_ty					`thenTc` \ (rhs', rhs_lie) ->
+	getLIE (tcCheckRho lhs rule_ty)	`thenM` \ (lhs', lhs_lie) ->
+	getLIE (tcCheckRho rhs rule_ty)	`thenM` \ (rhs', rhs_lie) ->
 	
-	returnTc (ids, lhs', rhs', lhs_lie, rhs_lie)
-    )						`thenTc` \ (ids, lhs', rhs', lhs_lie, rhs_lie) ->
+	returnM (ids, lhs', rhs', lhs_lie, rhs_lie)
+    )				`thenM` \ (ids, lhs', rhs', lhs_lie, rhs_lie) ->
 
 		-- Check that LHS has no overloading at all
-    tcSimplifyToDicts lhs_lie			`thenTc` \ (lhs_dicts, lhs_binds) ->
+    getLIE (tcSimplifyToDicts lhs_lie)	`thenM` \ (lhs_binds, lhs_dicts) ->
 
 	-- Gather the template variables and tyvars
     let
@@ -100,34 +72,34 @@ tcSourceRule (HsRule name act vars lhs rhs src_loc)
 	--	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.
+	-- We also need to get the free tyvars of the LHS; but we do that
+	-- during zonking (see TcHsSyn.zonkRule)
+	--
 	forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids)
     in
-
 	-- RHS can be a bit more lenient.  In particular,
 	-- we let constant dictionaries etc float outwards
 	--
-	-- 
+	-- NB: tcSimplifyInferCheck zonks the forall_tvs, and 
+	--     knocks out any that are constrained by the environment
     tcSimplifyInferCheck (text "tcRule")
 			 forall_tvs
-			 lhs_dicts rhs_lie	`thenTc` \ (forall_tvs1, lie', rhs_binds) ->
+			 lhs_dicts rhs_lie	`thenM` \ (forall_tvs1, rhs_binds) ->
 
-    returnTc (lie', HsRule	name act
-				(map RuleBndr (forall_tvs1 ++ tpl_ids))	-- yuk
-				(mkHsLet lhs_binds lhs')
-				(mkHsLet rhs_binds rhs')
-				src_loc)
+    returnM (HsRule name act
+		    (map (RuleBndr . noLoc) (forall_tvs1 ++ tpl_ids))	-- yuk
+		    (mkHsLet lhs_binds lhs')
+		    (mkHsLet rhs_binds rhs'))
   where
-    new_id (RuleBndr var) 	   = newTyVarTy openTypeKind			`thenNF_Tc` \ ty ->
-		          	     returnNF_Tc (mkLocalId var ty)
-    new_id (RuleBndrSig var rn_ty) = tcHsSigType (RuleSigCtxt var) rn_ty	`thenTc` \ ty ->
-				     returnNF_Tc (mkLocalId var ty)
+    new_id (RuleBndr var) 	   = newTyVarTy openTypeKind			`thenM` \ ty ->
+		          	     returnM (mkLocalId (unLoc var) ty)
+    new_id (RuleBndrSig var rn_ty) = tcHsSigType (RuleSigCtxt nl_var) rn_ty	`thenM` \ ty ->
+				     returnM (mkLocalId nl_var ty)
+				   where
+				     nl_var = unLoc var
 
 ruleCtxt name = ptext SLIT("When checking the transformation rule") <+> 
-		doubleQuotes (ptext name)
+		doubleQuotes (ftext name)
 \end{code}