Major patch to add -fwarn-redundant-constraints

The idea was promted by Trac #9939, but it was Christmas, so I did
some recreational programming that went much further.

The idea is to warn when a constraint in a user-supplied context is
redundant.  Everything is described in detail in
  Note [Tracking redundant constraints]
in TcSimplify.

Main changes:

 * The new ic_status field in an implication, of type ImplicStatus.
   It replaces ic_insol, and includes information about redundant
   constraints.

 * New function TcSimplify.setImplicationStatus sets the ic_status.

 * TcSigInfo has sig_report_redundant field to say whenther a
   redundant constraint should be reported; and similarly
   the FunSigCtxt constructor of UserTypeCtxt

 * EvBinds has a field eb_is_given, to record whether it is a given
   or wanted binding. Some consequential chagnes to creating an evidence
   binding (so that we record whether it is given or wanted).

 * AbsBinds field abs_ev_binds is now a *list* of TcEvBiinds;
   see Note [Typechecking plan for instance declarations] in
   TcInstDcls

 * Some significant changes to the type checking of instance
   declarations; Note [Typechecking plan for instance declarations]
   in TcInstDcls.

 * I found that TcErrors.relevantBindings was failing to zonk the
   origin of the constraint it was looking at, and hence failing to
   find some relevant bindings.  Easy to fix, and orthogonal to
   everything else, but hard to disentangle.

Some minor refactorig:

 * TcMType.newSimpleWanteds moves to Inst, renamed as newWanteds

 * TcClassDcl and TcInstDcls now have their own code for typechecking
   a method body, rather than sharing a single function. The shared
   function (ws TcClassDcl.tcInstanceMethodBody) didn't have much code
   and the differences were growing confusing.

 * Add new function TcRnMonad.pushLevelAndCaptureConstraints, and
   use it

 * Add new function Bag.catBagMaybes, and use it in TcSimplify

1 files changed, 148 insertions, 96 deletions

diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index 23cc0481f1..d9b6fc7a47 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -42,6 +42,7 @@ import DynFlags
 import StaticFlags      ( opt_PprStyle_Debug )
 import ListSetOps       ( equivClasses )
 
+import Control.Monad    ( when )
 import Data.Maybe
 import Data.List        ( partition, mapAccumL, nub, sortBy )
 
@@ -133,6 +134,7 @@ report_unsolved mb_binds_var defer_errors expr_holes type_holes wanted
   = return ()
   | otherwise
   = do { traceTc "reportUnsolved (before unflattening)" (ppr wanted)
+       ; warn_redundant <- woptM Opt_WarnRedundantConstraints
 
        ; env0 <- tcInitTidyEnv
 
@@ -146,6 +148,7 @@ report_unsolved mb_binds_var defer_errors expr_holes type_holes wanted
                             , cec_expr_holes = expr_holes
                             , cec_type_holes = type_holes
                             , cec_suppress = False -- See Note [Suppressing error messages]
+                            , cec_warn_redundant = warn_redundant
                             , cec_binds    = mb_binds_var }
 
        ; traceTc "reportUnsolved (after unflattening):" $
@@ -181,6 +184,8 @@ data ReportErrCtxt
           , cec_expr_holes :: HoleChoice  -- Holes in expressions
           , cec_type_holes :: HoleChoice  -- Holes in types
 
+          , cec_warn_redundant :: Bool    -- True <=> -fwarn-redundant-constraints
+
           , cec_suppress :: Bool    -- True <=> More important errors have occurred,
                                     --          so create bindings if need be, but
                                     --          don't issue any more errors/warnings
@@ -204,15 +209,20 @@ Specifically (see reportWanteds)
 reportImplic :: ReportErrCtxt -> Implication -> TcM ()
 reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
                                  , ic_wanted = wanted, ic_binds = evb
-                                 , ic_insol = ic_insoluble, ic_info = info })
+                                 , ic_status = status, ic_info = info
+                                 , ic_env = tcl_env })
   | BracketSkol <- info
-  , not ic_insoluble -- For Template Haskell brackets report only
-  = return ()        -- definite errors. The whole thing will be re-checked
+  , not (isInsolubleStatus status)
+  = return ()        -- For Template Haskell brackets report only
+                     -- definite errors. The whole thing will be re-checked
                      -- later when we plug it in, and meanwhile there may
                      -- certainly be un-satisfied constraints
 
   | otherwise
