From: lewie <unknown>
Date: Thu, 12 Apr 2001 21:29:43 +0000 (+0000)
Subject: [project @ 2001-04-12 21:29:43 by lewie]
X-Git-Tag: Approximately_9120_patches~2161
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=ebf2c80221ccf11aeb7a0a2be27bfc72529855a5;p=ghc-hetmet.git

[project @ 2001-04-12 21:29:43 by lewie]
Don't use the same simplify code for both restricted and unrestricted
bindings.  In particular, a restricted binding shouldn't try to capture
implicit params.
---

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 282e61b..5bd9cae 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -27,7 +27,7 @@ import Inst		( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..),
 import TcEnv		( tcExtendLocalValEnv,
 			  newSpecPragmaId, newLocalId
 			)
-import TcSimplify	( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck, tcSimplifyToDicts )
+import TcSimplify	( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck, tcSimplifyRestricted, tcSimplifyToDicts )
 import TcMonoType	( tcHsSigType, checkSigTyVars,
 			  TcSigInfo(..), tcTySig, maybeSig, sigCtxt
 			)
@@ -289,10 +289,11 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
 		-- at all.
     in
 
+    traceTc (text "binding:" <+> ppr ((zonked_dict_ids, dict_binds),
+	     exports, [idType poly_id | (_, poly_id, _) <- exports])) `thenTc_`
+
 	 -- BUILD RESULTS
     returnTc (
-	-- pprTrace "binding.." (ppr ((zonked_dict_ids, dict_binds), 
-	--				exports, [idType poly_id | (_, poly_id, _) <- exports])) $
 	AbsBinds real_tyvars_to_gen
 		 zonked_dict_ids
 		 exports
@@ -462,7 +463,7 @@ generalise binder_names mbind tau_tvs lie_req sigs
 
 	-- Now simplify with exactly that set of tyvars
 	-- We have to squash those Methods
-    tcSimplifyCheck doc final_forall_tvs [] lie_req	`thenTc` \ (lie_free, binds) ->
+    tcSimplifyRestricted doc final_forall_tvs [] lie_req	`thenTc` \ (lie_free, binds) ->
 
     returnTc (final_forall_tvs, lie_free, binds, [])
 
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index bfaf629..a4f6af4 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -7,7 +7,8 @@
 
 \begin{code}
 module TcSimplify (
-	tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck, 
+	tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck,
+	tcSimplifyRestricted,
 	tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop, 
 
 	tcSimplifyThetas, tcSimplifyCheckThetas,
@@ -479,33 +480,45 @@ tcSimplifyCheck
 		 TcDictBinds)	-- Bindings
 
 tcSimplifyCheck doc qtvs givens wanted_lie
-  = checkLoop doc qtvs givens (lieToList wanted_lie)	`thenTc` \ (frees, binds, irreds) ->
+  = checkLoop doc qtvs givens (lieToList wanted_lie) try `thenTc` \ (frees, binds, irreds) ->
 
 	-- Complain about any irreducible ones
     complainCheck doc givens irreds		`thenNF_Tc_`
 
 	-- Done
     returnTc (mkLIE frees, binds)
+  where
+	-- When checking against a given signature we always reduce
+	-- until we find a match against something given, or can't reduce
+    try qtvs inst | isFree qtvs inst  = Free
+		  | otherwise         = ReduceMe 
 
-checkLoop doc qtvs givens wanteds
-  =   	-- Step 1
+tcSimplifyRestricted doc qtvs givens wanted_lie
+  = checkLoop doc qtvs givens (lieToList wanted_lie) try `thenTc` \ (frees, binds, irreds) ->
+
+	-- Complain about any irreducible ones
+    complainCheck doc givens irreds		`thenNF_Tc_`
+
+	-- Done
+    returnTc (mkLIE frees, binds)
+  where
+    try qtvs inst | not (tyVarsOfInst inst `intersectsVarSet` qtvs) = Free
+	          | otherwise                                       = ReduceMe
+
+checkLoop doc qtvs givens wanteds try_me
+  =		-- Step 1
     zonkTcTyVarsAndFV qtvs		`thenNF_Tc` \ qtvs' ->
     mapNF_Tc zonkInst givens		`thenNF_Tc` \ givens' ->
     mapNF_Tc zonkInst wanteds		`thenNF_Tc` \ wanteds' ->
-    let
-	      -- When checking against a given signature we always reduce
-	      -- until we find a match against something given, or can't reduce
-	try_me inst | isFree qtvs' inst  = Free
-		    | otherwise          = ReduceMe 
-    in
+
 		-- Step 2
-    reduceContext doc try_me givens' wanteds'    `thenTc` \ (no_improvement, frees, binds, irreds) ->
+    reduceContext doc (try_me qtvs') givens' wanteds'		`thenTc` \ (no_improvement, frees, binds, irreds) ->
 	
 		-- Step 3
     if no_improvement then
 	returnTc (frees, binds, irreds)
     else
-	checkLoop doc qtvs givens' (irreds ++ frees)	`thenTc` \ (frees1, binds1, irreds1) ->
+	checkLoop doc qtvs givens' (irreds ++ frees) try_me	`thenTc` \ (frees1, binds1, irreds1) ->
 	returnTc (frees1, binds `AndMonoBinds` binds1, irreds1)
 
 complainCheck doc givens irreds