{-# 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 (Course a -> Course a -> Bool
(Course a -> Course a -> Bool)
-> (Course a -> Course a -> Bool) -> Eq (Course a)
forall a. Eq a => Course a -> Course a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Course a -> Course a -> Bool
$c/= :: forall a. Eq a => Course a -> Course a -> Bool
== :: Course a -> Course a -> Bool
$c== :: forall a. Eq a => Course a -> Course a -> Bool
Eq, Eq (Course a)
Eq (Course a)
-> (Course a -> Course a -> Ordering)
-> (Course a -> Course a -> Bool)
-> (Course a -> Course a -> Bool)
-> (Course a -> Course a -> Bool)
-> (Course a -> Course a -> Bool)
-> (Course a -> Course a -> Course a)
-> (Course a -> Course a -> Course a)
-> Ord (Course a)
Course a -> Course a -> Bool
Course a -> Course a -> Ordering
Course a -> Course a -> Course a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Course a)
forall a. Ord a => Course a -> Course a -> Bool
forall a. Ord a => Course a -> Course a -> Ordering
forall a. Ord a => Course a -> Course a -> Course a
min :: Course a -> Course a -> Course a
$cmin :: forall a. Ord a => Course a -> Course a -> Course a
max :: Course a -> Course a -> Course a
$cmax :: forall a. Ord a => Course a -> Course a -> Course a
>= :: Course a -> Course a -> Bool
$c>= :: forall a. Ord a => Course a -> Course a -> Bool
> :: Course a -> Course a -> Bool
$c> :: forall a. Ord a => Course a -> Course a -> Bool
<= :: Course a -> Course a -> Bool
$c<= :: forall a. Ord a => Course a -> Course a -> Bool
< :: Course a -> Course a -> Bool
$c< :: forall a. Ord a => Course a -> Course a -> Bool
compare :: Course a -> Course a -> Ordering
$ccompare :: forall a. Ord a => Course a -> Course a -> Ordering
Ord, Int -> Course a -> ShowS
[Course a] -> ShowS
Course a -> String
(Int -> Course a -> ShowS)
-> (Course a -> String) -> ([Course a] -> ShowS) -> Show (Course a)
forall a. Show a => Int -> Course a -> ShowS
forall a. Show a => [Course a] -> ShowS
forall a. Show a => Course a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Course a] -> ShowS
$cshowList :: forall a. Show a => [Course a] -> ShowS
show :: Course a -> String
$cshow :: forall a. Show a => Course a -> String
showsPrec :: Int -> Course a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Course a -> ShowS
Show, (forall a b. (a -> b) -> Course a -> Course b)
-> (forall a b. a -> Course b -> Course a) -> Functor Course
forall a b. a -> Course b -> Course a
forall a b. (a -> b) -> Course a -> Course b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Course b -> Course a
$c<$ :: forall a b. a -> Course b -> Course a
fmap :: forall a b. (a -> b) -> Course a -> Course b
$cfmap :: forall a b. (a -> b) -> Course a -> Course b
Functor)

setup
  :: RB.Event a
  -> RB.Event (a -> Either final a)
  -> RBF.MomentIO (RB.Event a, RB.Event final, RB.Behavior (Course a))
setup :: forall a final.
Event a
-> Event (a -> Either final a)
-> MomentIO (Event a, Event final, Behavior (Course a))
setup Event a
triggerE Event (a -> Either final a)
stepE = mdo
  (Event (Maybe final)
e, Behavior (Course a)
b) <- Course a
-> Event (Course a -> (Maybe final, Course a))
-> MomentIO (Event (Maybe final), Behavior (Course a))
forall (m :: * -> *) acc x.
MonadMoment m =>
acc -> Event (acc -> (x, acc)) -> m (Event x, Behavior acc)
RB.mapAccum Course a
forall a. Course a
Idle (Event (Course a -> (Maybe final, Course a))
 -> MomentIO (Event (Maybe final), Behavior (Course a)))
-> Event (Course a -> (Maybe final, Course a))
-> MomentIO (Event (Maybe final), Behavior (Course a))
forall a b. (a -> b) -> a -> b
$
    (These a (a -> Either final a)
 -> Course a -> (Maybe final, Course a))
