Commit 1a938956 authored by Thomas Schilling's avatar Thomas Schilling

Make 'gblock' and 'gunblock' part of 'ExceptionMonad'. This way the

default implementations of 'gbracket' and 'gfinally' just work.

MERGE TO 6.10
parent 7be8ea9d
......@@ -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
......
......@@ -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
......
......@@ -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))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment