Course.hs

{-# 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
  ) 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 -- ^ 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 -- ^ 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 $
      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