Course.hs

{-# LANGUAGE RecursiveDo #-}

module Engine.ReactiveBanana.Course
  ( Course(..)

  , setup

  , whenIdle
  , whenActive
  , whenFinished

  , isIdle
  , isActive
  , isFinished
  , when
  , unless
  ) where

import RIO hiding (when, unless)

import Data.Maybe (fromJust)
import Data.These (These(..))
import Reactive.Banana qualified as RB
import Reactive.Banana.Frameworks qualified as RBF

data Course a
  = Idle
  | Active a
  | Finished
  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))
setup triggerE stepE = mdo
  (e, b) <- RB.mapAccum Idle $
    fmap dispatch $
      RB.merge triggerE (whenActive b stepE)

  (activeE, fireActive) <- RBF.newEvent
  RBF.reactimate $ (e RB.@> b) <&> \case
    Active a ->
      fireActive a
    _ ->
      pure ()

  finishedE <- RB.once $
    fmap fromJust $ RB.filterE isJust e
  pure (activeE, finishedE, b)
  where
    dispatch = \case
      This initial -> \case
        Idle ->
          (Nothing, Active initial)
        Active{} ->
          error "trigger not filtered when active"
        Finished ->
          error "trigger not filtered when finished"

      That step -> \case
        Idle ->
          error "tick not filtered when idle"
        Active current ->
          case step current of
            Left done ->
              (Just done, Finished)
            Right next ->
              (Nothing, Active next)
        Finished ->
          error "tick not filtered when finished"

      These{} ->
        error "tick happened on top of trigger"

when :: (Course a -> Bool) -> RB.Behavior (Course a) -> RB.Event e -> RB.Event e
when pred course =
  RB.filterApply (course <&> const . pred)

unless :: (Course a -> Bool) -> RB.Behavior (Course a) -> RB.Event e -> RB.Event e
unless pred course =
  RB.filterApply (course <&> const . not . pred)

whenIdle :: RB.Behavior (Course a) -> RB.Event e -> RB.Event e
whenIdle = when isIdle

whenActive :: RB.Behavior (Course a) -> RB.Event e -> RB.Event e
whenActive = when isActive

whenFinished :: RB.Behavior (Course a) -> RB.Event e -> RB.Event e
whenFinished = when isFinished

isIdle :: Course a -> Bool
isIdle = \case
  Idle -> True
  _    -> False

isActive :: Course a -> Bool
isActive = \case
  Active{} -> True
  _        -> False

isFinished :: Course a -> Bool
isFinished = \case
  Finished -> True
  _        -> False