Deal with exceptions in dsWhenNoErrs

Gracious me.  Ever since this patch

  commit 374457809de343f409fbeea0a885877947a133a2
  Author: Jan Stolarek <jan.stolarek@p.lodz.pl>
  Date:   Fri Jul 11 13:54:45 2014 +0200

      Injective type families

TcRnMonad.askNoErrs has been wrong. It looked like this

   askNoErrs :: TcRn a -> TcRn (a, Bool)
   askNoErrs m
    = do { errs_var <- newTcRef emptyMessages
         ; res  <- setErrsVar errs_var m
         ; (warns, errs) <- readTcRef errs_var
         ; addMessages (warns, errs)
         ; return (res, isEmptyBag errs) }

The trouble comes if 'm' throws an exception in the TcRn monad.
Then 'errs_var is never read, so any errors are simply lost.

This mistake was then propgated into DsMonad.dsWhenNoErrs, where
it gave rise to Trac #13642.

Thank to Ryan for narrowing it down so sharply.

I did some refactoring, as usual.

8 files changed, 94 insertions, 74 deletions

diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
index 8345859d92..81a8e35d7c 100644
--- a/compiler/deSugar/DsMonad.hs
+++ b/compiler/deSugar/DsMonad.hs
@@ -454,19 +454,35 @@ failDs :: DsM a
 failDs = failM
 
 -- (askNoErrsDs m) runs m
--- If m fails, (askNoErrsDs m) fails
--- If m succeeds with result r, (askNoErrsDs m) succeeds with result (r, b),
---  where b is True iff m generated no errors
--- Regardless of success or failure, any errors generated by m are propagated
+-- If m fails,
+--    then (askNoErrsDs m) fails
+-- If m succeeds with result r,
+--    then (askNoErrsDs m) succeeds with result (r, b),
+--         where b is True iff m generated no errors
+-- Regardless of success or failure,
+--   propagate any errors/warnings generated by m
+--
 -- c.f. TcRnMonad.askNoErrs
 askNoErrsDs :: DsM a -> DsM (a, Bool)
-askNoErrsDs m
+askNoErrsDs thing_inside
  = do { errs_var <- newMutVar emptyMessages
       ; env <- getGblEnv
-      ; res <- setGblEnv (env { ds_msgs = errs_var }) m
-      ; (warns, errs) <- readMutVar errs_var
+      ; mb_res <- tryM $  -- Be careful to catch exceptions
+                          -- so that we propagate errors correctly
+                          -- (Trac #13642)
+                  setGblEnv (env { ds_msgs = errs_var }) $
+                  thing_inside
+
+      -- Propagate errors
+      ; msgs@(warns, errs) <- readMutVar errs_var
       ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs))
-      ; return (res, isEmptyBag errs) }
+
+      -- And return
+      ; case mb_res of
+           Left _    -> failM
+           Right res -> do { dflags <- getDynFlags
+                           ; let errs_found = errorsFound dflags msgs
+                           ; return (res, not errs_found) } }
 
 mkPrintUnqualifiedDs :: DsM PrintUnqualified
 mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index a5b791a151..785513b3b6 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -576,11 +576,7 @@ traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
 -- recoverM retains the errors in the first action,
 --  whereas recoverTc here does not
 recoverTR :: TR a -> TR a -> TR a
-recoverTR recover thing = do
-  (_,mb_res) <- tryTcErrs thing
-  case mb_res of
-    Nothing  -> recover
-    Just res -> return res
+recoverTR = tryTcDiscardingErrs
 
 trIO :: IO a -> TR a
 trIO = liftTcM . liftIO
@@ -747,7 +743,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
                         then parens (text "already monomorphic: " <> ppr my_ty)
                         else Ppr.empty)
         Right dcname <- dataConInfoPtrToName (infoPtr clos)
