io-classes: MonadMaskingState

A monad in which one can access 'MaskingState' using 'getMaskingState'.

The patch switches to use "Control.Exception.MaskingState" in "io-sim".
It lacks an 'Ord' instance, hence the need for
`atLeastInterruptibleMask` in place of `max MaskedInterruptible`.

Author: coot

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

@@ -10,7 +10,9 @@ module Control.Monad.Class.MonadThrow
   ( MonadThrow(..)
   , MonadCatch(..)
   , MonadMask(..)
+  , MonadMaskingState(..)
   , MonadEvaluate(..)
+  , MaskingState(..)
   , Exception(..)
   , SomeException
   , ExitCase(..)
@@ -20,7 +22,7 @@ module Control.Monad.Class.MonadThrow
   , throwM
   ) where
 
-import           Control.Exception (Exception (..), SomeException)
+import           Control.Exception (Exception (..), MaskingState, SomeException)
 import qualified Control.Exception as IO
 import           Control.Monad (liftM)
 import           Control.Monad.Except (ExceptT (..), lift, runExceptT)
@@ -183,6 +185,9 @@ class MonadCatch m => MonadMask m where
   uninterruptibleMask_ action = uninterruptibleMask $ \_ -> action
 
 
+class MonadMask m => MonadMaskingState m where
+  getMaskingState :: m MaskingState
+
 -- | Monads which can 'evaluate'.
 --
 class MonadThrow m => MonadEvaluate m where
@@ -223,6 +228,9 @@ instance MonadMask IO where
   uninterruptibleMask  = IO.uninterruptibleMask
   uninterruptibleMask_ = IO.uninterruptibleMask_
 
+instance MonadMaskingState IO where
+  getMaskingState = IO.getMaskingState
+
 instance MonadEvaluate IO where
   evaluate = IO.evaluate
 

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

@@ -97,7 +97,8 @@ import           Control.Monad.Class.MonadSay
 import           Control.Monad.Class.MonadST
 import           Control.Monad.Class.MonadSTM hiding (STM, TVar)
 import qualified Control.Monad.Class.MonadSTM as MonadSTM
-import           Control.Monad.Class.MonadThrow as MonadThrow
+import           Control.Monad.Class.MonadThrow hiding (getMaskingState)
+import qualified Control.Monad.Class.MonadThrow as MonadThrow
 import           Control.Monad.Class.MonadTime
 import           Control.Monad.Class.MonadTimer
 
@@ -174,9 +175,6 @@ type STMSim = STM
 type SimSTM = STM
 {-# DEPRECATED SimSTM "Use STMSim" #-}
 
-data MaskingState = Unmasked | MaskedInterruptible | MaskedUninterruptible
-  deriving (Eq, Ord, Show)
-
 --
 -- Monad class instances
 --
@@ -300,19 +298,22 @@ instance Exceptions.MonadCatch (IOSim s) where
 
 instance MonadMask (IOSim s) where
   mask action = do
-      b <- getMaskingState
+      b <- getMaskingStateImpl
       case b of
         Unmasked              -> block $ action unblock
         MaskedInterruptible   -> action block
         MaskedUninterruptible -> action blockUninterruptible
 
   uninterruptibleMask action = do
-      b <- getMaskingState
+      b <- getMaskingStateImpl
       case b of
         Unmasked              -> blockUninterruptible $ action unblock
         MaskedInterruptible   -> blockUninterruptible $ action block
         MaskedUninterruptible -> action blockUninterruptible
 
+instance MonadMaskingState (IOSim s) where
+    getMaskingState = getMaskingStateImpl
+
 instance Exceptions.MonadMask (IOSim s) where
   mask                = MonadThrow.mask
   uninterruptibleMask = MonadThrow.uninterruptibleMask
@@ -327,10 +328,10 @@ instance Exceptions.MonadMask (IOSim s) where
       return (b, c)
 
 
-getMaskingState :: IOSim s MaskingState
+getMaskingStateImpl :: IOSim s MaskingState
 unblock, block, blockUninterruptible :: IOSim s a -> IOSim s a
 
-getMaskingState        = IOSim  GetMaskState
+getMaskingStateImpl    = IOSim  GetMaskState
 unblock              a = IOSim (SetMaskState Unmasked a)
 block                a = IOSim (SetMaskState MaskedInterruptible a)
 blockUninterruptible a = IOSim (SetMaskState MaskedUninterruptible a)
@@ -1289,9 +1290,13 @@ unwindControlStack e thread =
                       -- As per async exception rules, the handler is run masked
                      threadControl = ThreadControl (handler e')
                                                    (MaskFrame k maskst ctl),
-                     threadMasking = max maskst MaskedInterruptible
+                     threadMasking = atLeastInterruptibleMask maskst
                    }
 
+    atLeastInterruptibleMask :: MaskingState -> MaskingState
+    atLeastInterruptibleMask Unmasked = MaskedInterruptible
+    atLeastInterruptibleMask ms       = ms
+
 
 removeMinimums :: (Ord k, Ord p)
                => OrdPSQ k p a