{-# 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 {} -> Event -> Purview event m -> Purview event m
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 = Purview event m -> Purview event m
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) = Purview event m -> ([Event], [(Hash, Hash)])
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' = [(Hash, Hash)] -> Purview event m -> Purview event m
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 = Event -> Purview event m -> Maybe 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
  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 <- case (Maybe Event
event, Event
message) of
      (Maybe Event
_, event' :: Event
event'@InternalEvent {}) -> m [Event] -> IO [Event]
runner (m [Event] -> IO [Event]) -> m [Event] -> IO [Event]
forall a b. (a -> b) -> a -> b
$ Event -> Purview event m -> m [Event]
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 (m [Event] -> IO [Event]) -> m [Event] -> IO [Event]
forall a b. (a -> b) -> a -> b
$ Event -> Purview event m -> m [Event]
forall event (m :: * -> *).
(Typeable event, Monad m) =>
Event -> Purview event m -> m [Event]
runEvent Event
event' Purview event m
newTree'
      (Maybe Event
Nothing,     Event
_)             -> [Event] -> IO [Event]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    (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

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

    diffs :: [Change (Purview event m)]
diffs = Identifier
-> Location
-> Purview event m
-> Purview event m
-> [Change (Purview event m)]
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 = (Change (Purview event m) -> Change Hash)
-> [Change (Purview event m)] -> [Change Hash]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Update Location
location Purview event m
graph) -> Location -> Hash -> Change Hash
forall a. Location -> a -> Change a
Update Location
location (Purview event m -> Hash
forall action (m :: * -> *). Purview action m -> Hash
render Purview event m
graph)) [Change (Purview event m)]
diffs

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Hash, Hash)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Hash, Hash)]
css) (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 [(Hash, Hash)] -> ByteString
forall a. ToJSON a => a -> ByteString
encode (ForFrontEndEvent [(Hash, Hash)] -> ByteString)
-> ForFrontEndEvent [(Hash, Hash)] -> ByteString
forall a b. (a -> b) -> a -> b
$ ForFrontEndEvent { $sel:event:ForFrontEndEvent :: Text
event = Text
"setCSS", $sel:message:ForFrontEndEvent :: [(Hash, Hash)]
message = [(Hash, Hash)]
css })

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

  Maybe (Purview event m) -> IO (Maybe (Purview event m))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Purview event m -> Maybe (Purview event m)
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
  Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WebSockets.sendTextData
    Connection
connection
    (ForFrontEndEvent [Hash] -> ByteString
forall a. ToJSON a => a -> ByteString
encode (ForFrontEndEvent [Hash] -> ByteString)
-> ForFrontEndEvent [Hash] -> ByteString
forall a b. (a -> b) -> a -> b
$ ForFrontEndEvent { $sel:event:ForFrontEndEvent :: Text
event = Text
"callJS", $sel:message:ForFrontEndEvent :: [Hash]
message = [Hash
name, Hash
value] })

  Maybe (Purview event m) -> IO (Maybe (Purview event m))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Purview event m)
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 <- 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
$ Event -> Hash
forall a. Show a => a -> Hash
show Event
message

  Maybe (Purview event m)
newTree <- case Event
message of
    JavascriptCallEvent Hash
name Hash
value -> Hash -> Hash -> Connection -> IO (Maybe (Purview event m))
forall event (m :: * -> *).
Hash -> Hash -> Connection -> IO (Maybe (Purview event m))
handleJavascriptCall Hash
name Hash
value Connection
connection
    Event
_ -> Event
-> Bool
-> (m [Event] -> IO [Event])
-> Log IO
-> TChan Event
-> Connection
-> Purview event m
-> IO (Maybe (Purview event m))
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
kind :: Text
$sel:kind:FromFrontendEvent :: Event -> Text
kind }) -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
devMode Bool -> Bool -> Bool
&& Text
kind 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 Hash] -> ByteString
forall a. ToJSON a => a -> ByteString
encode (ForFrontEndEvent [Change Hash] -> ByteString)
-> ForFrontEndEvent [Change Hash] -> ByteString
forall a b. (a -> b) -> a -> b
$ ForFrontEndEvent { $sel:event:ForFrontEndEvent :: Text
event = Text
"setHtml", $sel:message:ForFrontEndEvent :: [Change Hash]
message = [ Location -> Hash -> Change Hash
forall a. Location -> a -> Change a
Update [] (Purview event m -> Hash
forall action (m :: * -> *). Purview action m -> Hash
render Purview event m
tree) ] })

          Bool
-> (m [Event] -> IO [Event])
-> Log IO
-> TChan Event
-> Connection
-> Purview event m
-> IO ()
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
_ ->
          Bool
-> (m [Event] -> IO [Event])
-> Log IO
-> TChan Event
-> Connection
-> Purview event m
-> IO ()
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 -> Bool
-> (m [Event] -> IO [Event])
-> Log IO
-> TChan Event
-> Connection
-> Purview event m
-> IO ()
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