module UI.HSCurses.MonadException where
import Prelude hiding (catch)
import Control.Exception
import Control.Monad.State
import Data.Dynamic
class Monad m => MonadExc m where
catchM :: Exception e => m a -> (e -> m a) -> m a
blockM :: m a -> m a
unblockM :: m a -> m a
class (MonadIO m, MonadExc m) => MonadExcIO m
catchJustM :: (Exception e, MonadExc m) =>
(e -> Maybe b)
-> m a
-> (b -> m a)
-> m a
catchJustM p a handler = catchM a handler'
where handler' e = case p e of
Nothing -> throw e
Just b -> handler b
handleM :: (Exception e, MonadExc m) => (e -> m a) -> m a -> m a
handleM = flip catchM
handleJustM :: (Exception e,MonadExc m) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m a
handleJustM p = flip (catchJustM p)
tryM :: (Exception e, MonadExc m) => m a -> m (Either e a)
tryM a = catchM (a >>= \ v -> return (Right v)) (\e -> return (Left e))
tryJustM :: (Exception e, MonadExc m) => (e -> Maybe b) -> m a -> m (Either b a)
tryJustM p a = do
r <- tryM a
case r of
Right v -> return (Right v)
Left e -> case p e of
Nothing -> throw e
Just b -> return (Left b)
bracketM :: MonadExc m =>
m a
-> (a -> m b)
-> (a -> m c)
-> m c
bracketM before after thing =
blockM (do
a <- before
r <- catchM
(unblockM (thing a))
(\(e::SomeException) -> do { after a; throw e })
after a
return r
)
bracketM_ :: MonadExc m => m a -> m b -> m c -> m c
bracketM_ before after thing = bracketM before (const after) (const thing)
finally :: IO a
-> IO b
-> IO a
a `finally` sequel =
blockM (do
r <- catchM
(unblockM a)
(\(e::SomeException) -> do { sequel; throw e })
sequel
return r
)
instance MonadExc IO where
catchM = catch
blockM = block
unblockM = unblock
instance MonadExcIO IO
instance MonadExc m => MonadExc (StateT s m) where
catchM = catchState
blockM = blockState
unblockM = unblockState
instance (MonadExc m, MonadIO m) => MonadExcIO (StateT s m)
modifyState :: MonadExc m => (s -> m (a, s)) -> StateT s m a
modifyState f =
do oldState <- get
(x, newState) <- lift $ f oldState
put newState
return x
catchState :: (Exception e, MonadExc m)
=> StateT s m a -> (e -> StateT s m a) -> StateT s m a
catchState run handler =
modifyState (\oldState -> runStateT run oldState `catchM`
(\e -> runStateT (handler e) oldState))
blockState, unblockState :: (MonadExc m) => StateT s m a -> StateT s m a
blockState run =
modifyState (\oldState -> blockM (runStateT run oldState))
unblockState run =
modifyState (\oldState -> unblockM (runStateT run oldState))