{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}

module EventLoop
 ( eventLoop )
where

import           Control.Concurrent.STM.TChan
import           Control.Monad.STM
import           Control.Monad
import           Control.Concurrent
import           Data.Typeable
import           Data.Aeson (encode)
import qualified Network.WebSockets as WebSockets

import           Component
import           Diffing
import           EventHandling
import           Events
import           PrepareTree
import           Rendering
import           CleanTree (cleanTree)
import           CollectInitials (collectInitials)

type Log m = String -> m ()

eventLoop'
  :: (Monad m, Typeable event)
  => Event
  -> Bool
  -> (m [Event] -> IO [Event])
  -> Log IO
  -> TChan Event
  -> WebSockets.Connection
  -> Purview event m
  -> IO (Maybe (Purview event m))
eventLoop' :: forall (m :: * -> *) event.
(Monad m, Typeable event) =>
Event
-> Bool
-> (m [Event] -> IO [Event])
-> Log IO
-> TChan Event
-> Connection
-> Purview event m
-> IO (Maybe (Purview event m))
eventLoop' Event
message Bool
devMode m [Event] -> IO [Event]
runner Log IO
log TChan Event
eventBus Connection
connection Purview event m
component = do
  -- if it's special newState event, the state is replaced in the tree
  let newTree :: Purview event m
newTree = case Event
message of
        FromFrontendEvent {}                 -> Purview event m
component
        InternalEvent {}                     -> Purview event m
component
        JavascriptCallEvent {}               -> Purview event m
component
        stateChangeEvent :: Event
stateChangeEvent@StateChangeEvent {} -> forall event (m :: * -> *).
Event -> Purview event m -> Purview event m
applyNewState Event
stateChangeEvent Purview event m
component

  let
    -- 1. adds locations
    locatedTree :: Purview event m
locatedTree = forall event (m :: * -> *).
Typeable event =>
Purview event m -> Purview event m
prepareTree Purview event m
newTree
    -- 2. collects css and initial events
    ([Event]
initialEvents, [(Hash, Hash)]
css) = forall event (m :: * -> *).
Typeable event =>
Purview event m -> ([Event], [(Hash, Hash)])
collectInitials Purview event m
locatedTree
    -- 3. removes captured css and initial events
    newTree' :: Purview event m
newTree' = forall event (m :: * -> *).
Typeable event =>
[(Hash, Hash)] -> Purview event m -> Purview event m
cleanTree [(Hash, Hash)]
css Purview event m
locatedTree
    -- why pass in the found css?  otherwise haskell will optimize by
    -- putting the function that removes css into the tree, which results
    -- in the css being removed before it's been found by collectInitials.
    -- or at least, that's what seemed to be happening.  very funny.

    event :: Maybe Event
event = forall event (m :: * -> *). Event -> Purview event m -> Maybe Event
findEvent Event
message Purview event m
newTree'

  -- this is where handlers are actually called, and their events are sent back into
  -- this loop
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
    [Event]
newEvents <- case (Maybe Event
event, Event
message) of
      (Maybe Event
_, event' :: Event
event'@InternalEvent {}) -> m [Event] -> IO [Event]
runner forall a b. (a -> b) -> a -> b
$ forall event (m :: * -> *).
(Typeable event, Monad m) =>
Event -> Purview event m -> m [Event]
runEvent Event
event' Purview event m
newTree'
      (Just Event
event', Event
_)             -> m [Event] -> IO [Event]
runner forall a b. (a -> b) -> a -> b
$ forall event (m :: * -> *).
(Typeable event, Monad m) =>
Event -> Purview event m -> m [Event]
runEvent Event
event' Purview event m
newTree'
      (Maybe Event
Nothing,     Event
_)             -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TChan a -> a -> STM ()
writeTChan TChan Event
eventBus) [Event]
newEvents

  let
    -- collect diffs
    location :: Identifier
location = case Event
message of
      (FromFrontendEvent { Identifier
$sel:location:FromFrontendEvent :: Event -> Identifier
location :: Identifier
location }) -> Identifier
location
      (StateChangeEvent state -> state
_ Identifier
location)    -> Identifier
location
      (InternalEvent { Identifier
$sel:handlerId:FromFrontendEvent :: Event -> Identifier
handlerId :: Identifier
handlerId })    -> Identifier
handlerId
      (JavascriptCallEvent {})         -> forall a. HasCallStack => Hash -> a
error Hash
"tried to get location off javascript call"

    diffs :: [Change (Purview event m)]
diffs = forall event (m :: * -> *).
Identifier
-> Location
-> Purview event m
-> Purview event m
-> [Change (Purview event m)]
diff Identifier
location [Int
0] Purview event m
component Purview event m
newTree'
    -- for now it's just "Update", which the javascript handles as replacing
    -- the html beneath the handler.  I imagine it could be more exact, with
    -- Delete / Create events.
    renderedDiffs :: [Change Hash]
renderedDiffs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Update Location
location Purview event m
graph) -> forall a. Location -> a -> Change a
Update Location
location (forall action (m :: * -> *). Purview action m -> Hash
render Purview event m
graph)) [Change (Purview event m)]
diffs

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Hash, Hash)]
css) forall a b. (a -> b) -> a -> b
$ forall a. WebSocketsData a => Connection -> a -> IO ()
WebSockets.sendTextData
    Connection
