MonadMaskingState: added interruptible and allowInterrupt

Fixes IntersectMBO/ouroboros-network#3436

Author: coot

io-classes/src/Control/Monad/Class/MonadThrow.hs

@@ -186,7 +186,14 @@ class MonadCatch m => MonadMask m where
 
 
 class MonadMask m => MonadMaskingState m where
+  {-# MINIMAL getMaskingState, interruptible #-}
   getMaskingState :: m MaskingState
+  interruptible   :: m a -> m a
+  allowInterrupt  :: m ()
+
+  allowInterrupt = interruptible (return ())
+
+
 
 -- | Monads which can 'evaluate'.
 --
@@ -230,6 +237,8 @@ instance MonadMask IO where
 
 instance MonadMaskingState IO where
   getMaskingState = IO.getMaskingState
+  interruptible   = IO.interruptible
+  allowInterrupt  = IO.allowInterrupt
 
 instance MonadEvaluate IO where
   evaluate = IO.evaluate

io-sim/src/Control/Monad/IOSim/Types.hs

@@ -339,6 +339,12 @@ instance MonadMask (IOSim s) where
 
 instance MonadMaskingState (IOSim s) where
   getMaskingState = getMaskingStateImpl
+  interruptible action = do
+      b <- getMaskingStateImpl
+      case b of
+        Unmasked              -> action
+        MaskedInterruptible   -> unblock action
+        MaskedUninterruptible -> action
 
 instance Exceptions.MonadMask (IOSim s) where
   mask                = MonadThrow.mask