-  = reportWanteds ctxt' wanted
+  = do { reportWanteds ctxt' wanted
+       ; traceTc "reportImplic" (ppr implic)
+       ; when (cec_warn_redundant ctxt) $
+         warnRedundantConstraints ctxt' tcl_env info' dead_givens }
   where
     (env1, tvs') = mapAccumL tidyTyVarBndr (cec_tidy ctxt) tvs
     (env2, info') = tidySkolemInfo env1 info
@@ -224,40 +234,65 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
                  , cec_binds = case cec_binds ctxt of
                                  Nothing -> Nothing
                                  Just {} -> Just evb }
+    dead_givens = case status of
+                    IC_Solved { ics_dead = dead } -> dead
+                    _                             -> []
+
+warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM ()
+warnRedundantConstraints ctxt env info ev_vars
+ | null ev_vars
+ = return ()
+
+ | SigSkol {} <- info
+ = setLclEnv env $  -- We want to add "In the type signature for f"
+                    -- to the error context, which is a bit tiresome
+   addErrCtxt (ptext (sLit "In") <+> ppr info) $
+   do { env <- getLclEnv
+      ; msg <- mkErrorMsg ctxt env doc
+      ; reportWarning msg }
+
+ | otherwise  -- But for InstSkol there already *is* a surrounding
+              -- "In the instance declaration for Eq [a]" context
+              -- and we don't want to say it twice. Seems a bit ad-hoc
+ = do { msg <- mkErrorMsg ctxt env doc
+      ; reportWarning msg }
+ where
+   doc = ptext (sLit "Redundant constraint") <> plural ev_vars <> colon
+         <+> pprEvVarTheta ev_vars
 
 reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
-reportWanteds ctxt wanted@(WC { wc_simple = simples, wc_insol = insols, wc_impl = implics })
-  = do { reportSimples ctxt  (mapBag (tidyCt env) insol_given)
-       ; reportSimples ctxt1 (mapBag (tidyCt env) insol_wanted)
-       ; reportSimples ctxt2 (mapBag (tidyCt env) simples)
+reportWanteds ctxt (WC { wc_simple = simples, wc_insol = insols, wc_impl = implics })
+  = do { ctxt1 <- reportSimples ctxt  (mapBag (tidyCt env) insol_given)
+       ; ctxt2 <- reportSimples ctxt1 (mapBag (tidyCt env) insol_wanted)
+
+         -- For the simple wanteds, suppress them if there are any
+         -- insolubles in the tree, to avoid unnecessary clutter
+       ; let ctxt2' = ctxt { cec_suppress = cec_suppress ctxt2
+                                         || anyBag insolubleImplic implics }
+       ; _ <- reportSimples ctxt2'  (mapBag (tidyCt env) simples)
+
             -- All the Derived ones have been filtered out of simples
             -- by the constraint solver. This is ok; we don't want
             -- to report unsolved Derived goals as errors
             -- See Note [Do not report derived but soluble errors]
        ; mapBagM_ (reportImplic ctxt1) implics }
             -- NB ctxt1: don't suppress inner insolubles if there's only a
-            -- wanted insoluble here; but do suppress inner insolubles
-            -- if there's a given insoluble here (= inaccessible code)
+            -- *wanted* insoluble here; but do suppress inner insolubles
+            -- if there's a *given* insoluble here (= inaccessible code)
  where
-    (insol_given, insol_wanted) = partitionBag isGivenCt insols
     env = cec_tidy ctxt
+    (insol_given, insol_wanted) = partitionBag isGivenCt insols
 
-      -- See Note [Suppressing error messages]
-    suppress0 = cec_suppress ctxt
-    suppress1 = suppress0 || not (isEmptyBag insol_given)
-    suppress2 = suppress0 || insolubleWC wanted
-    ctxt1     = ctxt { cec_suppress = suppress1 }
-    ctxt2     = ctxt { cec_suppress = suppress2 }
-
-reportSimples :: ReportErrCtxt -> Cts -> TcM ()
+reportSimples :: ReportErrCtxt -> Cts -> TcM ReportErrCtxt
 reportSimples ctxt simples    -- Here 'simples' includes insolble goals
   =  traceTc "reportSimples" (vcat [ ptext (sLit "Simples =") <+> ppr simples
                                    , ptext (sLit "Suppress =") <+> ppr (cec_suppress ctxt)])
-  >> tryReporters
+  >> tryReporters ctxt
       [ -- First deal with things that are utterly wrong
         -- Like Int ~ Bool (incl nullary TyCons)
         -- or  Int ~ t a   (AppTy on one side)
-        ("Utterly wrong",  utterly_wrong,   True,  mkGroupReporter mkEqErr)
+        ("Utterly wrong (given)",  utterly_wrong_given, True,  mkGroupReporter mkEqErr)
+      , ("Utterly wrong (other)",  utterly_wrong_other, True,  mkGroupReporter mkEqErr)
       , ("Holes",          is_hole,         False, mkHoleReporter)
 
         -- Report equalities of form (a~ty).  They are usually
@@ -272,15 +307,19 @@ reportSimples ctxt simples    -- Here 'simples' includes insolble goals
       , ("Irreds",          is_irred,    False, mkGroupReporter mkIrredErr)
       , ("Dicts",           is_dict,     False, mkGroupReporter mkDictErr)
       ]
-      panicReporter ctxt (bagToList simples)
+      (bagToList simples)
           -- TuplePreds should have been expanded away by the constraint
           -- simplifier, so they shouldn't show up at this point
   where
-    utterly_wrong, skolem_eq, is_hole, is_dict,
+    utterly_wrong_given, utterly_wrong_other, skolem_eq, is_hole, is_dict,
       is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool
 
-    utterly_wrong _ (EqPred _ ty1 ty2) = isRigid ty1 && isRigid ty2
-    utterly_wrong _ _ = False
+    utterly_wrong_given ct (EqPred _ ty1 ty2)
+      | isGivenCt ct = isRigid ty1 && isRigid ty2
+    utterly_wrong_given _ _ = False
+
+    utterly_wrong_other _ (EqPred _ ty1 ty2) = isRigid ty1 && isRigid ty2
+    utterly_wrong_other _ _ = False
 
     is_hole ct _ = isHoleCt ct
 
@@ -330,11 +369,6 @@ type ReporterSpec
     , Bool                       -- True <=> suppress subsequent reporters
     , Reporter)                  -- The reporter itself
 
