Skip to content

Commit 8ef9715

Browse files
cootcoot
authored
Merge pull request #212 from bolt12/bolt12/monad-trace-mvar
Provide MonadTraceMVar
2 parents dffa001 + f27ad47 commit 8ef9715

File tree

12 files changed

+70
-44
lines changed

12 files changed

+70
-44
lines changed

‎.gitignore

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,3 +25,4 @@ cabal.project.local~
2525
tags
2626
io-sim/tags
2727
README.haddock
28+
*.vim

‎io-classes/CHANGELOG.md

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,8 @@
66

77
### Breaking changes
88

9+
- Provided `MonadTraceMVar`
10+
- Renamed `InspectMonad` to `InspectMonadSTM`
911
* Added `threadLabel` to `MonadThread`
1012
* Added `MonadLabelledMVar` class.
1113
* Added `labelMVar` to `Control.Concurrent.Class.MonadMVar.Strict`

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

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -163,7 +163,7 @@ instance MonadSTM m => MonadSTM (ContT r m) where
163163

164164

165165
instance MonadInspectSTM m => MonadInspectSTM (ContT r m) where
166-
type InspectMonad (ContT r m) = InspectMonad m
166+
type InspectMonadSTM (ContT r m) = InspectMonadSTM m
167167
inspectTVar _ = inspectTVar (Proxy @m)
168168
inspectTMVar _ = inspectTMVar (Proxy @m)
169169

@@ -254,7 +254,7 @@ instance (Monoid w, MonadSTM m) => MonadSTM (Lazy.WriterT w m) where
254254

255255

256256
instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Lazy.WriterT w m) where
257-
type InspectMonad (Lazy.WriterT w m) = InspectMonad m
257+
type InspectMonadSTM (Lazy.WriterT w m) = InspectMonadSTM m
258258
inspectTVar _ = inspectTVar (Proxy @m)
259259
inspectTMVar _ = inspectTMVar (Proxy @m)
260260

@@ -345,7 +345,7 @@ instance (Monoid w, MonadSTM m) => MonadSTM (Strict.WriterT w m) where
345345

346346

347347
instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Strict.WriterT w m) where
348-
type InspectMonad (Strict.WriterT w m) = InspectMonad m
348+
type InspectMonadSTM (Strict.WriterT w m) = InspectMonadSTM m
349349
inspectTVar _ = inspectTVar (Proxy @m)
350350
inspectTMVar _ = inspectTMVar (Proxy @m)
351351

@@ -436,7 +436,7 @@ instance MonadSTM m => MonadSTM (Lazy.StateT s m) where
436436

437437

438438
instance MonadInspectSTM m => MonadInspectSTM (Lazy.StateT s m) where
439-
type InspectMonad (Lazy.StateT s m) = InspectMonad m
439+
type InspectMonadSTM (Lazy.StateT s m) = InspectMonadSTM m
440440
inspectTVar _ = inspectTVar (Proxy @m)
441441
inspectTMVar _ = inspectTMVar (Proxy @m)
442442

@@ -527,7 +527,7 @@ instance MonadSTM m => MonadSTM (Strict.StateT s m) where
527527

528528

529529
instance MonadInspectSTM m => MonadInspectSTM (Strict.StateT s m) where
530-
type InspectMonad (Strict.StateT s m) = InspectMonad m
530+
type InspectMonadSTM (Strict.StateT s m) = InspectMonadSTM m
531531
inspectTVar _ = inspectTVar (Proxy @m)
532532
inspectTMVar _ = inspectTMVar (Proxy @m)
533533

@@ -618,7 +618,7 @@ instance MonadSTM m => MonadSTM (ExceptT e m) where
618618

619619

620620
instance MonadInspectSTM m => MonadInspectSTM (ExceptT e m) where
621-
type InspectMonad (ExceptT e m) = InspectMonad m
621+
type InspectMonadSTM (ExceptT e m) = InspectMonadSTM m
622622
inspectTVar _ = inspectTVar (Proxy @m)
623623
inspectTMVar _ = inspectTMVar (Proxy @m)
624624

