module System.Console.Haskeline.MonadException(
MonadException(..),
catch,
handle,
catches,
Handler(..),
finally,
throwIO,
throwTo,
bracket,
liftIOOp,
liftIOOp_,
RunIO(..),
Exception,
SomeException(..),
E.IOException(),
)
where
import qualified Control.Exception as E
import Control.Exception (Exception,SomeException)
#if __GLASGOW_HASKELL__ < 705
import Prelude hiding (catch)
#endif
import Control.Monad(liftM, join)
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Error
import Control.Monad.Trans.List
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.RWS
import Control.Monad.Trans.Writer
import Data.Monoid
import Control.Concurrent(ThreadId)
newtype RunIO m = RunIO (forall b . m b -> IO (m b))
class MonadIO m => MonadException m where
controlIO :: (RunIO m -> IO (m a)) -> m a
liftIOOp :: MonadException m => ((a -> IO (m b)) -> IO (m c)) -> (a -> m b) -> m c
liftIOOp f g = controlIO $ \(RunIO run) -> f (run . g)
liftIOOp_ :: MonadException m => (IO (m a) -> IO (m a)) -> m a -> m a
liftIOOp_ f act = controlIO $ \(RunIO run) -> f (run act)
catch :: (MonadException m, E.Exception e) => m a -> (e -> m a) -> m a
catch act handler = controlIO $ \(RunIO run) -> E.catch
(run act)
(run . handler)
handle :: (MonadException m, Exception e) => (e -> m a) -> m a -> m a
handle = flip catch
catches :: (MonadException m) => m a -> [Handler m a] -> m a
catches act handlers = controlIO $ \(RunIO run) ->
let catchesHandler e = foldr tryHandler (E.throw e) handlers
where tryHandler (Handler handler) res =
case E.fromException e of
Just e' -> run $ handler e'
Nothing -> res
in E.catch (run act) catchesHandler
data Handler m a = forall e . Exception e => Handler (e -> m a)
bracket :: MonadException m => m a -> (a -> m b) -> (a -> m c) -> m c
bracket before after thing
= controlIO $ \(RunIO run) -> E.bracket
(run before)
(\m -> run (m >>= after))
(\m -> run (m >>= thing))
finally :: MonadException m => m a -> m b -> m a
finally thing ender = controlIO $ \(RunIO run) -> E.finally (run thing) (run ender)
throwIO :: (MonadIO m, Exception e) => e -> m a
throwIO = liftIO . E.throwIO
throwTo :: (MonadIO m, Exception e) => ThreadId -> e -> m ()
throwTo tid = liftIO . E.throwTo tid
instance MonadException IO where
controlIO f = join $ f (RunIO (liftM return))
instance MonadException m => MonadException (ReaderT r m) where
controlIO f = ReaderT $ \r -> controlIO $ \(RunIO run) -> let
run' = RunIO (fmap (ReaderT . const) . run . flip runReaderT r)
in fmap (flip runReaderT r) $ f run'
instance MonadException m => MonadException (StateT s m) where
controlIO f = StateT $ \s -> controlIO $ \(RunIO run) -> let
run' = RunIO (fmap (StateT . const) . run . flip runStateT s)
in fmap (flip runStateT s) $ f run'
instance MonadException m => MonadException (MaybeT m) where
controlIO f = MaybeT $ controlIO $ \(RunIO run) -> let
run' = RunIO (fmap MaybeT . run . runMaybeT)
in fmap runMaybeT $ f run'
instance (MonadException m, Error e) => MonadException (ErrorT e m) where
controlIO f = ErrorT $ controlIO $ \(RunIO run) -> let
run' = RunIO (fmap ErrorT . run . runErrorT)
in fmap runErrorT $ f run'
instance MonadException m => MonadException (ListT m) where
controlIO f = ListT $ controlIO $ \(RunIO run) -> let
run' = RunIO (fmap ListT . run . runListT)
in fmap runListT $ f run'
instance (Monoid w, MonadException m) => MonadException (WriterT w m) where
controlIO f = WriterT $ controlIO $ \(RunIO run) -> let
run' = RunIO (fmap WriterT . run . runWriterT)
in fmap runWriterT $ f run'
instance (Monoid w, MonadException m) => MonadException (RWST r w s m) where
controlIO f = RWST $ \r s -> controlIO $ \(RunIO run) -> let
run' = RunIO (fmap (\act -> RWST (\_ _ -> act))
. run . (\m -> runRWST m r s))
in fmap (\m -> runRWST m r s) $ f run'