Widget.hs

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
    }