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

import           Control.Concurrent.STM.TChan
import           Data.Aeson
import           Data.Typeable

import           Events
import           Component


{-|

This is a special case event to assign new state to handlers

-}
applyNewState
  :: Event
  -> Purview parentAction action m
  -> Purview parentAction action m
applyNewState :: forall parentAction action (m :: * -> *).
Event
-> Purview parentAction action m -> Purview parentAction action m
applyNewState fromEvent :: Event
fromEvent@(StateChangeEvent state -> state
newStateFn Maybe [Int]
location) Purview parentAction action m
component = case Purview parentAction action m
component of
  EffectHandler Maybe [Int]
ploc Maybe [Int]
loc state
state action
-> state -> m (state -> state, [DirectedEvent parentAction action])
handler state -> Purview action any m
cont -> case (state -> state) -> Maybe (state -> state)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast state -> state
newStateFn of
    Just state -> state
newStateFn' -> Maybe [Int]
-> Maybe [Int]
-> state
-> (action
    -> state
    -> m (state -> state, [DirectedEvent parentAction action]))
-> (state -> Purview action any m)
-> Purview parentAction action m
forall newAction parentAction state (m :: * -> *) any.
(FromJSON newAction, ToJSON newAction, ToJSON parentAction,
 FromJSON state, ToJSON state, Typeable state, Eq state) =>
Maybe [Int]
-> Maybe [Int]
-> state
-> (newAction
    -> state
    -> m (state -> state, [DirectedEvent parentAction newAction]))
-> (state -> Purview newAction any m)
-> Purview parentAction newAction m
EffectHandler Maybe [Int]
ploc Maybe [Int]
loc (state -> state
newStateFn' state
state) action
-> state -> m (state -> state, [DirectedEvent parentAction action])
handler state -> Purview action any m
cont
    Maybe (state -> state)
Nothing ->
      let children :: state -> Purview action any m
children = (Purview action any m -> Purview action any m)
-> (state -> Purview action any m) -> state -> Purview action any m
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Event -> Purview action any m -> Purview action any m
forall parentAction action (m :: * -> *).
Event
-> Purview parentAction action m -> Purview parentAction action m
applyNewState Event
fromEvent) state -> Purview action any m
cont
      in Maybe [Int]
-> Maybe [Int]
-> state
-> (action
    -> state
    -> m (state -> state, [DirectedEvent parentAction action]))
-> (state -> Purview action any m)
-> Purview parentAction action m
forall newAction parentAction state (m :: * -> *) any.
(FromJSON newAction, ToJSON newAction, ToJSON parentAction,
 FromJSON state, ToJSON state, Typeable state, Eq state) =>
Maybe [Int]
-> Maybe [Int]
-> state
-> (newAction
    -> state
    -> m (state -> state, [DirectedEvent parentAction newAction]))
-> (state -> Purview newAction any m)
-> Purview parentAction newAction m
EffectHandler Maybe [Int]
ploc Maybe [Int]
loc state
state action
-> state -> m (state -> state, [DirectedEvent parentAction action])
handler state -> Purview action any m
children

  Hide Purview parentAction newAction m
x ->
    let
      children :: Purview parentAction newAction m
children = Event
-> Purview parentAction newAction m
-> Purview parentAction newAction m
forall parentAction action (m :: * -> *).
Event
-> Purview parentAction action m -> Purview parentAction action m
applyNewState Event
fromEvent Purview parentAction newAction m
x
    in
      Purview parentAction newAction m -> Purview parentAction action m
forall parentAction state (m :: * -> *) any.
Purview parentAction state m -> Purview parentAction any m
Hide Purview parentAction newAction m
children

  Html String
kind [Purview parentAction action m]
children ->
    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] -> Purview parentAction action m)
-> [Purview parentAction action m] -> Purview parentAction action m
forall a b. (a -> b) -> a -> b
$ (Purview parentAction action m -> Purview parentAction action m)
-> [Purview parentAction action m]
-> [Purview parentAction action m]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Event
-> Purview parentAction action m -> Purview parentAction action m
forall parentAction action (m :: * -> *).
Event
-> Purview parentAction action m -> Purview parentAction action m
applyNewState Event
fromEvent) [Purview parentAction action m]
children

  Attribute Attributes action
n Purview parentAction action m
cont ->
    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
n (Event
-> Purview parentAction action m -> Purview parentAction action m
forall parentAction action (m :: * -> *).
Event
-> Purview parentAction action m -> Purview parentAction action m
applyNewState Event
fromEvent Purview parentAction action m
cont)

  Once (action -> Event) -> Event