-> Event (These a (a -> Either final a))
-> Event (Course a -> (Maybe final, Course a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap These a (a -> Either final a)
-> Course a -> (Maybe final, Course a)
forall {a} {a} {a}.
These a (a -> Either a a) -> Course a -> (Maybe a, Course a)
dispatch (Event (These a (a -> Either final a))
 -> Event (Course a -> (Maybe final, Course a)))
-> Event (These a (a -> Either final a))
-> Event (Course a -> (Maybe final, Course a))
forall a b. (a -> b) -> a -> b
$
      Event a
-> Event (a -> Either final a)
-> Event (These a (a -> Either final a))
forall a b. Event a -> Event b -> Event (These a b)
RB.merge Event a
triggerE (Behavior (Course a)
-> Event (a -> Either final a) -> Event (a -> Either final a)
forall a e. Behavior (Course a) -> Event e -> Event e
whenActive Behavior (Course a)
b Event (a -> Either final a)
stepE)

  (Event a
activeE, Handler a
fireActive) <- MomentIO (Event a, Handler a)
forall a. MomentIO (Event a, Handler a)
RBF.newEvent
  Event (IO ()) -> MomentIO ()
RBF.reactimate (Event (IO ()) -> MomentIO ()) -> Event (IO ()) -> MomentIO ()
forall a b. (a -> b) -> a -> b
$ (Event (Maybe final)
e Event (Maybe final) -> Behavior (Course a) -> Event (Course a)
forall a b. Event a -> Behavior b -> Event b
RB.@> Behavior (Course a)
b) Event (Course a) -> (Course a -> IO ()) -> Event (IO ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Active a
a ->
      Handler a
fireActive a
a
    Course a
_ ->
      () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  Event final
finishedE <- Event final -> MomentIO (Event final)
forall (m :: * -> *) a. MonadMoment m => Event a -> m (Event a)
RB.once (Event final -> MomentIO (Event final))
-> Event final -> MomentIO (Event final)
forall a b. (a -> b) -> a -> b
$
    (Maybe final -> final) -> Event (Maybe final) -> Event final
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe final -> final
forall a. HasCallStack => Maybe a -> a
fromJust (Event (Maybe final) -> Event final)
-> Event (Maybe final) -> Event final
forall a b. (a -> b) -> a -> b
$ (Maybe final -> Bool) -> Event (Maybe final) -> Event (Maybe final)
forall a. (a -> Bool) -> Event a -> Event a
RB.filterE Maybe final -> Bool
forall a. Maybe a -> Bool
isJust Event (Maybe final)
e
  (Event a, Event final, Behavior (Course a))
-> MomentIO (Event a, Event final, Behavior (Course a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Event a
activeE, Event final
finishedE, Behavior (Course a)
b)
  where
    dispatch :: These a (a -> Either a a) -> Course a -> (Maybe a, Course a)
dispatch = \case
      This a
initial -> \case
        Course a
Idle ->
          (Maybe a
forall a. Maybe a
Nothing, a -> Course a
forall a. a -> Course a
Active a
initial)
        Active{} ->
          String -> (Maybe a, Course a)
forall a. HasCallStack => String -> a
error String
"trigger not filtered when active"
        Course a
Finished ->
          String -> (Maybe a, Course a)
forall a. HasCallStack => String -> a
error String
"trigger not filtered when finished"

      That a -> Either a a
step -> \case
        Course a
Idle ->
          String -> (Maybe a, Course a)
forall a. HasCallStack => String -> a
error String
"tick not filtered when idle"
        Active a
current ->
          case a -> Either a a
step a
current of
            Left a
done ->
              (a -> Maybe a
forall a. a -> Maybe a
Just a
done, Course a
forall a. Course a
Finished)
            Right a
next ->
              (Maybe a
forall a. Maybe a
Nothing, a -> Course a
forall a. a -> Course a
Active a
next)
        Course a
Finished ->
          String -> (Maybe a, Course a)
forall a. HasCallStack => String -> a
error String
"tick not filtered when finished"

      These{} ->
        String -> Course a -> (Maybe a, Course a)
forall a. HasCallStack => String -> a
error String
"tick happened on top of trigger"

when :: (Course a -> Bool) -> RB.Behavior (Course a) -> RB.Event e -> RB.Event e
when :: forall a e.
(Course a -> Bool) -> Behavior (Course a) -> Event e -> Event e
when Course a -> Bool
pred Behavior (Course a)
course =
  Behavior (e -> Bool) -> Event e -> Event e
forall a. Behavior (a -> Bool) -> Event a -> Event a
RB.filterApply (Behavior (Course a)
course Behavior (Course a)
-> (Course a -> e -> Bool) -> Behavior (e -> Bool)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> e -> Bool
forall a b. a -> b -> a
const (Bool -> e -> Bool) -> (Course a -> Bool) -> Course a -> e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Course a -> Bool
pred)

unless :: (Course a -> Bool) -> RB.Behavior (Course a) -> RB.Event e -> RB.Event e
unless :: forall a e.
(Course a -> Bool) -> Behavior (Course a) -> Event e -> Event e
unless Course a -> Bool
pred Behavior (Course a)
course =
  Behavior (e -> Bool) -> Event e -> Event e
forall a. Behavior (a -> Bool) -> Event a -> Event a
RB.filterApply (Behavior (Course a)
course Behavior (Course a)
-> (Course a -> e -> Bool) -> Behavior (e -> Bool)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> e -> Bool
forall a b. a -> b -> a
const (Bool -> e -> Bool) -> (Course a -> Bool) -> Course a -> e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> (Course a -> Bool) -> Course a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Course a -> Bool
pred)

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

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

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

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

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

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