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
  { forall e b. Widget e b -> MomentIO (Event e, Behavior b)
plug :: RBF.MomentIO (RB.Event e, RB.Behavior b)
  , forall e b. Widget e b -> IO ()
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
  Widget () b
a <> :: Widget () b -> Widget () b -> Widget () b
<> Widget () b
b = (b -> b -> b) -> Widget () b -> Widget () b -> Widget () b
forall lb rb b le re.
(lb -> rb -> b) -> Widget le lb -> Widget re rb -> Widget () b
clumpWithB b -> b -> b
forall a. Semigroup a => a -> a -> a
(<>) Widget () b
a Widget () b
b

instance Semigroup b => Semigroup (Widget Void b) where
  Widget Void b
a <> :: Widget Void b -> Widget Void b -> Widget Void b
<> Widget Void b
b = (Void -> Void)
-> (Void -> Void)
-> (Void -> Void -> Void)
-> (b -> b -> b)
-> Widget Void b
-> Widget Void b
-> Widget Void b
forall ae ce be ab bb cb.
(ae -> ce)
-> (be -> ce)
-> (ae -> be -> ce)
-> (ab -> bb -> cb)
-> Widget ae ab
-> Widget be bb
-> Widget ce cb
clumpWith Void -> Void
forall a. Void -> a
absurd Void -> Void
forall a. Void -> a
absurd Void -> Void -> Void
forall a. Void -> a
absurd b -> b -> b
forall a. Semigroup a => a -> a -> a
(<>) Widget Void b
a Widget Void b
b

-- | Widget is covariant functor over its "output" behavior.
instance Functor (Widget e) where
  fmap :: forall a b. (a -> b) -> Widget e a -> Widget e b
fmap a -> b
f Widget e a
w = Widget
    { $sel:plug:Widget :: MomentIO (Event e, Behavior b)
plug = do
        (Event e
e, Behavior a
b) <- Widget e a
w.plug
        (Event e, Behavior b) -> MomentIO (Event e, Behavior b)
forall a. a -> MomentIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Event e
e, (a -> b) -> Behavior a -> Behavior b
forall a b. (a -> b) -> Behavior a -> Behavior b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Behavior a
b)
    , $sel:draw:Widget :: IO ()
draw = Widget e a
w.draw
    }

-- | Widget is covariant functor over its "output" events and behavior.
instance Bifunctor Widget where
  bimap :: forall a b c d. (a -> b) -> (c -> d) -> Widget a c -> Widget b d
bimap a -> b
f c -> d
g Widget a c
w = Widget
    { $sel:plug:Widget :: MomentIO (Event b, Behavior d)
plug = do
        (Event a
e, Behavior c
b) <- Widget a c
w.plug
        (Event b, Behavior d) -> MomentIO (Event b, Behavior d)
forall a. a -> MomentIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> b) -> Event a -> Event b
forall a b. (a -> b) -> Event a -> Event b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Event a
e, (c -> d) -> Behavior c -> Behavior d
forall a b. (a -> b) -> Behavior a -> Behavior b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g Behavior c
b)
    , $sel:draw:Widget :: IO ()
draw =
        Widget a c
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 :: forall e i b c.
(Event e -> Event i)
-> (Behavior b -> Behavior c)
-> (IO () -> IO ())
-> Widget e b
-> Widget i c
wrap Event e -> Event i
f Behavior b -> Behavior c
g IO () -> IO ()
c Widget e b
w = Widget
  { $sel:plug:Widget :: MomentIO (Event i, Behavior c)
plug = do
      (Event e
e, Behavior b
b) <- Widget e b
w.plug
      (Event i, Behavior c) -> MomentIO (Event i, Behavior c)
forall a. a -> MomentIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Event e -> Event i
f Event e
e, Behavior b -> Behavior c
g Behavior b
b)
  , $sel:draw:Widget :: IO ()
draw =
      IO () -> IO ()
c Widget e b
w.draw
  }

-- | A widget without events of its own, sampling external behavior.
drawB
  :: RB.Behavior b
  -> IO ()
  -> Widget Void b
