{-# 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.Aeson (encode)
import qualified Network.WebSockets as WebSockets

import           Component
import           Diffing
import           EventHandling
import           Events
import           PrepareTree
import           Rendering

type Log m = String -> m ()

--
-- 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
  => Bool
  -> (m [Event] -> IO [Event])
  -> Log IO
  -> TChan Event
  -> WebSockets.Connection
  -> Purview parentAction action m
  -> IO ()
eventLoop :: forall (m :: * -> *) parentAction action.
Monad m =>
Bool
-> (m [Event] -> IO [Event])
-> Log IO
-> TChan Event
-> Connection
-> Purview parentAction action m
-> IO ()
eventLoop Bool
devMode m [Event] -> IO [Event]
runner Log IO
log TChan Event
eventBus Connection
connection Purview parentAction action m
component = do
  Event
message <- STM Event -> IO Event
forall a. STM a -> IO a
atomically (STM Event -> IO Event) -> STM Event -> IO Event
forall a b. (a -> b) -> a -> b
$ TChan Event -> STM Event
forall a. TChan a -> STM a
readTChan TChan Event
eventBus

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

  let
    -- this collects any actions that should run once and sets them
    -- to "run" in the tree, while assigning locations / identifiers
    -- to the event handlers
    (Purview parentAction action m
newTree, [Event]
actions) = Purview parentAction action m
-> (Purview parentAction action m, [Event])
forall parentAction action (m :: * -> *).
Purview parentAction action m
-> (Purview parentAction action m, [Event])
prepareTree Purview parentAction action m
component

  -- if it's special newState event, the state is replaced in the tree
  let newTree' :: Purview parentAction action m
newTree' = case Event
message of
        Event {} -> Purview parentAction action m
newTree
        Event
stateChangeEvent -> Event
-> Purview parentAction action m -> Purview parentAction action m
forall parentAction action (m :: * -> *).
Event
-> Purview parentAction action m -> Purview parentAction action m
applyNewState Event
stateChangeEvent Purview parentAction action m
newTree

  -- this is where handlers are actually called, and their events are sent back into
  -- this loop
  IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Event]
newEvents <- m [Event] -> IO [Event]
runner (m [Event] -> IO [Event]) -> m [Event] -> IO [Event]
forall a b. (a -> b) -> a -> b
$ Event -> Purview parentAction action m -> m [Event]
forall (m :: * -> *) parentAction action.
Monad m =>
Event -> Purview parentAction action m -> m [Event]
runEvent Event
message Purview parentAction action m
newTree'
    (Event -> IO ()) -> [Event] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (Event -> STM ()) -> Event -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan Event -> Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Event
eventBus) [Event]
newEvents

  (Event -> IO ()) -> [Event] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (Event -> STM ()) -> Event -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan Event -> Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Event
eventBus) [Event]
actions

  let
    -- collect diffs
    location :: Maybe [Int]
location = case Event
message of
      (Event { Maybe [Int]
$sel:location:Event :: Event -> Maybe [Int]
location :: Maybe [Int]
location }) -> Maybe [Int]
location
      (StateChangeEvent state -> state
_ Maybe [Int]
location) -> Maybe [Int]
location

    diffs :: [Change (Purview parentAction action m)]
diffs = Maybe [Int]
-> [Int]
-> Purview parentAction action m
-> Purview parentAction action m
-> [Change (Purview parentAction action m)]
forall parentAction action (m :: * -> *).
Maybe [Int]
-> [Int]
-> Purview parentAction action m
-> Purview parentAction action m
-> [Change (Purview parentAction action m)]
diff Maybe [Int]
location [Int
0] Purview parentAction action m
component Purview parentAction action 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 String]
renderedDiffs = (Change (Purview parentAction action m) -> Change String)
-> [Change (Purview parentAction action m)] -> [Change String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Update [Int]
location Purview parentAction action m
graph) -> [Int] -> String -> Change String
forall a. [Int] -> a -> Change a
Update [Int]
location (Purview parentAction action m -> String
forall parentAction action (m :: * -> *).
Purview parentAction action m -> String
render Purview parentAction action m
graph)) [Change (Purview parentAction action m)]
diffs

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
devMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Log IO
log Log IO -> Log IO
forall a b. (a -> b) -> a -> b
$ String
"sending> " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Change String] -> String
forall a. Show a => a -> String
show [Change String]
renderedDiffs

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

  case Event
message of
    (Event { Text
$sel:event:Event :: Event -> Text
event :: Text
event }) ->
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
devMode Bool -> Bool -> Bool
&& Text
event Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"init") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WebSockets.sendTextData
          Connection
connection
          (ForFrontEndEvent [Change String] -> ByteString
forall a. ToJSON a => a -> ByteString
encode (ForFrontEndEvent [Change String] -> ByteString)
-> ForFrontEndEvent [Change String] -> ByteString
forall a b. (a -> b) -> a -> b
$ ForFrontEndEvent { $sel:event:ForFrontEndEvent :: Text
event = Text
"setHtml", $sel:message:ForFrontEndEvent :: [Change String]
message = [ [Int] -> String -> Change String
forall a. [Int] -> a -> Change a
Update [] (Purview parentAction action m -> String
forall parentAction action (m :: * -> *).
Purview parentAction action m -> String
render Purview parentAction action m
newTree') ] })
    Event
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  Bool
-> (m [Event] -> IO [Event])
-> Log IO
-> TChan Event
-> Connection
-> Purview parentAction action m
-> IO ()
forall (m :: * -> *) parentAction action.
Monad m =>
Bool
-> (m [Event] -> IO [Event])
-> Log IO
-> TChan Event
-> Connection
-> Purview parentAction action m
-> IO ()
eventLoop Bool
devMode m [Event] -> IO [Event]
runner Log IO
log TChan Event
eventBus Connection
connection Purview parentAction action m
newTree'