Show-based default traceT[M]VarShow functions

Author: jasagredo

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

@@ -26,6 +26,8 @@ module Control.Concurrent.Class.MonadSTM.TMVar
     -- * MonadTraceSTM
   , traceTMVar
   , traceTMVarIO
+  , traceTMVarShow
+  , traceTMVarShowIO
   ) 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
+  , traceTVarShow
+  , traceTVarShowIO
   ) where
 
 import Control.Monad.Class.MonadSTM.Internal

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

@@ -103,6 +103,11 @@ module Control.Monad.Class.MonadSTM.Internal
   -- * WithTMVar
   , withTMVar
   , withTMVarAnd
+  -- * Trace tvar and tmvar
+  , traceTVarShow
+  , traceTVarShowIO
+  , traceTMVarShow
+  , traceTMVarShowIO
   ) where
 
 import Prelude hiding (read)
@@ -539,6 +544,51 @@ class MonadInspectSTM m
                       -> m ()
   traceTSemIO = \v f -> atomically (traceTSem Proxy v f)
 
+traceTVarShow :: (MonadTraceSTM m, Show a)
+               => proxy m
+               -> TVar m a
+               -> STM m ()
+traceTVarShow p tvar =
+  traceTVar p tvar (\pv v -> pure $ TraceString $ case (pv, v) of
+          (Nothing, st') -> "Created: " <> show st'
+          (Just st', st'') -> "Modified: " <> show st' <> " -> " <> show st''
+      )
+
+traceTVarShowIO :: (MonadTraceSTM m, Show a)
+               => TVar m a
+               -> m ()
+traceTVarShowIO tvar =
+  traceTVarIO tvar (\pv v -> pure $ TraceString $ case (pv, v) of
+          (Nothing, st') -> "Created: " <> show st'
+          (Just st', st'') -> "Modified: " <> show st' <> " -> " <> show st''
+      )
+
+traceTMVarShow :: (MonadTraceSTM m, Show a)
+               => proxy m
+               -> TMVar m a
+               -> STM m ()
+traceTMVarShow p tmvar =
+  traceTMVar p tmvar (\pv v -> pure $ TraceString $ case (pv, v) of
+          (Nothing, Nothing) -> "Created empty"
+          (Nothing, Just st') -> "Created full: " <> show st'
+          (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''
+      )
+
+traceTMVarShowIO :: (Show a, MonadTraceSTM m)
+                 => TMVar m a
+                 -> m ()
+traceTMVarShowIO tmvar =
+  traceTMVarIO tmvar (\pv v -> pure $ TraceString $ case (pv, v) of
+          (Nothing, Nothing) -> "Created empty"
+          (Nothing, Just st') -> "Created full: " <> show st'
+          (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-stm/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs

@@ -33,6 +33,8 @@ module Control.Concurrent.Class.MonadSTM.Strict.TMVar
     -- * MonadTraceSTM
   , traceTMVar
   , traceTMVarIO
+  , traceTMVarShow
+  , traceTMVarShowIO
   ) where
 
 
@@ -61,12 +63,23 @@ traceTMVar :: MonadTraceSTM m
            -> STM m ()
 traceTMVar p (StrictTMVar var) = Lazy.traceTMVar p var
 
+traceTMVarShow :: (MonadTraceSTM m, Show a)
+               => proxy m
+               -> StrictTMVar m a
+               -> STM m ()
+traceTMVarShow p (StrictTMVar var) = Lazy.traceTMVarShow p var
+
 traceTMVarIO :: MonadTraceSTM m
              => StrictTMVar m a
              -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
              -> m ()
 traceTMVarIO (StrictTMVar var) = Lazy.traceTMVarIO var
 
+traceTMVarShowIO :: (MonadTraceSTM m, Show a)
+                 => StrictTMVar m a
+                 -> m ()
+traceTMVarShowIO (StrictTMVar var) = Lazy.traceTMVarShowIO 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
+  , traceTVarShow
+  , traceTVarShowIO
   ) 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
 
+traceTVarShow :: (MonadTraceSTM m, Show a)
+              => proxy m
+              -> StrictTVar m a
+              -> STM m ()
+traceTVarShow p StrictTVar {tvar} = Lazy.traceTVarShow p tvar
+
 traceTVarIO :: MonadTraceSTM m
             => StrictTVar m a
             -> (Maybe a -> a -> InspectMonad m TraceValue)
             -> m ()
 traceTVarIO StrictTVar {tvar} = Lazy.traceTVarIO tvar
 
+traceTVarShowIO :: (MonadTraceSTM m, Show a)
+                => StrictTVar m a
+                -> m ()
+traceTVarShowIO StrictTVar {tvar} = Lazy.traceTVarShowIO 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