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.

1 files changed, 24 insertions, 8 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