From 1dd2ce2910e2a30b1f861eb3b5719b664a3dda94 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 15 Oct 2024 16:30:00 +0200 Subject: [PATCH] Show-based default `debugTraceT[M]Var` functions --- .../Concurrent/Class/MonadSTM/TMVar.hs | 2 + .../Control/Concurrent/Class/MonadSTM/TVar.hs | 2 + .../Control/Monad/Class/MonadSTM/Internal.hs | 48 +++++++++++++++++++ .../Concurrent/Class/MonadSTM/Strict/TMVar.hs | 13 +++++ .../Concurrent/Class/MonadSTM/Strict/TVar.hs | 13 +++++ 5 files changed, 78 insertions(+) diff --git a/io-classes/src/Control/Concurrent/Class/MonadSTM/TMVar.hs b/io-classes/src/Control/Concurrent/Class/MonadSTM/TMVar.hs index 389ec115..270f4d6a 100644 --- 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 index fa715970..c8816aae 100644 --- 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 index 1faf7e9f..65d220e9 100644 --- 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 index c2d9f217..8b9641ad 100644 --- 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 index f287aa1f..a56d8ef0 100644 --- 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