Use MonadThrow/MonadCatch for MonadConc exceptions

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

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)

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