Follow extensible exceptions changes

2 files changed, 41 insertions, 19 deletions

diff --git a/src/Haddock/Exception.hs b/src/Haddock/Exception.hs
index 0ce002b0..b537127c 100644
--- a/src/Haddock/Exception.hs
+++ b/src/Haddock/Exception.hs
@@ -15,19 +15,19 @@ module Haddock.Exception (
 
 
 import Data.Typeable
-
-
--- TODO: change this to test for base version instead
-#if __GLASGOW_HASKELL__ >= 609 
-import Control.OldException
-#else
 import Control.Exception
-#endif
 
 
 data HaddockException = HaddockException String deriving Typeable
-throwE str = throwDyn (HaddockException str)
 
 
 instance Show HaddockException where
   show (HaddockException str) = str
+
+
+#if __GLASGOW_HASKELL__ >= 609
+instance Exception HaddockException
+throwE str = throw (HaddockException str)
+#else
+throwE str = throwDyn (HaddockException str)
+#endif
diff --git a/src/Main.hs b/src/Main.hs
index 3626abe4..6fc1a6cd 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -23,8 +23,12 @@ import Haddock.Utils
 import Paths_haddock
 
 import Control.Monad
+#if __GLASGOW_HASKELL__ >= 609
+import Control.OldException
+import qualified Control.Exception as NewException
+#else
 import Control.Exception
-import Control.Exception
+#endif
 import Data.Dynamic
 import Data.Maybe
 import Data.IORef
@@ -37,8 +41,13 @@ import GHC
 import GHC.Paths
 import DynFlags
 import Bag
-import Util (handleDyn)
 import ErrUtils
+#if __GLASGOW_HASKELL__ >= 609
+import Panic (handleGhcException)
+import Util
+#else
+import Util hiding (handle)
+#endif
 
 
 --------------------------------------------------------------------------------
@@ -65,28 +74,41 @@ handleNormalExceptions inner =
 
 
 handleHaddockExceptions inner = 
-  handleDyn (\(e::HaddockException) -> do
-    putStrLn $ "haddock: " ++ (show e)
-    exitFailure
-  ) inner
+#if __GLASGOW_HASKELL__ >= 609
+  NewException.catches inner [NewException.Handler handler]
+#else
+  handleDyn handler inner
+#endif
+  where
+    handler (e::HaddockException) = do
+      putStrLn $ "haddock: " ++ (show e)
+      exitFailure
 
 
 handleGhcExceptions inner = 
   -- compilation errors: messages with locations attached
-  handleDyn (\dyn -> do
+#if __GLASGOW_HASKELL__ >= 609
+  handleErrMsg (\e -> do
+#else
+ handleDyn (\e -> do
+#endif
     putStrLn "haddock: Compilation error(s):"
-    printBagOfErrors defaultDynFlags (unitBag dyn)
+    printBagOfErrors defaultDynFlags (unitBag e)
     exitFailure
   ) $
 
   -- error messages propagated as exceptions
-  handleDyn (\dyn -> do
+#if __GLASGOW_HASKELL__ >= 609
+  handleGhcException (\e -> do
+#else
+  handleDyn (\e -> do
+#endif
     hFlush stdout
-    case dyn of
+    case e of
       PhaseFailed _ code -> exitWith code
       Interrupted -> exitFailure
       _ -> do 
-        print (dyn :: GhcException)
+        print (e :: GhcException)
         exitFailure
   ) inner