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



import           Data.Typeable
import           Data.Maybe

import           Events
import           Component


type Location = [Int]

directedEventToInternalEvent :: (Typeable a, Typeable b) => Location -> Location -> DirectedEvent a b -> Event
directedEventToInternalEvent :: forall a b.
(Typeable a, Typeable b) =>
Location -> Location -> DirectedEvent a b -> Event
directedEventToInternalEvent Location
parentLocation Location
location DirectedEvent a b
directedEvent = case DirectedEvent a b
directedEvent of
  Parent a
event       -> InternalEvent { $sel:event:FromFrontendEvent :: a
event=a
event, $sel:childId:FromFrontendEvent :: Identifier
childId=Identifier
forall a. Maybe a
Nothing, $sel:handlerId:FromFrontendEvent :: Identifier
handlerId=Location -> Identifier
forall a. a -> Maybe a
Just Location
parentLocation }
  Self b
event         -> InternalEvent { $sel:event:FromFrontendEvent :: b
event=b
event, $sel:childId:FromFrontendEvent :: Identifier
childId=Identifier
forall a. Maybe a
Nothing, $sel:handlerId:FromFrontendEvent :: Identifier
handlerId=Location -> Identifier
forall a. a -> Maybe a
Just Location
location }
  Browser String
name String
value -> String -> String -> Event
JavascriptCallEvent String
name String
value

{-|

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

-}
applyNewState
  :: Event
  -> Purview event m
  -> Purview event m
applyNewState :: forall event (m :: * -> *).
Event -> Purview event m -> Purview event m
applyNewState fromEvent :: Event
fromEvent@(StateChangeEvent state -> state
newStateFn Identifier
location) Purview event m
component = case Purview event m
component of
  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 ->
    if Identifier
loc Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
location then
      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' -> 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 Identifier
ploc Identifier
loc [DirectedEvent event newEvent]
initEvents (state -> state
newStateFn' state
state) newEvent
-> state -> m (state -> state, [DirectedEvent event newEvent])
handler state -> Purview newEvent m
cont
        Maybe (state -> state)
Nothing ->
          let children :: state -> Purview newEvent m
