Add interruptible to Control.Monad.Conc.Class

concurrency/CHANGELOG.rst

@@ -13,6 +13,7 @@ Added
 ~~~~~
 
 * (:issue:`316`) ``Control.Monad.Conc.Class.unsafeUnmask``.
+* ``Control.Monad.Conc.Class.interruptible``.
 
 1.10.0.0 (2020-05-10)
 ---------------------

concurrency/Control/Monad/Conc/Class.hs

@@ -72,6 +72,7 @@ module Control.Monad.Conc.Class
   , Ca.mask_
   , uninterruptibleMask
   , Ca.uninterruptibleMask_
+  , interruptible
 
   -- * Mutable State
   , newMVar
@@ -91,7 +92,7 @@ module Control.Monad.Conc.Class
 
 -- for the class and utilities
 import           Control.Exception            (AsyncException(ThreadKilled),
-                                               Exception, MaskingState,
+                                               Exception, MaskingState(..),
                                                SomeException)
 import           Control.Monad.Catch          (MonadCatch, MonadMask,
                                                MonadThrow)
@@ -700,6 +701,21 @@ mask = Ca.mask
 uninterruptibleMask :: MonadConc m => ((forall a. m a -> m a) -> m b) -> m b
 uninterruptibleMask = Ca.uninterruptibleMask
 
+-- | Allow asynchronous exceptions to be raised even inside 'mask',
+-- making the operation interruptible.
+--
+-- When called outside 'mask', or inside 'uninterruptibleMask', this
+-- function has no effect.
+--
+-- @since unreleased
+interruptible :: MonadConc m => m a -> m a
+interruptible act = do
+  st <- getMaskingState
+  case st of
+    Unmasked              -> act
+    MaskedInterruptible   -> unsafeUnmask act
+    MaskedUninterruptible -> act
+
 -- Mutable Variables
 
 -- | Create a new @MVar@ containing a value.