keid-frp-banana 0.1.0.0 → 0.1.1.0

raw patch · 7 files changed

+245/−98 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• keid-frp-banana.cabal +2/−1
• src/Engine/ReactiveBanana.hs +89/−78
• src/Engine/ReactiveBanana/Course.hs +31/−9
• src/Engine/ReactiveBanana/Stateful.hs +16/−8
• src/Engine/ReactiveBanana/Timer.hs +43/−0
• src/Engine/ReactiveBanana/Window.hs +59/−2

@@ -1,5 +1,10 @@ # Changelog for keid-frp-banana +## 0.1.1.0++- Added more `Engine.Window.*` wrappers to `Engine.ReactiveBanana.Window`.+- Moved `Engine.ReactiveBanana.timer` to `Engine.ReactiveBanana.Timer.every`.+ ## 0.1.0.0  Initial release

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           keid-frp-banana-version:        0.1.0.0+version:        0.1.1.0 synopsis:       Reactive Banana integration for Keid engine. category:       Game Engine author:         IC Rainbow@@ -27,6 +27,7 @@       Engine.ReactiveBanana       Engine.ReactiveBanana.Course       Engine.ReactiveBanana.Stateful+      Engine.ReactiveBanana.Timer       Engine.ReactiveBanana.Window   other-modules:       Paths_keid_frp_banana