children = (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 (Event -> Purview newEvent m -> Purview newEvent m
forall event (m :: * -> *).
Event -> Purview event m -> Purview event m
applyNewState Event
fromEvent) 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 Identifier
ploc Identifier
loc [DirectedEvent event newEvent]
initEvents state
state newEvent
-> state -> m (state -> state, [DirectedEvent event newEvent])
handler state -> Purview newEvent m
children
    else
      let children :: state -> Purview newEvent m
children = (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 (Event -> Purview newEvent m -> Purview newEvent m
forall event (m :: * -> *).
Event -> Purview event m -> Purview event m
applyNewState Event
fromEvent) 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 Identifier
ploc Identifier
loc [DirectedEvent event newEvent]
initEvents state
state newEvent
-> state -> m (state -> state, [DirectedEvent event newEvent])
handler state -> Purview newEvent m
children

  Handler Identifier
ploc Identifier
loc [DirectedEvent event newEvent]
initEvents state
state newEvent
-> state -> (state -> state, [DirectedEvent event newEvent])
handler state -> Purview newEvent m
cont ->
    if Identifier
loc Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
location then
      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' -> 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 Identifier
ploc Identifier
loc [DirectedEvent event newEvent]
initEvents (state -> state
newStateFn' state
state) newEvent
-> state -> (state -> state, [DirectedEvent event newEvent])
handler state -> Purview newEvent m
cont
        Maybe (state -> state)
Nothing ->
          let children :: state -> Purview newEvent m
children = (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 (Event -> Purview newEvent m -> Purview newEvent m
forall event (m :: * -> *).
Event -> Purview event m -> Purview event m
applyNewState Event
fromEvent) 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 Identifier
ploc Identifier
loc [DirectedEvent event newEvent]
initEvents state
state newEvent
-> state -> (state -> state, [DirectedEvent event newEvent])
handler state -> Purview newEvent m
children
    else
      let children :: state -> Purview newEvent m
children = (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 (Event -> Purview newEvent m -> Purview newEvent m
forall event (m :: * -> *).
Event -> Purview event m -> Purview event m
applyNewState Event
fromEvent) 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 Identifier
ploc Identifier
loc [DirectedEvent event newEvent]
initEvents state
state newEvent
-> state -> (state -> state, [DirectedEvent event newEvent])
handler state -> Purview newEvent m
children

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

  Attribute Attributes event
n Purview event m
cont ->
    Attributes event -> Purview event m -> Purview event m
forall event (m :: * -> *).
Attributes event -> Purview event m -> Purview event m
Attribute Attributes event
n (Event -> Purview event m -> Purview event m
forall event (m :: * -> *).
Event -> Purview event m -> Purview event m
applyNewState Event
fromEvent Purview event m
cont)

  receiver :: Purview event m
receiver@Receiver {} -> Purview event m
receiver

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

  Value a
x -> a -> Purview event m
forall a event (m :: * -> *). Show a => a -> Purview event m
Value a
x
applyNewState (FromFrontendEvent {}) Purview event m
component = Purview event m
component
applyNewState (InternalEvent {}) Purview event m
component = Purview event m
component
applyNewState (JavascriptCallEvent {}) Purview event m
component = Purview event m
component


findEvent :: Event -> Purview event m -> Maybe Event
findEvent :: forall event (m :: * -> *). Event -> Purview event m -> Maybe Event
findEvent (StateChangeEvent {}) Purview event m
_ = Maybe Event
forall a. Maybe a
Nothing
findEvent (InternalEvent {}) Purview event m
_ = Maybe Event
forall a. Maybe a
Nothing
findEvent (JavascriptCallEvent {}) Purview event m
_ = Maybe Event
forall a. Maybe a
Nothing
findEvent event :: Event
event@FromFrontendEvent { $sel:childLocation:FromFrontendEvent :: Event -> Identifier
childLocation=Identifier
childLocation, $sel:location:FromFrontendEvent :: Event -> Identifier
location=Identifier
handlerLocation, $sel:value:FromFrontendEvent :: Event -> Maybe String
value=Maybe String
value } Purview event m
tree = case Purview event m
tree of
  Attribute Attributes event
attr Purview event m
cont -> case Attributes event
attr of
    On String
_ Identifier
ident Maybe String -> event
evt ->
      if Identifier
ident Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
childLocation
      then Event -> Maybe Event
forall a. a -> Maybe a
Just (Event -> Maybe Event) -> Event -> Maybe Event
forall a b. (a -> b) -> a -> b
$ event -> Identifier -> Identifier -> Event
forall event.
(Show event, Eq event, Typeable event) =>
event -> Identifier -> Identifier -> Event
InternalEvent (Maybe String -> event
evt Maybe String
value) Identifier
childLocation Identifier
handlerLocation
      else Maybe Event
forall a. Maybe a
Nothing
    Attributes event
_ -> Event -> Purview event m -> Maybe Event
forall event (m :: * -> *). Event -> Purview event m -> Maybe Event
findEvent Event
event Purview event m
cont

  Html String
_ [Purview event m]
children ->
    case (Purview event m -> Maybe Event) -> [Purview event m] -> [Event]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Event -> Purview event m -> Maybe Event
forall event (m :: * -> *). Event -> Purview event m -> Maybe Event
findEvent Event
event) [Purview event m]
children of
      [Event
found] -> Event -> Maybe Event
forall a. a -> Maybe a
Just Event
found
      []      -> Maybe Event
forall a. Maybe a
Nothing
      [Event]
_       -> Maybe Event
forall a. Maybe a
Nothing

  EffectHandler Identifier
_ Identifier
ident [DirectedEvent event newEvent]
initEvents state
state newEvent
-> state -> m (state -> state, [DirectedEvent event newEvent])
_ state -> Purview newEvent m
cont ->
    Event -> Purview newEvent m -> Maybe Event
forall event (m :: * -> *). Event -> Purview event m -> Maybe Event
findEvent Event
event (state -> Purview newEvent m
cont state
state)

  Handler Identifier
_ Identifier
ident [DirectedEvent event newEvent]
initEvents state
state newEvent
-> state -> (state -> state, [DirectedEvent event newEvent])
_ state -> Purview newEvent m
cont ->
    Event -> Purview newEvent m -> Maybe Event
forall event (m :: * -> *). Event -> Purview event m -> Maybe Event
findEvent Event
event (state -> Purview newEvent m
cont state
state)

  -- TODO: dunno how I feel about findEvent running anything
  Receiver Identifier
parentLocation Identifier
location String
name Maybe String -> event
eventHandler state -> Purview event m
child state
state ->
    if Identifier
location Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
childLocation
    then Event -> Maybe Event
forall a. a -> Maybe a
Just (Event -> Maybe Event) -> Event -> Maybe Event
forall a b. (a -> b) -> a -> b
$ event -> Identifier -> Identifier -> Event
forall event.
(Show event, Eq event, Typeable event) =>
event -> Identifier -> Identifier -> Event
InternalEvent (Maybe String -> event
eventHandler Maybe String
value) Identifier
location Identifier
parentLocation
    else Event -> Purview event m -> Maybe Event
forall event (m :: * -> *). Event -> Purview event m -> Maybe Event
findEvent Event
event (state -> Purview event m
child state
state)

  Text String
_ -> Maybe Event
forall a. Maybe a
Nothing

  Value a
_ -> Maybe Event
forall a. Maybe a
Nothing

runEvent :: (Typeable event, Monad m) => Event -> Purview event m -> m [Event]
runEvent :: forall event (m :: * -> *).
(Typeable event, Monad m) =>
Event -> Purview event m -> m [Event]
runEvent (FromFrontendEvent {})   Purview event m
_ = [Event] -> m [Event]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
runEvent (StateChangeEvent {})    Purview event m
_ = [Event] -> m [Event]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
runEvent (JavascriptCallEvent {}) Purview event m
_ = [Event] -> m [Event]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
runEvent internalEvent :: Event
internalEvent@InternalEvent { event
$sel:event:FromFrontendEvent :: ()
event :: event
event, Identifier
$sel:handlerId:FromFrontendEvent :: Event -> Identifier
handlerId :: Identifier
handlerId } Purview event m
tree = case Purview event m
tree of
  Attribute Attributes event
attr Purview event m
cont ->
    Event -> Purview event m -> m [Event]
forall event (m :: * -> *).
(Typeable event, Monad m) =>
Event -> Purview event m -> m [Event]
runEvent Event
internalEvent Purview event m
cont

  Html String
_ [Purview event m]
children -> [[Event]] -> [Event]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Event]] -> [Event]) -> m [[Event]] -> m [Event]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Purview event m -> m [Event]) -> [Purview event m] -> m [[Event]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Event -> Purview event m -> m [Event]
forall event (m :: * -> *).
(Typeable event, Monad m) =>
Event -> Purview event m -> m [Event]
runEvent Event
internalEvent) [Purview event m]
children

  EffectHandler (Just Location
parentIdent) (Just Location
ident) [DirectedEvent event newEvent]
initEvents state
state newEvent
-> state -> m (state -> state, [DirectedEvent event newEvent])
handler state -> Purview newEvent m
cont ->
    if Location -> Identifier
