Two more error message indendations

[ghc-hetmet.git] / compiler / typecheck / TcSimplify.lhs

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 19557c6..3c8160c 100644 (file)
--- 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 )
 
@@ -42,8 +41,7 @@ import Inst           ( lookupInst, LookupInstResult(..),
 import TcEnv           ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders,
                          lclEnvElts, tcMetaTy )
 import InstEnv         ( lookupInstEnv, classInstances, pprInstances )
-import TcMType         ( zonkTcTyVarsAndFV, tcInstTyVars, zonkTcPredType,
-                         checkAmbiguity, checkInstTermination )
+import TcMType         ( zonkTcTyVarsAndFV, tcInstTyVars, zonkTcPredType  )
 import TcType          ( TcTyVar, TcTyVarSet, ThetaType, TcPredType, tidyPred,
                           mkClassPred, isOverloadedTy, mkTyConApp, isSkolemTyVar,
                          mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
@@ -72,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}
 
 
@@ -923,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)
@@ -1716,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
@@ -2012,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"
 
@@ -2023,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))
 
@@ -2049,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
@@ -2283,19 +2283,10 @@ tcSimplifyDeriv tc tyvars theta
        rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars)
                -- This reverse-mapping is a Royal Pain, 
                -- but the result should mention TyVars not TcTyVars
-
-       head_ty = TyConApp tc (map TyVarTy tvs)
     in
    
     addNoInstanceErrs Nothing [] bad_insts             `thenM_`
     mapM_ (addErrTc . badDerivedPred) weird_preds      `thenM_`
-    checkAmbiguity tvs simpl_theta tv_set              `thenM_`
-      -- Check instance termination as for user-declared instances.
-      -- unless we had -fallow-undecidable-instances (which risks
-      -- non-termination in the 'deriving' context-inference fixpoint
-      -- loop).
-    ifM (gla_exts && not undecidable_ok)
-       (checkInstTermination simpl_theta [head_ty])    `thenM_`
     returnM (substTheta rev_env simpl_theta)
   where
     doc    = ptext SLIT("deriving classes for a data type")
@@ -2460,8 +2451,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
@@ -2534,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)