fn Bool
run Purview parentAction action m
cont ->
    ((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
fn Bool
run (Purview parentAction action m -> Purview parentAction action m)
-> Purview parentAction action m -> Purview parentAction action m
forall a b. (a -> b) -> a -> b
$ Event
-> Purview parentAction action m -> Purview parentAction action m
forall parentAction action (m :: * -> *).
Event
-> Purview parentAction action m -> Purview parentAction action m
applyNewState Event
fromEvent Purview parentAction action m
cont

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

  Value a
x -> a -> Purview parentAction action m
forall state parentAction action (m :: * -> *).
Show state =>
state -> Purview parentAction action m
Value a
x
applyNewState (Event {}) Purview parentAction action m
component = Purview parentAction action m
component


runEvent :: Monad m => Event -> Purview parentAction action m -> m [Event]
runEvent :: forall (m :: * -> *) parentAction action.
Monad m =>
Event -> Purview parentAction action m -> m [Event]
runEvent (StateChangeEvent state -> state
_ Maybe [Int]
_) Purview parentAction action m
_ = [Event] -> m [Event]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
runEvent fromEvent :: Event
fromEvent@(Event { Value
$sel:message:Event :: Event -> Value
message :: Value
message, Maybe [Int]
$sel:location:Event :: Event -> Maybe [Int]
location :: Maybe [Int]
location }) Purview parentAction action m
component = case Purview parentAction action m
component of
  EffectHandler Maybe [Int]
parentLocation Maybe [Int]
loc state
state action
-> state -> m (state -> state, [DirectedEvent parentAction action])
handler state -> Purview action any m
cont -> case Value -> Result action
forall a. FromJSON a => Value -> Result a
fromJSON Value
message of
    Success action
parsedAction -> do
      -- if locations match, we actually run what is in the handler
      (state -> state
newStateFn, [DirectedEvent parentAction action]
events) <-
        if Maybe [Int]
loc Maybe [Int] -> Maybe [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe [Int]
location
        then action
-> state -> m (state -> state, [DirectedEvent parentAction action])
handler action
parsedAction state
state
        else (state -> state, [DirectedEvent parentAction action])
-> m (state -> state, [DirectedEvent parentAction action])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (state -> state -> state
forall a b. a -> b -> a
const state
state, [])

      -- although it doesn't break anything, only send this when the
      -- locations match (cuts down on noise)
      let newStateEvent :: [Event]
newStateEvent = [(state -> state) -> Maybe [Int] -> Event
forall state.
(Eq state, Typeable state, ToJSON state, FromJSON state) =>
(state -> state) -> Maybe [Int] -> Event
StateChangeEvent state -> state
newStateFn Maybe [Int]
loc | Maybe [Int]
loc Maybe [Int] -> Maybe [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe [Int]
location]

      let createMessage :: DirectedEvent a a -> Event
createMessage DirectedEvent a a
directedEvent = case DirectedEvent a a
directedEvent of
            (Parent a
event) -> Event
              -- TODO: this should probably be a new kind of event
              { $sel:event:Event :: Text
event = Text
"internal"
              , $sel:message:Event :: Value
message = a -> Value
forall a. ToJSON a => a -> Value
toJSON a
event
              , $sel:location:Event :: Maybe [Int]
location = Maybe [Int]
parentLocation
              }
            (Self a
event) -> Event
              { $sel:event:Event :: Text
event = Text
"internal"
              , $sel:message:Event :: Value
message = a -> Value
forall a. ToJSON a => a -> Value
toJSON a
event
              , $sel:location:Event :: Maybe [Int]
location = Maybe [Int]
loc
              }

      -- here we handle sending events returned to either this
      -- same handler or passing it up the chain
      -- mapM_ (atomically . writeTChan eventBus . createMessage) events
      let handlerEvents :: [Event]
handlerEvents = (DirectedEvent parentAction action -> Event)
-> [DirectedEvent parentAction action] -> [Event]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DirectedEvent parentAction action -> Event
forall {a} {a}. (ToJSON a, ToJSON a) => DirectedEvent a a -> Event
createMessage [DirectedEvent parentAction action]
events

      -- ok, right, no where in this function does the tree actually change
      -- that's handled by the setting state event
      [Event]
childEvents <- Event -> Purview action any m -> m [Event]
forall (m :: * -> *) parentAction action.
Monad m =>
Event -> Purview parentAction action m -> m [Event]
runEvent Event
fromEvent (state -> Purview action any m
cont state
state)

      -- so we can ignore the results from applyEvent and continue
      -- pure $ EffectHandler parentLocation loc state handler cont
      [Event] -> m [Event]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Event] -> m [Event]) -> [Event] -> m [Event]
forall a b. (a -> b) -> a -> b
$ [Event]
newStateEvent [Event] -> [Event] -> [Event]
forall a. Semigroup a => a -> a -> a
<> [Event]
handlerEvents [Event] -> [Event] -> [Event]
forall a. Semigroup a => a -> a -> a
<> [Event]
childEvents

    Error String
_err -> Event -> Purview action any m -> m [Event]
forall (m :: * -> *) parentAction action.
Monad m =>
Event -> Purview parentAction action m -> m [Event]
runEvent Event
fromEvent (state -> Purview action any m
cont state
state)

  Html String
kind [Purview parentAction action m]
children -> do
    [[Event]]
childEvents' <- (Purview parentAction action m -> m [Event])
-> [Purview parentAction action m] -> m [[Event]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Event -> Purview parentAction action m -> m [Event]
forall (m :: * -> *) parentAction action.
Monad m =>
Event -> Purview parentAction action m -> m [Event]
runEvent Event
fromEvent) [Purview parentAction action m]
children
    [Event] -> m [Event]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Event] -> m [Event]) -> [Event] -> m [Event]
forall a b. (a -> b) -> a -> b
$ [[Event]] -> [Event]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Event]]
childEvents'

  Attribute Attributes action
n Purview parentAction action m
cont -> Event -> Purview parentAction action m -> m [Event]
forall (m :: * -> *) parentAction action.
Monad m =>
Event -> Purview parentAction action m -> m [Event]
runEvent Event
fromEvent Purview parentAction action m
cont

  Hide Purview parentAction newAction m
x -> Event -> Purview parentAction newAction m -> m [Event]
forall (m :: * -> *) parentAction action.
Monad m =>
Event -> Purview parentAction action m -> m [Event]
runEvent Event
fromEvent Purview parentAction newAction m
x

  Once (action -> Event) -> Event
_ Bool
_ Purview parentAction action m
cont -> Event -> Purview parentAction action m -> m [Event]
forall (m :: * -> *) parentAction action.
Monad m =>
Event -> Purview parentAction action m -> m [Event]
runEvent Event
fromEvent Purview parentAction action m
cont

  Text String
_ -> [Event] -> m [Event]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

  Value a
_ -> [Event] -> m [Event]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []