ouroboros-consensus: add newTestGuardedBlockchainTime

ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime.hs

@@ -17,6 +17,7 @@ module Ouroboros.Consensus.BlockchainTime (
   , NumSlots(..)
   , TestBlockchainTime(..)
   , newTestBlockchainTime
+  , newTestGuardedBlockchainTime
     -- * Real blockchain time
   , realBlockchainTime
     -- * Time to slots and back again
@@ -178,7 +179,19 @@ newTestBlockchainTime
     -> NumSlots           -- ^ Number of slots
     -> DiffTime           -- ^ Slot duration
     -> m (TestBlockchainTime m)
-newTestBlockchainTime registry (NumSlots numSlots) slotLen = do
+newTestBlockchainTime registry numSlots slotLen =
+    newTestGuardedBlockchainTime registry numSlots slotLen (\_ -> pure ())
+
+-- | Like 'newTestBlockchainTime', but also allows other computations to delay
+-- the end of each slot
+newTestGuardedBlockchainTime
+    :: forall m. (IOLike m, HasCallStack)
+    => ResourceRegistry m
+    -> NumSlots           -- ^ Number of slots
+    -> DiffTime           -- ^ Slot duration
+    -> (SlotNo -> m ())   -- ^ Blocks until slot is finished
+    -> m (TestBlockchainTime m)
+newTestGuardedBlockchainTime registry (NumSlots numSlots) slotLen waitOn = do
     slotVar <- newTVarM initVal
     doneVar <- newEmptyMVar ()
 
@@ -207,10 +220,15 @@ newTestBlockchainTime registry (NumSlots numSlots) slotLen = do
     loop slotVar doneVar = do
         -- count off each requested slot
         replicateM_ numSlots $ do
-          atomically $ modifyTVar slotVar $ Running . \case
-            Initializing -> SlotNo 0
-            Running slot -> succ slot
+          s' <- atomically $ do
+            st <- readTVar slotVar
+            let s' = case st of
+                    Initializing -> SlotNo 0
+                    Running s    -> succ s
+            writeTVar slotVar (Running s')
+            pure s'
           threadDelay slotLen
+          waitOn s'
         -- signal the end of the final slot
         putMVar doneVar ()