Show-based default debugTraceT[M]Var functions

input-output-hk · Oct 22, 2024 · 1dd2ce2 · 1dd2ce2
1 parent b2a45bd
commit 1dd2ce2
Show file tree

Hide file tree

Showing 5 changed files with 78 additions and 0 deletions.
diff --git a/io-classes/src/Control/Concurrent/Class/MonadSTM/TMVar.hs b/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
diff --git a/io-classes/src/Control/Concurrent/Class/MonadSTM/TVar.hs b/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
diff --git a/io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs b/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

diff --git a/io-classes/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs b/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

diff --git a/io-classes/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TVar.hs b/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