From: Thomas Schilling <nominolo@googlemail.com>
Date: Mon, 6 Oct 2008 22:28:31 +0000 (+0000)
Subject: Make 'gblock' and 'gunblock' part of 'ExceptionMonad'.  This way the
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=1a93895686c5ad0dfd3fd1279a4bd51fd5a3279e

Make 'gblock' and 'gunblock' part of 'ExceptionMonad'.  This way the
default implementations of 'gbracket' and 'gfinally' just work.

MERGE TO 6.10
---

diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs
index 0bd484a..ef1879d 100644
--- a/compiler/ghci/GhciMonad.hs
+++ b/compiler/ghci/GhciMonad.hs
@@ -170,12 +170,8 @@ instance GhcMonad GHCi where
 
 instance ExceptionMonad GHCi where
   gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
-  gbracket acq rel ib =
-      GHCi $ \r -> gbracket (unGHCi acq r)
-                            (\x -> unGHCi (rel x) r)
-                            (\x -> unGHCi (ib x) r)
-  gfinally th cu =
-      GHCi $ \r -> gfinally (unGHCi th r) (unGHCi cu r)
+  gblock (GHCi m)   = GHCi $ \r -> gblock (m r)
+  gunblock (GHCi m) = GHCi $ \r -> gunblock (m r)
 
 instance WarnLogMonad GHCi where
   setWarnings warns = liftGhc $ setWarnings warns
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 343e75d..30362a8 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -302,6 +302,9 @@ instance MonadIO Ghc where
 instance ExceptionMonad Ghc where
   gcatch act handle =
       Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s
+  gblock (Ghc m)   = Ghc $ \s -> gblock (m s)
+  gunblock (Ghc m) = Ghc $ \s -> gunblock (m s)
+
 instance WarnLogMonad Ghc where
   setWarnings warns = Ghc $ \(Session _ wref) -> writeIORef wref warns
   -- | Return 'Warnings' accumulated so far.
@@ -331,6 +334,8 @@ instance MonadIO m => MonadIO (GhcT m) where
 instance ExceptionMonad m => ExceptionMonad (GhcT m) where
   gcatch act handle =
       GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s
+  gblock (GhcT m) = GhcT $ \s -> gblock (m s)
+  gunblock (GhcT m) = GhcT $ \s -> gunblock (m s)
 
 instance MonadIO m => WarnLogMonad (GhcT m) where
   setWarnings warns = GhcT $ \(Session _ wref) -> liftIO $ writeIORef wref warns
diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs
index 3242292..c51c232 100644
--- a/compiler/utils/Exception.hs
+++ b/compiler/utils/Exception.hs
@@ -26,14 +26,27 @@ tryIO = try
 -- | 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.
+-- Implementations on top of 'IO' should implement 'gblock' and 'gunblock' to
+-- eventually call the primitives 'Control.Exception.block' and
+-- 'Control.Exception.unblock' respectively.  These are used for
+-- implementations that support asynchronous exceptions.  The default
+-- implementations of 'gbracket' and 'gfinally' use 'gblock' and 'gunblock'
+-- thus rarely require overriding.
+--
 class Monad 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.block', 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
+
   -- | 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
@@ -42,22 +55,26 @@ class Monad m => ExceptionMonad m where
   -- 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
+  gblock = id
+  gunblock = id
+
+  gbracket before after thing =
+    gblock (do
+      a <- before
+      r <- gunblock (thing a) `gonException` after a
+      after a
+      return r)
 
-  gfinally thing cleanup = do
-      r <- thing `gonException` cleanup
-      cleanup
-      return r
+  a `gfinally` sequel =
+    gblock (do
+      r <- gunblock a `gonException` sequel
+      sequel
+      return r)
 
 instance ExceptionMonad IO where
   gcatch    = catch
-  gbracket  = bracket
-  gfinally  = finally
-
+  gblock    = block
+  gunblock  = unblock
 
 gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a)
 gtry act = gcatch (act >>= \a -> return (Right a))