diff --git a/Control/Monad/Conc/Class.hs b/Control/Monad/Conc/Class.hs index 39ad94b..4dc467f 100755 --- a/Control/Monad/Conc/Class.hs +++ b/Control/Monad/Conc/Class.hs @@ -7,7 +7,9 @@ module Control.Monad.Conc.Class where import Control.Concurrent (forkIO) import Control.Concurrent.MVar (MVar, readMVar, newEmptyMVar, putMVar, tryPutMVar, takeMVar, tryTakeMVar) +import Control.Exception (Exception) import Control.Monad (unless, void) +import Control.Monad.Catch (MonadCatch, MonadThrow, catch, throwM) import Control.Monad.STM (STM) import Control.Monad.STM.Class (MonadSTM) @@ -36,7 +38,7 @@ import qualified Control.Monad.STM as S -- 'takeCVar' and 'putCVar', however, are very inefficient, and should -- probably always be overridden to make use of -- implementation-specific blocking functionality. -class (Monad m, MonadSTM (STMLike m)) => MonadConc m where +class (Monad m, MonadCatch m, MonadSTM (STMLike m), MonadThrow m) => MonadConc m where -- | The associated 'MonadSTM' for this class. type STMLike m :: * -> * @@ -100,6 +102,21 @@ class (Monad m, MonadSTM (STMLike m)) => MonadConc m where -- | Perform a series of STM actions atomically. atomically :: STMLike m a -> m a + -- | Throw an exception. This will \"bubble up\" looking for an + -- exception handler capable of dealing with it and, if one is not + -- found, the thread is killed. + -- + -- > throw = throwM + throw :: Exception e => e -> m a + throw = throwM + + -- | Catch an exception. This is only required to be able to catch + -- exceptions raised by 'throw', unlike the more general + -- Control.Exception.catch function. If you need to be able to catch + -- /all/ errors, you will have to use 'IO'. + catch :: Exception e => m a -> (e -> m a) -> m a + catch = Control.Monad.Catch.catch + -- | Runs its argument, just as if the @_concNoTest@ weren't there. -- -- > _concNoTest x = x diff --git a/Test/DejaFu/Deterministic.hs b/Test/DejaFu/Deterministic.hs index 52c87b5..5d5d82a 100755 --- a/Test/DejaFu/Deterministic.hs +++ b/Test/DejaFu/Deterministic.hs @@ -41,6 +41,8 @@ module Test.DejaFu.Deterministic ) where import Control.Applicative (Applicative(..), (<$>)) +import Control.Exception (Exception) +import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) import Control.Monad.Cont (cont, runCont) import Control.Monad.ST (ST, runST) import Control.State (Wrapper(..), refST) @@ -57,6 +59,12 @@ import qualified Control.Monad.Conc.Class as C -- monad. newtype Conc t a = C { unC :: M (ST t) (STRef t) (STMLike t) a } deriving (Functor, Applicative, Monad) +instance MonadCatch (Conc t) where + catch = error "Exceptions not yet handled in Conc." + +instance MonadThrow (Conc t) where + throwM = error "Exceptions not yet handled in Conc." + instance C.MonadConc (Conc t) where type CVar (Conc t) = CVar t type STMLike (Conc t) = STMLike t (ST t) (STRef t) diff --git a/Test/DejaFu/Deterministic/IO.hs b/Test/DejaFu/Deterministic/IO.hs index 4a4ab82..4bed039 100644 --- a/Test/DejaFu/Deterministic/IO.hs +++ b/Test/DejaFu/Deterministic/IO.hs @@ -45,6 +45,8 @@ module Test.DejaFu.Deterministic.IO ) where import Control.Applicative (Applicative(..), (<$>)) +import Control.Exception (Exception) +import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) import Control.Monad.Cont (cont, runCont) import Control.State (Wrapper(..), refIO) import Data.IORef (IORef, newIORef) @@ -58,6 +60,12 @@ import qualified Control.Monad.IO.Class as IO -- | The 'IO' variant of Test.DejaFu.Deterministic's @Conc@ monad. newtype ConcIO t a = C { unC :: M IO IORef (STMLike t) a } deriving (Functor, Applicative, Monad) +instance MonadCatch (ConcIO t) where + catch = error "Exceptions not yet handled in ConcIO." + +instance MonadThrow (ConcIO t) where + throwM = error "Exceptions not yet handled in ConcIO." + instance IO.MonadIO (ConcIO t) where liftIO = liftIO