Provide MonadTraceMVar

.gitignore

@@ -25,3 +25,4 @@ cabal.project.local~
 tags
 io-sim/tags
 README.haddock
+*.vim

io-classes/CHANGELOG.md

@@ -6,6 +6,8 @@
 
 ### Breaking changes
 
+- Provided `MonadTraceMVar`
+- Renamed `InspectMonad` to `InspectMonadSTM`
 * Added `threadLabel` to `MonadThread`
 * Added `MonadLabelledMVar` class.
 * Added `labelMVar` to `Control.Concurrent.Class.MonadMVar.Strict`

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

@@ -163,7 +163,7 @@ instance MonadSTM m => MonadSTM (ContT r m) where
 
 
 instance MonadInspectSTM m => MonadInspectSTM (ContT r m) where
-  type InspectMonad (ContT r m) = InspectMonad m
+  type InspectMonadSTM (ContT r m) = InspectMonadSTM m
   inspectTVar  _ = inspectTVar  (Proxy @m)
   inspectTMVar _ = inspectTMVar (Proxy @m)
 
@@ -254,7 +254,7 @@ instance (Monoid w, MonadSTM m) => MonadSTM (Lazy.WriterT w m) where
 
 
 instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Lazy.WriterT w m) where
-  type InspectMonad (Lazy.WriterT w m) = InspectMonad m
+  type InspectMonadSTM (Lazy.WriterT w m) = InspectMonadSTM m
   inspectTVar  _ = inspectTVar  (Proxy @m)
   inspectTMVar _ = inspectTMVar (Proxy @m)
 
@@ -345,7 +345,7 @@ instance (Monoid w, MonadSTM m) => MonadSTM (Strict.WriterT w m) where
 
 
 instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Strict.WriterT w m) where
-  type InspectMonad (Strict.WriterT w m) = InspectMonad m
+  type InspectMonadSTM (Strict.WriterT w m) = InspectMonadSTM m
   inspectTVar  _ = inspectTVar  (Proxy @m)
   inspectTMVar _ = inspectTMVar (Proxy @m)
 
@@ -436,7 +436,7 @@ instance MonadSTM m => MonadSTM (Lazy.StateT s m) where
 
 
 instance MonadInspectSTM m => MonadInspectSTM (Lazy.StateT s m) where
-  type InspectMonad (Lazy.StateT s m) = InspectMonad m
+  type InspectMonadSTM (Lazy.StateT s m) = InspectMonadSTM m
   inspectTVar  _ = inspectTVar  (Proxy @m)
   inspectTMVar _ = inspectTMVar (Proxy @m)
 
@@ -527,7 +527,7 @@ instance MonadSTM m => MonadSTM (Strict.StateT s m) where
 
 
 instance MonadInspectSTM m => MonadInspectSTM (Strict.StateT s m) where
-  type InspectMonad (Strict.StateT s m) = InspectMonad m
+  type InspectMonadSTM (Strict.StateT s m) = InspectMonadSTM m
   inspectTVar  _ = inspectTVar  (Proxy @m)
   inspectTMVar _ = inspectTMVar (Proxy @m)
 
@@ -618,7 +618,7 @@ instance MonadSTM m => MonadSTM (ExceptT e m) where
 
 
 instance MonadInspectSTM m => MonadInspectSTM (ExceptT e m) where
-  type InspectMonad (ExceptT e m) = InspectMonad m
+  type InspectMonadSTM (ExceptT e m) = InspectMonadSTM m
   inspectTVar  _ = inspectTVar  (Proxy @m)
   inspectTMVar _ = inspectTMVar (Proxy @m)
 
@@ -709,7 +709,7 @@ instance (Monoid w, MonadSTM m) => MonadSTM (Lazy.RWST r w s m) where
 
 
 instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Lazy.RWST r w s m) where
-  type InspectMonad (Lazy.RWST r w s m) = InspectMonad m
+  type InspectMonadSTM (Lazy.RWST r w s m) = InspectMonadSTM m
   inspectTVar  _ = inspectTVar  (Proxy @m)
   inspectTMVar _ = inspectTMVar (Proxy @m)
 
@@ -800,7 +800,7 @@ instance (Monoid w, MonadSTM m) => MonadSTM (Strict.RWST r w s m) where
 
 
 instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Strict.RWST r w s m) where
-  type InspectMonad (Strict.RWST r w s m) = InspectMonad m
+  type InspectMonadSTM (Strict.RWST r w s m) = InspectMonadSTM m
   inspectTVar  _ = inspectTVar  (Proxy @m)
   inspectTMVar _ = inspectTMVar (Proxy @m)
 

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

