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

import Data.Typeable

import Component




{-|

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 :: Typeable event => Purview event m -> Purview event m
prepareTree :: forall event (m :: * -> *).
Typeable event =>
Purview event m -> Purview event m
prepareTree = Location -> Location -> Purview event m -> Purview event m
forall event (m :: * -> *).
Typeable event =>
Location -> Location -> Purview event m -> Purview event m
prepareTree' [] []

type Location = [Int]

addLocationToAttr :: Location -> Attributes e -> Attributes e
addLocationToAttr :: forall e. Location -> Attributes e -> Attributes e
addLocationToAttr Location
loc Attributes e
attr = case Attributes e
attr of
  On String
str Identifier
_ Maybe String -> e
event' -> String -> Identifier -> (Maybe String -> e) -> Attributes e
forall event.
(Show event, Eq event, Typeable event) =>
String -> Identifier -> (Maybe String -> event) -> Attributes event
On String
str (Location -> Identifier
forall a. a -> Maybe a
Just Location
loc) Maybe String -> e
event'
  Attributes e
_               -> Attributes e
attr

prepareTree'
  :: Typeable event
  => Location
  -> Location
  -> Purview event m
  -> Purview event m
prepareTree' :: forall event (m :: * -> *).
Typeable event =>
Location -> Location -> Purview event m -> Purview event m
prepareTree' Location
parentLocation Location
location Purview event m
component = case Purview event m
component of
  Attribute Attributes event
attr Purview event m
cont ->
    let
      child :: Purview event m
child = Location -> Location -> Purview event m -> Purview event m
forall event (m :: * -> *).
Typeable event =>
Location -> Location -> Purview event m -> Purview event m
prepareTree' Location
parentLocation (Location
location Location -> Location -> Location
forall a. Semigroup a => a -> a -> a
<> [Int
0]) Purview event m
cont
      newAttr :: Attributes event
newAttr = Location -> Attributes event -> Attributes event
forall e. Location -> Attributes e -> Attributes e
addLocationToAttr Location
location Attributes event
attr
    in
      Attributes event -> Purview event m -> Purview event m
forall event (m :: * -> *).
Attributes event -> Purview event m -> Purview event m
Attribute Attributes event
newAttr Purview event m
child

  Html String
kind [Purview event m]
children ->
    let
      indexedChildren :: [(Int, Purview event m)]
indexedChildren = Location -> [Purview event m] -> [(Int, Purview event m)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Purview event m]
children
      children' :: [Purview event m]
children' =
        ((Int, Purview event m) -> Purview event m)
-> [(Int, Purview event m)] -> [Purview event m]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Int
location', Purview event m
child) -> Location -> Location -> Purview event m -> Purview event m
forall event (m :: * -> *).
Typeable event =>
Location -> Location -> Purview event m -> Purview event m
prepareTree' Location
parentLocation (Location
location Location -> Location -> Location
forall a. Semigroup a => a -> a -> a
<> [Int
location']) Purview event m
child) [(Int, Purview event m)]
indexedChildren
    in
      String -> [Purview event m] -> Purview event m
forall event (m :: * -> *).
String -> [Purview event m] -> Purview event m
Html String
kind [Purview event m]
children'

  EffectHandler Identifier
_ploc Identifier
_loc [DirectedEvent event newEvent]
initEvents state
state newEvent
-> state -> m (state -> state, [DirectedEvent event newEvent])
handler state -> Purview newEvent m
cont ->
    let
      cont' :: state -> Purview newEvent m
cont' = (Purview newEvent m -> Purview newEvent m)
-> (state -> Purview newEvent m) -> state -> Purview newEvent m
forall a b. (a -> b) -> (state -> a) -> state -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Location -> Location -> Purview newEvent m -> Purview newEvent m
forall event (m :: * -> *).
Typeable event =>
Location -> Location -> Purview event m -> Purview event m
prepareTree' Location
location (Location
location Location -> Location -> Location
forall a. Semigroup a => a -> a -> a
<> [Int
0])) state -> Purview newEvent m
cont
    in
      Identifier
-> Identifier
-> [DirectedEvent event newEvent]
-> state
-> (newEvent
    -> state -> m (state -> state, [DirectedEvent event newEvent]))
