keid-frp-banana 0.1.2.0 → 0.1.2.1

raw patch · 4 files changed

+268/−3 lines, 4 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• keid-frp-banana.cabal +5/−3
• src/Engine/ReactiveBanana/Utils.hs +63/−0
• src/Engine/ReactiveBanana/Widget.hs +196/−0

@@ -1,5 +1,9 @@ # Changelog for keid-frp-banana +## 0.1.2.1++- Added `Engine.ReactiveBanana.Widget` for composable and reusable wrappers for e.g. UI.+ ## 0.1.2.0  - Switched to `geomancy-layout`.

@@ -1,16 +1,16 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2.+-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack  name:           keid-frp-banana-version:        0.1.2.0+version:        0.1.2.1 synopsis:       Reactive Banana integration for Keid engine. category:       Game Engine author:         IC Rainbow maintainer:     keid@aenor.ru-copyright:      2023 IC Rainbow+copyright:      2024 IC Rainbow license:        BSD3 license-file:   LICENSE build-type:     Simple@@ -28,6 +28,8 @@       Engine.ReactiveBanana.Course       Engine.ReactiveBanana.Stateful       Engine.ReactiveBanana.Timer+      Engine.ReactiveBanana.Utils+      Engine.ReactiveBanana.Widget       Engine.ReactiveBanana.Window   other-modules:       Paths_keid_frp_banana