@@ -709,7 +709,7 @@ instance (Monoid w, MonadSTM m) => MonadSTM (Lazy.RWST r w s m) where
709709

710710

711711
instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Lazy.RWST r w s m) where
712-
type InspectMonad (Lazy.RWST r w s m) = InspectMonad m
712+
type InspectMonadSTM (Lazy.RWST r w s m) = InspectMonadSTM m
713713
inspectTVar _ = inspectTVar (Proxy @m)
714714
inspectTMVar _ = inspectTMVar (Proxy @m)
715715

@@ -800,7 +800,7 @@ instance (Monoid w, MonadSTM m) => MonadSTM (Strict.RWST r w s m) where
800800

801801

802802
instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Strict.RWST r w s m) where
803-
type InspectMonad (Strict.RWST r w s m) = InspectMonad m
803+
type InspectMonadSTM (Strict.RWST r w s m) = InspectMonadSTM m
804804
inspectTVar _ = inspectTVar (Proxy @m)
805805
inspectTMVar _ = inspectTMVar (Proxy @m)
806806

‎io-classes/src/Control/Concurrent/Class/MonadMVar.hs

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@ module Control.Concurrent.Class.MonadMVar
77
( MonadMVar (..)
88
-- * non-standard extensions
99
, MonadInspectMVar (..)
10+
, MonadTraceMVar (..)
1011
, MonadLabelledMVar (..)
1112
) where
1213

@@ -16,6 +17,7 @@ import Control.Monad.Class.MonadThrow
1617
import Control.Monad.Reader (ReaderT (..))
1718
import Control.Monad.Trans (lift)
1819

20+
import Control.Concurrent.Class.MonadSTM (TraceValue)
1921
import Data.Kind (Type)
2022

2123

@@ -205,6 +207,15 @@ instance MonadInspectMVar IO where
205207
type InspectMVarMonad IO = IO
206208
inspectMVar _ = tryReadMVar
207209

210+
class MonadTraceMVar m where
211+
traceMVarIO :: proxy
212+
-> MVar m a
213+
-> (Maybe (Maybe a) -> Maybe a -> InspectMVarMonad m TraceValue)
214+
-> m ()
215+
216+
instance MonadTraceMVar IO where
217+
traceMVarIO = \_ _ _ -> pure ()
218+
208219
-- | Labelled `MVar`s
209220
--
210221
-- The `IO` instances is no-op, the `IOSim` instance enhances simulation trace.

‎io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs

Lines changed: 25 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -372,21 +372,21 @@ class MonadSTM m
372372
-- to access a 'TVar' in the underlying 'ST' monad.
373373
--
374374
class ( MonadSTM m
375-
, Monad (InspectMonad m)
375+
, Monad (InspectMonadSTM m)
376376
)
377377
=> MonadInspectSTM m where
378-
type InspectMonad m :: Type -> Type
378+
type InspectMonadSTM m :: Type -> Type
379379
-- | Return the value of a `TVar` as an `InspectMonad` computation.
380380
--
381381
-- `inspectTVar` is useful if the value of a `TVar` observed by `traceTVar`
382382
-- contains other `TVar`s.
383-
inspectTVar :: proxy m -> TVar m a -> InspectMonad m a
383+
inspectTVar :: proxy m -> TVar m a -> InspectMonadSTM m a
384384
-- | Return the value of a `TMVar` as an `InspectMonad` computation.
385-
inspectTMVar :: proxy m -> TMVar m a -> InspectMonad m (Maybe a)
385+
inspectTMVar :: proxy m -> TMVar m a -> InspectMonadSTM m (Maybe a)
386386
-- TODO: inspectTQueue, inspectTBQueue
387387