-> (state -> Purview newEvent m)
-> Purview event m
forall state newEvent event (m :: * -> *).
(Show state, Eq state, Typeable state, Typeable newEvent) =>
Identifier
-> Identifier
-> [DirectedEvent event newEvent]
-> state
-> (newEvent
    -> state -> m (state -> state, [DirectedEvent event newEvent]))
-> (state -> Purview newEvent m)
-> Purview event m
EffectHandler (Location -> Identifier
forall a. a -> Maybe a
Just Location
parentLocation) (Location -> Identifier
forall a. a -> Maybe a
Just Location
location) [DirectedEvent event newEvent]
initEvents state
state newEvent
-> state -> m (state -> state, [DirectedEvent event newEvent])
handler state -> Purview newEvent m
cont'

  Handler Identifier
_ploc Identifier
_loc [DirectedEvent event newEvent]
initEvents state
state newEvent
-> state -> (state -> state, [DirectedEvent event newEvent])
handler state -> Purview newEvent m
cont ->
    let
      cont' :: state -> Purview newEvent m
cont' = (Purview newEvent m -> Purview newEvent m)
-> (state -> Purview newEvent m) -> state -> Purview newEvent m
forall a b. (a -> b) -> (state -> a) -> state -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Location -> Location -> Purview newEvent m -> Purview newEvent m
forall event (m :: * -> *).
Typeable event =>
Location -> Location -> Purview event m -> Purview event m
prepareTree' Location
location (Location
location Location -> Location -> Location
forall a. Semigroup a => a -> a -> a
<> [Int
0])) state -> Purview newEvent m
cont
    in
      Identifier
-> Identifier
-> [DirectedEvent event newEvent]
-> state
-> (newEvent
    -> state -> (state -> state, [DirectedEvent event newEvent]))
-> (state -> Purview newEvent m)
-> Purview event m
forall state newEvent event (m :: * -> *).
(Show state, Eq state, Typeable state, Typeable newEvent) =>
Identifier
-> Identifier
-> [DirectedEvent event newEvent]
-> state
-> (newEvent
    -> state -> (state -> state, [DirectedEvent event newEvent]))
-> (state -> Purview newEvent m)
-> Purview event m
Handler (Location -> Identifier
forall a. a -> Maybe a
Just Location
parentLocation) (Location -> Identifier
forall a. a -> Maybe a
Just Location
location) [DirectedEvent event newEvent]
initEvents state
state newEvent
-> state -> (state -> state, [DirectedEvent event newEvent])
handler state -> Purview newEvent m
cont'

  Receiver { String
name :: String
$sel:name:Attribute :: forall event (m :: * -> *). Purview event m -> String
name, Maybe String -> event
eventHandler :: Maybe String -> event
$sel:eventHandler:Attribute :: forall event (m :: * -> *).
Purview event m -> Maybe String -> event
eventHandler, state -> Purview event m
child :: state -> Purview event m
$sel:child:Attribute :: ()
child, state
state :: state
$sel:state:Attribute :: ()
state } ->
    let
      child' :: state -> Purview event m
child' = (Purview event m -> Purview event m)
-> (state -> Purview event m) -> state -> Purview event m
forall a b. (a -> b) -> (state -> a) -> state -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Location -> Location -> Purview event m -> Purview event m
forall event (m :: * -> *).
Typeable event =>
Location -> Location -> Purview event m -> Purview event m
prepareTree' Location
location (Location
location Location -> Location -> Location
forall a. Semigroup a => a -> a -> a
<> [Int
0])) state -> Purview event m
child
    in
      Identifier
-> Identifier
-> String
-> (Maybe String -> event)
-> (state -> Purview event m)
-> state
-> Purview event m
forall event state (m :: * -> *).
(Show event, Eq event, Typeable event) =>
Identifier
-> Identifier
-> String
-> (Maybe String -> event)
-> (state -> Purview event m)
-> state
-> Purview event m
Receiver (Location -> Identifier
forall a. a -> Maybe a
Just Location
parentLocation) (Location -> Identifier
forall a. a -> Maybe a
Just Location
location) String
name Maybe String -> event
eventHandler state -> Purview event m
child' state
state

  Text String
val -> String -> Purview event m
forall event (m :: * -> *). String -> Purview event m
Text String
val

  Value a
val -> a -> Purview event m
forall a event (m :: * -> *). Show a => a -> Purview event m
Value a
val