[commit: ghc] ghc-8.0: Improve error messages for recursive superclasses (4916993)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/4916993c5adf241bf9382f948349a2177423482a/ghc

>---------------------------------------------------------------

commit 4916993c5adf241bf9382f948349a2177423482a
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Feb 8 13:31:11 2016 +0000

    Improve error messages for recursive superclasses
    
    If we fail to typecheck by blowing the constraint simplifier
    iteration limit, we want to see the limit-blowing meessage.
    Previously it was being suppressed by the type /error/, which
    suppress the iteration-limit /warning/.  Solution: make the
    iteration-limit message into an error.
    
    (cherry picked from commit d6b68be1100203aa13755457f89ee4bbb0297473)


>---------------------------------------------------------------

4916993c5adf241bf9382f948349a2177423482a
 compiler/typecheck/TcSMonad.hs   |  7 ++++---
 compiler/typecheck/TcSimplify.hs | 26 ++++++++++++++++++--------
 2 files changed, 22 insertions(+), 11 deletions(-)

diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index aa16a80..ad7822b 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -14,7 +14,7 @@ module TcSMonad (
 
     -- The TcS monad
     TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds,
-    failTcS, warnTcS,
+    failTcS, warnTcS, addErrTcS,
     runTcSEqualities,
     nestTcS, nestImplicTcS,
 
@@ -2316,10 +2316,11 @@ wrapWarnTcS :: TcM a -> TcS a
 -- There's no static check; it's up to the user
 wrapWarnTcS = wrapTcS
 
-failTcS, panicTcS :: SDoc -> TcS a
-warnTcS           :: SDoc -> TcS ()
+failTcS, panicTcS  :: SDoc -> TcS a
+warnTcS, addErrTcS :: SDoc -> TcS ()
 failTcS      = wrapTcS . TcM.failWith
 warnTcS      = wrapTcS . TcM.addWarn
+addErrTcS    = wrapTcS . TcM.addErr
 panicTcS doc = pprPanic "TcCanonical" doc
 
 traceTcS :: String -> SDoc -> TcS ()
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index 8804655..5716f91 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -560,8 +560,8 @@ simplifyInfer rhs_tclvl apply_mr sigs name_taus wanteds
                             -- again later. All we want here are the predicates over which to
                             -- quantify.
                             --
-                            -- If any meta-tyvar unifications take place (unlikely), we'll
-                            -- pick that up later.
+                            -- If any meta-tyvar unifications take place (unlikely),
+                            -- we'll pick that up later.
 
                       -- See Note [Promote _and_ default when inferring]
                       ; let def_tyvar tv
@@ -573,9 +573,10 @@ simplifyInfer rhs_tclvl apply_mr sigs name_taus wanteds
                       ; WC { wc_simple = simples }
                            <- setTcLevel rhs_tclvl $
                               runTcSDeriveds       $
-                              solveSimpleWanteds $ mapBag toDerivedCt quant_cand
-                                -- NB: we don't want evidence, so used
-                                -- Derived constraints
+                              solveSimpleWanteds   $
+                              mapBag toDerivedCt quant_cand
+                                -- NB: we don't want evidence,
+                                -- so use Derived constraints
 
                       ; simples <- TcM.zonkSimples simples
 
@@ -976,7 +977,7 @@ This only half-works, but then let-generalisation only half-works.
 -}
 
 simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints
--- Zonk the input constraints, and simplify them
+-- Solve the specified Wanted constraints
 -- Discard the evidence binds
 -- Discards all Derived stuff in result
 -- Postcondition: fully zonked and unflattened constraints
@@ -1033,7 +1034,11 @@ simpl_loop n limit floated_eqs no_new_scs
   = return wc  -- Done!
 
   | n `intGtLimit` limit
-  = do { warnTcS (hang (text "solveWanteds: too many iterations"
+  = do { -- Add an error (not a warning) if we blow the limit,
+         -- Typically if we blow the limit we are going to report some other error
+         -- (an unsolved constraint), and we don't want that error to suppress
+         -- the iteration limit warning!
+         addErrTcS (hang (text "solveWanteds: too many iterations"
                    <+> parens (text "limit =" <+> ppr limit))
                 2 (vcat [ text "Unsolved:" <+> ppr wc
                         , ppUnless (isEmptyBag floated_eqs) $
@@ -1045,7 +1050,12 @@ simpl_loop n limit floated_eqs no_new_scs
        ; return wc }
 
   | otherwise
-  = do { traceTcS "simpl_loop, iteration" (int n)
+  = do { let n_floated = lengthBag floated_eqs
+       ; csTraceTcS $
+         text "simpl_loop iteration=" <> int n
+         <+> (parens $ hsep [ text "no new scs =" <+> ppr no_new_scs <> comma
+                            , int n_floated <+> text "floated eqs" <> comma
+                            , int (lengthBag simples) <+> text "simples to solve" ])
 
        -- solveSimples may make progress if either float_eqs hold
        ; (unifs1, wc1) <- reportUnifications $