-panicReporter :: Reporter
-panicReporter _ cts
-  | null cts  = return ()
-  | otherwise =  pprPanic "reportSimples" (ppr cts)
-
 mkSkolReporter :: Reporter
 -- Suppress duplicates with the same LHS
 mkSkolReporter ctxt cts
@@ -418,7 +452,7 @@ addDeferredBinding ctxt err ct
                        err_msg $$ text "(deferred type error)"
 
          -- Create the binding
-       ; addTcEvBind ev_binds_var ev_id (EvDelayedError pred err_fs) }
+       ; addTcEvBind ev_binds_var (mkWantedEvBind ev_id (EvDelayedError pred err_fs)) }
 
   | otherwise   -- Do not set any evidence for Given/Derived
   = return ()
@@ -441,14 +475,18 @@ maybeAddDeferredBinding ctxt err ct
     | otherwise
     = return ()
 
-tryReporters :: [ReporterSpec] -> Reporter -> Reporter
+tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM ReportErrCtxt
 -- Use the first reporter in the list whose predicate says True
-tryReporters reporters deflt ctxt cts
+tryReporters ctxt reporters cts
   = do { traceTc "tryReporters {" (ppr cts)
-       ; go ctxt reporters cts
-       ; traceTc "tryReporters }" empty }
+       ; ctxt' <- go ctxt reporters cts
+       ; traceTc "tryReporters }" empty
+       ; return ctxt' }
   where
-    go ctxt [] cts = deflt ctxt cts
+    go ctxt [] cts
+      | null cts  = return ctxt
+      | otherwise = pprPanic "tryReporters" (ppr cts)
+
     go ctxt ((str, pred, suppress_after, reporter) : rs) cts
       | null yeses  = do { traceTc "tryReporters: no" (text str)
                          ; go ctxt rs cts }
