Some tracing improvements

io-classes/CHANGELOG.md

@@ -6,6 +6,8 @@
 
 * Added `threadLabel` to `MonadThread`
 * Added `MonadLabelledMVar` class.
+* Added `labelMVar` to `Control.Concurrent.Class.MonadMVar.Strict`
+* Added `debugTraceTVar`, `debugTraceTMVar`, `debugTraceTVarIO`, `debugTraceTMVarIO` for `Show`-based tracing.
 
 ### 1.7.0.0
 

io-classes/src/Control/Concurrent/Class/MonadSTM/TMVar.hs

@@ -24,6 +24,8 @@ module Control.Concurrent.Class.MonadSTM.TMVar
     -- * MonadTraceSTM
   , traceTMVar
   , traceTMVarIO
+  , debugTraceTMVar
+  , debugTraceTMVarIO
   ) where
 
 import Control.Monad.Class.MonadSTM.Internal

io-classes/src/Control/Concurrent/Class/MonadSTM/TVar.hs

@@ -21,6 +21,8 @@ module Control.Concurrent.Class.MonadSTM.TVar
     -- * MonadTraceSTM
   , traceTVar
   , traceTVarIO
+  , debugTraceTVar
+  , debugTraceTVarIO
   ) where
 
 import Control.Monad.Class.MonadSTM.Internal

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

@@ -99,6 +99,11 @@ module Control.Monad.Class.MonadSTM.Internal
   , isEmptyTChanDefault
   , cloneTChanDefault
   , labelTChanDefault
+    -- * Trace tvar and tmvar
+  , debugTraceTVar
+  , debugTraceTVarIO
+  , debugTraceTMVar
+  , debugTraceTMVarIO
   ) where
 
 import Prelude hiding (read)
@@ -535,6 +540,49 @@ class MonadInspectSTM m
                       -> m ()
   traceTSemIO = \v f -> atomically (traceTSem Proxy v f)
 
