From 61193fe4e9c4c47c44b37524db091c1fa71f3a45 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Thu, 23 May 2002 15:51:26 +0000
Subject: [PATCH] [project @ 2002-05-23 15:51:26 by simonpj] Don't report
 ambiguity errors 	if other type errors have happened

This saves a gratuitous error cascade when the type checker
recovers from one error by giving f type (forall a.a), and
then find an ambiguity problem as a direct result.
---
 ghc/compiler/typecheck/TcModule.lhs   |    5 +++--
 ghc/compiler/typecheck/TcMonad.lhs    |   15 ++++++++++++++-
 ghc/compiler/typecheck/TcSimplify.lhs |   18 ++++++++++++++----
 3 files changed, 31 insertions(+), 7 deletions(-)

diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 9251283..6b76101 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -445,8 +445,9 @@ tcModule pcs hst (RnResult { rr_decls = decls, rr_mod = this_mod,
 			   lie_rules	 `plusLIE`
 			   lie_main
 	in
-	tcSimplifyTop lie_alldecls	`thenTc` \ const_inst_binds ->
-        traceTc (text "endsimpltop")	`thenTc_`
+	tcSimplifyTop lie_alldecls		`thenTc` \ const_inst_binds ->
+        traceTc (text "endsimpltop")		`thenTc_`
+	
 	
 	    -- Backsubstitution.    This must be done last.
 	    -- Even tcSimplifyTop may do some unification.
diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index de83f05..7b06460 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -17,7 +17,7 @@ module TcMonad(
 
 	checkTc, checkTcM, checkMaybeTc, checkMaybeTcM, 
 	failTc, failWithTc, addErrTc, addErrsTc, warnTc, 
-	recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
+	recoverTc, checkNoErrsTc, ifErrsTc, recoverNF_Tc, discardErrsTc,
 	addErrTcM, addInstErrTcM, failWithTcM,
 
 	tcGetEnv, tcSetEnv,
@@ -408,6 +408,19 @@ checkNoErrsTc main
 	  errs_var = getTcErrs down
 
 
+ifErrsTc :: TcM r -> TcM r -> TcM r
+--	ifErrsTc bale_out main
+-- does 'bale_out' if there are errors in errors collection
+-- and does 'main' otherwise
+-- Useful to avoid error cascades
+
+ifErrsTc bale_out main
+  = getErrsTc	`thenNF_Tc` \ (warns, errs) -> 
+    if isEmptyBag errs then
+	   main
+    else	
+	   bale_out
+
 -- (tryTc_ r m) tries m; if it succeeds it returns it,
 -- otherwise it returns r.  Any error messages added by m are discarded,
 -- whether or not m succeeds.
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index c7280a3..c28105a 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -1609,15 +1609,25 @@ tcSimplifyTop wanted_lie
 		-- Collect together all the bad guys
 	bad_guys = non_stds ++ concat std_bads
     in
-	-- Disambiguate the ones that look feasible
-    mapTc disambigGroup std_oks		`thenTc` \ binds_ambig ->
 
-	-- And complain about the ones that don't
+    ifErrsTc (returnTc []) (
+	-- Don't check for ambiguous things
+	-- if there has been an error; errors often
+	-- give rise to spurious ambiguous Insts
+	
+    
+	-- And complain about the ones that don't fall under
+	-- the Haskell rules for disambiguation
 	-- This group includes both non-existent instances
 	--	e.g. Num (IO a) and Eq (Int -> Int)
 	-- and ambiguous dictionaries
 	--	e.g. Num a
-    addTopAmbigErrs bad_guys		`thenNF_Tc_`
+        addTopAmbigErrs bad_guys	`thenNF_Tc_`
+
+	-- Disambiguate the ones that look feasible
+        mapTc disambigGroup std_oks
+    )					`thenTc` \ binds_ambig ->
+
 
     returnTc (binds `andMonoBinds` andMonoBindList binds_ambig)
   where
-- 
1.7.10.4