Merge pull request #209 from input-output-hk/coot/io-classes-simplifications

Changes in MonadMaskingState and MonadEvaluate

Author: coot

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
 

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

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

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

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

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