@@ -487,10 +525,13 @@ pprWithArising (ct:cts)
     ppr_one ct' = hang (parens (pprType (ctPred ct')))
                      2 (pprArisingAt (ctLoc ct'))
 
-mkErrorMsg :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg
-mkErrorMsg ctxt ct msg
-  = do { let tcl_env = ctLocEnv (ctLoc ct)
-       ; err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
+mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg
+mkErrorMsgFromCt ctxt ct msg
+  = mkErrorMsg ctxt (ctLocEnv (ctLoc ct)) msg
+
+mkErrorMsg :: ReportErrCtxt -> TcLclEnv -> SDoc -> TcM ErrMsg
+mkErrorMsg ctxt tcl_env msg
+  = do { err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
        ; mkLongErrAt (RealSrcSpan (tcl_loc tcl_env)) msg err_info }
 
 type UserGiven = ([EvVar], SkolemInfo, Bool, RealSrcSpan)
@@ -572,16 +613,16 @@ solve it.
 
 
 ************************************************************************
-*                  *
+*                                                                      *
                 Irreducible predicate errors
-*                  *
+*                                                                      *
 ************************************************************************
 -}
 
 mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
 mkIrredErr ctxt cts
-  = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct1
-       ; mkErrorMsg ctxt ct1 (msg $$ binds_msg) }
+  = do { (ctxt, binds_msg, _) <- relevantBindings True ctxt ct1
+       ; mkErrorMsgFromCt ctxt ct1 (msg $$ binds_msg) }
   where
     (ct1:_) = cts
     orig    = ctLocOrigin (ctLoc ct1)
@@ -597,9 +638,9 @@ mkHoleError ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort })
                              2 (ptext (sLit "with type:") <+> pprType (ctEvPred (ctEvidence ct)))
                         , ppUnless (null tyvars_msg) (ptext (sLit "Where:") <+> vcat tyvars_msg)
                         , pts_hint ]
-       ; (ctxt, binds_doc) <- relevantBindings False ctxt ct
+       ; (ctxt, binds_doc, _) <- relevantBindings False ctxt ct
                -- The 'False' means "don't filter the bindings"; see Trac #8191
-       ; mkErrorMsg ctxt ct (msg $$ binds_doc) }
+       ; mkErrorMsgFromCt ctxt ct (msg $$ binds_doc) }
   where
     pts_hint
       | TypeHole  <- hole_sort
@@ -621,8 +662,8 @@ mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct)
 ----------------
 mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
 mkIPErr ctxt cts
-  = do { (ctxt, bind_msg) <- relevantBindings True ctxt ct1
-       ; mkErrorMsg ctxt ct1 (msg $$ bind_msg) }
+  = do { (ctxt, bind_msg, _) <- relevantBindings True ctxt ct1
+       ; mkErrorMsgFromCt ctxt ct1 (msg $$ bind_msg) }
   where
     (ct1:_) = cts
     orig    = ctLocOrigin (ctLoc ct1)
@@ -671,7 +712,7 @@ mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
 -- Wanted constraints only!
 mkEqErr1 ctxt ct
   | isGiven ev
-  = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct
+  = do { (ctxt, binds_msg, _) <- relevantBindings True ctxt ct
        ; let (given_loc, given_msg) = mk_given (cec_encl ctxt)
        ; dflags <- getDynFlags
        ; mkEqErr_help dflags ctxt (given_msg $$ binds_msg)
@@ -679,8 +720,7 @@ mkEqErr1 ctxt ct
                       Nothing ty1 ty2 }
 
   | otherwise   -- Wanted or derived
-  = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct
-       ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
+  = do { (ctxt, binds_msg, tidy_orig) <- relevantBindings True ctxt ct
        ; rdr_env <- getGlobalRdrEnv
        ; fam_envs <- tcGetFamInstEnvs
        ; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig
@@ -689,8 +729,7 @@ mkEqErr1 ctxt ct
                ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2
        ; dflags <- getDynFlags
        ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctLocOrigin loc) $$ pprCtOrigin tidy_orig)
