module Engine.ReactiveBanana
  ( -- * Network setup
    allocateActuated
  , allocatePaused

    -- * Event utilities
  , eventHandler
  , debounce
  , reactimateDebugShow
  , timer

    -- * "Engine.Worker" interface
    -- ** From workers to networks
  , observe
    -- ** From networks to workers
  , pushWorkerInput
  , pushWorkerInputJust
  , pushWorkerOutput
  , pushWorkerOutputJust
  ) 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

import Engine.ReactiveBanana.Timer qualified as Timer

-- * Network setup

-- | Set up a network, run it and fire the started event before returning.
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

{- | Set up a network, passing a current context to the network-building function.

The network would pause when leaving resource region.
-}
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

-- | Make an 'RB.Event' that can be fired by a callback registered in a current resource region.
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

-- * Event utilities

-- | An async process that will fire monotonic timestamp events and self-adjust for the delays induced by its handling.
timer
  :: (MonadUnliftIO m)
  => Int -- ^ Timer interval in microseconds
  -> ResourceT m (RBF.MomentIO (RB.Event Double))
timer :: forall (m :: * -> *).
MonadUnliftIO m =>
Int -> ResourceT m (MomentIO (Event Double))
timer = Int -> ResourceT m (MomentIO (Event Double))
forall (m :: * -> *).
MonadUnliftIO m =>
Int -> ResourceT m (MomentIO (Event Double))
Timer.every
{-# DEPRECATED timer "Use Engine.ReactiveBanana.Timer.every" #-}

{- | Filter out successive events with the same data.

The output event will be delayed by one step due to 'RBF.reactimate' use.
-}
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

-- | Dump event contents to application debug log.
reactimateDebugShow
  :: (Show a, MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
  => (m () -> IO ()) -- ^ Unlift into application
  -> RB.Event a -- ^ Event to monitor
  -> 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)

-- * "Engine.Worker" interface

-- ** From workers to networks

-- | Convert 'Worker.Var' updates into events.
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

-- ** From networks to workers

-- | Set worker input to event contents.
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)

-- | Set worker input to event contents, if present.
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)

-- | Set worker output to event contents.
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)

-- | Set worker output to event contents, if present.
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)