Make MonadMask a requirement for MonadConc

Control/Monad/Conc/Class.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes       #-}
 {-# LANGUAGE TypeFamilies     #-}
 
 -- | This module captures in a typeclass the interface of concurrency
@@ -7,17 +8,19 @@ module Control.Monad.Conc.Class
   ( MonadConc(..)
   -- * Utilities
   , spawn
+  , forkFinally
   , killThread
   ) where
 
 import Control.Concurrent (forkIO)
 import Control.Concurrent.MVar (MVar, readMVar, newEmptyMVar, putMVar, tryPutMVar, takeMVar, tryTakeMVar)
-import Control.Exception (Exception, AsyncException(ThreadKilled))
+import Control.Exception (Exception, AsyncException(ThreadKilled), SomeException)
 import Control.Monad (unless)
-import Control.Monad.Catch (MonadCatch, MonadThrow, catch, throwM)
+import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask)
 import Control.Monad.STM (STM)
 import Control.Monad.STM.Class (MonadSTM)
 
+import qualified Control.Monad.Catch as Ca
 import qualified Control.Concurrent as C
 import qualified Control.Monad.STM as S
 
@@ -44,7 +47,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, MonadCatch m, MonadThrow m
+class ( Monad m, MonadCatch m, MonadThrow m, MonadMask m
       , MonadSTM (STMLike m)
       , Eq (ThreadId m), Show (ThreadId m)) => MonadConc m  where
   -- | The associated 'MonadSTM' for this class.
