Skip to content

Commit a668dcf

Browse files
cootcoot
committed
io-classes: deprecated MonadMaskingState
All `MonadMaskingState` methods moved to `MonadMask`, deprecated `MonadMaskingState`. It's methods are now available by the `MonadMask` type class.
1 parent 4d6c8b2 commit a668dcf

File tree

6 files changed

+64
-18
lines changed

6 files changed

+64
-18
lines changed

‎io-classes/CHANGELOG.md

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,9 @@
1111
* Added `labelMVar` to `Control.Concurrent.Class.MonadMVar.Strict`
1212
* Added `debugTraceTVar`, `debugTraceTMVar`, `debugTraceTVarIO`, `debugTraceTMVarIO` for `Show`-based tracing.
1313
* `MonadEvaluate` is not a supper-class of `MonadThrow` anymore.
14+
* Moved all `MonadMaskingState` methods to `MonadMask`. `MonadMaskingState` is
15+
available but deprecated, it will be removed in one of the future releases.
16+
* `io-classes:mtl` instances support the extended `MonadMask` instance.
1417

1518
### Non-breaking changes
1619

‎io-classes/mtl/Control/Monad/Class/MonadThrow/Trans.hs

Lines changed: 30 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -60,6 +60,11 @@ instance MonadMask m => MonadMask (ExceptT e m) where
6060
-> ExceptT e m a -> ExceptT e m a
6161
q u (ExceptT b) = ExceptT (u b)
6262

63+
getMaskingState = lift getMaskingState
64+
interruptible = ExceptT . interruptible . runExceptT
65+
allowInterrupt = lift allowInterrupt
66+
67+
6368
--
6469
-- Lazy.WriterT instances
6570
--
@@ -104,6 +109,11 @@ instance (Monoid w, MonadMask m) => MonadMask (Lazy.WriterT w m) where
104109
-> Lazy.WriterT w m a -> Lazy.WriterT w m a
105110
q u (Lazy.WriterT b) = Lazy.WriterT (u b)
106111

112+
getMaskingState = lift getMaskingState
113+
interruptible = Lazy.WriterT . interruptible . Lazy.runWriterT
114+
allowInterrupt = lift allowInterrupt
115+
116+
107117
--
108118
-- Strict.WriterT instances
109119
--
@@ -147,6 +157,10 @@ instance (Monoid w, MonadMask m) => MonadMask (Strict.WriterT w m) where
147157
-> Strict.WriterT w m a -> Strict.WriterT w m a
148158
q u (Strict.WriterT b) = Strict.WriterT (u b)
149159

160+
getMaskingState = lift getMaskingState
161+
interruptible = Strict.WriterT . interruptible . Strict.runWriterT
162+
allowInterrupt = lift allowInterrupt
163+
150164

151165
--
152166
-- Lazy.RWST Instances
@@ -193,6 +207,10 @@ instance (Monoid w, MonadMask m) => MonadMask (Lazy.RWST r w s m) where
193207
-> Lazy.RWST r w s m a -> Lazy.RWST r w s m a
194208
q u (Lazy.RWST b) = Lazy.RWST $ \r s -> u (b r s)
195209

210+
getMaskingState = lift getMaskingState
211+
interruptible f = Lazy.RWST $ \r s -> interruptible (Lazy.runRWST f r s)
212+
allowInterrupt = lift allowInterrupt
213+
196214

197215
--
198216
-- Strict.RWST Instances
@@ -239,6 +257,10 @@ instance (Monoid w, MonadMask m) => MonadMask (Strict.RWST r w s m) where
239257
-> Strict.RWST r w s m a -> Strict.RWST r w s m a
240258
q u (Strict.RWST b) = Strict.RWST $ \r s -> u (b r s)
241259

260+
getMaskingState = lift getMaskingState
261+
interruptible f = Strict.RWST $ \r s -> interruptible (Strict.runRWST f r s)
262+
allowInterrupt = lift allowInterrupt
263+
242264

243265
--
244266
-- Lazy.StateT instances
@@ -283,6 +305,10 @@ instance MonadMask m => MonadMask (Lazy.StateT s m) where
283305
-> Lazy.StateT s m a -> Lazy.StateT s m a
284306
q u (Lazy.StateT b) = Lazy.StateT $ \s -> u (b s)
285307