-        (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
+        (_,mb_dc)    <- tryTc (tcLookupDataCon dcname)
         case mb_dc of
           Nothing -> do -- This can happen for private constructors compiled -O0
                         -- where the .hi descriptor does not export them
@@ -893,7 +889,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
       Constr -> do
         Right dcname <- dataConInfoPtrToName (infoPtr clos)
         traceTR (text "Constr1" <+> ppr dcname)
-        (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
+        (_,mb_dc)    <- tryTc (tcLookupDataCon dcname)
         case mb_dc of
           Nothing-> do
             forM (elems $ ptrs clos) $ \a -> do
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 76377b4448..564fd01c06 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -1953,7 +1953,7 @@ type Plan = TcM PlanResult
 runPlans :: [Plan] -> TcM PlanResult
 runPlans []     = panic "runPlans"
 runPlans [p]    = p
-runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
+runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p
 
 -- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the
 -- GHCi 'environment'.
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 2b73812de0..53a8c8c28e 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -67,8 +67,7 @@ module TcRnMonad(
   mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,
   reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
   tryTc,
-  askNoErrs, discardErrs,
-  tryTcErrs, tryTcLIE_,
+  askNoErrs, discardErrs, tryTcDiscardingErrs,
   checkNoErrs, whenNoErrs,
   ifErrsM, failIfErrsM,
   checkTH, failTH,
@@ -959,7 +958,8 @@ try_m thing
 
 -----------------------
 recoverM :: TcRn r      -- Recovery action; do this if the main one fails
-         -> TcRn r      -- Main action: do this first
+         -> TcRn r      -- Main action: do this first;
+                        --  if it generates errors, propagate them all
          -> TcRn r
 -- Errors in 'thing' are retained
 recoverM recover thing
@@ -997,30 +997,25 @@ tryTc :: TcRn a -> TcRn (Messages, Maybe a)
 --      Nothing, if m fails
 -- It also returns all the errors and warnings accumulated by m
 -- It always succeeds (never raises an exception)
-tryTc m
+tryTc thing_inside
  = do { errs_var <- newTcRef emptyMessages ;
-        res  <- try_m (setErrsVar errs_var m) ;
+
+        res  <- try_m $  -- Be sure to catch exceptions, so that
+                         -- we guaranteed to read the messages out
+                         -- of that brand-new errs_var!
+                setErrsVar errs_var $
+                thing_inside ;
+
         msgs <- readTcRef errs_var ;
+
         return (msgs, case res of
-                            Left _  -> Nothing
-                            Right val -> Just val)
+                        Left _    -> Nothing
+                        Right val -> Just val)
         -- The exception is always the IOEnv built-in
         -- in exception; see IOEnv.failM
    }
 
--- (askNoErrs m) runs m
--- If m fails, (askNoErrs m) fails
--- If m succeeds with result r, (askNoErrs m) succeeds with result (r, b),
---  where b is True iff m generated no errors
--- Regardless of success or failure, any errors generated by m are propagated
-askNoErrs :: TcRn a -> TcRn (a, Bool)
-askNoErrs m
- = do { errs_var <- newTcRef emptyMessages
-      ; res  <- setErrsVar errs_var m
-      ; (warns, errs) <- readTcRef errs_var
-      ; addMessages (warns, errs)
-      ; return (res, isEmptyBag errs) }
-
+-----------------------
 discardErrs :: TcRn a -> TcRn a
 -- (discardErrs m) runs m,
 --   discarding all error messages and warnings generated by m
@@ -1030,36 +1025,43 @@ discardErrs m
       ; setErrsVar errs_var m }
 
 -----------------------
-tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
--- Run the thing, returning
---      Just r,  if m succceeds with no error messages
---      Nothing, if m fails, or if it succeeds but has error messages
--- Either way, the messages are returned;
--- even in the Just case there might be warnings
-tryTcErrs thing
-  = do  { (msgs, res) <- tryTc thing
+tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r
+-- (tryTcDiscardingErrs recover main) tries 'main';
+--      if 'main' succeeds with no error messages, it's the answer
+--      otherwise discard everything from 'main', including errors,
+--          and try 'recover' instead.
+tryTcDiscardingErrs recover main
+  = do  { (msgs, mb_res) <- tryTc main
         ; dflags <- getDynFlags
-        ; let errs_found = errorsFound dflags msgs
-        ; return (msgs, case res of
-                          Nothing -> Nothing
-                          Just val | errs_found -> Nothing
-                                   | otherwise  -> 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) <- tryTcErrs main
         ; case mb_res of
-             Just val -> do { addMessages msgs  -- There might be warnings
-                            ; return val }
-             Nothing  -> recover                -- Discard all msgs
+            Just res | not (errorsFound dflags msgs)
+              -> -- 'main' succeeed with no error messages
+                 do { addMessages msgs  -- msgs might still have warnings
+                    ; return res }
+
+            _ -> -- 'main' failed, or produced an error message
+                 recover     -- Discard all errors and warnings entirely
         }
 
 -----------------------
+-- (askNoErrs m) runs m
+-- If m fails,
+--    then (askNoErrs m) fails
+-- If m succeeds with result r,
+--    then (askNoErrs m) succeeds with result (r, b),
+--         where b is True iff m generated no errors
+-- Regardless of success or failure,
+--   propagate any errors/warnings generated by m
+askNoErrs :: TcRn a -> TcRn (a, Bool)
+askNoErrs m
+  = do { (msgs, mb_res) <- tryTc m
+       ; addMessages msgs  -- Always propagate errors
+       ; case mb_res of
+           Nothing  -> failM
+           Just res -> do { dflags <- getDynFlags
+                          ; let errs_found = errorsFound dflags msgs
+                          ; return (res, not errs_found) } }
+-----------------------
 checkNoErrs :: TcM r -> TcM r
 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
 -- If m fails then (checkNoErrsTc m) fails.
@@ -1068,13 +1070,11 @@ 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) <- tryTcErrs main
-        ; addMessages msgs
-        ; case mb_res of
-            Nothing  -> failM
-            Just val -> return val
-        }
+  = do  { (res, no_errs) <- askNoErrs main
+        ; unless no_errs failM
+        ; return res }
 
