{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
module PrepareTree where

import Data.Aeson

import Component
import Events

{-|

This walks through the tree and collects actions that should be run
only once, and sets their run value to True.  It's up to something
else to actually send the actions.

It also assigns a location to message and effect handlers.

-}

prepareTree :: Purview parentAction action m -> (Purview parentAction action m, [Event])
prepareTree :: forall parentAction action (m :: * -> *).
Purview parentAction action m
-> (Purview parentAction action m, [Event])
prepareTree = Location
-> Location
-> Purview parentAction action m
-> (Purview parentAction action m, [Event])
forall parentAction action (m :: * -> *).
Location
-> Location
-> Purview parentAction action m
-> (Purview parentAction action m, [Event])
prepareTree' [] []

type Location = [Int]

prepareTree'
  :: Location
  -> Location
  -> Purview parentAction action m
  -> (Purview parentAction action m, [Event])
prepareTree' :: forall parentAction action (m :: * -> *).
Location
-> Location
-> Purview parentAction action m
-> (Purview parentAction action m, [Event])
prepareTree' Location
parentLocation Location
location Purview parentAction action m
component = case Purview parentAction action m
component of
  Attribute Attributes action
attrs Purview parentAction action m
cont ->
    let result :: (Purview parentAction action m, [Event])
result = Location
-> Location
-> Purview parentAction action m
-> (Purview parentAction action m, [Event])
forall parentAction action (m :: * -> *).
Location
-> Location
-> Purview parentAction action m
-> (Purview parentAction action m, [Event])
prepareTree' Location
parentLocation Location
location Purview parentAction action m
cont
    in (Attributes action
-> Purview parentAction action m -> Purview parentAction action m
forall action parentAction (m :: * -> *).
Attributes action
-> Purview parentAction action m -> Purview parentAction action m
Attribute Attributes action
attrs ((Purview parentAction action m, [Event])
-> Purview parentAction action m
forall a b. (a, b) -> a
fst (Purview parentAction action m, [Event])
result), (Purview parentAction action m, [Event]) -> [Event]
forall a b. (a, b) -> b
snd (Purview parentAction action m, [Event])
result)

  Html String
kind [Purview parentAction action m]
children ->
    let result :: [(Purview parentAction action m, [Event])]
result = ((Int, Purview parentAction action m)
 -> (Purview parentAction action m, [Event]))
-> [(Int, Purview parentAction action m)]
-> [(Purview parentAction action m, [Event])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Int
index, Purview parentAction action m
child) -> Location
-> Location
-> Purview parentAction action m
-> (Purview parentAction action m, [Event])
forall parentAction action (m :: * -> *).
Location
-> Location
-> Purview parentAction action m
-> (Purview parentAction action m, [Event])
prepareTree' Location
parentLocation (Int
indexInt -> Location -> Location
forall a. a -> [a] -> [a]
:Location
location) Purview parentAction action m
child) (Location
-> [Purview parentAction action m]
-> [(Int, Purview parentAction action m)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Purview parentAction action m]
children)
    in (String
-> [Purview parentAction action m] -> Purview parentAction action m
forall parentAction action (m :: * -> *).
String
-> [Purview parentAction action m] -> Purview parentAction action m
Html String
kind (((Purview parentAction action m, [Event])
 -> Purview parentAction action m)
-> [(Purview parentAction action m, [Event])]
-> [Purview parentAction action m]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Purview parentAction action m, [Event])
-> Purview parentAction action m
forall a b. (a, b) -> a
fst [(Purview parentAction action m, [Event])]
result), ((Purview parentAction action m, [Event]) -> [Event])
-> [(Purview parentAction action m, [Event])] -> [Event]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Purview parentAction action m, [Event]) -> [Event]
forall a b. (a, b) -> b
snd [(Purview parentAction action m, [Event])]
result)

  EffectHandler ParentIdentifier
_ploc ParentIdentifier
_loc state
state action
-> state -> m (state -> state, [DirectedEvent parentAction action])
handler state -> Purview action any m
cont ->
    let
      rest :: state -> (Purview action any m, [Event])
