module Engine.ReactiveBanana
(
allocateActuated
, allocatePaused
, eventHandler
, debounce
, reactimateDebugShow
, timer
, observe
, 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
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
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 -> ResourceT m (MomentIO (Event Double))
forall (m :: * -> *).
MonadUnliftIO m =>
Int -> ResourceT m (MomentIO (Event Double))
Timer.every
{-# DEPRECATED timer "Use Engine.ReactiveBanana.Timer.every" #-}
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
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)
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)
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
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)