@@ -7,6 +7,7 @@ module Control.Concurrent.Class.MonadMVar
   ( MonadMVar (..)
     -- * non-standard extensions
   , MonadInspectMVar (..)
+  , MonadTraceMVar (..)
   , MonadLabelledMVar (..)
   ) where
 
@@ -16,6 +17,7 @@ import Control.Monad.Class.MonadThrow
 import Control.Monad.Reader (ReaderT (..))
 import Control.Monad.Trans (lift)
 
+import Control.Concurrent.Class.MonadSTM (TraceValue)
 import Data.Kind (Type)
 
 
@@ -205,6 +207,15 @@ instance MonadInspectMVar IO where
   type InspectMVarMonad IO = IO
   inspectMVar _ = tryReadMVar
 
+class MonadTraceMVar m where
+  traceMVarIO :: proxy
+              -> MVar m a
+              -> (Maybe (Maybe a) -> Maybe a -> InspectMVarMonad m TraceValue)
+              -> m ()
+
+instance MonadTraceMVar IO where
+  traceMVarIO = \_ _ _ -> pure ()
+
 -- | Labelled `MVar`s
 --
 -- The `IO` instances is no-op, the `IOSim` instance enhances simulation trace.

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

@@ -372,21 +372,21 @@ class MonadSTM m
 -- to access a 'TVar' in the underlying 'ST' monad.
 --
 class ( MonadSTM m
-      , Monad (InspectMonad m)
+      , Monad (InspectMonadSTM m)
       )
     => MonadInspectSTM m where
-    type InspectMonad m :: Type -> Type
+    type InspectMonadSTM m :: Type -> Type
     -- | Return the value of a `TVar` as an `InspectMonad` computation.
     --
     -- `inspectTVar` is useful if the value of a `TVar` observed by `traceTVar`
     -- contains other `TVar`s.
-    inspectTVar  :: proxy m -> TVar  m a -> InspectMonad m a
+    inspectTVar  :: proxy m -> TVar  m a -> InspectMonadSTM m a
     -- | Return the value of a `TMVar` as an `InspectMonad` computation.
-    inspectTMVar :: proxy m -> TMVar m a -> InspectMonad m (Maybe a)
+    inspectTMVar :: proxy m -> TMVar m a -> InspectMonadSTM m (Maybe a)
     -- TODO: inspectTQueue, inspectTBQueue
 
 instance MonadInspectSTM IO where
-    type InspectMonad IO = IO
+    type InspectMonadSTM IO = IO
     inspectTVar  _ = readTVarIO
     -- issue #3198: tryReadTMVarIO
     inspectTMVar _ = atomically . tryReadTMVar
@@ -454,89 +454,89 @@ class MonadInspectSTM m
   --
   traceTVar    :: proxy m
                -> TVar m a
-               -> (Maybe a -> a -> InspectMonad m TraceValue)
+               -> (Maybe a -> a -> InspectMonadSTM m TraceValue)
                -- ^ callback which receives initial value or 'Nothing' (if it
                -- is a newly created 'TVar'), and the committed value.
                -> STM m ()
 
 
   traceTMVar   :: proxy m
                -> TMVar m a
-               -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
+               -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue)
                -> STM m ()
 
   traceTQueue  :: proxy m
                -> TQueue m a
-               -> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
+               -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)
                -> STM m ()
 
   traceTBQueue :: proxy m
                -> TBQueue m a
-               -> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
+               -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)
                -> STM m ()
 
   traceTSem    :: proxy m
                -> TSem m
-               -> (Maybe Integer -> Integer -> InspectMonad m TraceValue)
+               -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue)
                -> STM m ()
 
   default traceTMVar :: TMVar m a ~ TMVarDefault m a
                      => proxy m
                      -> TMVar m a
-                     -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
+                     -> (Maybe (Maybe a) -> Maybe a -> InspectMonadSTM m TraceValue)
                      -> STM m ()
   traceTMVar = traceTMVarDefault
 
   default traceTSem :: TSem m ~ TSemDefault m
                     => proxy m
                     -> TSem m
-                    -> (Maybe Integer -> Integer -> InspectMonad m TraceValue)
+                    -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue)
                     -> STM m ()
   traceTSem = traceTSemDefault
 
 
   traceTVarIO    :: TVar m a
