From cc54e035026b266df4fd0ed6ef023cac203936ad Mon Sep 17 00:00:00 2001
From: David Waern <david.waern@gmail.com>
Date: Wed, 25 Feb 2009 20:04:38 +0000
Subject: Fix bad error handling with newer GHCs

When support for GHC 6.10 was added, an error handler was installed only around
the typechecking phase. This had the effect that errors thrown during
dependency chasing were caught in the top-level exception handler and not
printed with enough detail.  With this patch we wrap the error handler around
all our usage of the Ghc monad.
---
 src/Haddock/Interface.hs | 46 ++++++++++++++++++++--------------------------
 src/Main.hs              |  8 +++++++-
 2 files changed, 27 insertions(+), 27 deletions(-)

(limited to 'src')

diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index d33d322d..2e4c3072 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -160,32 +160,26 @@ ppModInfo (HaddockModInfo a b c d) = show (fmap pretty a) ++ show b ++ show c ++
 
 #if __GLASGOW_HASKELL__ >= 609
 processModule :: ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> Ghc (Maybe Interface)
-processModule modsum flags modMap instIfaceMap = 
-
-  let handleSrcErrors action = flip handleSourceError action $ \err -> do 
-        printExceptionAndWarnings err
-        throwE ("Failed to check module: " ++ moduleString (ms_mod modsum))
-
-  in handleSrcErrors $ do
-       tc_mod <- loadModule =<< typecheckModule =<< parseModule modsum
-       if not $ isBootSummary modsum
-         then do
-           let filename = msHsFilePath modsum
-           let dynflags = ms_hspp_opts modsum
-           let Just renamed_src = renamedSource tc_mod
-           let ghcMod = mkGhcModule (ms_mod modsum,
-                                 filename,
-                                 (parsedSource tc_mod,
-                                  renamed_src,
-                                  typecheckedSource tc_mod,
-                                  moduleInfo tc_mod))
-                                 dynflags
-           let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap
-           liftIO $ mapM_ putStrLn msg
-           liftIO $ evaluate interface
-           return (Just interface)
-         else
-           return Nothing
+processModule modsum flags modMap instIfaceMap = do
+  tc_mod <- loadModule =<< typecheckModule =<< parseModule modsum
+  if not $ isBootSummary modsum
+    then do
+      let filename = msHsFilePath modsum
+      let dynflags = ms_hspp_opts modsum
+      let Just renamed_src = renamedSource tc_mod
+      let ghcMod = mkGhcModule (ms_mod modsum,
+                            filename,
+                            (parsedSource tc_mod,
+                             renamed_src,
+                             typecheckedSource tc_mod,
+                             moduleInfo tc_mod))
+                            dynflags
+      let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap
+      liftIO $ mapM_ putStrLn msg
+      liftIO $ evaluate interface
+      return (Just interface)
+    else
+      return Nothing
 #else
 processModule :: Session -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> IO (Maybe Interface)
 processModule session modsum flags modMap instIfaceMap = do
diff --git a/src/Main.hs b/src/Main.hs
index 328fce4d..05b71223 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -160,8 +160,14 @@ main = handleTopExceptions $ do
 #endif
 
 #if __GLASGOW_HASKELL__ >= 609
+      -- We have one global error handler for all GHC source errors.  Other kinds
+      -- of exceptions will be propagated to the top-level error handler. 
+      let handleSrcErrors action = flip handleSourceError action $ \err -> do
+            printExceptionAndWarnings err
+            liftIO exitFailure
+
       -- initialize GHC
-      startGhc libDir (ghcFlags flags) $ \dynflags -> do
+      startGhc libDir (ghcFlags flags) $ \dynflags -> handleSrcErrors $ do
 
         -- get packages supplied with --read-interface
         packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags)
-- 
cgit v1.2.3