@@ -1,20 +1,22 @@ module Engine.ReactiveBanana-  ( eventHandler-  , timer-  , observe--  , allocateActuated+  ( -- * 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--  , reactimateDebugShow--  , debounce   ) where  import RIO@@ -27,6 +29,43 @@ 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 builder = do+  (ah, fire) <- liftIO RBF.newAddHandler++  network <- allocatePaused \unlift -> do+    started <- RBF.fromAddHandler ah+    builder unlift started++  liftIO do+    RBF.actuate network+    fire ()+    pure 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 builder = do+  unlift <- lift askUnliftIO+  fmap snd $+    Resource.allocate+      (RBF.compile $ builder unlift)+      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)@@ -36,33 +75,46 @@   Region.local_ $ action (liftIO . fire)   pure $ RBF.fromAddHandler 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+  => Int -- ^ Timer interval in microseconds   -> ResourceT m (RBF.MomentIO (RB.Event Double))-timer delayMS = do-  (addHandler, fire) <- liftIO RBF.newAddHandler-  ticker <- async do-    begin <- getMonotonicTime-    threadDelay delayMS-    forever do-      before <- getMonotonicTime-      liftIO $ fire before-      after <- getMonotonicTime-      let-        tickNum       = (after - begin) * 1e6 / fromIntegral delayMS :: Double-        intTick       = truncate tickNum :: Integer-        driftTicks    = tickNum - fromInteger intTick :: Double-        driftMS       = driftTicks * fromIntegral delayMS :: Double-        adjustedDelay = max 0 $ delayMS - ceiling driftMS :: Int-      -- when (driftTicks > 0.01) $-      --   -- traceShowM driftTicks-      --   traceShowM (delayMS, (tickNum, intTick, driftTicks), driftMS, adjustedDelay)-      threadDelay adjustedDelay+timer = Timer.every+{-# DEPRECATED timer "Use Engine.ReactiveBanana.Timer.every" #-} -  Region.attachAsync ticker-  pure $ RBF.fromAddHandler addHandler+{- | 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 initial spamUpdates = do+  (e, fire) <- RBF.newEvent+  oldVar <- newIORef initial+  RBF.reactimate $+    spamUpdates <&> \new -> do+      changed <- atomicModifyIORef' oldVar \old ->+        (new, old /= new)+      when changed $+        fire new+  pure 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 unlift =+  RBF.reactimate . fmap (unlift . withFrozenCallStack logDebug . displayShow)++-- * "Engine.Worker" interface++-- ** From workers to networks++-- | Convert 'Worker.Var' updates into events. observe   :: (MonadUnliftIO m)   => Worker.Var a@@ -89,33 +141,9 @@       liftIO $ fire vData       go fire vVersion -allocateActuated-  :: MonadUnliftIO m-  => (UnliftIO m -> RB.Event () -> RBF.MomentIO ())-  -> ResourceT m RBF.EventNetwork-allocateActuated builder = do-  (ah, fire) <- liftIO RBF.newAddHandler--  network <- allocatePaused \unlift -> do-    started <- RBF.fromAddHandler ah-    builder unlift started--  liftIO do-    RBF.actuate network-    fire ()-    pure network--allocatePaused-  :: MonadUnliftIO m-  => (UnliftIO m -> RBF.MomentIO ())-  -> ResourceT m RBF.EventNetwork-allocatePaused builder = do-  unlift <- lift askUnliftIO-  fmap snd $-    Resource.allocate-      (RBF.compile $ builder unlift)-      RBF.pause+-- ** From networks to workers +-- | Set worker input to event contents. pushWorkerInput   :: Worker.HasInput var   => var@@ -123,6 +151,7 @@   -> RBF.MomentIO () pushWorkerInput p = RBF.reactimate . fmap (Worker.pushInput p . const) +-- | Set worker input to event contents, if present. pushWorkerInputJust   :: Worker.HasInput var   => var@@ -130,6 +159,7 @@   -> RBF.MomentIO () pushWorkerInputJust p = RBF.reactimate . fmap (traverse_ $ Worker.pushInput p . const) +-- | Set worker output to event contents. pushWorkerOutput   :: Worker.HasOutput var   => var@@ -137,29 +167,10 @@   -> RBF.MomentIO () pushWorkerOutput p = RBF.reactimate . fmap (Worker.pushOutput p . const) +-- | Set worker output to event contents, if present. pushWorkerOutputJust   :: Worker.HasOutput var   => var   -> RB.Event (Maybe (Worker.GetOutput var))   -> RBF.MomentIO () pushWorkerOutputJust p = RBF.reactimate . fmap (traverse_ $ Worker.pushOutput p . const)--reactimateDebugShow-  :: (Show a, MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)-  => (m () -> IO ())-  -> RB.Event a-  -> RBF.MomentIO ()-reactimateDebugShow unlift =-  RBF.reactimate . fmap (unlift . withFrozenCallStack logDebug . displayShow)--debounce :: Eq a => a -> RB.Event a -> RBF.MomentIO (RB.Event a)-debounce initial spamUpdates = do-  (e, fire) <- RBF.newEvent-  oldVar <- newIORef initial-  RBF.reactimate $-    spamUpdates <&> \new -> do-      changed <- atomicModifyIORef' oldVar \old ->-        (new, old /= new)-      when changed $-        fire new-  pure e

@@ -1,19 +1,41 @@ {-# LANGUAGE RecursiveDo #-} +{- | A process that is triggered, stepped for a while, then finished.++Useful to drive animations and filter other events and behaviors.++@+-- Set up a 1 second countdown+(startingE, startedE, starting) <-+  Course.setup (startE $> 1.0) $+    tickE $> \old ->+      if old > dt then+        Right (old - dt)+      else+        Left ()++-- Prevent click events after starting the countdown+let clicks = fmap (Course.whenIdle starting) allClicks+@+-}+ module Engine.ReactiveBanana.Course   ( Course(..)-   , setup +    -- * General state-aware event filters+  , when+  , unless++    -- * Course state event filters   , whenIdle   , whenActive   , whenFinished +    -- * Course state predicates   , isIdle   , isActive   , isFinished-  , when-  , unless   ) where  import RIO hiding (when, unless)@@ -24,15 +46,15 @@ import Reactive.Banana.Frameworks qualified as RBF  data Course a-  = Idle-  | Active a-  | Finished+  = Idle -- ^ Waiting for a trigger event+  | Active a -- ^ Processing step events+  | Finished -- ^ A final event has fired   deriving (Eq, Ord, Show, Functor)  setup-  :: RB.Event a-  -> RB.Event (a -> Either final a)-  -> RBF.MomentIO (RB.Event a, RB.Event final, RB.Behavior (Course a))+  :: RB.Event a -- ^ Trigger event+  -> RB.Event (a -> Either final a) -- ^ Step event+  -> RBF.MomentIO (RB.Event a, RB.Event final, RB.Behavior (Course a)) -- ^ (active event, finished event, current state) setup triggerE stepE = mdo   (e, b) <- RB.mapAccum Idle $     fmap dispatch $

@@ -1,5 +1,10 @@ {-# LANGUAGE RecursiveDo #-} +{- | "Crank the world"-style stateful process.++An input event comes in, an update step runs and an output event is fired.+-}+ module Engine.ReactiveBanana.Stateful   ( setup   , runWorldWith@@ -7,27 +12,30 @@   ) where  import Prelude+ import Control.Monad.ST (ST) import Reactive.Banana qualified as RB  setup   :: RB.MonadMoment m-  => m acc-  -> (a -> acc -> (x, acc))-  -> RB.Event a-  -> m (RB.Event x, RB.Behavior acc)+  => m acc -- ^ An action to produce the initial stat+  -> (a -> acc -> (x, acc)) -- ^ Step function+  -> RB.Event a -- ^ Step  event+  -> m (RB.Event x, RB.Behavior acc) -- ^ A post-step event and a current state snapshot setup initialWorld action triggerE = mdo   initial <- initialWorld   RB.mapAccum initial $     fmap action triggerE +-- | A helper to connect a world snapshot with its dynamic representation under an existential @s@. type family Thaw world s  runWorldWith-  :: (world -> ST s (Thaw world s))-  -> (Thaw world s -> ST s world)-  -> world-  -> (Thaw world s -> ST s update)+  :: forall world update s+  .  (world -> ST s (Thaw world s)) -- ^ Thaw the world into 'STRef's+  -> (Thaw world s -> ST s world) -- ^ Read the world STRefs and freeze+  -> world -- ^ Previous world snapshot+  -> (Thaw world s -> ST s update) -- ^ Update procedure yielding a result and a new world snapshot   -> ST s (update, world) runWorldWith t f old action = do   st <- t old

@@ -0,0 +1,43 @@+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 delayMS = do+  (addHandler, fire) <- liftIO RBF.newAddHandler+  ticker <- async do+    begin <- getMonotonicTime+    threadDelay delayMS+    forever do+      before <- getMonotonicTime+      liftIO $ fire before+      after <- getMonotonicTime+      let+        tickNum       = (after - begin) * 1e6 / fromIntegral delayMS :: Double+        intTick       = truncate tickNum :: Integer+        driftTicks    = tickNum - fromInteger intTick :: Double+        driftMS       = driftTicks * fromIntegral delayMS :: Double+        adjustedDelay = max 0 $ delayMS - ceiling driftMS :: Int+      -- when (driftTicks > 0.01) $+      --   -- traceShowM driftTicks+      --   traceShowM (delayMS, (tickNum, intTick, driftTicks), driftMS, adjustedDelay)+      threadDelay adjustedDelay++  Region.attachAsync ticker+  pure $ RBF.fromAddHandler addHandler

@@ -2,10 +2,16 @@  import RIO +import Control.Monad.Trans.Resource (ResourceT)+import Engine.ReactiveBanana (eventHandler) import Engine.Types (StageRIO) import Engine.Types qualified as Engine import Engine.UI.Layout qualified as Layout+import Engine.Window.CursorPos qualified as CursorPos+import Engine.Window.Drop qualified as Drop+import Engine.Window.Key qualified as Key import Engine.Window.MouseButton qualified as MouseButton+import Engine.Window.Scroll qualified as Scroll import Engine.Worker qualified as Worker import Geomancy (Vec2, vec2, (^/)) import GHC.Float (double2Float)@@ -14,6 +20,57 @@ import Reactive.Banana.Frameworks qualified as RBF import Vulkan.Core10 qualified as Vk +-- * Wrapped Engine.Window.* callbacks++-- | Set up a window callback to fire window "CursorPos"  events.+allocateCursorPos :: ResourceT (StageRIO st) (RBF.MomentIO (RB.Event (Double, Double)))+allocateCursorPos = eventHandler $ CursorPos.callback . curry++-- | Set up a window callback to fire window "Drop"  events.+allocateDrop :: ResourceT (StageRIO st) (RBF.MomentIO (RB.Event [FilePath]))+allocateDrop = eventHandler Drop.callback++{- | Set up a window callback to fire window "MouseButton"  events.++To prevent clicks when hovering over some ImGui window wrap in a `RB.whenE` filter:++@+imguiCaptureMouse <- RBF.fromPoll ImGui.wantCaptureMouse+mouseButtonE <- fmap (RB.whenE $ fmap not imguiCaptureMouse) fromMouseButton+@+-}+allocateMouseButton+  :: ResourceT+      (StageRIO st)+      ( RBF.MomentIO+          ( RB.Event+            ( MouseButton.ModifierKeys+            , MouseButton.MouseButtonState+            , MouseButton.MouseButton+            )+          )+        )+allocateMouseButton = eventHandler MouseButton.callback++-- | Set up a window callback to fire window "Scroll"  events.+allocateScroll :: ResourceT (StageRIO st) (RBF.MomentIO (RB.Event (Double, Double)))+allocateScroll = eventHandler $ Scroll.callback . curry++{- | Set up a window callback to fire window "Key"  events.++To prevent clicks when ImGui is busy with text input wrap in a `RB.whenE` filter:++@+imguiCaptureKeyboard <- RBF.fromPoll ImGui.wantCaptureKeyboard+keyE <- fmap (RB.whenE $ fmap not imguiCaptureKeyboard) fromKey+@+-}+allocateKey :: ResourceT (StageRIO st) (RBF.MomentIO (RB.Event (Int, (MouseButton.ModifierKeys, Key.KeyState, Key.Key))))+allocateKey = eventHandler $ Key.callback . curry++-- * 'Engine.UI.Layout' helpers++-- | Screen-sized layout base. setupScreenBox   :: (forall a. StageRIO env a -> RBF.MomentIO a)   -> RBF.MomentIO (RB.Behavior Layout.Box)@@ -38,6 +95,7 @@    pure screenBox +-- | Project window cursor position to layout. setupCursorPos   :: RB.MonadMoment m   => m (RB.Event (Double, Double))@@ -57,14 +115,13 @@       vec2 (double2Float cx) (double2Float cy) -       boxSize ^/ 2 +-- | Set up a per-button collection of fused (position, modifier) click ("button pressed") events. setupMouseClicks   :: RBF.MomentIO (RB.Event (MouseButton.ModifierKeys, MouseButton.MouseButtonState, MouseButton.MouseButton))   -> RB.Behavior cursor   -> RBF.MomentIO (MouseButton.Collection (RB.Event (MouseButton.ModifierKeys, cursor))) setupMouseClicks fromMouseButton cursorPos = do-  -- imguiCaptureMouse <- RBF.fromPoll ImGui.wantCaptureMouse -  -- mouseButtonE <- RB.whenE (fmap not imguiCaptureMouse) <$> fromMouseButton   mouseButtonE <- fromMouseButton    -- XXX: Set up cursor event fusion, driven by mouseButtonE