-       ; mkEqErr_help dflags (ctxt {cec_tidy = env1})
-                      (wanted_msg $$ coercible_msg $$ binds_msg)
+       ; mkEqErr_help dflags ctxt (wanted_msg $$ coercible_msg $$ binds_msg)
                       ct is_oriented ty1 ty2 }
   where
     ev         = ctEvidence ct
@@ -818,8 +857,8 @@ reportEqErr :: ReportErrCtxt -> SDoc
             -> TcType -> TcType -> TcM ErrMsg
 reportEqErr ctxt extra1 ct oriented ty1 ty2
   = do { let extra2 = mkEqInfoMsg ct ty1 ty2
-       ; mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
-                                   , extra2, extra1]) }
+       ; mkErrorMsgFromCt ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
+                                        , extra2, extra1]) }
 
 mkTyVarEqErr :: DynFlags -> ReportErrCtxt -> SDoc -> Ct
              -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg
@@ -829,29 +868,29 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
                             -- be oriented the other way round;
                             -- see TcCanonical.canEqTyVarTyVar
   || isSigTyVar tv1 && not (isTyVarTy ty2)
-  = mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
-                             , extraTyVarInfo ctxt tv1 ty2
-                             , extra ])
+  = mkErrorMsgFromCt ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
+                                   , extraTyVarInfo ctxt tv1 ty2
+                                   , extra ])
 
   -- So tv is a meta tyvar (or started that way before we
   -- generalised it).  So presumably it is an *untouchable*
   -- meta tyvar or a SigTv, else it'd have been unified
   | not (k2 `tcIsSubKind` k1)            -- Kind error
-  = mkErrorMsg ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra)
+  = mkErrorMsgFromCt ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra)
 
   | OC_Occurs <- occ_check_expand
   , NomEq <- ctEqRel ct      -- reporting occurs check for Coercible is strange
   = do { let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:")
                               2 (sep [ppr ty1, char '~', ppr ty2])
              extra2 = mkEqInfoMsg ct ty1 ty2
-       ; mkErrorMsg ctxt ct (occCheckMsg $$ extra2 $$ extra) }
+       ; mkErrorMsgFromCt ctxt ct (occCheckMsg $$ extra2 $$ extra) }
 
   | OC_Forall <- occ_check_expand
   = do { let msg = vcat [ ptext (sLit "Cannot instantiate unification variable")
                           <+> quotes (ppr tv1)
                         , hang (ptext (sLit "with a type involving foralls:")) 2 (ppr ty2)
                         , nest 2 (ptext (sLit "Perhaps you want ImpredicativeTypes")) ]
-       ; mkErrorMsg ctxt ct msg }
+       ; mkErrorMsgFromCt ctxt ct msg }
 
   -- If the immediately-enclosing implication has 'tv' a skolem, and
   -- we know by now its an InferSkol kind of skolem, then presumably
@@ -860,9 +899,9 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
   | (implic:_) <- cec_encl ctxt
   , Implic { ic_skols = skols } <- implic
   , tv1 `elem` skols
-  = mkErrorMsg ctxt ct (vcat [ misMatchMsg oriented eq_rel ty1 ty2
-                             , extraTyVarInfo ctxt tv1 ty2
-                             , extra ])
+  = mkErrorMsgFromCt ctxt ct (vcat [ misMatchMsg oriented eq_rel ty1 ty2
+                                   , extraTyVarInfo ctxt tv1 ty2
+                                   , extra ])
 
   -- Check for skolem escape
   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
@@ -882,7 +921,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
                                <+> ptext (sLit "bound by")
                              , nest 2 $ ppr skol_info
                              , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] ]
-       ; mkErrorMsg ctxt ct (msg $$ tv_extra $$ extra) }
+       ; mkErrorMsgFromCt ctxt ct (msg $$ tv_extra $$ extra) }
 
   -- Nastiest case: attempt to unify an untouchable variable
   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
@@ -896,7 +935,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
                       , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ]
              tv_extra = extraTyVarInfo ctxt tv1 ty2
              add_sig  = suggestAddSig ctxt ty1 ty2
