Don't suppress *all* Wanteds

Code in GHC.Tc.Errors.reportWanteds suppresses a Wanted if its
rewriters have unfilled coercion holes; see
Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint.

But if we thereby suppress *all* errors that's really confusing,
and as #22707 shows, GHC goes on without even realising that the
program is broken. Disaster.

This MR arranges to un-suppress them all if they all get suppressed.

Close #22707

5 files changed, 63 insertions, 17 deletions

diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 356d36e0ab..3816f31ddd 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -476,30 +476,37 @@ mkErrorItem ct
                             , ei_m_reason = m_reason
                             , ei_suppress = suppress }}
 
+-- | Actually report this 'ErrorItem'.
+unsuppressErrorItem :: ErrorItem -> ErrorItem
+unsuppressErrorItem ei = ei { ei_suppress = False }
+
 ----------------------------------------------------------------
 reportWanteds :: SolverReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
 reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
                                  , wc_errors = errs })
   | isEmptyWC wc = traceTc "reportWanteds empty WC" empty
   | otherwise
-  = do { tidy_items <- mapMaybeM mkErrorItem tidy_cts
+  = do { tidy_items1 <- mapMaybeM mkErrorItem tidy_cts
        ; traceTc "reportWanteds 1" (vcat [ text "Simples =" <+> ppr simples
                                          , text "Suppress =" <+> ppr (cec_suppress ctxt)
                                          , text "tidy_cts   =" <+> ppr tidy_cts
-                                         , text "tidy_items =" <+> ppr tidy_items
+                                         , text "tidy_items1 =" <+> ppr tidy_items1
                                          , text "tidy_errs =" <+> ppr tidy_errs ])
 
-       -- This check makes sure that we aren't suppressing the only error that will
-       -- actually stop compilation
-       ; assertPprM
-           ( do { errs_already <- ifErrsM (return True) (return False)
-                ; return $
-                    errs_already ||                  -- we already reported an error (perhaps from an outer implication)
-                    null simples ||                  -- no errors to report here
-                    any ignoreConstraint simples ||  -- one error is ignorable (is reported elsewhere)
-                    not (all ei_suppress tidy_items) -- not all errors are suppressed
-                } )
-           (vcat [text "reportWanteds is suppressing all errors"])
+         -- Catch an awkward case in which /all/ errors are suppressed:
+         -- see Wrinkle at end of Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint
+         -- Unless we are sure that an error will be reported some other way (details
+         -- in the defn of tidy_items) un-suppress the lot. This makes sure we don't forget to
+         -- report an error at all, which is catastrophic: GHC proceeds to desguar and optimise
+         -- the program, even though it is full of type errors (#22702, #22793)
+       ; errs_already <- ifErrsM (return True) (return False)
+       ; let tidy_items
+               | not errs_already                     -- Have not already reported an error (perhaps
+                                                      --   from an outer implication); see #21405
+               , not (any ignoreConstraint simples)   -- No error is ignorable (is reported elsewhere)
+               , all ei_suppress tidy_items1          -- All errors are suppressed
+                           = map unsuppressErrorItem tidy_items1
+               | otherwise = tidy_items1
 
          -- First, deal with any out-of-scope errors:
        ; let (out_of_scope, other_holes, not_conc_errs) = partition_errors tidy_errs
diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs
index 0623acd3d5..bd66282b24 100644
--- a/compiler/GHC/Tc/Types/Constraint.hs
+++ b/compiler/GHC/Tc/Types/Constraint.hs
@@ -2127,10 +2127,10 @@ uses GHC.Tc.Utils.anyUnfilledCoercionHoles to look through any filled coercion
 holes. The idea is that we wish to report the "root cause" -- the error that
 rewrote all the others.
 
-Worry: It seems possible that *all* unsolved wanteds are rewritten by other
-unsolved wanteds, so that e.g. w1 has w2 in its rewriter set, and w2 has
-w1 in its rewiter set. We are unable to come up with an example of this in
-practice, however, and so we believe this case cannot happen.
+Wrinkle: In #22707, we have a case where all of the Wanteds have rewritten
+each other. In order to report /some/ error in this case, we simply report
+all the Wanteds. The user will get a perhaps-confusing error message, but
+they've written a confusing program!
 
 Note [Avoiding rewriting cycles]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/testsuite/tests/typecheck/should_fail/T22707.hs b/testsuite/tests/typecheck/should_fail/T22707.hs
new file mode 100644
index 0000000000..35b0817ec2
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T22707.hs
@@ -0,0 +1,22 @@
+module T22707 where
+
+newtype Cont o i a = Cont {runCont ::(a -> i) -> o }
+
+t1:: Cont (i2 -> o) i1 a -> Cont o i2 (a -> i1)
+t1 c = Cont $ \ati1tti2 -> (runCont c) (ati1tti2 $ \a -> evalCont (t1 c) >>== \ati1 -> return ati1 a )
+
+evalCont:: Cont o a a -> o
+evalCont c = (runCont c)id
+
+instance Monad (Cont p p) where
+  return a = Cont ($ a)
+  (>>=) = (>>==)
+
+class PMonad m where
+  (>>==):: m p q a -> (a -> m q r b) -> m p r b
+
+instance PMonad Cont where
+ (Cont cont) >>== afmb = Cont $ \bti -> cont $ \a -> (runCont . afmb) a bti
+
+main:: IO ()
+main = putStrLn "bug"
diff --git a/testsuite/tests/typecheck/should_fail/T22707.stderr b/testsuite/tests/typecheck/should_fail/T22707.stderr
new file mode 100644
index 0000000000..0620e5996f
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T22707.stderr
@@ -0,0 +1,16 @@
+
+T22707.hs:6:37: error: [GHC-18872]
+    • Couldn't match kind ‘*’ with ‘GHC.Types.RuntimeRep’
+      When matching types
+        p0 :: *
+        GHC.Types.LiftedRep :: GHC.Types.RuntimeRep
+      Expected: Cont o i1 a
+        Actual: Cont (i2 -> o) i1 a
+    • In the first argument of ‘runCont’, namely ‘c’
+      In the expression:
+        (runCont c)
+          (ati1tti2 $ \ a -> evalCont (t1 c) >>== \ ati1 -> return ati1 a)
+      In the second argument of ‘($)’, namely
+        ‘\ ati1tti2
+           -> (runCont c)
+                (ati1tti2 $ \ a -> evalCont (t1 c) >>== \ ati1 -> ...)’
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 430e8f409c..bf03352115 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -321,6 +321,7 @@ test('T7856', normal, compile_fail, [''])
 test('T7869', normal, compile_fail, [''])
 test('T7892', normal, compile_fail, [''])
 test('T7809', normal, compile_fail, [''])
+test('T22707', normal, compile_fail, [''])
 test('T7989', normal, compile_fail, [''])
 test('T8034', normal, compile_fail, [''])
 test('T8142', normal, compile_fail, [''])