@@ -63,6 +66,10 @@ class ( Monad m, MonadCatch m, MonadThrow m
   -- happen over @CVar@s.
   fork :: m () -> m (ThreadId m)
 
+  -- | Like 'fork', but the child thread is passed a function that can
+  -- be used to unmask asynchronous exceptions.
+  forkWithUnmask :: ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
+
   -- | Get the @ThreadId@ of the current thread.
   myThreadId :: m (ThreadId m)
 
@@ -107,22 +114,52 @@ class ( Monad m, MonadCatch m, MonadThrow m
   -- exception handler capable of dealing with it and, if one is not
   -- found, the thread is killed.
   --
-  -- > throw = throwM
+  -- > throw = Control.Monad.Catch.throwM
   throw :: Exception e => e -> m a
-  throw = throwM
+  throw = Ca.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 = Control.Monad.Catch.catch
   catch :: Exception e => m a -> (e -> m a) -> m a
-  catch = Control.Monad.Catch.catch
+  catch = Ca.catch
 
   -- | Throw an exception to the target thread. This blocks until the
   -- exception is delivered, and it is just as if the target thread
   -- had raised it with 'throw'. This can interrupt a blocked action.
   throwTo :: Exception e => ThreadId m => e -> m ()
 
+  -- | Executes a computation with asynchronous exceptions
+  -- /masked/. That is, any thread which attempts to raise an
+  -- exception in the current thread with 'throwTo' will be blocked
+  -- until asynchronous exceptions are unmasked again.
+  --
+  -- The argument passed to mask is a function that takes as its
+  -- argument another function, which can be used to restore the
+  -- prevailing masking state within the context of the masked
+  -- computation.
+  --
+  -- > mask = Control.Monad.Catch.mask
+  mask :: ((forall a. m a -> m a) -> m b) -> m b
+  mask = Ca.mask
+
+  -- | Like 'mask', but the masked computation is not
+  -- interruptible. THIS SHOULD BE USED WITH GREAT CARE, because if a
+  -- thread executing in 'uninterruptibleMask' blocks for any reason,
+  -- then the thread (and possibly the program, if this is the main
+  -- thread) will be unresponsive and unkillable. This function should
+  -- only be necessary if you need to mask exceptions around an
+  -- interruptible operation, and you can guarantee that the
+  -- interruptible operation will only block for a short period of
+  -- time.
+  --
+  -- > uninterruptibleMask = Control.Monad.Catch.uninterruptibleMask
+  uninterruptibleMask :: ((forall a. m a -> m a) -> m b) -> m b
+  uninterruptibleMask = Ca.uninterruptibleMask
+
   -- | Runs its argument, just as if the @_concNoTest@ weren't there.
   --
   -- > _concNoTest x = x
@@ -151,6 +188,7 @@ instance MonadConc IO where
 
   readCVar       = readMVar
   fork           = forkIO
+  forkWithUnmask = C.forkIOWithUnmask
   myThreadId     = C.myThreadId
   throwTo        = C.throwTo
   newEmptyCVar   = newEmptyMVar
@@ -168,6 +206,17 @@ spawn ma = do
   _ <- fork $ ma >>= putCVar cvar
   return cvar
 
+-- | Fork a thread and call the supplied function when the thread is
+-- about to terminate, with an exception or a returned value. The
+-- function is called with asynchronous exceptions masked.
+--
+-- This function is useful for informing the parent when a child
+-- terminates, for example.
+forkFinally :: MonadConc m => m a -> (Either SomeException a -> m ()) -> m (ThreadId m)
+forkFinally action and_then =
+  mask $ \restore ->
+    fork $ Ca.try (restore action) >>= and_then
+
 -- | Raise the 'ThreadKilled' exception in the target thread. Note
 -- that if the thread is prepared to catch this exception, it won't
 -- actually kill it.

Test/DejaFu/Deterministic.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE Rank2Types                 #-}
+{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE TypeFamilies               #-}
 
 -- | Deterministic traced execution of concurrent computations which
@@ -14,6 +14,8 @@ module Test.DejaFu.Deterministic
   , Failure(..)
   , runConc
   , fork
+  , forkFinally
+  , forkWithUnmask
   , myThreadId
   , spawn
   , atomically
@@ -21,6 +23,8 @@ module Test.DejaFu.Deterministic
   , throwTo
   , killThread
   , catch
+  , mask
+  , uninterruptibleMask
 
   -- * Communication: CVars
   , CVar
@@ -70,12 +74,17 @@ instance Ca.MonadCatch (Conc t) where
 instance Ca.MonadThrow (Conc t) where
   throwM = throw
 
+instance Ca.MonadMask (Conc t) where
+  mask = mask
+  uninterruptibleMask = uninterruptibleMask
+
 instance C.MonadConc (Conc t) where
   type CVar     (Conc t) = CVar t
   type STMLike  (Conc t) = STMLike t (ST t) (STRef t)
   type ThreadId (Conc t) = Int
 
   fork           = fork
+  forkWithUnmask = forkWithUnmask
   myThreadId     = myThreadId
   throwTo        = throwTo
   newEmptyCVar   = newEmptyCVar
@@ -170,6 +179,45 @@ killThread = C.killThread
 catch :: Exception e => Conc t a -> (e -> Conc t a) -> Conc t a
 catch ma h = C $ cont $ ACatching (unC . h) (unC ma)
 
+-- | Fork a thread and call the supplied function when the thread is
+-- about to terminate, with an exception or a returned value. The
+-- function is called with asynchronous exceptions masked.
+--
+-- This function is useful for informing the parent when a child
+-- terminates, for example.
+forkFinally :: Conc t a -> (Either SomeException a -> Conc t ()) -> Conc t ThreadId
+forkFinally action and_then =
+  mask $ \restore ->
+    fork $ Ca.try (restore action) >>= and_then
+
+-- | Like 'fork', but the child thread is passed a function that can
+-- be used to unmask asynchronous exceptions.
+forkWithUnmask :: ((forall a. Conc t a -> Conc t a) -> Conc t ()) -> Conc t ThreadId
+forkWithUnmask = error "'forkWithUnmask' not yet implemented for 'Conc'"
+
+-- | Executes a computation with asynchronous exceptions
+-- /masked/. That is, any thread which attempts to raise an exception
+-- in the current thread with 'throwTo' will be blocked until
+-- asynchronous exceptions are unmasked again.
+--
+-- The argument passed to mask is a function that takes as its
+-- argument another function, which can be used to restore the
+-- prevailing masking state within the context of the masked
+-- computation.
+mask :: ((forall a. Conc t a -> Conc t a) -> Conc t b) -> Conc t b
+mask = error "'mask' not yet implemented for 'Conc'"
+
+-- | Like 'mask', but the masked computation is not
+-- interruptible. THIS SHOULD BE USED WITH GREAT CARE, because if a
+-- thread executing in 'uninterruptibleMask' blocks for any reason,
+-- then the thread (and possibly the program, if this is the main
+-- thread) will be unresponsive and unkillable. This function should
+-- only be necessary if you need to mask exceptions around an
+-- interruptible operation, and you can guarantee that the
+-- interruptible operation will only block for a short period of time.
+uninterruptibleMask :: ((forall a. Conc t a -> Conc t a) -> Conc t b) -> Conc t b
+uninterruptibleMask = error "'uninterruptibleMask' not yet implemented for 'Conc'"
+
 -- | Run the argument in one step. If the argument fails, the whole
 -- computation will fail.
 _concNoTest :: Conc t a -> Conc t a

Test/DejaFu/Deterministic/IO.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE Rank2Types                 #-}
+{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE TypeFamilies               #-}
 
 -- | Deterministic traced execution of concurrent computations which
@@ -18,6 +18,8 @@ module Test.DejaFu.Deterministic.IO
   , runConcIO
   , liftIO
   , fork
+  , forkFinally
+  , forkWithUnmask
   , myThreadId
   , spawn
   , atomically
@@ -25,6 +27,8 @@ module Test.DejaFu.Deterministic.IO
   , throwTo
   , killThread
   , catch
+  , mask
+  , uninterruptibleMask
 
   -- * Communication: CVars
   , CVar
@@ -71,6 +75,10 @@ instance Ca.MonadCatch (ConcIO t) where
 instance Ca.MonadThrow (ConcIO t) where
   throwM = throw
 
+instance Ca.MonadMask (ConcIO t) where
+  mask = mask
+  uninterruptibleMask = uninterruptibleMask
+
 instance IO.MonadIO (ConcIO t) where
   liftIO = liftIO
 
@@ -80,6 +88,7 @@ instance C.MonadConc (ConcIO t) where
   type ThreadId (ConcIO t) = Int
 
   fork           = fork
+  forkWithUnmask = forkWithUnmask
   myThreadId     = myThreadId
   throwTo        = throwTo
   newEmptyCVar   = newEmptyCVar
@@ -175,6 +184,45 @@ killThread = C.killThread
 catch :: Exception e => ConcIO t a -> (e -> ConcIO t a) -> ConcIO t a
 catch ma h = C $ cont $ ACatching (unC . h) (unC ma)
 
+-- | Fork a thread and call the supplied function when the thread is
+-- about to terminate, with an exception or a returned value. The
+-- function is called with asynchronous exceptions masked.
+--
+-- This function is useful for informing the parent when a child
+-- terminates, for example.
+forkFinally :: ConcIO t a -> (Either SomeException a -> ConcIO t ()) -> ConcIO t ThreadId
+forkFinally action and_then =
+  mask $ \restore ->
+    fork $ Ca.try (restore action) >>= and_then
+
+-- | Like 'fork', but the child thread is passed a function that can
+-- be used to unmask asynchronous exceptions.
+forkWithUnmask :: ((forall a. ConcIO t a -> ConcIO t a) -> ConcIO t ()) -> ConcIO t ThreadId
+forkWithUnmask = error "'forkWithUnmask' not yet implemented for 'ConcIO'"
+
+-- | Executes a computation with asynchronous exceptions
+-- /masked/. That is, any thread which attempts to raise an exception
+-- in the current thread with 'throwTo' will be blocked until
+-- asynchronous exceptions are unmasked again.
+--
+-- The argument passed to mask is a function that takes as its
+-- argument another function, which can be used to restore the
+-- prevailing masking state within the context of the masked
+-- computation.
+mask :: ((forall a. ConcIO t a -> ConcIO t a) -> ConcIO t b) -> ConcIO t b
+mask = error "'mask' not yet implemented for 'ConcIO'"
+
+-- | Like 'mask', but the masked computation is not
+-- interruptible. THIS SHOULD BE USED WITH GREAT CARE, because if a
+-- thread executing in 'uninterruptibleMask' blocks for any reason,
+-- then the thread (and possibly the program, if this is the main
+-- thread) will be unresponsive and unkillable. This function should
+-- only be necessary if you need to mask exceptions around an
+-- interruptible operation, and you can guarantee that the
+-- interruptible operation will only block for a short period of time.
+uninterruptibleMask :: ((forall a. ConcIO t a -> ConcIO t a) -> ConcIO t b) -> ConcIO t b
+uninterruptibleMask = error "'uninterruptibleMask' not yet implemented for 'ConcIO'"
+
 -- | Run the argument in one step. If the argument fails, the whole
 -- computation will fail.
 _concNoTest :: ConcIO t a -> ConcIO t a