-       ; mkErrorMsg ctxt ct (vcat [msg, tclvl_extra, tv_extra, add_sig, extra]) }
+       ; mkErrorMsgFromCt ctxt ct (vcat [msg, tclvl_extra, tv_extra, add_sig, extra]) }
 
   | otherwise
   = reportEqErr ctxt extra ct oriented (mkTyVarTy tv1) ty2
@@ -1166,7 +1205,7 @@ mkDictErr ctxt cts
        -- have the same source-location origin, to try avoid a cascade
        -- of error from one location
        ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
-       ; mkErrorMsg ctxt ct1 err }
+       ; mkErrorMsgFromCt ctxt ct1 err }
   where
     no_givens = null (getUserGivens ctxt)
 
@@ -1198,7 +1237,7 @@ mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
 mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
   | null matches  -- No matches but perhaps several unifiers
   = do { let (is_ambig, ambig_msg) = mkAmbigMsg ct
-       ; (ctxt, binds_msg) <- relevantBindings True ctxt ct
+       ; (ctxt, binds_msg, _) <- relevantBindings True ctxt ct
        ; traceTc "mk_dict_err" (ppr ct $$ ppr is_ambig $$ ambig_msg)
        ; return (ctxt, cannot_resolve_msg is_ambig binds_msg ambig_msg) }
 
@@ -1348,15 +1387,22 @@ usefulContext ctxt pred
     pred_tvs = tyVarsOfType pred
     go [] = []
     go (ic : ics)
-       = case ic_info ic of
-               -- Do not suggest adding constraints to an *inferred* type signature!
-           SigSkol (InfSigCtxt {}) _ -> rest
-           info                      -> info : rest
+       | implausible ic = rest
+       | otherwise      = ic_info ic : rest
        where
           -- Stop when the context binds a variable free in the predicate
           rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = []
                | otherwise                                 = go ics
 
+    implausible ic
+      | null (ic_skols ic)            = True
+      | implausible_info (ic_info ic) = True
+      | otherwise                     = False
+
+    implausible_info (SigSkol (InfSigCtxt {}) _) = True
+    implausible_info _                           = False
+    -- Do not suggest adding constraints to an *inferred* type signature!
+
 show_fixes :: [SDoc] -> SDoc
 show_fixes []     = empty
 show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:")
@@ -1493,17 +1539,31 @@ getSkolemInfo (implic:implics) tv
 relevantBindings :: Bool  -- True <=> filter by tyvar; False <=> no filtering
                           -- See Trac #8191
                  -> ReportErrCtxt -> Ct
