X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=e1424189285d4173798b8f451d37cc284f2112da;hb=e656c6e3aaa827c51cd39c9cd9f0a6461db1d4c2;hp=4cb32b8a0fbf5cf367daf8dd4f3cb1f326ea074e;hpb=7f0ce617a0380339da927433dc816e45704db0be;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 4cb32b8..e142418 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -21,7 +21,6 @@ module TcSimplify (
 #include "HsVersions.h"
 
 import {-# SOURCE #-} TcUnify( unifyType )
-import TypeRep		( Type(..) )
 import HsSyn		( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds )
 import TcHsSyn		( mkHsApp, mkHsTyApp, mkHsDictApp )
 
@@ -71,8 +70,9 @@ import ListSetOps	( equivClasses )
 import Util		( zipEqual, isSingleton )
 import List		( partition )
 import SrcLoc		( Located(..) )
-import DynFlags		( DynFlag(..) )
-import StaticFlags
+import DynFlags		( DynFlags(ctxtStkDepth), 
+			  DynFlag( Opt_GlasgowExts, Opt_AllowUndecidableInstances, 
+			  Opt_WarnTypeDefaults, Opt_ExtendedDefaultRules ) )
 \end{code}
 
 
@@ -922,7 +922,8 @@ Two more nasty cases are in
 tcSimplifySuperClasses qtvs givens sc_wanteds
   = ASSERT( all isSkolemTyVar qtvs )
     do	{ (_, frees, binds1) <- tcSimplCheck doc get_qtvs NoSCs givens sc_wanteds
-	; binds2	     <- tc_simplify_top doc False NoSCs frees
+	; ext_default        <- doptM Opt_ExtendedDefaultRules
+	; binds2	     <- tc_simplify_top doc ext_default NoSCs frees
 	; return (binds1 `unionBags` binds2) }
   where
     get_qtvs = return (mkVarSet qtvs)
@@ -1715,22 +1716,21 @@ I had to produce Y, to produce Y I had to produce Z, and so on.
 
 \begin{code}
 reduceList (n,stack) try_me wanteds state
-  | n > opt_MaxContextReductionDepth
-  = failWithTc (reduceDepthErr n stack)
-
-  | otherwise
-  =
+  = do 	{ dopts <- getDOpts
 #ifdef DEBUG
-   (if n > 8 then
-	pprTrace "Interesting! Context reduction stack deeper than 8:" 
-		(int n $$ ifPprDebug (nest 2 (pprStack stack)))
-    else (\x->x))
+	; if n > 8 then
+		dumpTcRn (text "Interesting! Context reduction stack deeper than 8:" 
+			  <+> (int n $$ ifPprDebug (nest 2 (pprStack stack))))
+	  else return ()
 #endif
-    go wanteds state
+	; if n >= ctxtStkDepth dopts then
+	    failWithTc (reduceDepthErr n stack)
+	  else
+	    go wanteds state }
   where
-    go []     state = returnM state
-    go (w:ws) state = reduce (n+1, w:stack) try_me w state	`thenM` \ state' ->
-		      go ws state'
+    go []     state = return state
+    go (w:ws) state = do { state' <- reduce (n+1, w:stack) try_me w state
+			 ; go ws state' }
 
     -- Base case: we're done!
 reduce stack try_me wanted avails
@@ -2011,7 +2011,8 @@ It's OK: the final zonking stage should zap y to (), which is fine.
 \begin{code}
 tcSimplifyTop, tcSimplifyInteractive :: [Inst] -> TcM TcDictBinds
 tcSimplifyTop wanteds
-  = tc_simplify_top doc False {- Not interactive loop -} AddSCs wanteds
+  = do 	{ ext_default <- doptM Opt_ExtendedDefaultRules
+	; tc_simplify_top doc ext_default AddSCs wanteds }
   where 
     doc = text "tcSimplifyTop"
 
@@ -2022,7 +2023,7 @@ tcSimplifyInteractive wanteds
 
 -- The TcLclEnv should be valid here, solely to improve
 -- error message generation for the monomorphism restriction
-tc_simplify_top doc is_interactive want_scs wanteds
+tc_simplify_top doc use_extended_defaulting want_scs wanteds
   = do	{ lcl_env <- getLclEnv
 	; traceTc (text "tcSimplifyTop" <+> ppr (lclEnvElts lcl_env))
 
@@ -2048,13 +2049,13 @@ tc_simplify_top doc is_interactive want_scs wanteds
 		=  not (bad_tyvars `intersectsVarSet` tyVarsOfInst (head ds))
 		&& defaultable_classes (map get_clas ds)
 	    defaultable_classes clss 
-		| is_interactive = any isInteractiveClass clss
-		| otherwise	 = all isStandardClass clss && any isNumericClass clss
+		| use_extended_defaulting = 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 []"
+		 	-- In interactive mode, or with -fextended-default-rules,
+			-- we default Show a to Show () to avoid graututious errors on "show []"
 
     
 		    -- Collect together all the bad guys
@@ -2524,7 +2525,7 @@ badDerivedPred pred
 
 reduceDepthErr n stack
   = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
-	  ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
+	  ptext SLIT("Use -fcontext-stack=N to increase stack size to N"),
 	  nest 4 (pprStack stack)]
 
 pprStack stack = vcat (map pprInstInFull stack)