Improve error handling in TcRnMonad

See Note [Constraints and errors] in TcRnMonad.  This
patch fixes Trac #12124 in quite a neat way.

8 files changed, 57 insertions, 39 deletions

diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index a83fbf26bd..6d949a993a 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -69,7 +69,7 @@ module TcRnMonad(
   reportWarning, recoverM, mapAndRecoverM, mapAndReportM,
   tryTc,
   askNoErrs, discardErrs,
-  tryTcErrs, tryTcLIE, tryTcLIE_,
+  tryTcErrs, tryTcLIE_,
   checkNoErrs, whenNoErrs,
   ifErrsM, failIfErrsM,
   checkTH, failTH,
@@ -907,12 +907,15 @@ reportWarning reason err
 try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
 -- Does tryM, with a debug-trace on failure
 try_m thing
-  = do { mb_r <- tryM thing ;
-         case mb_r of
-             Left exn -> do { traceTc "tryTc/recoverM recovering from" $
-                                      text (showException exn)
-                            ; return mb_r }
-             Right _  -> return mb_r }
+  = do { mb_r <- tryM (captureConstraints thing)
+            -- See Note [Constraints and errors] for the
+            -- captureConstraints/emitContraints dance
+       ; case mb_r of
+           Left exn -> do { traceTc "tryTc/recoverM recovering from" $
+                                    text (showException exn)
+                          ; return (Left exn) }
+           Right (res, lie) -> do { emitConstraints lie
+                                  ; return (Right res) } }
 
 -----------------------
 recoverM :: TcRn r      -- Recovery action; do this if the main one fails
@@ -999,27 +1002,15 @@ tryTcErrs thing
         }
 
 -----------------------
-tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
--- Just like tryTcErrs, except that it ensures that the LIE
--- for the thing is propagated only if there are no errors
--- Hence it's restricted to the type-check monad
-tryTcLIE thing_inside
-  = do  { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ;
-        ; case mb_res of
-            Nothing  -> return (msgs, Nothing)
-            Just val -> do { emitConstraints lie; return (msgs, Just val) }
-        }
-
------------------------
 tryTcLIE_ :: TcM r -> TcM r -> TcM r
 -- (tryTcLIE_ r m) tries m;
 --      if m succeeds with no error messages, it's the answer
 --      otherwise tryTcLIE_ drops everything from m and tries r instead.
 tryTcLIE_ recover main
-  = do  { (msgs, mb_res) <- tryTcLIE main
+  = do  { (msgs, mb_res) <- tryTcErrs main
         ; case mb_res of
              Just val -> do { addMessages msgs  -- There might be warnings
-                             ; return val }
+                            ; return val }
              Nothing  -> recover                -- Discard all msgs
         }
 
@@ -1032,7 +1023,7 @@ checkNoErrs :: TcM r -> TcM r
 --      If so, it fails too.
 -- Regardless, any errors generated by m are propagated to the enclosing context.
 checkNoErrs main
-  = do  { (msgs, mb_res) <- tryTcLIE main
+  = do  { (msgs, mb_res) <- tryTcErrs main
         ; addMessages msgs
         ; case mb_res of
             Nothing  -> failM
@@ -1074,7 +1065,30 @@ failTH e what  -- Raise an error in a stage-1 compiler
                           2 (ppr e)
                      , text "Perhaps you are using a stage-1 compiler?" ])
 
