module Control.Monad.Exception (
E.Exception(..),
E.SomeException,
MonadException(..),
MonadIOException(..),
ExceptionT(..),
mapExceptionT,
liftException
) where
import Prelude hiding (catch)
import qualified Control.Exception as E (Exception(..),
SomeException,
block,
catch,
throw,
unblock)
import Control.Monad (MonadPlus(..))
import Control.Monad.Cont (MonadCont(..))
import Control.Monad.Fix (MonadFix(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.RWS.Class (MonadRWS)
import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.State.Class (MonadState(..))
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..),
runRWST)
import Control.Monad.Trans.RWS.Strict as Strict (RWST(..),
runRWST)
import Control.Monad.Trans.Reader (ReaderT(..))
import Control.Monad.Trans.State.Lazy as Lazy (StateT(..),
runStateT)
import Control.Monad.Trans.State.Strict as Strict (StateT(..),
runStateT)
import Control.Monad.Trans.Writer.Lazy as Lazy (WriterT(..),
runWriterT)
import Control.Monad.Trans.Writer.Strict as Strict (WriterT(..),
runWriterT)
import Data.Monoid (Monoid)
class (Monad m) => MonadException m where
throw :: E.Exception e => e -> m a
catch :: E.Exception e => m a -> (e -> m a) -> m a
class (MonadIO m, MonadException m) => MonadIOException m where
block :: m a -> m a
unblock :: m a -> m a
newtype ExceptionT m a = ExceptionT { runExceptionT :: m (Either E.SomeException a) }
mapExceptionT :: (m (Either E.SomeException a) -> n (Either E.SomeException b))
-> ExceptionT m a
-> ExceptionT n b
mapExceptionT f m = ExceptionT $ f (runExceptionT m)
liftException :: MonadException m => Either E.SomeException a -> m a
liftException (Left e) = throw e
liftException (Right a) = return a
instance (Monad m) => Functor (ExceptionT m) where
fmap f m = ExceptionT $ do
a <- runExceptionT m
case a of
Left l -> return (Left l)
Right r -> return (Right (f r))
instance (Monad m) => Monad (ExceptionT m) where
return a = ExceptionT $ return (Right a)
m >>= k = ExceptionT $ do
a <- runExceptionT m
case a of
Left l -> return (Left l)
Right r -> runExceptionT (k r)
fail msg = ExceptionT $ return (Left (E.toException (userError msg)))
instance (Monad m) => MonadPlus (ExceptionT m) where
mzero = ExceptionT $ return (Left (E.toException (userError "")))
m `mplus` n = ExceptionT $ do
a <- runExceptionT m
case a of
Left _ -> runExceptionT n
Right r -> return (Right r)
instance (MonadFix m) => MonadFix (ExceptionT m) where
mfix f = ExceptionT $ mfix $ \a -> runExceptionT $ f $ case a of
Right r -> r
_ -> error "empty mfix argument"
instance (Monad m) => MonadException (ExceptionT m) where
throw e = ExceptionT $ return (Left (E.toException e))
m `catch` h = ExceptionT $ do
a <- runExceptionT m
case a of
Left l -> case E.fromException l of
Just e -> runExceptionT (h e)
Nothing -> return (Left l)
Right r -> return (Right r)
instance MonadTrans ExceptionT where
lift m = ExceptionT $ do
a <- m
return (Right a)
instance (MonadIO m) => MonadIO (ExceptionT m) where
liftIO m = ExceptionT $ liftIO $
(m >>= return . Right)
`E.catch` \(e :: E.SomeException) -> return (Left e)
instance (MonadCont m) => MonadCont (ExceptionT m) where
callCC f = ExceptionT $
callCC $ \c ->
runExceptionT (f (\a -> ExceptionT $ c (Right a)))
instance (MonadRWS r w s m) => MonadRWS r w s (ExceptionT m)
instance (MonadReader r m) => MonadReader r (ExceptionT m) where
ask = lift ask
local f m = ExceptionT $ local f (runExceptionT m)
instance (MonadState s m) => MonadState s (ExceptionT m) where
get = lift get
put = lift . put
instance (MonadWriter w m) => MonadWriter w (ExceptionT m) where
tell = lift . tell
listen m = ExceptionT $ do
(a, w) <- listen (runExceptionT m)
case a of
Left l -> return $ Left l
Right r -> return $ Right (r, w)
pass m = ExceptionT $ pass $ do
a <- runExceptionT m
case a of
Left l -> return (Left l, id)
Right (r, f) -> return (Right r, f)
instance MonadException IO where
catch = E.catch
throw = E.throw
instance (Monoid w, MonadException m) => MonadException (Lazy.RWST r w s m) where
throw = lift . throw
m `catch` h = Lazy.RWST $ \r s ->
Lazy.runRWST m r s `catch` \e -> Lazy.runRWST (h e) r s
instance (Monoid w, MonadException m) => MonadException (Strict.RWST r w s m) where
throw = lift . throw
m `catch` h = Strict.RWST $ \r s ->
Strict.runRWST m r s `catch` \e -> Strict.runRWST (h e) r s
instance (MonadException m) => MonadException (ReaderT r m) where
throw = lift . throw
m `catch` h = ReaderT $ \r ->
runReaderT m r `catch` \e -> runReaderT (h e) r
instance (MonadException m) => MonadException (Lazy.StateT s m) where
throw = lift . throw
m `catch` h = Lazy.StateT $ \s ->
Lazy.runStateT m s `catch` \e -> Lazy.runStateT (h e) s
instance (MonadException m) => MonadException (Strict.StateT s m) where
throw = lift . throw
m `catch` h = Strict.StateT $ \s ->
Strict.runStateT m s `catch` \e -> Strict.runStateT (h e) s
instance (Monoid w, MonadException m) => MonadException (Lazy.WriterT w m) where
throw = lift . throw
m `catch` h = Lazy.WriterT $
Lazy.runWriterT m `catch` \e -> Lazy.runWriterT (h e)
instance (Monoid w, MonadException m) => MonadException (Strict.WriterT w m) where
throw = lift . throw
m `catch` h = Strict.WriterT $
Strict.runWriterT m `catch` \e -> Strict.runWriterT (h e)
instance MonadIOException IO where
block = E.block
unblock = E.unblock
instance (MonadIOException m) => MonadIOException (ExceptionT m) where
block = ExceptionT . block . runExceptionT
unblock = ExceptionT . block . runExceptionT
instance (Monoid w, MonadIOException m) => MonadIOException (Lazy.RWST r w s m) where
block m = Lazy.RWST $ \r s -> block (Lazy.runRWST m r s)
unblock m = Lazy.RWST $ \r s -> unblock (Lazy.runRWST m r s)
instance (Monoid w, MonadIOException m) => MonadIOException (Strict.RWST r w s m) where
block m = Strict.RWST $ \r s -> block (Strict.runRWST m r s)
unblock m = Strict.RWST $ \r s -> unblock (Strict.runRWST m r s)
instance (MonadIOException m) => MonadIOException (ReaderT r m) where
block m = ReaderT $ \r -> block (runReaderT m r)
unblock m = ReaderT $ \r -> unblock (runReaderT m r)
instance (MonadIOException m) => MonadIOException (Lazy.StateT s m) where
block m = Lazy.StateT $ \s -> block (Lazy.runStateT m s)
unblock m = Lazy.StateT $ \s -> unblock (Lazy.runStateT m s)
instance (MonadIOException m) => MonadIOException (Strict.StateT s m) where
block m = Strict.StateT $ \s -> block (Strict.runStateT m s)
unblock m = Strict.StateT $ \s -> unblock (Strict.runStateT m s)
instance (Monoid w, MonadIOException m) => MonadIOException (Lazy.WriterT w m) where
block m = Lazy.WriterT $ block (Lazy.runWriterT m)
unblock m = Lazy.WriterT $ unblock (Lazy.runWriterT m)
instance (Monoid w, MonadIOException m) => MonadIOException (Strict.WriterT w m) where
block m = Strict.WriterT $ block (Strict.runWriterT m)
unblock m = Strict.WriterT $ unblock (Strict.runWriterT m)