diff --git a/io-sim-classes/src/Control/Monad/Class/MonadAsync.hs b/io-sim-classes/src/Control/Monad/Class/MonadAsync.hs index f6657df7fc3..4718397af10 100644 --- a/io-sim-classes/src/Control/Monad/Class/MonadAsync.hs +++ b/io-sim-classes/src/Control/Monad/Class/MonadAsync.hs @@ -43,7 +43,7 @@ class (Functor async, MonadSTMTx stm) => MonadAsyncSTM async stm where waitCatchSTM :: async a -> stm (Either SomeException a) default waitSTM :: MonadThrow stm => async a -> stm a - waitSTM action = waitCatchSTM action >>= either throwM return + waitSTM action = waitCatchSTM action >>= either throwSTM return waitAnySTM :: [async a] -> stm (async a, a) waitAnyCatchSTM :: [async a] -> stm (async a, Either SomeException a) diff --git a/io-sim-classes/src/Control/Monad/Class/MonadSTM.hs b/io-sim-classes/src/Control/Monad/Class/MonadSTM.hs index ad07f9727a2..6ee56030e82 100644 --- a/io-sim-classes/src/Control/Monad/Class/MonadSTM.hs +++ b/io-sim-classes/src/Control/Monad/Class/MonadSTM.hs @@ -45,6 +45,10 @@ module Control.Monad.Class.MonadSTM , isEmptyTBQueueDefault , isFullTBQueueDefault , lengthTBQueueDefault + + -- * MonadThrow aliases + , throwSTM + , catchSTM ) where import Prelude hiding (read) @@ -55,6 +59,8 @@ import qualified Control.Concurrent.STM.TQueue as STM import qualified Control.Concurrent.STM.TVar as STM import qualified Control.Monad.STM as STM +import qualified Control.Monad.Class.MonadThrow as MonadThrow + import Control.Applicative (Alternative (..)) import Control.Exception import Control.Monad.Reader @@ -440,3 +446,17 @@ lengthTBQueueDefault (TBQueue rsize _read wsize _write size) = do r <- readTVar rsize w <- readTVar wsize return $! size - r - w + + +-- | 'throwIO' specialised to @stm@ monad. +-- +throwSTM :: (MonadSTMTx stm, MonadThrow.MonadThrow stm, Exception e) + => e -> stm a +throwSTM = MonadThrow.throwIO + + +-- | 'catch' speclialized for an @stm@ monad. +-- +catchSTM :: (MonadSTMTx stm, MonadThrow.MonadCatch stm, Exception e) + => stm a -> (e -> stm a) -> stm a +catchSTM = MonadThrow.catch diff --git a/io-sim-classes/src/Control/Monad/Class/MonadThrow.hs b/io-sim-classes/src/Control/Monad/Class/MonadThrow.hs index bcb9f4b4ab3..9ee47872456 100644 --- a/io-sim-classes/src/Control/Monad/Class/MonadThrow.hs +++ b/io-sim-classes/src/Control/Monad/Class/MonadThrow.hs @@ -16,6 +16,8 @@ module Control.Monad.Class.MonadThrow , ExitCase(..) , Handler(..) , catches + -- * Deprecated interfaces + , throwM ) where import Control.Exception (Exception (..), SomeException) @@ -32,8 +34,8 @@ import qualified Control.Monad.STM as STM -- class Monad m => MonadThrow m where - {-# MINIMAL throwM #-} - throwM :: Exception e => e -> m a + {-# MINIMAL throwIO #-} + throwIO :: Exception e => e -> m a bracket :: m a -> (a -> m b) -> (a -> m c) -> m c bracket_ :: m a -> m b -> m c -> m c @@ -52,6 +54,10 @@ class Monad m => MonadThrow m where a `finally` sequel = bracket_ (return ()) sequel a +throwM :: (MonadThrow m, Exception e) => e -> m a +throwM = throwIO +{-# DEPRECATED throwM "Use throwIO" #-} + -- | Catching exceptions. -- -- Covers standard utilities to respond to exceptions. @@ -86,7 +92,7 @@ class MonadThrow m => MonadCatch m where catch a handler' where handler' e = case p e of - Nothing -> throwM e + Nothing -> throwIO e Just b -> handler b try a = catch (Right `fmap` a) (return . Left) @@ -96,7 +102,7 @@ class MonadThrow m => MonadCatch m where case r of Right v -> return (Right v) Left e -> case p e of - Nothing -> throwM e + Nothing -> throwIO e Just b -> return (Left b) handle = flip catch @@ -105,7 +111,7 @@ class MonadThrow m => MonadCatch m where onException action what = action `catch` \e -> do _ <- what - throwM (e :: SomeException) + throwIO (e :: SomeException) bracketOnError acquire release = liftM fst . generalBracket acquire @@ -120,7 +126,7 @@ class MonadThrow m => MonadCatch m where resource <- acquire b <- unmasked (use resource) `catch` \e -> do _ <- release resource (ExitCaseException e) - throwM e + throwIO e c <- release resource (ExitCaseSuccess b) return (b, c) @@ -145,7 +151,7 @@ catchesHandler :: MonadCatch m => [Handler m a] -> SomeException -> m a -catchesHandler handlers e = foldr tryHandler (throwM e) handlers +catchesHandler handlers e = foldr tryHandler (throwIO e) handlers where tryHandler (Handler handler) res = case fromException e of Just e' -> handler e' @@ -188,7 +194,7 @@ class MonadThrow m => MonadEvaluate m where instance MonadThrow IO where - throwM = IO.throwIO + throwIO = IO.throwIO bracket = IO.bracket bracket_ = IO.bracket_ @@ -225,7 +231,7 @@ instance MonadEvaluate IO where -- instance MonadThrow STM where - throwM = STM.throwSTM + throwIO = STM.throwSTM instance MonadCatch STM where catch = STM.catchSTM @@ -234,7 +240,7 @@ instance MonadCatch STM where resource <- acquire b <- use resource `catch` \e -> do _ <- release resource (ExitCaseException e) - throwM e + throwIO e c <- release resource (ExitCaseSuccess b) return (b, c) @@ -244,7 +250,7 @@ instance MonadCatch STM where -- instance MonadThrow m => MonadThrow (ReaderT r m) where - throwM = lift . throwM + throwIO = lift . throwIO bracket acquire release use = ReaderT $ \env -> bracket ( runReaderT acquire env) @@ -282,7 +288,7 @@ instance MonadEvaluate m => MonadEvaluate (ReaderT r m) where -- instance MonadCatch m => MonadThrow (ExceptT e m) where - throwM = lift . throwM + throwIO = lift . throwIO instance MonadCatch m => MonadCatch (ExceptT e m) where catch (ExceptT m) f = ExceptT $ catch m (runExceptT . f)