module Engine.ReactiveBanana
  ( eventHandler
  , timer
  , observe

  , allocateActuated
  , allocatePaused

  , pushWorkerInput
  , pushWorkerInputJust

  , pushWorkerOutput
  , pushWorkerOutputJust

  , reactimateDebugShow

  , debounce
  ) where

import RIO

import Engine.Worker qualified as Worker
import GHC.Stack (withFrozenCallStack)
import Reactive.Banana qualified as RB
import Reactive.Banana.Frameworks qualified as RBF
import Resource.Region qualified as Region
import UnliftIO.Resource (ResourceT)
import UnliftIO.Resource qualified as Resource

eventHandler
  :: (Resource.MonadResource m, MonadIO io)
  => ((a -> io ()) -> m Resource.ReleaseKey)
  -> ResourceT m (RBF.MomentIO (RB.Event a))
eventHandler :: forall (m :: * -> *) (io :: * -> *) a.
(MonadResource m, MonadIO io) =>
((a -> io ()) -> m ReleaseKey) -> ResourceT m (MomentIO (Event a))
eventHandler (a -> io ()) -> m ReleaseKey
action = do
  (AddHandler a
addHandler, Handler a
fire) <- IO (AddHandler a, Handler a)
-> ResourceT m (AddHandler a, Handler a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (AddHandler a, Handler a)
forall a. IO (AddHandler a, Handler a)
RBF.newAddHandler
  m ReleaseKey -> ResourceT m ()
forall (m :: * -> *).
MonadResource m =>
m ReleaseKey -> ResourceT m ()
Region.local_ (m ReleaseKey -> ResourceT m ()) -> m ReleaseKey -> ResourceT m ()
forall a b. (a -> b) -> a -> b
$ (a -> io ()) -> m ReleaseKey
action (IO () -> io ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> io ()) -> Handler a -> a -> io ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handler a
fire)
  pure $ AddHandler a -> MomentIO (Event a)
forall a. AddHandler a -> MomentIO (Event a)
RBF.fromAddHandler AddHandler a
addHandler

timer
  :: (MonadUnliftIO m)
  => Int
  -> ResourceT m (RBF.MomentIO (RB.Event Double))
timer :: forall (m :: * -> *).
MonadUnliftIO m =>
Int -> ResourceT m (MomentIO (Event Double))
timer 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

observe
  :: (MonadUnliftIO m)
  => Worker.Var a
  -> ResourceT m (RBF.MomentIO (RB.Event a))