-                 -> (Maybe a -> a -> InspectMonad m TraceValue)
+                 -> (Maybe a -> a -> InspectMonadSTM m TraceValue)
                  -> m ()
 
   traceTMVarIO   :: TMVar m a
-                 -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
+                 -> (Maybe (Maybe a) -> Maybe a -> InspectMonadSTM m TraceValue)
                  -> m ()
 
   traceTQueueIO  :: TQueue m a
-                 -> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
+                 -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)
                  -> m ()
 
   traceTBQueueIO :: TBQueue m a
-                 -> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
+                 -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)
                  -> m ()
 
   traceTSemIO    :: TSem m
-                 -> (Maybe Integer -> Integer -> InspectMonad m TraceValue)
+                 -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue)
                  -> m ()
 
   default traceTVarIO :: TVar m a
-                      -> (Maybe a -> a -> InspectMonad m TraceValue)
+                      -> (Maybe a -> a -> InspectMonadSTM m TraceValue)
                       -> m ()
   traceTVarIO = \v f -> atomically (traceTVar Proxy v f)
 
   default traceTMVarIO :: TMVar m a
-                       -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
+                       -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue)
                        -> m ()
   traceTMVarIO = \v f -> atomically (traceTMVar Proxy v f)
 
   default traceTQueueIO :: TQueue m a
-                        -> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
+                        -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)
                         -> m ()
   traceTQueueIO = \v f -> atomically (traceTQueue Proxy v f)
 
   default traceTBQueueIO :: TBQueue m a
-                         -> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
+                         -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)
                          -> m ()
   traceTBQueueIO = \v f -> atomically (traceTBQueue Proxy v f)
 
   default traceTSemIO :: TSem m
-                      -> (Maybe Integer -> Integer -> InspectMonad m TraceValue)
+                      -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue)
                       -> m ()
   traceTSemIO = \v f -> atomically (traceTSem Proxy v f)
 
@@ -737,7 +737,7 @@ traceTMVarDefault
   :: MonadTraceSTM m
   => proxy m
   -> TMVarDefault m a
-  -> (Maybe (Maybe a) -> Maybe a -> InspectMonad m TraceValue)
+  -> (Maybe (Maybe a) -> Maybe a -> InspectMonadSTM m TraceValue)
   -> STM m ()
 traceTMVarDefault p (TMVar t) f = traceTVar p t f
 
@@ -1076,7 +1076,7 @@ labelTSemDefault (TSem t) = labelTVar t
 traceTSemDefault :: MonadTraceSTM m
                  => proxy m
                  -> TSemDefault m
-                 -> (Maybe Integer -> Integer -> InspectMonad m TraceValue)
+                 -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue)
                  -> STM m ()
 traceTSemDefault proxy (TSem t) k = traceTVar proxy t k
 
@@ -1295,7 +1295,7 @@ instance MonadSTM m => MonadSTM (ReaderT r m) where
     isEmptyTChan      = lift .  isEmptyTChan
 
 instance MonadInspectSTM m => MonadInspectSTM (ReaderT r m) where
-  type InspectMonad (ReaderT r m) = InspectMonad m
+  type InspectMonadSTM (ReaderT r m) = InspectMonadSTM m
   inspectTVar  _ = inspectTVar  (Proxy :: Proxy m)
   inspectTMVar _ = inspectTMVar (Proxy :: Proxy m)
 

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

@@ -59,13 +59,13 @@ labelTBQueueIO (StrictTBQueue queue) = Lazy.labelTBQueueIO queue
 traceTBQueue :: MonadTraceSTM m
              => proxy m
              -> StrictTBQueue m a
-             -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue)
+             -> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue)
              -> STM m ()
 traceTBQueue p (StrictTBQueue queue) = Lazy.traceTBQueue p queue
 
 traceTBQueueIO :: MonadTraceSTM m
                => StrictTBQueue m a
-               -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue)
+               -> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue)
                -> m ()
 traceTBQueueIO (StrictTBQueue queue) = Lazy.traceTBQueueIO queue
 

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

@@ -57,7 +57,7 @@ labelTMVarIO v = atomically . labelTMVar v
 traceTMVar :: MonadTraceSTM m
            => proxy m
            -> StrictTMVar m a
-           -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
+           -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue)
            -> STM m ()
 traceTMVar p (StrictTMVar var) = Lazy.traceTMVar p var
 
@@ -69,7 +69,7 @@ debugTraceTMVar p (StrictTMVar var) = Lazy.debugTraceTMVar p var
 
 traceTMVarIO :: MonadTraceSTM m
              => StrictTMVar m a
