{-# 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
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
locatedTree :: Purview event m
locatedTree = forall event (m :: * -> *).
Typeable event =>
Purview event m -> Purview event m
prepareTree Purview event m
newTree
([Event]
initialEvents, [(Hash, Hash)]
css) = forall event (m :: * -> *).
Typeable event =>
Purview event m -> ([Event], [(Hash, Hash)])
collectInitials Purview event m
locatedTree
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
event :: Maybe Event
event = forall event (m :: * -> *). Event -> Purview event m -> Maybe Event
findEvent Event
message Purview event m
newTree'
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
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'
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
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