connection
    (forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ ForFrontEndEvent { $sel:event:ForFrontEndEvent :: Text
event = Text
"setCSS", $sel:message:ForFrontEndEvent :: [(Hash, Hash)]
message = [(Hash, Hash)]
css })

  forall a. WebSocketsData a => Connection -> a -> IO ()
WebSockets.sendTextData
    Connection
connection
    (forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ ForFrontEndEvent { $sel:event:ForFrontEndEvent :: Text
event = Text
"setHtml", $sel:message:ForFrontEndEvent :: [Change Hash]
message = [Change Hash]
renderedDiffs })

  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Purview event m
newTree')

handleJavascriptCall :: String -> String -> WebSockets.Connection -> IO (Maybe (Purview event m))
handleJavascriptCall :: forall event (m :: * -> *).
Hash -> Hash -> Connection -> IO (Maybe (Purview event m))
handleJavascriptCall Hash
name Hash
value Connection
connection = do
  forall a. WebSocketsData a => Connection -> a -> IO ()
WebSockets.sendTextData
    Connection
connection
    (forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ ForFrontEndEvent { $sel:event:ForFrontEndEvent :: Text
event = Text
"callJS", $sel:message:ForFrontEndEvent :: [Hash]
message = [Hash
name, Hash
value] })

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

--
-- This is the main event loop of handling messages from the websocket
--
-- pretty much just get a message, then run the message via the component
-- handler, and then send the "setHtml" back downstream to tell it to replace
-- the html with the new.
--
eventLoop
  :: (Monad m, Typeable event)
  => Bool
  -> (m [Event] -> IO [Event])
  -> Log IO
  -> TChan Event
  -> WebSockets.Connection
  -> Purview event m
  -> IO ()
eventLoop :: forall (m :: * -> *) event.
(Monad m, Typeable event) =>
Bool
-> (m [Event] -> IO [Event])
-> Log IO
-> TChan Event
-> Connection
-> Purview event m
-> IO ()
eventLoop Bool
devMode m [Event] -> IO [Event]
runner Log IO
log TChan Event
eventBus Connection
connection Purview event m
component = do
  Event
message <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> STM a
readTChan TChan Event
eventBus

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
devMode forall a b. (a -> b) -> a -> b
$ Log IO
log forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Hash
show Event
message

  Maybe (Purview event m)
newTree <- case Event
message of
    JavascriptCallEvent Hash
name Hash
value -> forall event (m :: * -> *).
Hash -> Hash -> Connection -> IO (Maybe (Purview event m))
handleJavascriptCall Hash
name Hash
value Connection
connection
    Event
_ -> forall (m :: * -> *) event.
(Monad m, Typeable event) =>
Event
-> Bool
-> (m [Event] -> IO [Event])
-> Log IO
-> TChan Event
-> Connection
-> Purview event m
-> IO (Maybe (Purview event m))
eventLoop' Event
message Bool
devMode m [Event] -> IO [Event]
runner Log IO
log TChan Event
eventBus Connection
connection Purview event m
component

  case Maybe (Purview event m)
newTree of
    Just Purview event m
tree ->
      case Event
message of
        (FromFrontendEvent { Text
$sel:kind:FromFrontendEvent :: Event -> Text
kind :: Text
kind }) -> do
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
devMode Bool -> Bool -> Bool
&& Text
kind forall a. Eq a => a -> a -> Bool
== Text
"init") forall a b. (a -> b) -> a -> b
$
            forall a. WebSocketsData a => Connection -> a -> IO ()
WebSockets.sendTextData
            Connection
connection
            (forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ ForFrontEndEvent { $sel:event:ForFrontEndEvent :: Text
event = Text
"setHtml", $sel:message:ForFrontEndEvent :: [Change Hash]
message = [ forall a. Location -> a -> Change a
Update [] (forall action (m :: * -> *). Purview action m -> Hash
render Purview event m
tree) ] })

          forall (m :: * -> *) event.
(Monad m, Typeable event) =>
Bool
-> (m [Event] -> IO [Event])
-> Log IO
-> TChan Event
-> Connection
-> Purview event m
-> IO ()
eventLoop Bool
devMode m [Event] -> IO [Event]
runner Log IO
log TChan Event
eventBus Connection
connection Purview event m
tree
        Event
_ ->
          forall (m :: * -> *) event.
(Monad m, Typeable event) =>
Bool
-> (m [Event] -> IO [Event])
-> Log IO
-> TChan Event
-> Connection
-> Purview event m
-> IO ()
eventLoop Bool
devMode m [Event] -> IO [Event]
runner Log IO
log TChan Event
eventBus Connection
connection Purview event m
tree
    Maybe (Purview event m)
Nothing -> forall (m :: * -> *) event.
(Monad m, Typeable event) =>
Bool
-> (m [Event] -> IO [Event])
-> Log IO
-> TChan Event
-> Connection
-> Purview event m
-> IO ()
eventLoop Bool
devMode m [Event] -> IO [Event]
runner Log IO
log TChan Event
eventBus Connection
connection Purview event m
component