forall a. a -> Maybe a
Just Location
ident Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
handlerId then
      case event -> Maybe newEvent
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast event
event of
        Just newEvent
event' -> do
          (state -> state
newStateFn, [DirectedEvent event newEvent]
events) <- newEvent
-> state -> m (state -> state, [DirectedEvent event newEvent])
handler newEvent
event' state
state
          [Event] -> m [Event]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Event] -> m [Event]) -> [Event] -> m [Event]
forall a b. (a -> b) -> a -> b
$ [(state -> state) -> Identifier -> Event
forall state.
(Eq state, Show state, Typeable state) =>
(state -> state) -> Identifier -> Event
StateChangeEvent state -> state
newStateFn Identifier
handlerId] [Event] -> [Event] -> [Event]
forall a. Semigroup a => a -> a -> a
<> (DirectedEvent event newEvent -> Event)
-> [DirectedEvent event newEvent] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Location -> Location -> DirectedEvent event newEvent -> Event
forall a b.
(Typeable a, Typeable b) =>
Location -> Location -> DirectedEvent a b -> Event
directedEventToInternalEvent Location
parentIdent Location
ident) [DirectedEvent event newEvent]
events
        Maybe newEvent
Nothing -> [Event] -> m [Event]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    else
      Event -> Purview newEvent m -> m [Event]