388388
instance MonadInspectSTM IO where
389-
type InspectMonad IO = IO
389+
type InspectMonadSTM IO = IO
390390
inspectTVar _ = readTVarIO
391391
-- issue #3198: tryReadTMVarIO
392392
inspectTMVar _ = atomically . tryReadTMVar
@@ -454,89 +454,89 @@ class MonadInspectSTM m
454454
--
455455
traceTVar :: proxy m
456456
-> TVar m a
457-
-> (Maybe a -> a -> InspectMonad m TraceValue)
457+
-> (Maybe a -> a -> InspectMonadSTM m TraceValue)
458458
-- ^ callback which receives initial value or 'Nothing' (if it
459459
-- is a newly created 'TVar'), and the committed value.
460460
-> STM m ()
461461

462462

463463
traceTMVar :: proxy m
464464
-> TMVar m a
465-
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
465+
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue)
466466
-> STM m ()
467467

468468
traceTQueue :: proxy m
469469
-> TQueue m a
470-
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
470+
-> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)
471471
-> STM m ()
472472

473473
traceTBQueue :: proxy m
474474
-> TBQueue m a
475-
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
475+
-> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)
476476
-> STM m ()
477477

478478
traceTSem :: proxy m
479479
-> TSem m
480-
-> (Maybe Integer -> Integer -> InspectMonad m TraceValue)
480+
-> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue)
481481
-> STM m ()
482482

483483
default traceTMVar :: TMVar m a ~ TMVarDefault m a
484484
=> proxy m
485485
-> TMVar m a
486-
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
486+
-> (Maybe (Maybe a) -> Maybe a -> InspectMonadSTM m TraceValue)
487487
-> STM m ()
488488
traceTMVar = traceTMVarDefault
489489

490490
default traceTSem :: TSem m ~ TSemDefault m
491491
=> proxy m
492492
-> TSem m
493-
-> (Maybe Integer -> Integer -> InspectMonad m TraceValue)
493+
-> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue)
494494
-> STM m ()
495495
traceTSem = traceTSemDefault
496496

497497

498498
traceTVarIO :: TVar m a
499-
-> (Maybe a -> a -> InspectMonad m TraceValue)
499+
-> (Maybe a -> a -> InspectMonadSTM m TraceValue)
500500
-> m ()
501501

502502
traceTMVarIO :: TMVar m a
503-
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
503+
-> (Maybe (Maybe a) -> Maybe a -> InspectMonadSTM m TraceValue)
504504
-> m ()
505505

506506
traceTQueueIO :: TQueue m a
507-
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
507+
-> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)
508508
-> m ()
509509

510510
traceTBQueueIO :: TBQueue m a
511-
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
511+
-> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)
512512
-> m ()
513513

514514
traceTSemIO :: TSem m
515-
-> (Maybe Integer -> Integer -> InspectMonad m TraceValue)
515+
-> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue)
516516
-> m ()
517517

518518
default traceTVarIO :: TVar m a
519-
-> (Maybe a -> a -> InspectMonad m TraceValue)
519+
-> (Maybe a -> a -> InspectMonadSTM m TraceValue)
520520
-> m ()
521521
traceTVarIO = \v f -> atomically (traceTVar Proxy v f)
522522

523523
default traceTMVarIO :: TMVar m a
524-
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
524+
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue)
525525
-> m ()
526526
traceTMVarIO = \v f -> atomically (traceTMVar Proxy v f)
527527

528528
default traceTQueueIO :: TQueue m a
529-
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
529+
-> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)
530530
-> m ()
531531
traceTQueueIO = \v f -> atomically (traceTQueue Proxy v f)
532532

533533
default traceTBQueueIO :: TBQueue m a
534-
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
534+
-> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)
535535
-> m ()
536536
traceTBQueueIO = \v f -> atomically (traceTBQueue Proxy v f)
537537

538538
default traceTSemIO :: TSem m
539-
-> (Maybe Integer -> Integer -> InspectMonad m TraceValue)
539+
-> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue)
540540
-> m ()
541541
traceTSemIO = \v f -> atomically (traceTSem Proxy v f)
542542