drawB :: forall b. Behavior b -> IO () -> Widget Void b
drawB Behavior b
b IO ()
d = Widget
  { $sel:plug:Widget :: MomentIO (Event Void, Behavior b)
plug = (Event Void, Behavior b) -> MomentIO (Event Void, Behavior b)
forall a. a -> MomentIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Event Void
forall a. Event a
RB.never, Behavior b
b)
  , $sel:draw:Widget :: IO ()
draw = IO ()
d
  }

draw_ :: IO () -> Widget Void ()
draw_ :: IO () -> Widget Void ()
draw_ = Behavior () -> IO () -> Widget Void ()
forall b. Behavior b -> IO () -> Widget Void b
drawB Behavior ()
forall a. Monoid a => a
mempty

collectB
  :: Traversable t
  => t (RBF.MomentIO (Widget e b))
  -> RBF.MomentIO (Widget () (t b))
collectB :: forall (t :: * -> *) e b.
Traversable t =>
t (MomentIO (Widget e b)) -> MomentIO (Widget () (t b))
collectB t (MomentIO (Widget e b))
ws = do
  t (Widget e b)
widgets <- t (MomentIO (Widget e b)) -> MomentIO (t (Widget e b))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a)
sequenceA t (MomentIO (Widget e b))
ws
  pure Widget
    { $sel:plug:Widget :: MomentIO (Event (), Behavior (t b))
plug = do
        t (Event e, Behavior b)
plugs <- (Widget e b -> MomentIO (Event e, Behavior b))
-> t (Widget e b) -> MomentIO (t (Event e, Behavior b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b)
traverse (.plug) t (Widget e b)
widgets
        Event ()
event <- Event () -> MomentIO (Event ())
forall a. Event a -> MomentIO (Event a)
delay (Event () -> MomentIO (Event ()))
-> Event () -> MomentIO (Event ())
forall a b. (a -> b) -> a -> b
$ ((Event e, Behavior b) -> Event () -> Event ())
-> Event () -> t (Event e, Behavior b) -> Event ()
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Event e -> Event () -> Event ()
forall a b. Event a -> Event b -> Event ()
($>>) (Event e -> Event () -> Event ())
-> ((Event e, Behavior b) -> Event e)
-> (Event e, Behavior b)
-> Event ()
-> Event ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event e, Behavior b) -> Event e
forall a b. (a, b) -> a
fst) Event ()
forall a. Event a
RB.never t (Event e, Behavior b)
plugs
        pure
          ( Event ()
event
          , ((Event e, Behavior b) -> Behavior b)
-> t (Event e, Behavior b) -> Behavior (t b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b)
traverse (Event e, Behavior b) -> Behavior b
forall a b. (a, b) -> b
snd t (Event e, Behavior b)
plugs
          )
    , $sel:draw:Widget :: IO ()
draw =
        (Widget e b -> IO ()) -> t (Widget e b) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (.draw) t (Widget e b)
widgets
    }

clumpWithB
  :: (lb -> rb -> b)
  -> Widget le lb
  -> Widget re rb
  -> Widget () b
clumpWithB :: forall lb rb b le re.
(lb -> rb -> b) -> Widget le lb -> Widget re rb -> Widget () b
clumpWithB =
  (le -> ())
-> (re -> ())
-> (le -> re -> ())
-> (lb -> rb -> b)
-> Widget le lb
-> Widget re rb
-> Widget () b
forall ae ce be ab bb cb.
(ae -> ce)
-> (be -> ce)
-> (ae -> be -> ce)
-> (ab -> bb -> cb)
-> Widget ae ab
-> Widget be bb
-> Widget ce cb
clumpWith (() -> le -> ()
forall a b. a -> b -> a
const ()) (() -> re -> ()
forall a b. a -> b -> a
const ()) (\le
_ re
_ -> ())

clumpWith
  :: (ae -> ce)
  -> (be -> ce)
  -> (ae -> be -> ce)
  -> (ab -> bb -> cb)
  -> Widget ae ab
  -> Widget be bb
  -> Widget ce cb