forall event (m :: * -> *).
(Typeable event, Monad m) =>
Event -> Purview event m -> m [Event]
runEvent Event
internalEvent (state -> Purview newEvent m
cont state
state)

  Handler (Just Location
parentIdent) (Just Location
ident) [DirectedEvent event newEvent]
initEvents state
state newEvent
-> state -> (state -> state, [DirectedEvent event newEvent])
handler state -> Purview newEvent m
cont ->
    if Location -> Identifier
forall a. a -> Maybe a
Just Location
ident Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
handlerId then
      case event -> Maybe newEvent
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast event
event of
        Just newEvent
event' ->
          let (state -> state
newStateFn, [DirectedEvent event newEvent]
events) = newEvent
-> state -> (state -> state, [DirectedEvent event newEvent])
handler newEvent
event' state
state
          in [Event] -> m [Event]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Event] -> m [Event]) -> [Event] -> m [Event]
forall a b. (a -> b) -> a -> b
$ [(state -> state) -> Identifier -> Event
forall state.
(Eq state, Show state, Typeable state) =>
(state -> state) -> Identifier -> Event
StateChangeEvent state -> state
newStateFn Identifier
handlerId] [Event] -> [Event] -> [Event]
forall a. Semigroup a => a -> a -> a
<> (DirectedEvent event newEvent -> Event)
-> [DirectedEvent event newEvent] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Location -> Location -> DirectedEvent event newEvent -> Event
forall a b.
(Typeable a, Typeable b) =>
Location -> Location -> DirectedEvent a b -> Event
directedEventToInternalEvent Location
parentIdent Location
ident) [DirectedEvent event newEvent]
events
        Maybe newEvent
Nothing -> [Event] -> m [Event]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    else
      Event -> Purview newEvent m -> m [Event]
forall event (m :: * -> *).
(Typeable event, Monad m) =>
Event -> Purview event m -> m [Event]
runEvent Event
internalEvent (state -> Purview newEvent m
cont state
state)

  Receiver {} -> [Event] -> m [Event]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

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

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

  -- TODO: this should never happen, should refactor so it's clear
  EffectHandler { $sel:identifier:Attribute :: forall event (m :: * -> *). Purview event m -> Identifier
identifier = Identifier
Nothing }       -> m [Event]
forall a. HasCallStack => a
undefined
  EffectHandler { $sel:parentIdentifier:Attribute :: forall event (m :: * -> *). Purview event m -> Identifier
parentIdentifier = Identifier
Nothing } -> m [Event]
forall a. HasCallStack => a
undefined
  Handler { $sel:identifier:Attribute :: forall event (m :: * -> *). Purview event m -> Identifier
identifier = Identifier
Nothing }             -> m [Event]
forall a. HasCallStack => a
undefined
  Handler { $sel:parentIdentifier:Attribute :: forall event (m :: * -> *). Purview event m -> Identifier
parentIdentifier = Identifier
Nothing }       -> m [Event]
forall a. HasCallStack => a
undefined