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.Error (ErrorT ,runErrorT ,mapErrorT ,Error) 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 StrictState import Control.Monad.Trans.Writer (WriterT(WriterT),runWriterT,mapWriterT) import Control.Monad.Trans.RWS (RWST(RWST) ,runRWST ,mapRWST ) 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 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 (StrictState.StateT s m) where m `catch` f = StrictState.StateT $ \s -> StrictState.runStateT m s `catch` \e -> StrictState.runStateT (f e) s block = StrictState.mapStateT block unblock = StrictState.mapStateT unblock 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 (Monoid w, MonadCatchIO m) => MonadCatchIO (WriterT w m) where m `catch` f = WriterT $ runWriterT m `catch` \e -> runWriterT $ f e block = mapWriterT block unblock = mapWriterT 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 -- | 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