diff --git a/io-classes/CHANGELOG.md b/io-classes/CHANGELOG.md index 294f3311..03d0e27b 100644 --- a/io-classes/CHANGELOG.md +++ b/io-classes/CHANGELOG.md @@ -10,6 +10,10 @@ * Added `MonadLabelledMVar` class. * Added `labelMVar` to `Control.Concurrent.Class.MonadMVar.Strict` * Added `debugTraceTVar`, `debugTraceTMVar`, `debugTraceTVarIO`, `debugTraceTMVarIO` for `Show`-based tracing. +* `MonadEvaluate` is not a supper-class of `MonadThrow` anymore. +* Moved all `MonadMaskingState` methods to `MonadMask`. `MonadMaskingState` is + available but deprecated, it will be removed in one of the future releases. +* `io-classes:mtl` instances support the extended `MonadMask` instance. ### Non-breaking changes diff --git a/io-classes/mtl/Control/Monad/Class/MonadThrow/Trans.hs b/io-classes/mtl/Control/Monad/Class/MonadThrow/Trans.hs index 7684ce64..4752e2ee 100644 --- a/io-classes/mtl/Control/Monad/Class/MonadThrow/Trans.hs +++ b/io-classes/mtl/Control/Monad/Class/MonadThrow/Trans.hs @@ -60,6 +60,11 @@ instance MonadMask m => MonadMask (ExceptT e m) where -> ExceptT e m a -> ExceptT e m a q u (ExceptT b) = ExceptT (u b) + getMaskingState = lift getMaskingState + interruptible = ExceptT . interruptible . runExceptT + allowInterrupt = lift allowInterrupt + + -- -- Lazy.WriterT instances -- @@ -104,6 +109,11 @@ instance (Monoid w, MonadMask m) => MonadMask (Lazy.WriterT w m) where -> Lazy.WriterT w m a -> Lazy.WriterT w m a q u (Lazy.WriterT b) = Lazy.WriterT (u b) + getMaskingState = lift getMaskingState + interruptible = Lazy.WriterT . interruptible . Lazy.runWriterT + allowInterrupt = lift allowInterrupt + + -- -- Strict.WriterT instances -- @@ -147,6 +157,10 @@ instance (Monoid w, MonadMask m) => MonadMask (Strict.WriterT w m) where -> Strict.WriterT w m a -> Strict.WriterT w m a q u (Strict.WriterT b) = Strict.WriterT (u b) + getMaskingState = lift getMaskingState + interruptible = Strict.WriterT . interruptible . Strict.runWriterT + allowInterrupt = lift allowInterrupt + -- -- Lazy.RWST Instances @@ -193,6 +207,10 @@ instance (Monoid w, MonadMask m) => MonadMask (Lazy.RWST r w s m) where -> Lazy.RWST r w s m a -> Lazy.RWST r w s m a q u (Lazy.RWST b) = Lazy.RWST $ \r s -> u (b r s) + getMaskingState = lift getMaskingState + interruptible f = Lazy.RWST $ \r s -> interruptible (Lazy.runRWST f r s) + allowInterrupt = lift allowInterrupt + -- -- Strict.RWST Instances @@ -239,6 +257,10 @@ instance (Monoid w, MonadMask m) => MonadMask (Strict.RWST r w s m) where -> Strict.RWST r w s m a -> Strict.RWST r w s m a q u (Strict.RWST b) = Strict.RWST $ \r s -> u (b r s) + getMaskingState = lift getMaskingState + interruptible f = Strict.RWST $ \r s -> interruptible (Strict.runRWST f r s) + allowInterrupt = lift allowInterrupt + -- -- Lazy.StateT instances @@ -283,6 +305,10 @@ instance MonadMask m => MonadMask (Lazy.StateT s m) where -> Lazy.StateT s m a -> Lazy.StateT s m a q u (Lazy.StateT b) = Lazy.StateT $ \s -> u (b s) + getMaskingState = lift getMaskingState + interruptible f = Lazy.StateT $ \s -> interruptible (Lazy.runStateT f s) + allowInterrupt = lift allowInterrupt + -- -- Strict.StateT instances @@ -327,3 +353,7 @@ instance MonadMask m => MonadMask (Strict.StateT s m) where -> Strict.StateT s m a -> Strict.StateT s m a q u (Strict.StateT b) = Strict.StateT $ \s -> u (b s) + + getMaskingState = lift getMaskingState + interruptible f = Strict.StateT $ \s -> interruptible (Strict.runStateT f s) + allowInterrupt = lift allowInterrupt diff --git a/io-classes/src/Control/Monad/Class/MonadThrow.hs b/io-classes/src/Control/Monad/Class/MonadThrow.hs index a4e83fdb..d007908b 100644 --- a/io-classes/src/Control/Monad/Class/MonadThrow.hs +++ b/io-classes/src/Control/Monad/Class/MonadThrow.hs @@ -16,7 +16,7 @@ module Control.Monad.Class.MonadThrow ( MonadThrow (..) , MonadCatch (..) , MonadMask (..) - , MonadMaskingState (..) + , MonadMaskingState , MonadEvaluate (..) , MaskingState (..) , Exception (..) @@ -193,27 +193,30 @@ data ExitCase a -- class MonadCatch m => MonadMask m where - {-# MINIMAL mask, uninterruptibleMask #-} + {-# MINIMAL mask, + uninterruptibleMask, + getMaskingState, + interruptible #-} + mask, uninterruptibleMask :: ((forall a. m a -> m a) -> m b) -> m b mask_, uninterruptibleMask_ :: m a -> m a mask_ action = mask $ \_ -> action uninterruptibleMask_ action = uninterruptibleMask $ \_ -> action - -class MonadMask m => MonadMaskingState m where - {-# MINIMAL getMaskingState, interruptible #-} getMaskingState :: m MaskingState interruptible :: m a -> m a - allowInterrupt :: m () + allowInterrupt :: m () allowInterrupt = interruptible (return ()) +class MonadMask m => MonadMaskingState m +{-# DEPRECATED MonadMaskingState "Use MonadMask instead" #-} -- | Monads which can 'evaluate'. -- -class MonadThrow m => MonadEvaluate m where +class MonadEvaluate m where evaluate :: a -> m a -- @@ -254,11 +257,12 @@ instance MonadMask IO where uninterruptibleMask = IO.uninterruptibleMask uninterruptibleMask_ = IO.uninterruptibleMask_ -instance MonadMaskingState IO where getMaskingState = IO.getMaskingState interruptible = IO.interruptible allowInterrupt = IO.allowInterrupt +instance MonadMaskingState IO + instance MonadEvaluate IO where evaluate = IO.evaluate @@ -321,5 +325,10 @@ instance MonadMask m => MonadMask (ReaderT r m) where where q :: (m a -> m a) -> ReaderT e m a -> ReaderT e m a q u (ReaderT b) = ReaderT (u . b) -instance MonadEvaluate m => MonadEvaluate (ReaderT r m) where + getMaskingState = lift getMaskingState + interruptible a = + ReaderT $ \e -> interruptible (runReaderT a e) + allowInterrupt = lift allowInterrupt + +instance (Monad m, MonadEvaluate m) => MonadEvaluate (ReaderT r m) where evaluate = lift . evaluate diff --git a/io-sim/src/Control/Monad/IOSim/Types.hs b/io-sim/src/Control/Monad/IOSim/Types.hs index 064e2997..a7915964 100644 --- a/io-sim/src/Control/Monad/IOSim/Types.hs +++ b/io-sim/src/Control/Monad/IOSim/Types.hs @@ -17,6 +17,9 @@ -- Needed for `SimEvent` type. {-# OPTIONS_GHC -Wno-partial-fields #-} +-- `MonadMaskingState` is deprecated in `io-classes`, but we provide an instance +-- for it. +{-# OPTIONS_GHC -Wno-deprecations #-} module Control.Monad.IOSim.Types ( IOSim (..) @@ -425,7 +428,6 @@ instance MonadMask (IOSim s) where MaskedInterruptible -> blockUninterruptible $ action block MaskedUninterruptible -> action blockUninterruptible -instance MonadMaskingState (IOSim s) where getMaskingState = getMaskingStateImpl interruptible action = do b <- getMaskingStateImpl @@ -434,6 +436,8 @@ instance MonadMaskingState (IOSim s) where MaskedInterruptible -> unblock action MaskedUninterruptible -> action +instance MonadMaskingState (IOSim s) + instance Exceptions.MonadMask (IOSim s) where mask = MonadThrow.mask uninterruptibleMask = MonadThrow.uninterruptibleMask diff --git a/io-sim/test/Test/Control/Monad/IOSim.hs b/io-sim/test/Test/Control/Monad/IOSim.hs index 63a42437..0c944c1d 100644 --- a/io-sim/test/Test/Control/Monad/IOSim.hs +++ b/io-sim/test/Test/Control/Monad/IOSim.hs @@ -893,7 +893,6 @@ type TimeoutConstraints m = , MonadMask m , MonadThrow (STM m) , MonadSay m - , MonadMaskingState m ) instance Arbitrary DiffTime where diff --git a/io-sim/test/Test/Control/Monad/Utils.hs b/io-sim/test/Test/Control/Monad/Utils.hs index 69efda21..dc987a0c 100644 --- a/io-sim/test/Test/Control/Monad/Utils.hs +++ b/io-sim/test/Test/Control/Monad/Utils.hs @@ -340,7 +340,7 @@ maxMS Unmasked Unmasked = Unmasked -- | Check that setting masking state is effective. -- -prop_set_masking_state :: MonadMaskingState m +prop_set_masking_state :: MonadMask m => MaskingState -> m Property prop_set_masking_state ms = @@ -350,7 +350,7 @@ prop_set_masking_state ms = -- | Check that 'unmask' restores the masking state. -- -prop_unmask :: MonadMaskingState m +prop_unmask :: MonadMask m => MaskingState -> MaskingState -> m Property @@ -362,7 +362,7 @@ prop_unmask ms ms' = -- | Check that masking state is inherited by a forked thread. -- -prop_fork_masking_state :: ( MonadMaskingState m +prop_fork_masking_state :: ( MonadMask m , MonadFork m , MonadSTM m ) @@ -378,7 +378,7 @@ prop_fork_masking_state ms = setMaskingState_ ms $ do -- Note: unlike 'prop_unmask', 'forkIOWithUnmask's 'unmask' function will -- restore 'Unmasked' state, not the encosing masking state. -- -prop_fork_unmask :: ( MonadMaskingState m +prop_fork_unmask :: ( MonadMask m , MonadFork m , MonadSTM m ) @@ -397,8 +397,9 @@ prop_fork_unmask ms ms' = -- | A unit test which checks the masking state in the context of a catch -- handler. -- -prop_catch_throwIO_masking_state :: forall m. MonadMaskingState m - => MaskingState -> m Property +prop_catch_throwIO_masking_state :: forall m. MonadMask m + => MaskingState + -> m Property prop_catch_throwIO_masking_state ms = setMaskingState_ ms $ do throwIO (userError "error") @@ -409,7 +410,7 @@ prop_catch_throwIO_masking_state ms = -- | Like 'prop_catch_masking_state' but using 'throwTo'. -- prop_catch_throwTo_masking_state :: forall m. - ( MonadMaskingState m + ( MonadMask m , MonadFork m ) => MaskingState -> m Property @@ -425,7 +426,7 @@ prop_catch_throwTo_masking_state ms = -- thread which is in a non-blocking mode. -- prop_catch_throwTo_masking_state_async :: forall m. - ( MonadMaskingState m + ( MonadMask m , MonadFork m , MonadSTM m , MonadDelay m @@ -454,7 +455,7 @@ prop_catch_throwTo_masking_state_async ms = do -- 'willBlock' branch of 'ThrowTo' in 'schedule' is covered. -- prop_catch_throwTo_masking_state_async_mayblock :: forall m. - ( MonadMaskingState m + ( MonadMask m , MonadFork m , MonadSTM m , MonadDelay m