@@ -0,0 +1,63 @@+module Engine.ReactiveBanana.Utils where++import RIO++import Reactive.Banana qualified as RB+import Reactive.Banana.Frameworks qualified as RBF++{-# INLINE (<@@>) #-}+(<@@>) :: RB.Event a -> RB.Behavior (a -> b) -> RB.Event b+(<@@>) = flip (RB.<@>)++{-# INLINE ($>>) #-}+($>>) :: {- forall {a} {b} .  -}RB.Event a -> RB.Event b -> RB.Event ()+a $>> b =+  RB.mergeWith+    (const ())+    (const ())+    (\_ _ -> ())+    a+    b++delay :: RB.Event a -> RBF.MomentIO (RB.Event a)+delay e = do+  (delayed, fire) <- RBF.newEvent+  RBF.reactimate $ fmap fire e+  pure delayed++delayOnce :: RB.Event a -> RBF.MomentIO (RB.Event a)+delayOnce e = delay e >>= RB.once++lockstep :: a -> RB.Event a -> RBF.MomentIO (RB.Event a, RB.Behavior a)+lockstep initial e = do+  b <- RB.stepper initial e+  e' <- delay e+  pure (e', b)++accumE_ :: RB.MonadMoment m => [RB.Event a] -> m (RB.Event a)+accumE_ = RB.accumE undefined . unionsConst++unionsConst :: [RB.Event a] -> RB.Event (a -> a)+unionsConst = RB.unions . map (fmap const)++-- | Only pass events when their value changes.+--+-- The event is delayed for behavior value to match current value.+filterChange+  :: Eq a+  => a+  -> RB.Event a+  -> RBF.MomentIO (RB.Event (a, a), RB.Behavior a)+filterChange initial e = do+  b <- RB.stepper initial e+  let+    changeE = RB.filterJust $+      e <@@> do+        old <- b+        pure \new ->+          if old == new then+            Nothing+          else+            Just (old, new)+  syncE <- delay changeE+  pure (syncE, b)

@@ -0,0 +1,196 @@+module Engine.ReactiveBanana.Widget+  ( Widget(..)+  , Widget'+  , wrap++  , Instance(..)+  , install++    -- * Combinators+  , drawB+  , draw_++  , collectB++  , clumpWithB+  , clumpWith+    -- ** These+  , clump+  , clumpB+  , attachLeft+  , attachRight+  ) where++import RIO++import Data.These (These(..))+import Data.These.Combinators (justHere, justThere)+import Reactive.Banana qualified as RB+import Reactive.Banana.Frameworks qualified as RBF+import Engine.ReactiveBanana.Utils (delay, ($>>))++-- * Construction++-- | A composable pair of actions for planning and running stages.+data Widget e b = Widget+  { plug :: RBF.MomentIO (RB.Event e, RB.Behavior b)+  , draw :: IO ()+  }++-- | A "Widget" that doesn't transform the event it produces.+type Widget' a = Widget a a++instance Semigroup b => Semigroup (Widget () b) where+  a <> b = clumpWithB (<>) a b++instance Semigroup b => Semigroup (Widget Void b) where+  a <> b = clumpWith absurd absurd absurd (<>) a b++-- | Widget is covariant functor over its "output" behavior.+instance Functor (Widget e) where+  fmap f w = Widget+    { plug = do+        (e, b) <- w.plug+        pure (e, fmap f b)+    , draw = w.draw+    }++-- | Widget is covariant functor over its "output" events and behavior.+instance Bifunctor Widget where+  bimap f g w = Widget+    { plug = do+        (e, b) <- w.plug+        pure (fmap f e, fmap g b)+    , draw =+        w.draw+    }++-- | Like 'bimap', but wraps draw function too.+--+-- Parent @draw@ can be called at wrapper discretion.+wrap+  :: (RB.Event e -> RB.Event i)+  -> (RB.Behavior b -> RB.Behavior c)+  -> (IO () -> IO ())+  -> Widget e b+  -> Widget i c+wrap f g c w = Widget+  { plug = do+      (e, b) <- w.plug+      pure (f e, g b)+  , draw =+      c w.draw+  }++-- | A widget without events of its own, sampling external behavior.+drawB+  :: RB.Behavior b+  -> IO ()+  -> Widget Void b+drawB b d = Widget+  { plug = pure (RB.never, b)+  , draw = d+  }++draw_ :: IO () -> Widget Void ()+draw_ = drawB mempty++collectB+  :: Traversable t+  => t (RBF.MomentIO (Widget e b))+  -> RBF.MomentIO (Widget () (t b))+collectB ws = do+  widgets <- sequenceA ws+  pure Widget+    { plug = do+        plugs <- traverse (.plug) widgets+        event <- delay $ foldr (($>>) . fst) RB.never plugs+        pure+          ( event+          , traverse snd plugs+          )+    , draw =+        traverse_ (.draw) widgets+    }++clumpWithB+  :: (lb -> rb -> b)+  -> Widget le lb+  -> Widget re rb+  -> Widget () b+clumpWithB =+  clumpWith (const ()) (const ()) (\_ _ -> ())++clumpWith+  :: (ae -> ce)+  -> (be -> ce)+  -> (ae -> be -> ce)+  -> (ab -> bb -> cb)+  -> Widget ae ab+  -> Widget be bb+  -> Widget ce cb+clumpWith me1 me2 me12 mb a b = Widget+  { plug = do+      (ae, ab) <- a.plug+      (be, bb) <- b.plug+      pure+        ( RB.mergeWith me1 me2 me12 ae be+        , liftA2 mb ab bb+        )+  , draw =+      a.draw <> b.draw+  }++attachLeft+  :: Widget ae ab+  -> Widget be bb+  -> Widget ae ab+attachLeft l r =+  wrap filterHere (fmap fst) id $+    clump l r++attachRight+  :: Widget ae ab+  -> Widget be bb+  -> Widget be bb+attachRight l r =+  wrap filterThere (fmap snd) id $+    clump l r++clump+  :: Widget ae ab+  -> Widget b bb+  -> Widget (These ae b) (ab, bb)+clump = clumpB (,)++clumpB+  :: (ab -> bb -> b)+  -> Widget ae ab+  -> Widget be bb+  -> Widget (These ae be) b+clumpB = clumpWith This That These++filterHere :: RB.Event (These a b) -> RB.Event a+filterHere = RB.filterJust . fmap justHere++filterThere :: RB.Event (These a b) -> RB.Event b+filterThere = RB.filterJust . fmap justThere++-- * Running++data Instance e b = Instance+  { event :: RB.Event e+  , current :: RB.Behavior b+  , draw :: IO ()+  }+  deriving (Functor)++install :: RBF.MomentIO (Widget e b) -> RBF.MomentIO (Instance e b)+install action = do+  widget <- action+  (e, b) <- widget.plug+  pure Instance+    { event = e+    , current = b+    , draw = widget.draw+    }