diff --git a/io-classes/CHANGELOG.md b/io-classes/CHANGELOG.md index 8016cc98..2966b7d9 100644 --- a/io-classes/CHANGELOG.md +++ b/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 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 b7ed593c..57ca4598 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-mvar/src/Control/Concurrent/Class/MonadMVar/Strict.hs b/io-classes/strict-mvar/src/Control/Concurrent/Class/MonadMVar/Strict.hs index 4e296888..1078a378 100644 --- a/io-classes/strict-mvar/src/Control/Concurrent/Class/MonadMVar/Strict.hs +++ b/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 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