From 40d3a06b353392a322d8425fb5dd9f103f4421f3 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Fri, 20 May 2005 11:32:03 +0000
Subject: [PATCH] [project @ 2005-05-20 11:32:03 by simonpj] Liberalise the
 defaulting rules for GHCi

		Merge to STABLE?

The H98 defaulting rules are these.  Group constraints of the form (C v),
for some particular type variable v. Then default v if

a) v appears only in this group (no implicit params or D [v])
b) at least one of the C's is numeric
c) all the C's are standard

GHCi changed rules (b) to

(b') at least one of the C's is numeric, or Eq,Ord,Show

This commit further liberalises GHCi to change (c):

(c') any of the C's are standard

Otherwise the existence of a non-standard class (e.g. Random) is enough
to kill defaulting altogether.
---
 ghc/compiler/typecheck/TcSimplify.lhs |   55 ++++++++++++++++-----------------
 1 file changed, 27 insertions(+), 28 deletions(-)

diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 579ad3e..fb898a0 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -28,7 +28,7 @@ import TcRnMonad
 import Inst		( lookupInst, LookupInstResult(..),
 			  tyVarsOfInst, fdPredsOfInsts, newDicts, 
 			  isDict, isClassDict, isLinearInst, linearInstType,
-			  isStdClassTyVarDict, isMethodFor, isMethod,
+			  isMethodFor, isMethod,
 			  instToId, tyVarsOfInsts,  cloneDict,
 			  ipNamesOfInsts, ipNamesOfInst, dictPred,
 			  instBindingRequired, fdPredsOfInst,
@@ -53,7 +53,7 @@ import Name		( Name, getOccName, getSrcLoc )
 import NameSet		( NameSet, mkNameSet, elemNameSet )
 import Class		( classBigSig, classKey )
 import FunDeps		( oclose, grow, improve, pprEquationDoc )
-import PrelInfo		( isNumericClass ) 
+import PrelInfo		( isNumericClass, isStandardClass ) 
 import PrelNames	( splitName, fstName, sndName, integerTyConName,
 			  showClassKey, eqClassKey, ordClassKey )
 import Type		( zipTopTvSubst, substTheta, substTy )
@@ -2021,21 +2021,32 @@ tc_simplify_top doc is_interactive want_scs wanteds
 	; (frees, binds, irreds) <- simpleReduceLoop doc try_me wanteds
 
 	; let
-		-- All the non-std ones are definite errors
-	    (stds, non_stds) = partition isStdClassTyVarDict irreds
-    
-		    -- Group by type variable
-	    std_groups = equivClasses cmp_by_tyvar stds
-    
-		    -- Pick the ones which its worth trying to disambiguate
-		    -- namely, the onese whose type variable isn't bound
-		    -- up with one of the non-standard classes
-	    (std_oks, std_bads)	= partition worth_a_try std_groups
-	    worth_a_try group@(d:_) = not (non_std_tyvars `intersectsVarSet` tyVarsOfInst d)
-	    non_std_tyvars		= unionVarSets (map tyVarsOfInst non_stds)
+		-- All the non-tv ones are definite errors
+	    (tv_dicts, non_tvs) = partition isTyVarDict irreds
+	    bad_tyvars = unionVarSets (map tyVarsOfInst non_tvs)
+
+		-- Group by type variable
+	    tv_groups = equivClasses cmp_by_tyvar tv_dicts
+
+		-- Pick the ones which its worth trying to disambiguate
+		-- namely, the ones whose type variable isn't bound
+		-- up with one of the non-tyvar classes
+	    (default_gps, non_default_gps) = partition defaultable_group tv_groups
+	    defaultable_group ds@(d:_) 
+		=  not (bad_tyvars `intersectsVarSet` tyVarsOfInst d)
+		&& defaultable_classes (map get_clas ds)
+	    defaultable_classes clss 
+		| is_interactive = any isInteractiveClass clss
+		| otherwise	 = all isStandardClass clss && any isNumericClass clss
+
+	    isInteractiveClass cls = isNumericClass cls
+				  || (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey])
+		 	-- In interactive mode, we default Show a to Show ()
+			-- to avoid graututious errors on "show []"
+
     
 		    -- Collect together all the bad guys
-	    bad_guys 	   = non_stds ++ concat std_bads
+	    bad_guys 	       = non_tvs ++ concat non_default_gps
     	    (non_ips, bad_ips) = partition isClassDict bad_guys
     	    (ambigs, no_insts) = partition isTyVarDict non_ips
 	    -- If the dict has no type constructors involved, it must be ambiguous,
@@ -2069,7 +2080,7 @@ tc_simplify_top doc is_interactive want_scs wanteds
 		  addTopAmbigErrs ambigs
 
 		  -- Disambiguate the ones that look feasible
-		; mappM (disambigGroup is_interactive) std_oks }
+		; mappM (disambigGroup is_interactive) default_gps }
 
 	; return (binds `unionBags` unionManyBags binds_ambig) }
 
@@ -2120,7 +2131,6 @@ disambigGroup :: Bool	-- True <=> simplifying at top-level interactive loop
 	      -> TcM TcDictBinds
 
 disambigGroup is_interactive dicts
-  |   any std_default_class classes 	-- Guaranteed all standard classes
   = 	-- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
 	-- SO, TRY DEFAULT TYPES IN ORDER
 
@@ -2146,21 +2156,10 @@ disambigGroup is_interactive dicts
     case mb_ty of
 	Left  _ 		-> bomb_out
 	Right chosen_default_ty -> choose_default chosen_default_ty
-
-  | otherwise 				-- No defaults
-  = bomb_out
-
   where
     tyvar   = get_tv (head dicts)	-- Should be non-empty
     classes = map get_clas dicts
 
-    std_default_class cls
-      =  isNumericClass cls
-      || (is_interactive && 
-	  classKey cls `elem` [showClassKey, eqClassKey, ordClassKey])
-	 	-- In interactive mode, we default Show a to Show ()
-		-- to avoid graututious errors on "show []"
-
     choose_default default_ty	-- Commit to tyvar = default_ty
       =	-- Bind the type variable 
 	unifyTauTy default_ty (mkTyVarTy tyvar)	`thenM_`
-- 
1.7.10.4