consensus: change onKnownSlotChange to knownSlotWatcher

This commit is propagating the new Watcher abstraction through an abbreviation.

ouroboros-consensus-test/test-consensus/Test/Consensus/BlockchainTime/Simple.hs

@@ -30,6 +30,7 @@ import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.BlockchainTime
 import           Ouroboros.Consensus.Util.IOLike
 import           Ouroboros.Consensus.Util.ResourceRegistry
+import           Ouroboros.Consensus.Util.STM (withWatcher)
 import           Ouroboros.Consensus.Util.Time
 
 import           Test.Util.Orphans.Arbitrary ()
@@ -293,24 +294,23 @@ testOverrideDelay :: forall m. (IOLike m, MonadTime m, MonadDelay (OverrideDelay
                   -> Int  -- ^ Number of slots to collect
                   -> OverrideDelay m [SlotNo]
 testOverrideDelay systemStart slotLength maxClockRewind numSlots = do
-    result <- withRegistry $ \registry -> do
+    withRegistry $ \registry -> do
       time <- simpleBlockchainTime
                 registry
                 (defaultSystemTime systemStart nullTracer)
                 slotLength
                 maxClockRewind
       slotsVar <- uncheckedNewTVarM []
-      cancelCollection <-
-        onKnownSlotChange registry time "testOverrideDelay" $ \slotNo ->
-          atomically $ modifyTVar slotsVar (slotNo :)
-      -- Wait to collect the required number of slots
-      slots <- atomically $ do
-        slots <- readTVar slotsVar
-        when (length slots < numSlots) $ retry
-        return slots
-      cancelCollection
-      return $ reverse slots
-    return result
+      withWatcher
+        "testOverrideDelay"
+        ( knownSlotWatcher time $ \slotNo -> do
+            atomically $ modifyTVar slotsVar (slotNo :)
+        ) $ do
+        -- Wait to collect the required number of slots
+        atomically $ do
+          slots <- readTVar slotsVar
+          when (length slots < numSlots) $ retry
+          return $ reverse slots
 
 {-------------------------------------------------------------------------------
   Test-programmable time

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

@@ -9,17 +9,15 @@
 module Ouroboros.Consensus.BlockchainTime.API (
     BlockchainTime(..)
   , CurrentSlot(..)
-  , onKnownSlotChange
+  , knownSlotWatcher
   ) where
 
 import           GHC.Generics (Generic)
-import           GHC.Stack
 import           NoThunks.Class (OnlyCheckWhnfNamed (..))
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Util.IOLike
-import           Ouroboros.Consensus.Util.ResourceRegistry
-import           Ouroboros.Consensus.Util.STM (Watcher (..), forkLinkedWatcher)
+import           Ouroboros.Consensus.Util.STM (Watcher (..))
 
 {-------------------------------------------------------------------------------
   API
@@ -54,27 +52,22 @@ data CurrentSlot =
   Derived functionality
 -------------------------------------------------------------------------------}
 
--- | Spawn a thread to run an action each time the slot changes
+-- | Watches for changes in the current slot
 --
 -- The action will not be called until the current slot becomes known
 -- (if the tip of our ledger is too far away from the current wallclock time,
--- we may not know what the current 'SlotId' is).
---
--- Returns a handle to kill the thread.
-onKnownSlotChange :: forall m. (IOLike m, HasCallStack)
-                  => ResourceRegistry m
-                  -> BlockchainTime m
-                  -> String            -- ^ Label for the thread
-                  -> (SlotNo -> m ())  -- ^ Action to execute
-                  -> m (m ())
-onKnownSlotChange registry btime label notify =
-      fmap cancelThread
-    $ forkLinkedWatcher registry label Watcher {
-          wFingerprint = id
-        , wInitial     = Nothing
-        , wNotify      = notify
-        , wReader      = getCurrentSlot'
-        }
+-- we may not know what the current 'SlotNo' is).
+knownSlotWatcher :: forall m. IOLike m
+                 => BlockchainTime m
+                 -> (SlotNo -> m ())  -- ^ Action to execute
+                 -> Watcher m SlotNo SlotNo
+knownSlotWatcher btime notify =
+    Watcher {
+        wFingerprint = id
+      , wInitial     = Nothing
+      , wNotify      = notify
+      , wReader      = getCurrentSlot'
+      }
   where
     getCurrentSlot' :: STM m SlotNo
     getCurrentSlot' = do

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

@@ -349,8 +349,10 @@ forkBlockForging
     -> BlockForging m blk
     -> m ()
 forkBlockForging maxTxCapacityOverride IS{..} blockForging =
-    void $ onKnownSlotChange registry btime threadLabel $
-        withEarlyExit_ . go
+      void
+    $ forkLinkedWatcher registry threadLabel
+    $ knownSlotWatcher btime
+    $ withEarlyExit_ . go
   where
     threadLabel :: String
     threadLabel =