-{-
+{- Note [Constraints and errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (Trac #12124):
+
+  foo :: Maybe Int
+  foo = return (case Left 3 of
+                  Left -> 1  -- Error here!
+                  _    -> 0)
+
+The call to 'return' will generate a (Monad m) wanted constraint; but
+then there'll be "hard error" (i.e. an exception in the TcM monad).
+We'll recover in tcPolyBinds, using recoverM.  But then the final
+tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly
+un-filled-in, and will emit a misleading error message.
+
+The underlying problem is that an exception interrupts the connstraint
+gathering process. Bottom line: if we have an exception, it's best
+simply to discard any gathered constraints.  Hence in 'try_m' we
+capture the constraints in a fresh variable, and only emit them into
+the surrounding context if we exit normally.  If an exception is
+raised, simply discard the collected constraints... we have a hard
+error to report.  So this capture-the-emit dance isn't as stupid as it
+looks :-).
+
 ************************************************************************
 *                                                                      *
         Context management for the type checker
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index ed553234b5..552426bd71 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -879,7 +879,7 @@ instance TH.Quasi TcM where
 
         -- For qRecover, discard error messages if
         -- the recovery action is chosen.  Otherwise
-        -- we'll only fail higher up.  c.f. tryTcLIE_
+        -- we'll only fail higher up.
   qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
                              ; case mb_res of
                                  Just val -> do { addMessages msgs      -- There might be warnings
diff --git a/testsuite/tests/typecheck/should_fail/CustomTypeErrors02.stderr b/testsuite/tests/typecheck/should_fail/CustomTypeErrors02.stderr
index 0b8be13b1b..3d551ac8f3 100644
--- a/testsuite/tests/typecheck/should_fail/CustomTypeErrors02.stderr
+++ b/testsuite/tests/typecheck/should_fail/CustomTypeErrors02.stderr
@@ -3,8 +3,3 @@ CustomTypeErrors02.hs:17:1: error:
     • The type 'a0 -> a0' cannot be represented as an integer.
     • When checking the inferred type
         err :: (TypeError ...)
-
-CustomTypeErrors02.hs:17:7: error:
-    • The type 'a0 -> a0' cannot be represented as an integer.
-    • In the expression: convert id
-      In an equation for ‘err’: err = convert id
diff --git a/testsuite/tests/typecheck/should_fail/T12124.hs b/testsuite/tests/typecheck/should_fail/T12124.hs
new file mode 100644
index 0000000000..59d29c5f15
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T12124.hs
@@ -0,0 +1,8 @@
+module T12124 where
+
+data Whoops = Whoops Int Int
+
+foo :: Maybe Int
+foo = return (case Whoops 1 2 of
+                 Whoops a -> a
+                 _ -> 0)
diff --git a/testsuite/tests/typecheck/should_fail/T12124.srderr b/testsuite/tests/typecheck/should_fail/T12124.srderr
new file mode 100644
index 0000000000..0519ecba6e
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T12124.srderr
@@ -0,0 +1 @@
+ 
\ No newline at end of file
diff --git a/testsuite/tests/typecheck/should_fail/T12124.stderr b/testsuite/tests/typecheck/should_fail/T12124.stderr
new file mode 100644
index 0000000000..cf3c755f7e
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T12124.stderr
@@ -0,0 +1,9 @@
+
+T12124.hs:7:18: error:
+    • The constructor ‘Whoops’ should have 2 arguments, but has been given 1
+    • In the pattern: Whoops a
+      In a case alternative: Whoops a -> a
+      In the first argument of ‘return’, namely
+        ‘(case Whoops 1 2 of {
+            Whoops a -> a
+            _ -> 0 })’
diff --git a/testsuite/tests/typecheck/should_fail/T8142.stderr b/testsuite/tests/typecheck/should_fail/T8142.stderr
index 4200268c24..6916435d0d 100644
--- a/testsuite/tests/typecheck/should_fail/T8142.stderr
+++ b/testsuite/tests/typecheck/should_fail/T8142.stderr
@@ -14,13 +14,3 @@ T8142.hs:6:18: error:
             = h
             where
                 h = (\ (_, b) -> ((outI . fmap h) b)) . out
-
-T8142.hs:6:57: error:
-    • Couldn't match type ‘Nu ((,) a)’ with ‘g (Nu ((,) a))’
-      Expected type: Nu ((,) a) -> (a, g (Nu ((,) a)))
-        Actual type: Nu ((,) a) -> (a, Nu ((,) a))
-    • In the second argument of ‘(.)’, namely ‘out’
-      In the expression: (\ (_, b) -> ((outI . fmap h) b)) . out
-      In an equation for ‘h’: h = (\ (_, b) -> ((outI . fmap h) b)) . out
-    • Relevant bindings include
-        h :: Nu ((,) a) -> Nu g (bound at T8142.hs:6:18)
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index c5596d6ee1..e595000936 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -430,3 +430,4 @@ test('T7437', normal, compile_fail, [''])
 test('T12177', normal, compile_fail, [''])
 test('T12406', normal, compile_fail, [''])
 test('T12170a', normal, compile_fail, [''])
+test('T12124', normal, compile_fail, [''])