+debugTraceTVar :: (MonadTraceSTM m, Show a)
+               => proxy m
+               -> TVar m a
+               -> STM m ()
+debugTraceTVar p tvar =
+  traceTVar p tvar (\pv v -> pure $ TraceString $ case (pv, v) of
+          (Nothing, _)     -> error "Unreachable"
+          (Just st', st'') -> "Modified: " <> show st' <> " -> " <> show st''
+      )
+
+debugTraceTVarIO :: (MonadTraceSTM m, Show a)
+               => TVar m a
+               -> m ()
+debugTraceTVarIO tvar =
+  traceTVarIO tvar (\pv v -> pure $ TraceString $ case (pv, v) of
+          (Nothing, _)     -> error "Unreachable"
+          (Just st', st'') -> "Modified: " <> show st' <> " -> " <> show st''
+      )
+
+debugTraceTMVar :: (MonadTraceSTM m, Show a)
+               => proxy m
+               -> TMVar m a
+               -> STM m ()
+debugTraceTMVar p tmvar =
+  traceTMVar p tmvar (\pv v -> pure $ TraceString $ case (pv, v) of
+          (Nothing, _) -> error "Unreachable"
+          (Just Nothing, Just st') -> "Put: " <> show st'
+          (Just Nothing, Nothing) -> "Remains empty"
+          (Just Just{}, Nothing) -> "Take"
+          (Just (Just st'), Just st'') -> "Modified: " <> show st' <> " -> " <> show st''
+      )
+
+debugTraceTMVarIO :: (Show a, MonadTraceSTM m)
+                 => TMVar m a
+                 -> m ()
+debugTraceTMVarIO tmvar =
+  traceTMVarIO tmvar (\pv v -> pure $ TraceString $ case (pv, v) of
+          (Nothing, _) -> error "Unreachable"
+          (Just Nothing, Just st') -> "Put: " <> show st'
+          (Just Nothing, Nothing) -> "Remains empty"
+          (Just Just{}, Nothing) -> "Take"
+          (Just (Just st'), Just st'') -> "Modified: " <> show st' <> " -> " <> show st''
+      )
 
 --
 -- Instance for IO uses the existing STM library implementations

io-classes/strict-mvar/src/Control/Concurrent/Class/MonadMVar/Strict.hs

@@ -26,11 +26,12 @@ module Control.Concurrent.Class.MonadMVar.Strict
   , modifyMVarMasked_
   , modifyMVarMasked
   , tryReadMVar
+  , labelMVar
     -- * Re-exports
   , MonadMVar
   ) where
 
-import Control.Concurrent.Class.MonadMVar (MonadMVar)
+import Control.Concurrent.Class.MonadMVar (MonadLabelledMVar, MonadMVar)
 import Control.Concurrent.Class.MonadMVar qualified as Lazy
 
 --
@@ -62,6 +63,9 @@ toLazyMVar = mvar
 fromLazyMVar :: Lazy.MVar m a -> StrictMVar m a
 fromLazyMVar = StrictMVar
 
+labelMVar :: MonadLabelledMVar m => StrictMVar m a -> String -> m ()
+labelMVar (StrictMVar m) = Lazy.labelMVar m
+
 newEmptyMVar :: MonadMVar m => m (StrictMVar m a)
 newEmptyMVar = fromLazyMVar <$> Lazy.newEmptyMVar
 

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

@@ -31,6 +31,8 @@ module Control.Concurrent.Class.MonadSTM.Strict.TMVar
     -- * MonadTraceSTM
   , traceTMVar
   , traceTMVarIO
+  , debugTraceTMVar
+  , debugTraceTMVarIO
   ) where
 
 
@@ -59,12 +61,23 @@ traceTMVar :: MonadTraceSTM m
            -> STM m ()
 traceTMVar p (StrictTMVar var) = Lazy.traceTMVar p var
 
+debugTraceTMVar :: (MonadTraceSTM m, Show a)
+               => proxy m
+               -> StrictTMVar m a
+               -> STM m ()
+debugTraceTMVar p (StrictTMVar var) = Lazy.debugTraceTMVar p var
+
 traceTMVarIO :: MonadTraceSTM m
              => StrictTMVar m a
              -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
              -> m ()
 traceTMVarIO (StrictTMVar var) = Lazy.traceTMVarIO var
 
+debugTraceTMVarIO :: (MonadTraceSTM m, Show a)
+                 => StrictTMVar m a
+                 -> m ()
+debugTraceTMVarIO (StrictTMVar var) = Lazy.debugTraceTMVarIO var
+
 castStrictTMVar :: LazyTMVar m ~ LazyTMVar n
                 => StrictTMVar m a -> StrictTMVar n a
 castStrictTMVar (StrictTMVar var) = StrictTMVar var

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

@@ -27,6 +27,8 @@ module Control.Concurrent.Class.MonadSTM.Strict.TVar
     -- * MonadTraceSTM
   , traceTVar
   , traceTVarIO
+  , debugTraceTVar
+  , debugTraceTVarIO
   ) where
 
 import Control.Concurrent.Class.MonadSTM.TVar qualified as Lazy
@@ -51,12 +53,23 @@ traceTVar :: MonadTraceSTM m
           -> STM m ()
 traceTVar p StrictTVar {tvar} = Lazy.traceTVar p tvar
 
+debugTraceTVar :: (MonadTraceSTM m, Show a)
+              => proxy m
+              -> StrictTVar m a
+              -> STM m ()
+debugTraceTVar p StrictTVar {tvar} = Lazy.debugTraceTVar p tvar
+
 traceTVarIO :: MonadTraceSTM m
             => StrictTVar m a
             -> (Maybe a -> a -> InspectMonad m TraceValue)
             -> m ()
 traceTVarIO StrictTVar {tvar} = Lazy.traceTVarIO tvar
 
+debugTraceTVarIO :: (MonadTraceSTM m, Show a)
+                => StrictTVar m a
+                -> m ()
+debugTraceTVarIO StrictTVar {tvar} = Lazy.debugTraceTVarIO tvar
+
 -- | Cast the monad if both use the same representation of `TVar`s.
 --
 -- This function is useful for monad transformers stacks if the `TVar` is used