Deal with exceptions in dsWhenNoErrs
[ghc.git] / compiler / deSugar / DsMonad.hs
index 8345859..81a8e35 100644 (file)
@@ -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