IOLike: added MonadTraceSTM constraint

IntersectMBO · Oct 21, 2024 · be7c0f2 · be7c0f2
1 parent 254aa51
commit be7c0f2
Show file tree

Hide file tree

Showing 4 changed files with 15 additions and 2 deletions.
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs
@@ -69,6 +69,7 @@ import           Ouroboros.Consensus.Util.Orphans ()
 
 class ( MonadAsync              m
       , MonadLabelledSTM        m
+      , MonadTraceSTM           m
       , MonadMVar               m
       , MonadEventlog           m
       , MonadFork               m

diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs
@@ -539,6 +539,18 @@ instance MonadLabelledSTM m => MonadLabelledSTM (OverrideDelay m) where
   labelTQueueIO v  = OverrideDelay . lift . LazySTM.labelTQueueIO v
   labelTBQueueIO v = OverrideDelay . lift . LazySTM.labelTBQueueIO v
 
+instance MonadInspectSTM m => MonadInspectSTM (OverrideDelay m) where
+  type InspectMonad (OverrideDelay m) = InspectMonad m
+  inspectTVar = inspectTVar
+  inspectTMVar = inspectTMVar
+
+instance MonadTraceSTM m => MonadTraceSTM (OverrideDelay m) where
+  traceTVar _ v    = OverrideDelaySTM . lift . LazySTM.traceTVar Proxy v
+  traceTMVar _ v   = OverrideDelaySTM . lift . LazySTM.traceTMVar Proxy v
+  traceTQueue _ v  = OverrideDelaySTM . lift . LazySTM.traceTQueue Proxy v
+  traceTBQueue _ v = OverrideDelaySTM . lift . LazySTM.traceTBQueue Proxy v
+  traceTSem _ v    = OverrideDelaySTM . lift . LazySTM.traceTSem Proxy v
+
 newtype OverrideDelayAsync m a = OverrideDelayAsync {
     unOverrideDelayAsync :: Async m a
   }

diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs
@@ -119,7 +119,7 @@ data BlockFetchClientOutcome = BlockFetchClientOutcome {
 
 runBlockFetchTest ::
      forall m.
-     (IOLike m, MonadTime m, MonadTimer m, MonadTraceSTM m)
+     (IOLike m, MonadTime m, MonadTimer m)
   => BlockFetchClientTestSetup
   -> m BlockFetchClientOutcome
 runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do

diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs
@@ -314,7 +314,7 @@ data ChainSyncOutcome = ChainSyncOutcome {
 -- Note that updates that are scheduled before the time at which we start
 -- syncing help generate different chains to start syncing from.
 runChainSync ::
-       forall m. (IOLike m, MonadTime m, MonadTimer m, MonadTraceSTM m)
+       forall m. (IOLike m, MonadTime m, MonadTimer m)
     => ClockSkew
     -> SecurityParam
     -> ClientUpdates