@@ -737,7 +737,7 @@ traceTMVarDefault
737737
:: MonadTraceSTM m
738738
=> proxy m
739739
-> TMVarDefault m a
740-
-> (Maybe (Maybe a) -> Maybe a -> InspectMonad m TraceValue)
740+
-> (Maybe (Maybe a) -> Maybe a -> InspectMonadSTM m TraceValue)
741741
-> STM m ()
742742
traceTMVarDefault p (TMVar t) f = traceTVar p t f
743743

@@ -1076,7 +1076,7 @@ labelTSemDefault (TSem t) = labelTVar t
10761076
traceTSemDefault :: MonadTraceSTM m
10771077
=> proxy m
10781078
-> TSemDefault m
1079-
-> (Maybe Integer -> Integer -> InspectMonad m TraceValue)
1079+
-> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue)
10801080
-> STM m ()
10811081
traceTSemDefault proxy (TSem t) k = traceTVar proxy t k
10821082

@@ -1295,7 +1295,7 @@ instance MonadSTM m => MonadSTM (ReaderT r m) where
12951295
isEmptyTChan = lift . isEmptyTChan
12961296

12971297
instance MonadInspectSTM m => MonadInspectSTM (ReaderT r m) where
1298-
type InspectMonad (ReaderT r m) = InspectMonad m
1298+
type InspectMonadSTM (ReaderT r m) = InspectMonadSTM m
12991299
inspectTVar _ = inspectTVar (Proxy :: Proxy m)
13001300
inspectTMVar _ = inspectTMVar (Proxy :: Proxy m)
13011301

‎io-classes/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -59,13 +59,13 @@ labelTBQueueIO (StrictTBQueue queue) = Lazy.labelTBQueueIO queue
5959
traceTBQueue :: MonadTraceSTM m
6060
=> proxy m
6161
-> StrictTBQueue m a
62-
-> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue)
62+
-> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue)
6363
-> STM m ()
6464
traceTBQueue p (StrictTBQueue queue) = Lazy.traceTBQueue p queue
6565

6666
traceTBQueueIO :: MonadTraceSTM m
6767
=> StrictTBQueue m a
68-
-> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue)
68+
-> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue)
6969
-> m ()
7070
traceTBQueueIO (StrictTBQueue queue) = Lazy.traceTBQueueIO queue
7171

‎io-classes/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -57,7 +57,7 @@ labelTMVarIO v = atomically . labelTMVar v
5757
traceTMVar :: MonadTraceSTM m
5858
=> proxy m
5959
-> StrictTMVar m a
60-
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
60+
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue)
6161
-> STM m ()
6262
traceTMVar p (StrictTMVar var) = Lazy.traceTMVar p var
6363

@@ -69,7 +69,7 @@ debugTraceTMVar p (StrictTMVar var) = Lazy.debugTraceTMVar p var
6969

7070
traceTMVarIO :: MonadTraceSTM m
7171
=> StrictTMVar m a
72-
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
72+
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue)
7373
-> m ()
7474
traceTMVarIO (StrictTMVar var) = Lazy.traceTMVarIO var
7575

‎io-classes/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -56,13 +56,13 @@ labelTQueueIO (StrictTQueue queue) = Lazy.labelTQueueIO queue
5656
traceTQueue :: MonadTraceSTM m
5757
=> proxy m
5858
-> StrictTQueue m a
59-
-> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue)
59+
-> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue)
6060
-> STM m ()
6161
traceTQueue p (StrictTQueue queue) = Lazy.traceTQueue p queue
6262

6363
traceTQueueIO :: MonadTraceSTM m
6464
=> StrictTQueue m a
65-
-> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue)
65+
-> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue)
6666
-> m ()
6767
traceTQueueIO (StrictTQueue queue) = Lazy.traceTQueueIO queue
6868

