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 ++++++++++++++++++++--------------------------
 1 file changed, 20 insertions(+), 26 deletions(-)

(limited to 'src/Haddock/Interface.hs')

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
-- 
cgit v1.2.3