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 :: forall (m :: * -> *).
MonadUnliftIO m =>
Int -> ResourceT m (MomentIO (Event Double))
every Int
delayMS = do
  (AddHandler Double
addHandler, Handler Double
fire) <- IO (AddHandler Double, Handler Double)
-> ResourceT m (AddHandler Double, Handler Double)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (AddHandler Double, Handler Double)
forall a. IO (AddHandler a, Handler a)
RBF.newAddHandler
  Async Any
ticker <- ResourceT m Any -> ResourceT m (Async Any)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async do
    Double
begin <- ResourceT m Double
forall (m :: * -> *). MonadIO m => m Double
getMonotonicTime
    Int -> ResourceT m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
delayMS
    ResourceT m () -> ResourceT m Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever do
      Double
before <- ResourceT m Double
forall (m :: * -> *). MonadIO m => m Double
getMonotonicTime
      IO () -> ResourceT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ResourceT m ()) -> IO () -> ResourceT m ()
forall a b. (a -> b) -> a -> b
$ Handler Double
fire Double
before
      Double
after <- ResourceT m Double
forall (m :: * -> *). MonadIO m => m Double
getMonotonicTime
      let
        tickNum :: Double
tickNum       = (Double
after Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
begin) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1e6 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
delayMS :: Double
        intTick :: Integer
intTick       = Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
tickNum :: Integer
        driftTicks :: Double
driftTicks    = Double
tickNum Double -> Double -> Double
forall a. Num a => a -> a -> a
- Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
intTick :: Double
        driftMS :: Double
driftMS       = Double
driftTicks Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
delayMS :: Double
        adjustedDelay :: Int
adjustedDelay = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
delayMS Int -> Int -> Int
forall a. Num a => a -> a -> a
- Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Double
driftMS :: Int
      -- when (driftTicks > 0.01) $
      --   -- traceShowM driftTicks
      --   traceShowM (delayMS, (tickNum, intTick, driftTicks), driftMS, adjustedDelay)
      Int -> ResourceT m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
adjustedDelay

  Async Any -> ResourceT m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
Async a -> ResourceT m ()
Region.attachAsync Async Any
ticker
  pure $ AddHandler Double -> MomentIO (Event Double)
forall a. AddHandler a -> MomentIO (Event a)
RBF.fromAddHandler AddHandler Double
addHandler