clumpWith :: forall ae ce be ab bb cb.
(ae -> ce)
-> (be -> ce)
-> (ae -> be -> ce)
-> (ab -> bb -> cb)
-> Widget ae ab
-> Widget be bb
-> Widget ce cb
clumpWith ae -> ce
me1 be -> ce
me2 ae -> be -> ce
me12 ab -> bb -> cb
mb Widget ae ab
a Widget be bb
b = Widget
  { $sel:plug:Widget :: MomentIO (Event ce, Behavior cb)
plug = do
      (Event ae
ae, Behavior ab
ab) <- Widget ae ab
a.plug
      (Event be
be, Behavior bb
bb) <- Widget be bb
b.plug
      (Event ce, Behavior cb) -> MomentIO (Event ce, Behavior cb)
forall a. a -> MomentIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( (ae -> ce)
-> (be -> ce)
-> (ae -> be -> ce)
-> Event ae
-> Event be
-> Event ce
forall a c b.
(a -> c)
-> (b -> c) -> (a -> b -> c) -> Event a -> Event b -> Event c
RB.mergeWith ae -> ce
me1 be -> ce
me2 ae -> be -> ce
me12 Event ae
ae Event be
be
        , (ab -> bb -> cb) -> Behavior ab -> Behavior bb -> Behavior cb
forall a b c.
(a -> b -> c) -> Behavior a -> Behavior b -> Behavior c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ab -> bb -> cb
mb Behavior ab
ab Behavior bb
bb
        )
  , $sel:draw:Widget :: IO ()
draw =
      Widget ae ab
a.draw IO () -> IO () -> IO ()
forall a. Semigroup a => a -> a -> a
<> Widget be bb
b.draw
  }

attachLeft
  :: Widget ae ab
  -> Widget be bb
  -> Widget ae ab
attachLeft :: forall ae ab be bb. Widget ae ab -> Widget be bb -> Widget ae ab
attachLeft Widget ae ab
l Widget be bb
r =
  (Event (These ae be) -> Event ae)
-> (Behavior (ab, bb) -> Behavior ab)
-> (IO () -> IO ())
-> Widget (These ae be) (ab, bb)
-> Widget ae ab
forall e i b c.
(Event e -> Event i)
-> (Behavior b -> Behavior c)
-> (IO () -> IO ())
-> Widget e b
-> Widget i c
wrap Event (These ae be) -> Event ae
forall a b. Event (These a b) -> Event a
filterHere (((ab, bb) -> ab) -> Behavior (ab, bb) -> Behavior ab
forall a b. (a -> b) -> Behavior a -> Behavior b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ab, bb) -> ab
forall a b. (a, b) -> a
fst) IO () -> IO ()
forall a. a -> a
id (Widget (These ae be) (ab, bb) -> Widget ae ab)
-> Widget (These ae be) (ab, bb) -> Widget ae ab
forall a b. (a -> b) -> a -> b
$
    Widget ae ab -> Widget be bb -> Widget (These ae be) (ab, bb)
forall ae ab b bb.
Widget ae ab -> Widget b bb -> Widget (These ae b) (ab, bb)
clump Widget ae ab
l Widget be bb
r

attachRight
  :: Widget ae ab
  -> Widget be bb
  -> Widget be bb
attachRight :: forall ae ab be bb. Widget ae ab -> Widget be bb -> Widget be bb
attachRight Widget ae ab
l Widget be bb
r =
  (Event (These ae be) -> Event be)
-> (Behavior (ab, bb) -> Behavior bb)
-> (IO () -> IO ())
-> Widget (These ae be) (ab, bb)
-> Widget be bb
forall e i b c.
(Event e -> Event i)
-> (Behavior b -> Behavior c)
-> (IO () -> IO ())
-> Widget e b
-> Widget i c
wrap Event (These ae be) -> Event be
forall a b. Event (These a b) -> Event b
filterThere (((ab, bb) -> bb) -> Behavior (ab, bb) -> Behavior bb
forall a b. (a -> b) -> Behavior a -> Behavior b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ab, bb) -> bb
forall a b. (a, b) -> b
snd) IO () -> IO ()
forall a. a -> a
id (Widget (These ae be) (ab, bb) -> Widget be bb)
-> Widget (These ae be) (ab, bb) -> Widget be bb
forall a b. (a -> b) -> a -> b
$
    Widget ae ab -> Widget be bb -> Widget (These ae be) (ab, bb)
forall ae ab b bb.
Widget ae ab -> Widget b bb -> Widget (These ae b) (ab, bb)
clump Widget ae ab
l Widget be bb
r

clump
  :: Widget ae ab
  -> Widget b bb
  -> Widget (These ae b) (ab, bb)
