1 files changed, 83 insertions, 0 deletions
diff --git a/compiler/GHC/Utils/Exception.hs b/compiler/GHC/Utils/Exception.hs
new file mode 100644
index 0000000000..e84221cdbe
--- /dev/null
+++ b/compiler/GHC/Utils/Exception.hs
@@ -0,0 +1,83 @@
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
+module GHC.Utils.Exception
+    (
+    module Control.Exception,
+    module GHC.Utils.Exception
+    )
+    where
+
+import GHC.Prelude
+
+import Control.Exception
+import Control.Monad.IO.Class
+
+catchIO :: IO a -> (IOException -> IO a) -> IO a
+catchIO = Control.Exception.catch
+
+handleIO :: (IOException -> IO a) -> IO a -> IO a
+handleIO = flip catchIO
+
+tryIO :: IO a -> IO (Either IOException a)
+tryIO = try
+
+-- | A monad that can catch exceptions.  A minimal definition
+-- requires a definition of 'gcatch'.
+--
+-- Implementations on top of 'IO' should implement 'gmask' to
+-- eventually call the primitive 'Control.Exception.mask'.
+-- These are used for
+-- implementations that support asynchronous exceptions.  The default
+-- implementations of 'gbracket' and 'gfinally' use 'gmask'
+-- thus rarely require overriding.
+--
+class MonadIO m => ExceptionMonad m where
+
+  -- | Generalised version of 'Control.Exception.catch', allowing an arbitrary
+  -- exception handling monad instead of just 'IO'.
+  gcatch :: Exception e => m a -> (e -> m a) -> m a
+
+  -- | Generalised version of 'Control.Exception.mask_', allowing an arbitrary
+  -- exception handling monad instead of just 'IO'.
+  gmask :: ((m a -> m a) -> m b) -> m b
+
+  -- | 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 before after thing =
+    gmask $ \restore -> do
+      a <- before
+      r <- restore (thing a) `gonException` after a
+      _ <- after a
+      return r
+
+  a `gfinally` sequel =
+    gmask $ \restore -> do
+      r <- restore a `gonException` sequel
+      _ <- sequel
+      return r
+
+instance ExceptionMonad IO where
+  gcatch    = Control.Exception.catch
+  gmask f   = mask (\x -> f x)
+
+gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a)
+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'.
+ghandle :: (ExceptionMonad m, Exception e) => (e -> m a) -> m a -> m a
+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
+                                liftIO $ throwIO (e :: SomeException)
+