diff --git a/.gitignore b/.gitignore index d5c3c640..32dbadbd 100644 --- a/.gitignore +++ b/.gitignore @@ -25,3 +25,4 @@ cabal.project.local~ tags io-sim/tags README.haddock +*.vim diff --git a/io-classes/CHANGELOG.md b/io-classes/CHANGELOG.md index 03d0e27b..0a87196c 100644 --- a/io-classes/CHANGELOG.md +++ b/io-classes/CHANGELOG.md @@ -6,6 +6,8 @@ ### Breaking changes +- Provided `MonadTraceMVar` +- Renamed `InspectMonad` to `InspectMonadSTM` * Added `threadLabel` to `MonadThread` * Added `MonadLabelledMVar` class. * Added `labelMVar` to `Control.Concurrent.Class.MonadMVar.Strict` diff --git a/io-classes/mtl/Control/Monad/Class/MonadSTM/Trans.hs b/io-classes/mtl/Control/Monad/Class/MonadSTM/Trans.hs index d3cbe06b..f1c2443a 100644 --- a/io-classes/mtl/Control/Monad/Class/MonadSTM/Trans.hs +++ b/io-classes/mtl/Control/Monad/Class/MonadSTM/Trans.hs @@ -163,7 +163,7 @@ instance MonadSTM m => MonadSTM (ContT r m) where instance MonadInspectSTM m => MonadInspectSTM (ContT r m) where - type InspectMonad (ContT r m) = InspectMonad m + type InspectMonadSTM (ContT r m) = InspectMonadSTM m inspectTVar _ = inspectTVar (Proxy @m) inspectTMVar _ = inspectTMVar (Proxy @m) @@ -254,7 +254,7 @@ instance (Monoid w, MonadSTM m) => MonadSTM (Lazy.WriterT w m) where instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Lazy.WriterT w m) where - type InspectMonad (Lazy.WriterT w m) = InspectMonad m + type InspectMonadSTM (Lazy.WriterT w m) = InspectMonadSTM m inspectTVar _ = inspectTVar (Proxy @m) inspectTMVar _ = inspectTMVar (Proxy @m) @@ -345,7 +345,7 @@ instance (Monoid w, MonadSTM m) => MonadSTM (Strict.WriterT w m) where instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Strict.WriterT w m) where - type InspectMonad (Strict.WriterT w m) = InspectMonad m + type InspectMonadSTM (Strict.WriterT w m) = InspectMonadSTM m inspectTVar _ = inspectTVar (Proxy @m) inspectTMVar _ = inspectTMVar (Proxy @m) @@ -436,7 +436,7 @@ instance MonadSTM m => MonadSTM (Lazy.StateT s m) where instance MonadInspectSTM m => MonadInspectSTM (Lazy.StateT s m) where - type InspectMonad (Lazy.StateT s m) = InspectMonad m + type InspectMonadSTM (Lazy.StateT s m) = InspectMonadSTM m inspectTVar _ = inspectTVar (Proxy @m) inspectTMVar _ = inspectTMVar (Proxy @m) @@ -527,7 +527,7 @@ instance MonadSTM m => MonadSTM (Strict.StateT s m) where instance MonadInspectSTM m => MonadInspectSTM (Strict.StateT s m) where - type InspectMonad (Strict.StateT s m) = InspectMonad m + type InspectMonadSTM (Strict.StateT s m) = InspectMonadSTM m inspectTVar _ = inspectTVar (Proxy @m) inspectTMVar _ = inspectTMVar (Proxy @m) @@ -618,7 +618,7 @@ instance MonadSTM m => MonadSTM (ExceptT e m) where instance MonadInspectSTM m => MonadInspectSTM (ExceptT e m) where - type InspectMonad (ExceptT e m) = InspectMonad m + type InspectMonadSTM (ExceptT e m) = InspectMonadSTM m inspectTVar _ = inspectTVar (Proxy @m) inspectTMVar _ = inspectTMVar (Proxy @m) @@ -709,7 +709,7 @@ instance (Monoid w, MonadSTM m) => MonadSTM (Lazy.RWST r w s m) where instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Lazy.RWST r w s m) where - type InspectMonad (Lazy.RWST r w s m) = InspectMonad m + type InspectMonadSTM (Lazy.RWST r w s m) = InspectMonadSTM m inspectTVar _ = inspectTVar (Proxy @m) inspectTMVar _ = inspectTMVar (Proxy @m) @@ -800,7 +800,7 @@ instance (Monoid w, MonadSTM m) => MonadSTM (Strict.RWST r w s m) where instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Strict.RWST r w s m) where - type InspectMonad (Strict.RWST r w s m) = InspectMonad m + type InspectMonadSTM (Strict.RWST r w s m) = InspectMonadSTM m inspectTVar _ = inspectTVar (Proxy @m) inspectTMVar _ = inspectTMVar (Proxy @m) diff --git a/io-classes/src/Control/Concurrent/Class/MonadMVar.hs b/io-classes/src/Control/Concurrent/Class/MonadMVar.hs index d9a2dbd5..f70c2eb2 100644 --- a/io-classes/src/Control/Concurrent/Class/MonadMVar.hs +++ b/io-classes/src/Control/Concurrent/Class/MonadMVar.hs @@ -7,6 +7,7 @@ module Control.Concurrent.Class.MonadMVar ( MonadMVar (..) -- * non-standard extensions , MonadInspectMVar (..) + , MonadTraceMVar (..) , MonadLabelledMVar (..) ) where @@ -16,6 +17,7 @@ import Control.Monad.Class.MonadThrow import Control.Monad.Reader (ReaderT (..)) import Control.Monad.Trans (lift) +import Control.Concurrent.Class.MonadSTM (TraceValue) import Data.Kind (Type) @@ -205,6 +207,15 @@ instance MonadInspectMVar IO where type InspectMVarMonad IO = IO inspectMVar _ = tryReadMVar +class MonadTraceMVar m where + traceMVarIO :: proxy + -> MVar m a + -> (Maybe (Maybe a) -> Maybe a -> InspectMVarMonad m TraceValue) + -> m () + +instance MonadTraceMVar IO where + traceMVarIO = \_ _ _ -> pure () + -- | Labelled `MVar`s -- -- The `IO` instances is no-op, the `IOSim` instance enhances simulation trace. diff --git a/io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs b/io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs index 95f1875b..def1c490 100644 --- a/io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs +++ b/io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs @@ -372,21 +372,21 @@ class MonadSTM m -- to access a 'TVar' in the underlying 'ST' monad. -- class ( MonadSTM m - , Monad (InspectMonad m) + , Monad (InspectMonadSTM m) ) => MonadInspectSTM m where - type InspectMonad m :: Type -> Type + type InspectMonadSTM m :: Type -> Type -- | Return the value of a `TVar` as an `InspectMonad` computation. -- -- `inspectTVar` is useful if the value of a `TVar` observed by `traceTVar` -- contains other `TVar`s. - inspectTVar :: proxy m -> TVar m a -> InspectMonad m a + inspectTVar :: proxy m -> TVar m a -> InspectMonadSTM m a -- | Return the value of a `TMVar` as an `InspectMonad` computation. - inspectTMVar :: proxy m -> TMVar m a -> InspectMonad m (Maybe a) + inspectTMVar :: proxy m -> TMVar m a -> InspectMonadSTM m (Maybe a) -- TODO: inspectTQueue, inspectTBQueue instance MonadInspectSTM IO where - type InspectMonad IO = IO + type InspectMonadSTM IO = IO inspectTVar _ = readTVarIO -- issue #3198: tryReadTMVarIO inspectTMVar _ = atomically . tryReadTMVar @@ -454,7 +454,7 @@ class MonadInspectSTM m -- traceTVar :: proxy m -> TVar m a - -> (Maybe a -> a -> InspectMonad m TraceValue) + -> (Maybe a -> a -> InspectMonadSTM m TraceValue) -- ^ callback which receives initial value or 'Nothing' (if it -- is a newly created 'TVar'), and the committed value. -> STM m () @@ -462,81 +462,81 @@ class MonadInspectSTM m traceTMVar :: proxy m -> TMVar m a - -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue) -> STM m () traceTQueue :: proxy m -> TQueue m a - -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue) -> STM m () traceTBQueue :: proxy m -> TBQueue m a - -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue) -> STM m () traceTSem :: proxy m -> TSem m - -> (Maybe Integer -> Integer -> InspectMonad m TraceValue) + -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue) -> STM m () default traceTMVar :: TMVar m a ~ TMVarDefault m a => proxy m -> TMVar m a - -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> (Maybe (Maybe a) -> Maybe a -> InspectMonadSTM m TraceValue) -> STM m () traceTMVar = traceTMVarDefault default traceTSem :: TSem m ~ TSemDefault m => proxy m -> TSem m - -> (Maybe Integer -> Integer -> InspectMonad m TraceValue) + -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue) -> STM m () traceTSem = traceTSemDefault traceTVarIO :: TVar m a - -> (Maybe a -> a -> InspectMonad m TraceValue) + -> (Maybe a -> a -> InspectMonadSTM m TraceValue) -> m () traceTMVarIO :: TMVar m a - -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> (Maybe (Maybe a) -> Maybe a -> InspectMonadSTM m TraceValue) -> m () traceTQueueIO :: TQueue m a - -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue) -> m () traceTBQueueIO :: TBQueue m a - -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue) -> m () traceTSemIO :: TSem m - -> (Maybe Integer -> Integer -> InspectMonad m TraceValue) + -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue) -> m () default traceTVarIO :: TVar m a - -> (Maybe a -> a -> InspectMonad m TraceValue) + -> (Maybe a -> a -> InspectMonadSTM m TraceValue) -> m () traceTVarIO = \v f -> atomically (traceTVar Proxy v f) default traceTMVarIO :: TMVar m a - -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue) -> m () traceTMVarIO = \v f -> atomically (traceTMVar Proxy v f) default traceTQueueIO :: TQueue m a - -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue) -> m () traceTQueueIO = \v f -> atomically (traceTQueue Proxy v f) default traceTBQueueIO :: TBQueue m a - -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue) -> m () traceTBQueueIO = \v f -> atomically (traceTBQueue Proxy v f) default traceTSemIO :: TSem m - -> (Maybe Integer -> Integer -> InspectMonad m TraceValue) + -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue) -> m () traceTSemIO = \v f -> atomically (traceTSem Proxy v f) @@ -737,7 +737,7 @@ traceTMVarDefault :: MonadTraceSTM m => proxy m -> TMVarDefault m a - -> (Maybe (Maybe a) -> Maybe a -> InspectMonad m TraceValue) + -> (Maybe (Maybe a) -> Maybe a -> InspectMonadSTM m TraceValue) -> STM m () traceTMVarDefault p (TMVar t) f = traceTVar p t f @@ -1076,7 +1076,7 @@ labelTSemDefault (TSem t) = labelTVar t traceTSemDefault :: MonadTraceSTM m => proxy m -> TSemDefault m - -> (Maybe Integer -> Integer -> InspectMonad m TraceValue) + -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue) -> STM m () traceTSemDefault proxy (TSem t) k = traceTVar proxy t k @@ -1295,7 +1295,7 @@ instance MonadSTM m => MonadSTM (ReaderT r m) where isEmptyTChan = lift . isEmptyTChan instance MonadInspectSTM m => MonadInspectSTM (ReaderT r m) where - type InspectMonad (ReaderT r m) = InspectMonad m + type InspectMonadSTM (ReaderT r m) = InspectMonadSTM m inspectTVar _ = inspectTVar (Proxy :: Proxy m) inspectTMVar _ = inspectTMVar (Proxy :: Proxy m) diff --git a/io-classes/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs b/io-classes/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs index dee1c6c8..80cde64d 100644 --- a/io-classes/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs +++ b/io-classes/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs @@ -59,13 +59,13 @@ labelTBQueueIO (StrictTBQueue queue) = Lazy.labelTBQueueIO queue traceTBQueue :: MonadTraceSTM m => proxy m -> StrictTBQueue m a - -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue) + -> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue) -> STM m () traceTBQueue p (StrictTBQueue queue) = Lazy.traceTBQueue p queue traceTBQueueIO :: MonadTraceSTM m => StrictTBQueue m a - -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue) + -> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue) -> m () traceTBQueueIO (StrictTBQueue queue) = Lazy.traceTBQueueIO queue 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 8b9641ad..3ae1de09 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 @@ -57,7 +57,7 @@ labelTMVarIO v = atomically . labelTMVar v traceTMVar :: MonadTraceSTM m => proxy m -> StrictTMVar m a - -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue) -> STM m () traceTMVar p (StrictTMVar var) = Lazy.traceTMVar p var @@ -69,7 +69,7 @@ debugTraceTMVar p (StrictTMVar var) = Lazy.debugTraceTMVar p var traceTMVarIO :: MonadTraceSTM m => StrictTMVar m a - -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue) -> m () traceTMVarIO (StrictTMVar var) = Lazy.traceTMVarIO var diff --git a/io-classes/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs b/io-classes/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs index d4cee8a9..37498a1b 100644 --- a/io-classes/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs +++ b/io-classes/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs @@ -56,13 +56,13 @@ labelTQueueIO (StrictTQueue queue) = Lazy.labelTQueueIO queue traceTQueue :: MonadTraceSTM m => proxy m -> StrictTQueue m a - -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue) + -> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue) -> STM m () traceTQueue p (StrictTQueue queue) = Lazy.traceTQueue p queue traceTQueueIO :: MonadTraceSTM m => StrictTQueue m a - -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue) + -> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue) -> m () traceTQueueIO (StrictTQueue queue) = Lazy.traceTQueueIO queue 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 a56d8ef0..44028d8c 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 @@ -49,7 +49,7 @@ labelTVarIO v = atomically . labelTVar v traceTVar :: MonadTraceSTM m => proxy m -> StrictTVar m a - -> (Maybe a -> a -> InspectMonad m TraceValue) + -> (Maybe a -> a -> InspectMonadSTM m TraceValue) -> STM m () traceTVar p StrictTVar {tvar} = Lazy.traceTVar p tvar @@ -61,7 +61,7 @@ debugTraceTVar p StrictTVar {tvar} = Lazy.debugTraceTVar p tvar traceTVarIO :: MonadTraceSTM m => StrictTVar m a - -> (Maybe a -> a -> InspectMonad m TraceValue) + -> (Maybe a -> a -> InspectMonadSTM m TraceValue) -> m () traceTVarIO StrictTVar {tvar} = Lazy.traceTVarIO tvar diff --git a/io-sim/CHANGELOG.md b/io-sim/CHANGELOG.md index e390cc6e..dd35598d 100644 --- a/io-sim/CHANGELOG.md +++ b/io-sim/CHANGELOG.md @@ -2,6 +2,8 @@ ## next version +- Provided `MonadTraceMVar` +- Renamed `InspectMonad` to `InspectMonadSTM` - Support `threadLabel` (`io-classes-1.8`) - `IOSimPOR`'s `Effect` traces now will correctly show labels on read/written `TVars`. diff --git a/io-sim/src/Control/Monad/IOSim/STM.hs b/io-sim/src/Control/Monad/IOSim/STM.hs index 8ef492dd..e13d7428 100644 --- a/io-sim/src/Control/Monad/IOSim/STM.hs +++ b/io-sim/src/Control/Monad/IOSim/STM.hs @@ -38,7 +38,7 @@ traceTQueueDefault :: MonadTraceSTM m => proxy m -> TQueueDefault m a - -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue) -> STM m () traceTQueueDefault p (TQueue queue) f = traceTVar p queue @@ -122,7 +122,7 @@ traceTBQueueDefault :: MonadTraceSTM m => proxy m -> TBQueueDefault m a - -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue) -> STM m () traceTBQueueDefault p (TBQueue queue _size) f = traceTVar p queue (\mas as -> f (g <$> mas) (g as)) diff --git a/io-sim/src/Control/Monad/IOSim/Types.hs b/io-sim/src/Control/Monad/IOSim/Types.hs index a7915964..47e1fede 100644 --- a/io-sim/src/Control/Monad/IOSim/Types.hs +++ b/io-sim/src/Control/Monad/IOSim/Types.hs @@ -575,7 +575,7 @@ instance MonadSTM (IOSim s) where cloneTChan = MonadSTM.cloneTChanDefault instance MonadInspectSTM (IOSim s) where - type InspectMonad (IOSim s) = ST s + type InspectMonadSTM (IOSim s) = ST s inspectTVar _ TVar { tvarCurrent } = readSTRef tvarCurrent inspectTMVar _ (MonadSTM.TMVar TVar { tvarCurrent }) = readSTRef tvarCurrent @@ -615,6 +615,16 @@ instance MonadInspectMVar (IOSim s) where MVarEmpty _ _ -> pure Nothing MVarFull x _ -> pure (Just x) +instance MonadTraceMVar (IOSim s) where + traceMVarIO _ (MVar mvar) f = traceTVarIO mvar traceMVarAsTVar + where + traceMVarAsTVar Nothing (MVarEmpty _ _) = f Nothing Nothing + traceMVarAsTVar Nothing (MVarFull a _) = f Nothing (Just a) + traceMVarAsTVar (Just (MVarEmpty _ _)) (MVarEmpty _ _) = f (Just Nothing) Nothing + traceMVarAsTVar (Just (MVarEmpty _ _)) (MVarFull a _) = f (Just Nothing) (Just a) + traceMVarAsTVar (Just (MVarFull a _)) (MVarEmpty _ _) = f (Just (Just a)) Nothing + traceMVarAsTVar (Just (MVarFull a _)) (MVarFull a' _) = f (Just (Just a)) (Just a') + instance MonadLabelledMVar (IOSim s) where labelMVar = labelMVarDefault