Introduce an 'ExceptionMonad' class.

This monad provides variants of 'catch', 'bracket', and 'finally', so
exceptions can be handled in monads that wrap IO.  The latter two
methods need to be part of the class definition, because GHC uses
'block' and 'unblock' which are used in the definition of those two
methods for the IO monad.  A perhaps better class interface would
consist of 'gcatch', 'gblock', and 'gunblock' and let the latter two
default to 'id' like is done for non-GHC implementations of 'bracket'
and 'finally'.

diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs
index a316c56..8d5d438 100644 (file)
--- a/compiler/utils/Exception.hs
+++ b/compiler/utils/Exception.hs
@@ -10,6 +10,8 @@ import Prelude hiding (catch)
 import Control.Exception
 
 #if __GLASGOW_HASKELL__ < 609
+import Data.Typeable ( Typeable )
+
 type SomeException = Exception
 
 onException :: IO a -> IO () -> IO a
@@ -40,3 +42,74 @@ tryIO io = do ei <- try io
                   Left e -> throwIO e
 #endif
 
+-- | A monad that can catch exceptions.  A minimal definition
+-- requires a definition of 'gcatch'.
+--
+-- Although, 'gbracket' and 'gfinally' could be modelled on top of 'gcatch',
+-- they are included in the type class since GHC needs special implementations
+-- of these in order to properly handle asynchronous exceptions.
+class Monad m => ExceptionMonad m where
+  -- | Generalised version of 'Control.Exception.catch', allowing an arbitrary
+  -- exception handling monad instead of just 'IO'.
+#if __GLASGOW_HASKELL__ >= 609
+  gcatch :: Exception e => m a -> (e -> m a) -> m a
+#else
+  gcatch :: m a -> (Exception -> m a) -> m a
+  gcatchDyn :: Typeable e => m a -> (e -> m a) -> m a
+#endif
+
+  -- | Generalised version of 'Control.Exception.bracket', allowing an arbitrary
+  -- exception handling monad instead of just 'IO'.
+  gbracket :: m a -> (a -> m b) -> (a -> m c) -> m c
+
+  -- | Generalised version of 'Control.Exception.finally', allowing an arbitrary
+  -- exception handling monad instead of just 'IO'.
+  gfinally :: m a -> m b -> m a
+
+  gbracket acquire release in_between = do
+      a <- acquire
+      r <- in_between a `gonException` release a
+      release a
+      return r
+
+  gfinally thing cleanup = do
+      r <- thing `gonException` cleanup
+      cleanup
+      return r
+
+instance ExceptionMonad IO where
+  gcatch    = catch
+#if __GLASGOW_HASKELL__ < 609
+  gcatchDyn = catchDyn
+#endif
+  gbracket  = bracket
+  gfinally  = finally
+
+
+#if __GLASGOW_HASKELL__ >= 609
+gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a)
+#else
+gtry :: (ExceptionMonad m) => m a -> m (Either Exception a)
+#endif
+gtry act = gcatch (act >>= \a -> return (Right a))
+                  (\e -> return (Left e))
+
+-- | Generalised version of 'Control.Exception.handle', allowing an arbitrary
+-- exception handling monad instead of just 'IO'.
+#if __GLASGOW_HASKELL__ >= 609
+ghandle :: (ExceptionMonad m, Exception e) => (e -> m a) -> m a -> m a
+#else
+ghandle :: (ExceptionMonad m) => (Exception -> m a) -> m a -> m a
+#endif
+ghandle = flip gcatch
+
+-- | Always executes the first argument.  If this throws an exception the
+-- second argument is executed and the exception is raised again.
+gonException :: (ExceptionMonad m) => m a -> m b -> m a
+gonException ioA cleanup = ioA `gcatch` \e ->
+                             do cleanup
+#if __GLASGOW_HASKELL__ >= 609
+                                throw (e :: SomeException)
+#else
+                                throw e
+#endif