observe :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Var a -> ResourceT m (MomentIO (Event a))
observe Var a
var = do
  (AddHandler a
addHandler, Handler a
fire) <- IO (AddHandler a, Handler a)
-> ResourceT m (AddHandler a, Handler a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (AddHandler a, Handler a)
forall a. IO (AddHandler a, Handler a)
RBF.newAddHandler

  Versioned a
initial <- Var a -> ResourceT m (Versioned a)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO Var a
var

  Async Any
tracker <- ResourceT m Any -> ResourceT m (Async Any)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (ResourceT m Any -> ResourceT m (Async Any))
-> ResourceT m Any -> ResourceT m (Async Any)
forall a b. (a -> b) -> a -> b
$
    Handler a -> Vector Word64 -> ResourceT m Any
go Handler a
fire (Versioned a -> Vector Word64
forall a. Versioned a -> Vector Word64
Worker.vVersion Versioned a
initial)
  Async Any -> ResourceT m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
Async a -> ResourceT m ()
Region.attachAsync Async Any
tracker

  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 a
fire (Versioned a -> a
forall a. Versioned a -> a
Worker.vData Versioned a
initial) -- XXX: the network isn't compiled yet!
  pure $ AddHandler a -> MomentIO (Event a)
forall a. AddHandler a -> MomentIO (Event a)
RBF.fromAddHandler AddHandler a
addHandler
  where
    go :: Handler a -> Vector Word64 -> ResourceT m Any
go Handler a
fire Vector Word64
oldVersion = do
      Worker.Versioned{a
Vector Word64
vData :: a
vVersion :: Vector Word64
$sel:vData:Versioned :: forall a. Versioned a -> a
$sel:vVersion:Versioned :: forall a. Versioned a -> Vector Word64
..} <- STM (Versioned a) -> ResourceT m (Versioned a)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically do
        Versioned a
next <- Var a -> STM (Versioned a)
forall a. TVar a -> STM a
readTVar Var a
var
        if Versioned a -> Vector Word64
forall a. Versioned a -> Vector Word64
Worker.vVersion Versioned a
next Vector Word64 -> Vector Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Vector Word64
oldVersion then
          Versioned a -> STM (Versioned a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Versioned a
next
        else
          STM (Versioned a)
forall a. STM a
retrySTM
      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 a
fire a
vData
      Handler a -> Vector Word64 -> ResourceT m Any
go Handler a
fire Vector Word64
vVersion

allocateActuated
  :: MonadUnliftIO m
  => (UnliftIO m -> RB.Event () -> RBF.MomentIO ())
  -> ResourceT m RBF.EventNetwork
allocateActuated :: forall (m :: * -> *).
MonadUnliftIO m =>
(UnliftIO m -> Event () -> MomentIO ()) -> ResourceT m EventNetwork
allocateActuated UnliftIO m -> Event () -> MomentIO ()
builder = do
  (AddHandler ()
ah, Handler ()
fire) <- IO (AddHandler (), Handler ())
-> ResourceT m (AddHandler (), Handler ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (AddHandler (), Handler ())
forall a. IO (AddHandler a, Handler a)
RBF.newAddHandler

  EventNetwork
network <- (UnliftIO m -> MomentIO ()) -> ResourceT m EventNetwork
forall (m :: * -> *).
MonadUnliftIO m =>
(UnliftIO m -> MomentIO ()) -> ResourceT m EventNetwork
allocatePaused \UnliftIO m
unlift -> do
    Event ()
started <- AddHandler () -> MomentIO (Event ())
forall a. AddHandler a -> MomentIO (Event a)
RBF.fromAddHandler AddHandler ()
ah
    UnliftIO m -> Event () -> MomentIO ()
builder UnliftIO m
unlift Event ()
started

  IO EventNetwork -> ResourceT m EventNetwork
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
    EventNetwork -> IO ()
RBF.actuate EventNetwork
network
    Handler ()
fire ()
    pure EventNetwork
network

allocatePaused
  :: MonadUnliftIO m
  => (UnliftIO m -> RBF.MomentIO ())
  -> ResourceT m RBF.EventNetwork
allocatePaused :: forall (m :: * -> *).
MonadUnliftIO m =>
(UnliftIO m -> MomentIO ()) -> ResourceT m EventNetwork
allocatePaused UnliftIO m -> MomentIO ()
builder = do
  UnliftIO m
unlift <- m (UnliftIO m) -> ResourceT m (UnliftIO m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (UnliftIO m)
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
  ((ReleaseKey, EventNetwork) -> EventNetwork)
-> ResourceT m (ReleaseKey, EventNetwork)
-> ResourceT m EventNetwork
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ReleaseKey, EventNetwork) -> EventNetwork
forall a b. (a, b) -> b
snd (ResourceT m (ReleaseKey, EventNetwork)
 -> ResourceT m EventNetwork)
-> ResourceT m (ReleaseKey, EventNetwork)
-> ResourceT m EventNetwork
forall a b. (a -> b) -> a -> b
$
    IO EventNetwork
-> (EventNetwork -> IO ())
-> ResourceT m (ReleaseKey, EventNetwork)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
      (MomentIO () -> IO EventNetwork
RBF.compile (MomentIO () -> IO EventNetwork) -> MomentIO () -> IO EventNetwork
forall a b. (a -> b) -> a -> b
$ UnliftIO m -> MomentIO ()
builder UnliftIO m
unlift)
      EventNetwork -> IO ()
RBF.pause

pushWorkerInput
  :: Worker.HasInput var
  => var
  -> RB.Event (Worker.GetInput var)
  -> RBF.MomentIO ()
pushWorkerInput :: forall var.
HasInput var =>
var -> Event (GetInput var) -> MomentIO ()
pushWorkerInput var
p = Event (IO ()) -> MomentIO ()
RBF.reactimate (Event (IO ()) -> MomentIO ())
-> (Event (GetInput var) -> Event (IO ()))
-> Event (GetInput var)
-> MomentIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GetInput var -> IO ()) -> Event (GetInput var) -> Event (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (var -> (GetInput var -> GetInput var) -> IO ()
forall (m :: * -> *) var.
(MonadIO m, HasInput var) =>
var -> (GetInput var -> GetInput var) -> m ()
Worker.pushInput var
p ((GetInput var -> GetInput var) -> IO ())
-> (GetInput var -> GetInput var -> GetInput var)
-> GetInput var
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GetInput var -> GetInput var -> GetInput var
forall a b. a -> b -> a
const)

pushWorkerInputJust
  :: Worker.HasInput var
  => var
  -> RB.Event (Maybe (Worker.GetInput var))
  -> RBF.MomentIO ()
pushWorkerInputJust :: forall var.
HasInput var =>
var -> Event (Maybe (GetInput var)) -> MomentIO ()
pushWorkerInputJust var
p = Event (IO ()) -> MomentIO ()
RBF.reactimate (Event (IO ()) -> MomentIO ())
-> (Event (Maybe (GetInput var)) -> Event (IO ()))
-> Event (Maybe (GetInput var))
-> MomentIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (GetInput var) -> IO ())
-> Event (Maybe (GetInput var)) -> Event (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((GetInput var -> IO ()) -> Maybe (GetInput var) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((GetInput var -> IO ()) -> Maybe (GetInput var) -> IO ())
-> (GetInput var -> IO ()) -> Maybe (GetInput var) -> IO ()
forall a b. (a -> b) -> a -> b
$ var -> (GetInput var -> GetInput var) -> IO ()
forall (m :: * -> *) var.
(MonadIO m, HasInput var) =>
var -> (GetInput var -> GetInput var) -> m ()
Worker.pushInput var
p ((GetInput var -> GetInput var) -> IO ())
-> (GetInput var -> GetInput var -> GetInput var)
-> GetInput var
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GetInput var -> GetInput var -> GetInput var
forall a b. a -> b -> a
const)

pushWorkerOutput
  :: Worker.HasOutput var
  => var
  -> RB.Event (Worker.GetOutput var)
  -> RBF.MomentIO ()
pushWorkerOutput :: forall var.
HasOutput var =>
var -> Event (GetOutput var) -> MomentIO ()
pushWorkerOutput var
p = Event (IO ()) -> MomentIO ()
RBF.reactimate (Event (IO ()) -> MomentIO ())
-> (Event (GetOutput var) -> Event (IO ()))
-> Event (GetOutput var)
-> MomentIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GetOutput var -> IO ()) -> Event (GetOutput var) -> Event (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (var -> (GetOutput var -> GetOutput var) -> IO ()
forall (m :: * -> *) var.
(MonadIO m, HasOutput var) =>
var -> (GetOutput var -> GetOutput var) -> m ()
Worker.pushOutput var
p ((GetOutput var -> GetOutput var) -> IO ())
-> (GetOutput var -> GetOutput var -> GetOutput var)
-> GetOutput var
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GetOutput var -> GetOutput var -> GetOutput var
forall a b. a -> b -> a
const)

pushWorkerOutputJust
  :: Worker.HasOutput var
  => var
  -> RB.Event (Maybe (Worker.GetOutput var))
  -> RBF.MomentIO ()
pushWorkerOutputJust :: forall var.
HasOutput var =>
var -> Event (Maybe (GetOutput var)) -> MomentIO ()
pushWorkerOutputJust var
p = Event (IO ()) -> MomentIO ()
RBF.reactimate (Event (IO ()) -> MomentIO ())
-> (Event (Maybe (GetOutput var)) -> Event (IO ()))
-> Event (Maybe (GetOutput var))
-> MomentIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (GetOutput var) -> IO ())
-> Event (Maybe (GetOutput var)) -> Event (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((GetOutput var -> IO ()) -> Maybe (GetOutput var) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((GetOutput var -> IO ()) -> Maybe (GetOutput var) -> IO ())
-> (GetOutput var -> IO ()) -> Maybe (GetOutput var) -> IO ()
forall a b. (a -> b) -> a -> b
$ var -> (GetOutput var -> GetOutput var) -> IO ()
forall (m :: * -> *) var.
(MonadIO m, HasOutput var) =>
var -> (GetOutput var -> GetOutput var) -> m ()
Worker.pushOutput var
p ((GetOutput var -> GetOutput var) -> IO ())
-> (GetOutput var -> GetOutput var -> GetOutput var)
-> GetOutput var
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GetOutput var -> GetOutput var -> GetOutput var
forall a b. a -> b -> a
const)

reactimateDebugShow
  :: (Show a, MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
  => (m () -> IO ())
  -> RB.Event a
  -> RBF.MomentIO ()
reactimateDebugShow :: forall a (m :: * -> *) env.
(Show a, MonadIO m, MonadReader env m, HasLogFunc env,
 HasCallStack) =>
(m () -> IO ()) -> Event a -> MomentIO ()
reactimateDebugShow m () -> IO ()
unlift =
  Event (IO ()) -> MomentIO ()
RBF.reactimate (Event (IO ()) -> MomentIO ())
-> (Event a -> Event (IO ())) -> Event a -> MomentIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> IO ()) -> Event a -> Event (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (m () -> IO ()
unlift (m () -> IO ()) -> (a -> m ()) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HasCallStack => Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack HasCallStack => Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> m ()) -> (a -> Utf8Builder) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow)

debounce :: Eq a => a -> RB.Event a -> RBF.MomentIO (RB.Event a)
debounce :: forall a. Eq a => a -> Event a -> MomentIO (Event a)
debounce a
initial Event a
spamUpdates = do
  (Event a
e, Handler a
fire) <- MomentIO (Event a, Handler a)
forall a. MomentIO (Event a, Handler a)
RBF.newEvent
  IORef a
oldVar <- a -> MomentIO (IORef a)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef a
initial
  Event (IO ()) -> MomentIO ()
RBF.reactimate (Event (IO ()) -> MomentIO ()) -> Event (IO ()) -> MomentIO ()
forall a b. (a -> b) -> a -> b
$
    Event a
spamUpdates Event a -> Handler a -> Event (IO ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \a
new -> do
      Bool
changed <- IORef a -> (a -> (a, Bool)) -> IO Bool
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef a
oldVar \a
old ->
        (a
new, a
old a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
new)
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
changed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Handler a
fire a
new
  pure Event a
e