-             -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
+             -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue)
              -> m ()
 traceTMVarIO (StrictTMVar var) = Lazy.traceTMVarIO var
 

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

@@ -56,13 +56,13 @@ labelTQueueIO (StrictTQueue queue) = Lazy.labelTQueueIO queue
 traceTQueue :: MonadTraceSTM m
             => proxy m
             -> StrictTQueue m a
-            -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue)
+            -> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue)
             -> STM m ()
 traceTQueue p (StrictTQueue queue) = Lazy.traceTQueue p queue
 
 traceTQueueIO :: MonadTraceSTM m
               => StrictTQueue m a
-              -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue)
+              -> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue)
               -> m ()
 traceTQueueIO (StrictTQueue queue) = Lazy.traceTQueueIO queue
 

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

@@ -49,7 +49,7 @@ labelTVarIO v = atomically . labelTVar v
 traceTVar :: MonadTraceSTM m
           => proxy m
           -> StrictTVar m a
-          -> (Maybe a -> a -> InspectMonad m TraceValue)
+          -> (Maybe a -> a -> InspectMonadSTM m TraceValue)
           -> STM m ()
 traceTVar p StrictTVar {tvar} = Lazy.traceTVar p tvar
 
@@ -61,7 +61,7 @@ debugTraceTVar p StrictTVar {tvar} = Lazy.debugTraceTVar p tvar
 
 traceTVarIO :: MonadTraceSTM m
             => StrictTVar m a
-            -> (Maybe a -> a -> InspectMonad m TraceValue)
+            -> (Maybe a -> a -> InspectMonadSTM m TraceValue)
             -> m ()
 traceTVarIO StrictTVar {tvar} = Lazy.traceTVarIO tvar
 

io-sim/CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## next version
 
+- Provided `MonadTraceMVar`
+- Renamed `InspectMonad` to `InspectMonadSTM`
 - Support `threadLabel` (`io-classes-1.8`)
 - `IOSimPOR`'s `Effect` traces now will correctly show labels on read/written
   `TVars`.

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

@@ -38,7 +38,7 @@ traceTQueueDefault
   :: MonadTraceSTM m
   => proxy m
   -> TQueueDefault m a
-  -> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
+  -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)
   -> STM m ()
 traceTQueueDefault p (TQueue queue) f =
     traceTVar p queue
@@ -122,7 +122,7 @@ traceTBQueueDefault
   :: MonadTraceSTM m
   => proxy m
   -> TBQueueDefault m a
-  -> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
+  -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)
   -> STM m ()
 traceTBQueueDefault p (TBQueue queue _size) f =
     traceTVar p queue (\mas as -> f (g <$> mas) (g as))

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

@@ -575,7 +575,7 @@ instance MonadSTM (IOSim s) where
   cloneTChan        = MonadSTM.cloneTChanDefault
 
 instance MonadInspectSTM (IOSim s) where
-  type InspectMonad (IOSim s) = ST s
+  type InspectMonadSTM (IOSim s) = ST s
   inspectTVar  _                 TVar { tvarCurrent }  = readSTRef tvarCurrent
   inspectTMVar _ (MonadSTM.TMVar TVar { tvarCurrent }) = readSTRef tvarCurrent
 
@@ -615,6 +615,16 @@ instance MonadInspectMVar (IOSim s) where
         MVarEmpty _ _ -> pure Nothing
         MVarFull x _  -> pure (Just x)
 
+instance MonadTraceMVar (IOSim s) where
+  traceMVarIO _ (MVar mvar) f = traceTVarIO mvar traceMVarAsTVar
+    where
+      traceMVarAsTVar Nothing                (MVarEmpty _ _) = f Nothing         Nothing
+      traceMVarAsTVar Nothing                (MVarFull a _)  = f Nothing         (Just a)
+      traceMVarAsTVar (Just (MVarEmpty _ _)) (MVarEmpty _ _) = f (Just Nothing)  Nothing
+      traceMVarAsTVar (Just (MVarEmpty _ _)) (MVarFull a _)  = f (Just Nothing)  (Just a)
+      traceMVarAsTVar (Just (MVarFull a _))  (MVarEmpty _ _) = f (Just (Just a)) Nothing
+      traceMVarAsTVar (Just (MVarFull a _))  (MVarFull a' _) = f (Just (Just a)) (Just a')
+
 instance MonadLabelledMVar (IOSim s) where
   labelMVar = labelMVarDefault