308+
getMaskingState = lift getMaskingState
309+
interruptible f = Lazy.StateT $ \s -> interruptible (Lazy.runStateT f s)
310+
allowInterrupt = lift allowInterrupt
311+
286312

287313
--
288314
-- Strict.StateT instances
@@ -327,3 +353,7 @@ instance MonadMask m => MonadMask (Strict.StateT s m) where
327353
-> Strict.StateT s m a -> Strict.StateT s m a
328354
q u (Strict.StateT b) = Strict.StateT $ \s -> u (b s)
329355

356+
357+
getMaskingState = lift getMaskingState
358+
interruptible f = Strict.StateT $ \s -> interruptible (Strict.runStateT f s)
359+
allowInterrupt = lift allowInterrupt

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

Lines changed: 16 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,7 @@ module Control.Monad.Class.MonadThrow
1616
( MonadThrow (..)
1717
, MonadCatch (..)
1818
, MonadMask (..)
19-
, MonadMaskingState (..)
19+
, MonadMaskingState
2020
, MonadEvaluate (..)
2121
, MaskingState (..)
2222
, Exception (..)
@@ -193,22 +193,25 @@ data ExitCase a
193193
--
194194
class MonadCatch m => MonadMask m where
195195

196-
{-# MINIMAL mask, uninterruptibleMask #-}
196+
{-# MINIMAL mask,
197+
uninterruptibleMask,
198+
getMaskingState,
199+
interruptible #-}
200+
197201
mask, uninterruptibleMask :: ((forall a. m a -> m a) -> m b) -> m b
198202

199203
mask_, uninterruptibleMask_ :: m a -> m a
200204
mask_ action = mask $ \_ -> action
201205
uninterruptibleMask_ action = uninterruptibleMask $ \_ -> action
202206

203-
204-
class MonadMask m => MonadMaskingState m where
205-
{-# MINIMAL getMaskingState, interruptible #-}
206207
getMaskingState :: m MaskingState
207208
interruptible :: m a -> m a
208-
allowInterrupt :: m ()
209209

210+
allowInterrupt :: m ()
210211
allowInterrupt = interruptible (return ())
211212

213+
class MonadMask m => MonadMaskingState m
214+
{-# DEPRECATED MonadMaskingState "Use MonadMask instead" #-}
212215

213216

214217
-- | Monads which can 'evaluate'.
@@ -254,11 +257,12 @@ instance MonadMask IO where
254257
uninterruptibleMask = IO.uninterruptibleMask
255258
uninterruptibleMask_ = IO.uninterruptibleMask_
256259

257-
instance MonadMaskingState IO where
258260
getMaskingState = IO.getMaskingState
259261
interruptible = IO.interruptible
260262
allowInterrupt = IO.allowInterrupt
261263

264+
instance MonadMaskingState IO
265+
262266
instance MonadEvaluate IO where
263267
evaluate = IO.evaluate
264268

@@ -321,5 +325,10 @@ instance MonadMask m => MonadMask (ReaderT r m) where
321325
where q :: (m a -> m a) -> ReaderT e m a -> ReaderT e m a
322326
q u (ReaderT b) = ReaderT (u . b)
323327

328+
getMaskingState = lift getMaskingState
329+
interruptible a =
330+
ReaderT $ \e -> interruptible (runReaderT a e)
331+
allowInterrupt = lift allowInterrupt
332+
324333
instance (Monad m, MonadEvaluate m) => MonadEvaluate (ReaderT r m) where
325334
evaluate = lift . evaluate

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

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,9 @@
1717

1818
-- Needed for `SimEvent` type.
1919
{-# OPTIONS_GHC -Wno-partial-fields #-}
20+
-- `MonadMaskingState` is deprecated in `io-classes`, but we provide an instance
21+
-- for it.
22+
{-# OPTIONS_GHC -Wno-deprecations #-}
2023

2124
module Control.Monad.IOSim.Types
2225
( IOSim (..)
@@ -425,7 +428,6 @@ instance MonadMask (IOSim s) where
425428
MaskedInterruptible -> blockUninterruptible $ action block
426429
MaskedUninterruptible -> action blockUninterruptible
427430

428-
instance MonadMaskingState (IOSim s) where
429431
getMaskingState = getMaskingStateImpl
430432
interruptible action = do
431433
b <- getMaskingStateImpl
@@ -434,6 +436,8 @@ instance MonadMaskingState (IOSim s) where
434436
MaskedInterruptible -> unblock action
435437
MaskedUninterruptible -> action
436438

439+
instance MonadMaskingState (IOSim s)
440+
437441
instance Exceptions.MonadMask (IOSim s) where
438442
mask = MonadThrow.mask
439443
uninterruptibleMask = MonadThrow.uninterruptibleMask

‎io-sim/test/Test/Control/Monad/IOSim.hs

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -893,7 +893,6 @@ type TimeoutConstraints m =
893893
, MonadMask m
894894
, MonadThrow (STM m)
895895
, MonadSay m
896-
, MonadMaskingState m
897896
)
898897

899898
instance Arbitrary DiffTime where

‎io-sim/test/Test/Control/Monad/Utils.hs

Lines changed: 10 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -340,7 +340,7 @@ maxMS Unmasked Unmasked = Unmasked
340340

341341
-- | Check that setting masking state is effective.
342342
--
343-
prop_set_masking_state :: MonadMaskingState m
343+
prop_set_masking_state :: MonadMask m
344344
=> MaskingState
345345
-> m Property
346346
prop_set_masking_state ms =
@@ -350,7 +350,7 @@ prop_set_masking_state ms =
350350

351351
-- | Check that 'unmask' restores the masking state.
352352
--
353-
prop_unmask :: MonadMaskingState m
353+
prop_unmask :: MonadMask m
354354
=> MaskingState
355355
-> MaskingState
356356
-> m Property
@@ -362,7 +362,7 @@ prop_unmask ms ms' =
362362

363363
-- | Check that masking state is inherited by a forked thread.
364364
--
365-
prop_fork_masking_state :: ( MonadMaskingState m
365+
prop_fork_masking_state :: ( MonadMask m
366366
, MonadFork m
367367
, MonadSTM m
368368
)
@@ -378,7 +378,7 @@ prop_fork_masking_state ms = setMaskingState_ ms $ do
378378
-- Note: unlike 'prop_unmask', 'forkIOWithUnmask's 'unmask' function will
379379
-- restore 'Unmasked' state, not the encosing masking state.
380380
--
381-
prop_fork_unmask :: ( MonadMaskingState m
381+
prop_fork_unmask :: ( MonadMask m
382382
, MonadFork m
383383
, MonadSTM m
384384
)
@@ -397,8 +397,9 @@ prop_fork_unmask ms ms' =
397397
-- | A unit test which checks the masking state in the context of a catch
398398
-- handler.
399399
--
400-
prop_catch_throwIO_masking_state :: forall m. MonadMaskingState m
401-
=> MaskingState -> m Property
400+
prop_catch_throwIO_masking_state :: forall m. MonadMask m
401+
=> MaskingState
402+
-> m Property
402403
prop_catch_throwIO_masking_state ms =
403404
setMaskingState_ ms $ do
404405
throwIO (userError "error")
@@ -409,7 +410,7 @@ prop_catch_throwIO_masking_state ms =
409410
-- | Like 'prop_catch_masking_state' but using 'throwTo'.
410411
--
411412
prop_catch_throwTo_masking_state :: forall m.
412-
( MonadMaskingState m
413+
( MonadMask m
413414
, MonadFork m
414415
)
415416
=> MaskingState -> m Property
@@ -425,7 +426,7 @@ prop_catch_throwTo_masking_state ms =
425426
-- thread which is in a non-blocking mode.
426427
--
427428
prop_catch_throwTo_masking_state_async :: forall m.
428-
( MonadMaskingState m
429+
( MonadMask m
429430
, MonadFork m
430431
, MonadSTM m
431432
, MonadDelay m
@@ -454,7 +455,7 @@ prop_catch_throwTo_masking_state_async ms = do
454455
-- 'willBlock' branch of 'ThrowTo' in 'schedule' is covered.
455456
--
456457
prop_catch_throwTo_masking_state_async_mayblock :: forall m.
457-
( MonadMaskingState m
458+
( MonadMask m
458459
, MonadFork m
459460
, MonadSTM m
460461
, MonadDelay m

0 commit comments

Comments
 (0)