rest = (Purview action any m -> (Purview action any m, [Event]))
-> (state -> Purview action any m)
-> state
-> (Purview action any m, [Event])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Location
-> Location
-> Purview action any m
-> (Purview action any m, [Event])
forall parentAction action (m :: * -> *).
Location
-> Location
-> Purview parentAction action m
-> (Purview parentAction action m, [Event])
prepareTree' Location
location (Int
0Int -> Location -> Location
forall a. a -> [a] -> [a]
:Location
location)) state -> Purview action any m
cont
    in
      ( ParentIdentifier
-> ParentIdentifier
-> state
-> (action
    -> state
    -> m (state -> state, [DirectedEvent parentAction action]))
-> (state -> Purview action any m)
-> Purview parentAction action m
forall newAction parentAction a (m :: * -> *) any.
(FromJSON newAction, ToJSON newAction, ToJSON parentAction,
 FromJSON a, ToJSON a, Typeable a, Eq a) =>
ParentIdentifier
-> ParentIdentifier
-> a
-> (newAction
    -> a -> m (a -> a, [DirectedEvent parentAction newAction]))
-> (a -> Purview newAction any m)
-> Purview parentAction newAction m
EffectHandler (Location -> ParentIdentifier
forall a. a -> Maybe a
Just Location
parentLocation) (Location -> ParentIdentifier
forall a. a -> Maybe a
Just Location
location) state
state action
-> state -> m (state -> state, [DirectedEvent parentAction action])
handler (\state
state' -> (Purview action any m, [Event]) -> Purview action any m
forall a b. (a, b) -> a
fst (state -> (Purview action any m, [Event])
rest state
state'))
      , (Purview action any m, [Event]) -> [Event]
forall a b. (a, b) -> b
snd (state -> (Purview action any m, [Event])
rest state
state)
      )

  Once (action -> Event) -> Event
effect Bool
hasRun Purview parentAction action m
cont ->
    let send :: a -> Event
send a
message =
          Event
            { $sel:event:Event :: Text
event = Text
"once"
            , $sel:message:Event :: Value
message = a -> Value
forall a. ToJSON a => a -> Value
toJSON a
message
            , $sel:location:Event :: ParentIdentifier
location = Location -> ParentIdentifier
forall a. a -> Maybe a
Just Location
location
            }
    in if Bool -> Bool
not Bool
hasRun then
        let
          rest :: (Purview parentAction action m, [Event])
rest = Location
-> Location
-> Purview parentAction action m
-> (Purview parentAction action m, [Event])
forall parentAction action (m :: * -> *).
Location
-> Location
-> Purview parentAction action m
-> (Purview parentAction action m, [Event])
prepareTree' Location
parentLocation Location
location Purview parentAction action m
cont
        in
          (((action -> Event) -> Event)
-> Bool
-> Purview parentAction action m
-> Purview parentAction action m
forall action parentAction (m :: * -> *).
ToJSON action =>
((action -> Event) -> Event)
-> Bool
-> Purview parentAction action m
-> Purview parentAction action m
Once (action -> Event) -> Event
effect Bool
True ((Purview parentAction action m, [Event])
-> Purview parentAction action m
forall a b. (a, b) -> a
fst (Purview parentAction action m, [Event])
rest), [(action -> Event) -> Event
effect action -> Event
forall {a}. ToJSON a => a -> Event
send] [Event] -> [Event] -> [Event]
forall a. Semigroup a => a -> a -> a
<> ((Purview parentAction action m, [Event]) -> [Event]
forall a b. (a, b) -> b
snd (Purview parentAction action m, [Event])
rest))
       else
        let
          rest :: (Purview parentAction action m, [Event])
rest = Location
-> Location
-> Purview parentAction action m
-> (Purview parentAction action m, [Event])
forall parentAction action (m :: * -> *).
Location
-> Location
-> Purview parentAction action m
-> (Purview parentAction action m, [Event])
prepareTree' Location
parentLocation Location
location Purview parentAction action m
cont
        in
          (((action -> Event) -> Event)
-> Bool
-> Purview parentAction action m
-> Purview parentAction action m
forall action parentAction (m :: * -> *).
ToJSON action =>
((action -> Event) -> Event)
-> Bool
-> Purview parentAction action m
-> Purview parentAction action m
Once (action -> Event) -> Event
effect Bool
True ((Purview parentAction action m, [Event])
-> Purview parentAction action m
forall a b. (a, b) -> a
fst (Purview parentAction action m, [Event])
rest), (Purview parentAction action m, [Event]) -> [Event]
forall a b. (a, b) -> b
snd (Purview parentAction action m, [Event])
rest)

  Hide Purview parentAction newAction m
x ->
    let (Purview parentAction newAction m
child, [Event]
actions) = Location
-> Location
-> Purview parentAction newAction m
-> (Purview parentAction newAction m, [Event])
forall parentAction action (m :: * -> *).
Location
-> Location
-> Purview parentAction action m
-> (Purview parentAction action m, [Event])
prepareTree' Location
parentLocation Location
location Purview parentAction newAction m
x
    in (Purview parentAction newAction m -> Purview parentAction action m
forall parentAction a (m :: * -> *) any.
Purview parentAction a m -> Purview parentAction any m
Hide Purview parentAction newAction m
child, [Event]
actions)

  Value a
x -> (a -> Purview parentAction action m
forall a parentAction action (m :: * -> *).
Show a =>
a -> Purview parentAction action m
Value a
x, [])

  Text String
x -> (String -> Purview parentAction action m
forall parentAction action (m :: * -> *).
String -> Purview parentAction action m
Text String
x, [])