X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=1998cd2bc467b3aee682ac9fc47ca1bb646b4939;hb=658372b8c24dee8c37a729c9a1500a3e3b9735d9;hp=e1424189285d4173798b8f451d37cc284f2112da;hpb=6e0c3f50e131f502577a61b09a339af295de9d23;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index e142418..1998cd2 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -86,6 +86,24 @@ import DynFlags		( DynFlags(ctxtStkDepth),
 	Notes on functional dependencies (a bug)
 	--------------------------------------
 
+Consider this:
+
+	class C a b | a -> b
+	class D a b | a -> b
+
+	instance D a b => C a b	-- Undecidable 
+				-- (Not sure if it's crucial to this eg)
+	f :: C a b => a -> Bool
+	f _ = True
+	
+	g :: C a b => a -> Bool
+	g = f
+
+Here f typechecks, but g does not!!  Reason: before doing improvement,
+we reduce the (C a b1) constraint from the call of f to (D a b1).
+
+Here is a more complicated example:
+
 | > class Foo a b | a->b
 | >
 | > class Bar a b | a->b
@@ -257,9 +275,9 @@ any other type variables.
 
 
 
-	--------------------------------------
-		Notes on ambiguity
-	--------------------------------------
+-------------------------------------
+	Note [Ambiguity]
+-------------------------------------
 
 It's very hard to be certain when a type is ambiguous.  Consider
 
@@ -1048,8 +1066,6 @@ tcSimplifyRestricted 	-- Used for restricted binding groups
 tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
 	-- Zonk everything in sight
   = mappM zonkInst wanteds			`thenM` \ wanteds' ->
-    zonkTcTyVarsAndFV (varSetElems tau_tvs)	`thenM` \ tau_tvs' ->
-    tcGetGlobalTyVars				`thenM` \ gbl_tvs' ->
 
    	-- 'reduceMe': Reduce as far as we can.  Don't stop at
 	-- dicts; the idea is to get rid of as many type
@@ -1058,25 +1074,30 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
 	-- immediately, with no constraint on s.
 	--
 	-- BUT do no improvement!  See Plan D above
+	-- HOWEVER, some unification may take place, if we instantiate
+	-- 	    a method Inst with an equality constraint
     reduceContextWithoutImprovement 
 	doc reduceMe wanteds' 		`thenM` \ (_frees, _binds, constrained_dicts) ->
 
 	-- Next, figure out the tyvars we will quantify over
+    zonkTcTyVarsAndFV (varSetElems tau_tvs)	`thenM` \ tau_tvs' ->
+    tcGetGlobalTyVars				`thenM` \ gbl_tvs' ->
+    mappM zonkInst constrained_dicts		`thenM` \ constrained_dicts' ->
     let
-	constrained_tvs = tyVarsOfInsts constrained_dicts
-	qtvs = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs')
-			 `minusVarSet` constrained_tvs
+	constrained_tvs' = tyVarsOfInsts constrained_dicts'
+	qtvs' = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs')
+			 `minusVarSet` constrained_tvs'
     in
     traceTc (text "tcSimplifyRestricted" <+> vcat [
-		pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts,
+		pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts',
 		ppr _binds,
-		ppr constrained_tvs, ppr tau_tvs', ppr qtvs ])	`thenM_`
+		ppr constrained_tvs', ppr tau_tvs', ppr qtvs' ])	`thenM_`
 
 	-- The first step may have squashed more methods than
 	-- necessary, so try again, this time more gently, knowing the exact
 	-- set of type variables to quantify over.
 	--
-	-- We quantify only over constraints that are captured by qtvs;
+	-- We quantify only over constraints that are captured by qtvs';
 	-- these will just be a subset of non-dicts.  This in contrast
 	-- to normal inference (using isFreeWhenInferring) in which we quantify over
 	-- all *non-inheritable* constraints too.  This implements choice
@@ -1090,7 +1111,7 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
 	-- expose implicit parameters to the test that follows
     let
 	is_nested_group = isNotTopLevel top_lvl
-        try_me inst | isFreeWrtTyVars qtvs inst,
+        try_me inst | isFreeWrtTyVars qtvs' inst,
 		      (is_nested_group || isDict inst) = Free
 	            | otherwise  		       = ReduceMe AddSCs
     in
@@ -1101,14 +1122,14 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
 	-- See "Notes on implicit parameters, Question 4: top level"
     if is_nested_group then
 	extendLIEs frees	`thenM_`
-        returnM (varSetElems qtvs, binds)
+        returnM (varSetElems qtvs', binds)
     else
 	let
     	    (non_ips, bad_ips) = partition isClassDict frees
 	in    
 	addTopIPErrs bndrs bad_ips	`thenM_`
 	extendLIEs non_ips		`thenM_`
-        returnM (varSetElems qtvs, binds)
+        returnM (varSetElems qtvs', binds)
 \end{code}
 
 
@@ -2451,8 +2472,8 @@ addNoInstanceErrs mb_what givens dicts
 			        ptext SLIT("to the") <+> what] ]
 
     	fix2 | null instance_dicts = []
-	     | otherwise	   = [ ptext SLIT("add an instance declaration for")
-				       <+> pprDictsTheta instance_dicts ]
+	     | otherwise	   = [ sep [ptext SLIT("add an instance declaration for"),
+				            pprDictsTheta instance_dicts] ]
 	instance_dicts = [d | d <- dicts, isClassDict d, not (isTyVarDict d)]
 		-- Insts for which it is worth suggesting an adding an instance declaration
 		-- Exclude implicit parameters, and tyvar dicts