update submodule pointer

[ghc-hetmet.git] / compiler / utils / Exception.hs

diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs
index c51c232..fa067b0 100644 (file)
--- a/compiler/utils/Exception.hs
+++ b/compiler/utils/Exception.hs
@@ -1,4 +1,4 @@
-
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
 module Exception
     (
     module Control.Exception,
@@ -8,11 +8,7 @@ module Exception
 
 import Prelude hiding (catch)
 
-#if __GLASGOW_HASKELL__ < 609
-import Control.Exception.Extensible as Control.Exception
-#else
 import Control.Exception
-#endif
 
 catchIO :: IO a -> (IOException -> IO a) -> IO a
 catchIO = catch
@@ -39,13 +35,9 @@ class Monad m => ExceptionMonad m where
   -- exception handling monad instead of just 'IO'.
   gcatch :: Exception e => m a -> (e -> m a) -> m a
 
-  -- | Generalised version of 'Control.Exception.block', allowing an arbitrary
+  -- | Generalised version of 'Control.Exception.mask_', allowing an arbitrary
   -- exception handling monad instead of just 'IO'.
-  gblock :: m a -> m a
-
-  -- | Generalised version of 'Control.Exception.unblock', allowing an
-  -- arbitrary exception handling monad instead of just 'IO'.
-  gunblock :: m a -> m a
+  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'.
@@ -55,26 +47,46 @@ class Monad m => ExceptionMonad m where
   -- exception handling monad instead of just 'IO'.
   gfinally :: m a -> m b -> m a
 
-  gblock = id
-  gunblock = id
+  -- | DEPRECATED, here for backwards compatibilty.  Instances can
+  -- define either 'gmask', or both 'block' and 'unblock'.
+  gblock   :: m a -> m a
+  -- | DEPRECATED, here for backwards compatibilty  Instances can
+  -- define either 'gmask', or both 'block' and 'unblock'.
+  gunblock :: m a -> m a
+  -- XXX we're keeping these two methods for the time being because we
+  -- have to interact with Haskeline's MonadException class which
+  -- still has block/unblock; see GhciMonad.hs.
+
+  gmask    f = gblock (f gunblock)
+  gblock   f = gmask (\_ -> f)
+  gunblock f = f -- XXX wrong; better override this if you need it
 
   gbracket before after thing =
-    gblock (do
+    gmask $ \restore -> do
       a <- before
-      r <- gunblock (thing a) `gonException` after a
-      after a
-      return r)
+      r <- restore (thing a) `gonException` after a
+      _ <- after a
+      return r
 
   a `gfinally` sequel =
-    gblock (do
-      r <- gunblock a `gonException` sequel
-      sequel
-      return r)
+    gmask $ \restore -> do
+      r <- restore a `gonException` sequel
+      _ <- sequel
+      return r
 
+#if __GLASGOW_HASKELL__ < 613
 instance ExceptionMonad IO where
   gcatch    = catch
+  gmask f   = block $ f unblock
   gblock    = block
   gunblock  = unblock
+#else
+instance ExceptionMonad IO where
+  gcatch    = catch
+  gmask f   = mask (\x -> f x)
+  gblock    = block
+  gunblock  = unblock
+#endif
 
 gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a)
 gtry act = gcatch (act >>= \a -> return (Right a))
@@ -89,6 +101,6 @@ ghandle = flip gcatch
 -- 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
+                             do _ <- cleanup
                                 throw (e :: SomeException)