clump :: forall ae ab b bb.
Widget ae ab -> Widget b bb -> Widget (These ae b) (ab, bb)
clump = (ab -> bb -> (ab, bb))
-> Widget ae ab -> Widget b bb -> Widget (These ae b) (ab, bb)
forall ab bb b ae be.
(ab -> bb -> b)
-> Widget ae ab -> Widget be bb -> Widget (These ae be) b
clumpB (,)

clumpB
  :: (ab -> bb -> b)
  -> Widget ae ab
  -> Widget be bb
  -> Widget (These ae be) b
clumpB :: forall ab bb b ae be.
(ab -> bb -> b)
-> Widget ae ab -> Widget be bb -> Widget (These ae be) b
clumpB = (ae -> These ae be)
-> (be -> These ae be)
-> (ae -> be -> These ae be)
-> (ab -> bb -> b)
-> Widget ae ab
-> Widget be bb
-> Widget (These ae be) b
forall ae ce be ab bb cb.
(ae -> ce)
-> (be -> ce)
-> (ae -> be -> ce)
-> (ab -> bb -> cb)
-> Widget ae ab
-> Widget be bb
-> Widget ce cb
clumpWith ae -> These ae be
forall a b. a -> These a b
This be -> These ae be
forall a b. b -> These a b
That ae -> be -> These ae be
forall a b. a -> b -> These a b
These

filterHere :: RB.Event (These a b) -> RB.Event a
filterHere :: forall a b. Event (These a b) -> Event a
filterHere = Event (Maybe a) -> Event a
forall a. Event (Maybe a) -> Event a
RB.filterJust (Event (Maybe a) -> Event a)
-> (Event (These a b) -> Event (Maybe a))
-> Event (These a b)
-> Event a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (These a b -> Maybe a) -> Event (These a b) -> Event (Maybe a)
forall a b. (a -> b) -> Event a -> Event b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap These a b -> Maybe a
forall a b. These a b -> Maybe a
justHere

filterThere :: RB.Event (These a b) -> RB.Event b
filterThere :: forall a b. Event (These a b) -> Event b
filterThere = Event (Maybe b) -> Event b
forall a. Event (Maybe a) -> Event a
RB.filterJust (Event (Maybe b) -> Event b)
-> (Event (These a b) -> Event (Maybe b))
-> Event (These a b)
-> Event b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (These a b -> Maybe b) -> Event (These a b) -> Event (Maybe b)
forall a b. (a -> b) -> Event a -> Event b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap These a b -> Maybe b
forall a b. These a b -> Maybe b
justThere

-- * Running

data Instance e b = Instance
  { forall e b. Instance e b -> Event e
event :: RB.Event e
  , forall e b. Instance e b -> Behavior b
current :: RB.Behavior b
  , forall e b. Instance e b -> IO ()
draw :: IO ()
  }
  deriving ((forall a b. (a -> b) -> Instance e a -> Instance e b)
-> (forall a b. a -> Instance e b -> Instance e a)
-> Functor (Instance e)
forall a b. a -> Instance e b -> Instance e a
forall a b. (a -> b) -> Instance e a -> Instance e b
forall e a b. a -> Instance e b -> Instance e a
forall e a b. (a -> b) -> Instance e a -> Instance e b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall e a b. (a -> b) -> Instance e a -> Instance e b
fmap :: forall a b. (a -> b) -> Instance e a -> Instance e b
$c<$ :: forall e a b. a -> Instance e b -> Instance e a
<$ :: forall a b. a -> Instance e b -> Instance e a
Functor)

install :: RBF.MomentIO (Widget e b) -> RBF.MomentIO (Instance e b)
install :: forall e b. MomentIO (Widget e b) -> MomentIO (Instance e b)
install MomentIO (Widget e b)
action = do
  Widget e b
widget <- MomentIO (Widget e b)
action
  (Event e
e, Behavior b
b) <- Widget e b
widget.plug
  Instance e b -> MomentIO (Instance e b)
forall a. a -> MomentIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Instance
    { $sel:event:Instance :: Event e
event = Event e
e
    , $sel:current:Instance :: Behavior b
current = Behavior b
b
    , $sel:draw:Instance :: IO ()
draw = Widget e b
widget.draw
    }