+-----------------------
 whenNoErrs :: TcM () -> TcM ()
 whenNoErrs thing = ifErrsM (return ()) thing
 
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index b90de5e459..962ad2e0e0 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -864,13 +864,7 @@ instance TH.Quasi TcM where
         -- For qRecover, discard error messages if
         -- the recovery action is chosen.  Otherwise
         -- 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
-                                                ; return val }
-                                 Nothing  -> recover                    -- Discard all msgs
-                          }
-
+  qRecover recover main = tryTcDiscardingErrs recover main
   qRunIO io = liftIO io
 
   qAddDependentFile fp = do
diff --git a/testsuite/tests/th/T13642.hs b/testsuite/tests/th/T13642.hs
new file mode 100644
index 0000000000..35aee30ddb
--- /dev/null
+++ b/testsuite/tests/th/T13642.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE GADTs, TypeInType, TemplateHaskell, RankNTypes #-}
+module T13642 where
+
+import Data.Kind (Type)
+import Language.Haskell.TH (stringE, pprint)
+
+foo :: IO ()
+foo = $([d| data Foo :: forall a. a -> Type where MkFoo :: Foo Int |]
+         >>= \d -> stringE (pprint d))
diff --git a/testsuite/tests/th/T13642.stderr b/testsuite/tests/th/T13642.stderr
new file mode 100644
index 0000000000..a6ff054a26
--- /dev/null
+++ b/testsuite/tests/th/T13642.stderr
@@ -0,0 +1,4 @@
+
+T13642.hs:8:9: error:
+    Exotic form of kind not (yet) handled by Template Haskell
+      forall a. a -> Type
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 9dadeb699b..fd4530a6f1 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -383,3 +383,4 @@ test('T11046', normal, multimod_compile, ['T11046','-v0'])
 test('T13366', normal, compile_and_run, ['-lstdc++ -v0'])
 test('T13587', expect_broken(13587), compile_and_run, ['-v0'])
 test('T13618', normal, compile_and_run, ['-v0'])
+test('T13642', normal, compile_fail, ['-v0'])