{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables #-}
module Control.Monad.CatchIO
(
MonadCatchIO(..)
, E.Exception(..)
, throw
, try, tryJust
, Handler(..), catches
-- * Utilities
, bracket
, bracket_
, bracketOnError
, finally
, onException
)
where
import Prelude hiding ( catch )
import Control.Applicative ((<$>))
import qualified Control.Exception.Extensible as E
import Control.Monad.IO.Class (MonadIO,liftIO)
import Control.Monad.Trans.Cont (ContT(ContT) ,runContT ,mapContT )
import Control.Monad.Trans.Error (ErrorT ,runErrorT ,mapErrorT ,Error)
import Control.Monad.Trans.Identity (IdentityT ,runIdentityT,mapIdentityT)
import Control.Monad.Trans.List (ListT(ListT) ,runListT ,mapListT )
import Control.Monad.Trans.Maybe (MaybeT ,runMaybeT ,mapMaybeT )
import Control.Monad.Trans.RWS (RWST(RWST) ,runRWST ,mapRWST )
import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST(RWST) ,runRWST ,mapRWST )
import Control.Monad.Trans.Reader (ReaderT(ReaderT),runReaderT ,mapReaderT )
import Control.Monad.Trans.State (StateT(StateT) ,runStateT ,mapStateT )
import qualified Control.Monad.Trans.State.Strict as Strict (StateT(StateT) ,runStateT ,mapStateT )
import Control.Monad.Trans.Writer (WriterT ,runWriterT ,mapWriterT )
import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT ,runWriterT ,mapWriterT )
import Data.Monoid (Monoid)
class MonadIO m => MonadCatchIO m where
-- | Generalized version of 'E.catch'
catch :: E.Exception e => m a -> (e -> m a) -> m a
-- | Generalized version of 'E.block'
block :: m a -> m a
-- | Generalized version of 'E.unblock'
unblock :: m a -> m a
instance MonadCatchIO IO where
catch = E.catch
block = E.block
unblock = E.unblock
-- | Warning: this instance is somewhat contentious.
--
-- In the same way that the @ErrorT e@ instance may fail to perform the final
-- action, due to the \"early exit\" behaviour of the monad, this instance
-- may perform the final action any number of times, due to the nonlinear
-- nature of the continuation monad.
--
-- See the mailing list message
-- <http://web.archiveorange.com/archive/v/nDNOvaYx1poDHZNlmlgh>
-- for an example of what can go wrong (freeing memory twice).
instance MonadCatchIO m => MonadCatchIO (ContT r m) where
m `catch` f = ContT $ \c -> runContT m c `catch` \e -> runContT (f e) c
block = mapContT block
unblock = mapContT unblock
-- | Warning: this instance is somewhat contentious.
--
-- Note that in monads that fall under this instance (the most basic example
-- is @ErrorT e IO@), there are errors of two sorts:
--
-- 1. exceptions, (i.e., exceptional values in the underlying @IO@ monad);
--
-- 2. error values of type @e@, introduced by the @ErrorT e@ part of the monad.
--
-- The instance takes no special action to deal with errors of type 2.
-- In particular, 'bracket' will not perform its second argument, if
-- its third argument decides to \"exit early\" by throwing an error of type 2.
--
-- This may or may not be what you want.
--
-- See the mailing list thread starting with
-- <http://www.mail-archive.com/haskell-cafe@haskell.org/msg82859.html>
-- for some details.
instance (MonadCatchIO m, Error e) => MonadCatchIO (ErrorT e m) where
m `catch` f = mapErrorT (\m' -> m' `catch` \e -> runErrorT $ f e) m
block = mapErrorT block
unblock = mapErrorT unblock
instance (MonadCatchIO m) => MonadCatchIO (IdentityT m) where
m `catch` f = mapIdentityT (\m' -> m' `catch` \e -> runIdentityT $ f e) m
block = mapIdentityT block
unblock = mapIdentityT unblock
instance MonadCatchIO m => MonadCatchIO (ListT m) where
m `catch` f = ListT $ runListT m `catch` \e -> runListT (f e)
block = mapListT block
unblock = mapListT unblock
instance (MonadCatchIO m) => MonadCatchIO (MaybeT m) where
m `catch` f = mapMaybeT (\m' -> m' `catch` \e -> runMaybeT $ f e) m
block = mapMaybeT block
unblock = mapMaybeT unblock
instance (Monoid w, MonadCatchIO m) => MonadCatchIO (RWST r w s m) where
m `catch` f = RWST $ \r s -> runRWST m r s `catch` \e -> runRWST (f e) r s
block = mapRWST block
unblock = mapRWST unblock
instance (Monoid w, MonadCatchIO m) => MonadCatchIO (Strict.RWST r w s m) where
m `catch` f = Strict.RWST $ \r s -> Strict.runRWST m r s `catch` \e -> Strict.runRWST (f e) r s
block = Strict.mapRWST block
unblock = Strict.mapRWST unblock
instance MonadCatchIO m => MonadCatchIO (ReaderT r m) where
m `catch` f = ReaderT $ \r -> runReaderT m r `catch` \e -> runReaderT (f e) r
block = mapReaderT block
unblock = mapReaderT unblock
instance MonadCatchIO m => MonadCatchIO (StateT s m) where
m `catch` f = StateT $ \s -> runStateT m s `catch` \e -> runStateT (f e) s
block = mapStateT block
unblock = mapStateT unblock
instance MonadCatchIO m => MonadCatchIO (Strict.StateT s m) where
m `catch` f = Strict.StateT $ \s -> Strict.runStateT m s `catch` \e -> Strict.runStateT (f e) s
block = Strict.mapStateT block
unblock = Strict.mapStateT unblock
instance (Monoid w, MonadCatchIO m) => MonadCatchIO (WriterT w m) where
m `catch` f = mapWriterT (\m' -> m' `catch` \e -> runWriterT $ f e) m
block = mapWriterT block
unblock = mapWriterT unblock
instance (Monoid w, MonadCatchIO m) => MonadCatchIO (Strict.WriterT w m) where
m `catch` f = Strict.mapWriterT (\m' -> m' `catch` \e -> Strict.runWriterT $ f e) m
block = Strict.mapWriterT block
unblock = Strict.mapWriterT unblock
-- | Generalized version of 'E.throwIO'
throw :: (MonadIO m, E.Exception e) => e -> m a
throw = liftIO . E.throwIO
-- | Generalized version of 'E.try'
try :: (MonadCatchIO m, Functor m, E.Exception e) => m a -> m (Either e a)
try a = catch (Right <$> a) (return . Left)
-- | Generalized version of 'E.tryJust'
tryJust :: (MonadCatchIO m, Functor m, E.Exception e)
=> (e -> Maybe b) -> m a -> m (Either b a)
tryJust p a = do
r <- try a
case r of
Right v -> return (Right v)
Left e -> case p e of
Nothing -> throw e `asTypeOf` return (Left undefined)
Just b -> return (Left b)
-- | Generalized version of 'E.Handler'
data Handler m a = forall e . E.Exception e => Handler (e -> m a)
-- | Generalized version of 'E.catches'
catches :: MonadCatchIO m => m a -> [Handler m a] -> m a
catches a handlers = a `catch` handler where
handler e = foldr tryH (throw e) handlers where
tryH (Handler h) res = maybe res h $ E.fromException e
-- | Generalized version of 'E.bracket'
bracket :: MonadCatchIO m => m a -> (a -> m b) -> (a -> m c) -> m c
bracket before after thing = block $ do
a <- before
r <- unblock (thing a) `onException` after a
_ <- after a
return r
-- | Generalized version of 'E.onException'
onException :: MonadCatchIO m => m a -> m b -> m a
onException a onEx = a `catch` (\ (e :: E.SomeException) -> onEx >> throw e)
-- | A variant of 'bracket' where the return value from the first computation
-- is not required.
bracket_ :: MonadCatchIO m
=> m a -- ^ computation to run first (\"acquire resource\")
-> m b -- ^ computation to run last (\"release resource\")
-> m c -- ^ computation to run in-between
-> m c -- returns the value from the in-between computation
bracket_ before after thing = block $ do
_ <- before
r <- unblock thing `onException` after
_ <- after
return r
-- | A specialised variant of 'bracket' with just a computation to run
-- afterward.
finally :: MonadCatchIO m
=> m a -- ^ computation to run first
-> m b -- ^ computation to run afterward (even if an exception was
-- raised)
-> m a -- returns the value from the first computation
thing `finally` after = block $ do
r <- unblock thing `onException` after
_ <- after
return r
-- | Like 'bracket', but only performs the final action if there was an
-- exception raised by the in-between computation.
bracketOnError :: MonadCatchIO m
=> m a -- ^ computation to run first (\"acquire resource\")
-> (a -> m b) -- ^ computation to run last (\"release resource\")
-> (a -> m c) -- ^ computation to run in-between
-> m c -- returns the value from the in-between computation
bracketOnError before after thing = block $ do
a <- before
unblock (thing a) `onException` after a