{-# 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 {} -> 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
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
([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
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
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'
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
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'
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
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