‎io-classes/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TVar.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -49,7 +49,7 @@ labelTVarIO v = atomically . labelTVar v
4949
traceTVar :: MonadTraceSTM m
5050
=> proxy m
5151
-> StrictTVar m a
52-
-> (Maybe a -> a -> InspectMonad m TraceValue)
52+
-> (Maybe a -> a -> InspectMonadSTM m TraceValue)
5353
-> STM m ()
5454
traceTVar p StrictTVar {tvar} = Lazy.traceTVar p tvar
5555

@@ -61,7 +61,7 @@ debugTraceTVar p StrictTVar {tvar} = Lazy.debugTraceTVar p tvar
6161

6262
traceTVarIO :: MonadTraceSTM m
6363
=> StrictTVar m a
64-
-> (Maybe a -> a -> InspectMonad m TraceValue)
64+
-> (Maybe a -> a -> InspectMonadSTM m TraceValue)
6565
-> m ()
6666
traceTVarIO StrictTVar {tvar} = Lazy.traceTVarIO tvar
6767

‎io-sim/CHANGELOG.md

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,8 @@
22

33
## next version
44

5+
- Provided `MonadTraceMVar`
6+
- Renamed `InspectMonad` to `InspectMonadSTM`
57
- Support `threadLabel` (`io-classes-1.8`)
68
- `IOSimPOR`'s `Effect` traces now will correctly show labels on read/written
79
`TVars`.

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -38,7 +38,7 @@ traceTQueueDefault
3838
:: MonadTraceSTM m
3939
=> proxy m
4040
-> TQueueDefault m a
41-
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
41+
-> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)
4242
-> STM m ()
4343
traceTQueueDefault p (TQueue queue) f =
4444
traceTVar p queue
@@ -122,7 +122,7 @@ traceTBQueueDefault
122122
:: MonadTraceSTM m
123123
=> proxy m
124124
-> TBQueueDefault m a
125-
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
125+
-> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)
126126
-> STM m ()
127127
traceTBQueueDefault p (TBQueue queue _size) f =
128128
traceTVar p queue (\mas as -> f (g <$> mas) (g as))

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

Lines changed: 11 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -575,7 +575,7 @@ instance MonadSTM (IOSim s) where
575575
cloneTChan = MonadSTM.cloneTChanDefault
576576

577577
instance MonadInspectSTM (IOSim s) where
578-
type InspectMonad (IOSim s) = ST s
578+
type InspectMonadSTM (IOSim s) = ST s
579579
inspectTVar _ TVar { tvarCurrent } = readSTRef tvarCurrent
580580
inspectTMVar _ (MonadSTM.TMVar TVar { tvarCurrent }) = readSTRef tvarCurrent
581581

@@ -615,6 +615,16 @@ instance MonadInspectMVar (IOSim s) where
615615
MVarEmpty _ _ -> pure Nothing
616616
MVarFull x _ -> pure (Just x)
617617

618+
instance MonadTraceMVar (IOSim s) where
619+
traceMVarIO _ (MVar mvar) f = traceTVarIO mvar traceMVarAsTVar
620+
where
621+
traceMVarAsTVar Nothing (MVarEmpty _ _) = f Nothing Nothing
622+
traceMVarAsTVar Nothing (MVarFull a _) = f Nothing (Just a)
623+
traceMVarAsTVar (Just (MVarEmpty _ _)) (MVarEmpty _ _) = f (Just Nothing) Nothing
624+
traceMVarAsTVar (Just (MVarEmpty _ _)) (MVarFull a _) = f (Just Nothing) (Just a)
625+
traceMVarAsTVar (Just (MVarFull a _)) (MVarEmpty _ _) = f (Just (Just a)) Nothing
626+
traceMVarAsTVar (Just (MVarFull a _)) (MVarFull a' _) = f (Just (Just a)) (Just a')
627+
618628
instance MonadLabelledMVar (IOSim s) where
619629
labelMVar = labelMVarDefault
620630

0 commit comments

Comments
 (0)