-                 -> TcM (ReportErrCtxt, SDoc)
+                 -> TcM (ReportErrCtxt, SDoc, CtOrigin)
+-- Also returns the zonked and tidied CtOrigin of the constraint
 relevantBindings want_filtering ctxt ct
   = do { dflags <- getDynFlags
+       ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
+       ; let ct_tvs    = tyVarsOfCt ct `unionVarSet` extra_tvs
+
+             -- For *kind* errors, report the relevant bindings of the
+             -- enclosing *type* equality, because that's more useful for the programmer
+             extra_tvs = case tidy_orig of
+                             KindEqOrigin t1 t2 _ -> tyVarsOfTypes [t1,t2]
+                             _                    -> emptyVarSet
+       ; traceTc "relevantBindings" $
+           vcat [ ppr ct
+                , pprCtOrigin (ctLocOrigin loc)
+                , ppr ct_tvs
+                , ppr [id | TcIdBndr id _ <- tcl_bndrs lcl_env] ]
+
        ; (tidy_env', docs, discards)
-              <- go (cec_tidy ctxt) (maxRelevantBinds dflags)
+              <- go env1 ct_tvs (maxRelevantBinds dflags)
                     emptyVarSet [] False
                     (tcl_bndrs lcl_env)
          -- tcl_bndrs has the innermost bindings first,
          -- which are probably the most relevant ones
 
-       ; traceTc "relevantBindings" (ppr ct $$ ppr [id | TcIdBndr id _ <- tcl_bndrs lcl_env])
        ; let doc = hang (ptext (sLit "Relevant bindings include"))
                       2 (vcat docs $$ max_msg)
              max_msg | discards
@@ -1511,19 +1571,11 @@ relevantBindings want_filtering ctxt ct
                      | otherwise = empty
 
        ; if null docs
-         then return (ctxt, empty)
-         else do { traceTc "rb" doc
-                 ; return (ctxt { cec_tidy = tidy_env' }, doc) } }
+         then return (ctxt,                          empty, tidy_orig)
+         else return (ctxt { cec_tidy = tidy_env' }, doc,   tidy_orig) }
   where
     loc       = ctLoc ct
     lcl_env   = ctLocEnv loc
-    ct_tvs    = tyVarsOfCt ct `unionVarSet` extra_tvs
-
-    -- For *kind* errors, report the relevant bindings of the
-    -- enclosing *type* equality, because that's more useful for the programmer
-    extra_tvs = case ctLocOrigin loc of
-                  KindEqOrigin t1 t2 _ -> tyVarsOfTypes [t1,t2]
-                  _                    -> emptyVarSet
 
     run_out :: Maybe Int -> Bool
     run_out Nothing = False
@@ -1532,14 +1584,14 @@ relevantBindings want_filtering ctxt ct
     dec_max :: Maybe Int -> Maybe Int
     dec_max = fmap (\n -> n - 1)
 
-    go :: TidyEnv -> Maybe Int -> TcTyVarSet -> [SDoc]
+    go :: TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc]
        -> Bool                          -- True <=> some filtered out due to lack of fuel
        -> [TcIdBinder]
        -> TcM (TidyEnv, [SDoc], Bool)   -- The bool says if we filtered any out
                                         -- because of lack of fuel
-    go tidy_env _ _ docs discards []
+    go tidy_env _ _ _ docs discards []
        = return (tidy_env, reverse docs, discards)
-    go tidy_env n_left tvs_seen docs discards (TcIdBndr id top_lvl : tc_bndrs)
+    go tidy_env ct_tvs n_left tvs_seen docs discards (TcIdBndr id top_lvl : tc_bndrs)
        = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
             ; traceTc "relevantBindings 1" (ppr id <+> dcolon <+> ppr tidy_ty)
             ; let id_tvs = tyVarsOfType tidy_ty
@@ -1552,30 +1604,30 @@ relevantBindings want_filtering ctxt ct
                                  && id_tvs `disjointVarSet` ct_tvs)
                        -- We want to filter out this binding anyway
                        -- so discard it silently
-              then go tidy_env n_left tvs_seen docs discards tc_bndrs
+              then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs
 
               else if isTopLevel top_lvl && not (isNothing n_left)
                        -- It's a top-level binding and we have not specified
                        -- -fno-max-relevant-bindings, so discard it silently
-              then go tidy_env n_left tvs_seen docs discards tc_bndrs
+              then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs
 
               else if run_out n_left && id_tvs `subVarSet` tvs_seen
                        -- We've run out of n_left fuel and this binding only
                        -- mentions aleady-seen type variables, so discard it
-              then go tidy_env n_left tvs_seen docs True tc_bndrs
+              then go tidy_env ct_tvs n_left tvs_seen docs True tc_bndrs
 
                        -- Keep this binding, decrement fuel
-              else go tidy_env' (dec_max n_left) new_seen (doc:docs) discards tc_bndrs }
+              else go tidy_env' ct_tvs (dec_max n_left) new_seen (doc:docs) discards tc_bndrs }
 
 -----------------------
-warnDefaulting :: Cts -> Type -> TcM ()
+warnDefaulting :: [Ct] -> Type -> TcM ()
 warnDefaulting wanteds default_ty
   = do { warn_default <- woptM Opt_WarnTypeDefaults
        ; env0 <- tcInitTidyEnv
        ; let tidy_env = tidyFreeTyVars env0 $
-                        tyVarsOfCts wanteds
-             tidy_wanteds = mapBag (tidyCt tidy_env) wanteds
-             (loc, ppr_wanteds) = pprWithArising (bagToList tidy_wanteds)
+                        foldr (unionVarSet . tyVarsOfCt) emptyVarSet wanteds
+             tidy_wanteds = map (tidyCt tidy_env) wanteds
+             (loc, ppr_wanteds) = pprWithArising tidy_wanteds
              warn_msg  = hang (ptext (sLit "Defaulting the following constraint(s) to type")
                                 <+> quotes (ppr default_ty))
                             2 ppr_wanteds