Timer.hs

module Engine.ReactiveBanana.Timer
  ( every
  ) where

import RIO

import Reactive.Banana qualified as RB
import Reactive.Banana.Frameworks qualified as RBF
import Resource.Region qualified as Region
import UnliftIO.Resource (ResourceT)

{- | An async process that will run forever and fire monotonic timestamp events.

Events would be processed serially on the timer thread and delays would be adjusted to keep up.

Events for the intervals "missed" would fire right away.
-}
every
  :: (MonadUnliftIO m)
  => Int -- ^ Timer interval in microseconds (for 'threadDelay')
  -> ResourceT m (RBF.MomentIO (RB.Event Double))
every delayMS = do
  (addHandler, fire) <- liftIO RBF.newAddHandler
  ticker <- async do
    begin <- getMonotonicTime
    threadDelay delayMS
    forever do
      before <- getMonotonicTime
      liftIO $ fire before
      after <- getMonotonicTime
      let
        tickNum       = (after - begin) * 1e6 / fromIntegral delayMS :: Double
        intTick       = truncate tickNum :: Integer
        driftTicks    = tickNum - fromInteger intTick :: Double
        driftMS       = driftTicks * fromIntegral delayMS :: Double
        adjustedDelay = max 0 $ delayMS - ceiling driftMS :: Int
      -- when (driftTicks > 0.01) $
      --   -- traceShowM driftTicks
      --   traceShowM (delayMS, (tickNum, intTick, driftTicks), driftMS, adjustedDelay)
      threadDelay adjustedDelay

  Region.attachAsync ticker
  pure $ RBF.fromAddHandler addHandler