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)
every
:: (MonadUnliftIO m)
=> Int
-> 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
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