{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Miso.Internal
(
initialize
, freshComponentId
, runView
, renderStyles
, Hydrate(..)
, startSub
, stopSub
, subscribe
, unsubscribe
, publish
, Topic (..)
, topic
) where
import Control.Exception (SomeException)
import Control.Monad (forM, forM_, when, void, forever)
import Control.Monad.Reader (ask)
import Control.Monad.IO.Class
import Data.Aeson (FromJSON, ToJSON, Result, fromJSON, toJSON)
import Data.Foldable (toList)
import Data.IORef (IORef, newIORef, atomicModifyIORef', readIORef, atomicWriteIORef, modifyIORef')
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import qualified Data.Sequence as S
import Data.Sequence (Seq)
import qualified JavaScript.Array as JSArray
#ifndef GHCJS_BOTH
import Language.Javascript.JSaddle hiding (Sync, Result)
#else
import Language.Javascript.JSaddle
#endif
import GHC.Conc (ThreadStatus(ThreadDied, ThreadFinished), ThreadId, killThread, threadStatus)
import Prelude hiding (null)
import System.IO.Unsafe (unsafePerformIO)
import System.Mem.StableName (makeStableName)
import Text.HTML.TagSoup (Tag(..))
import Text.HTML.TagSoup.Tree (parseTree, TagTree(..))
import Miso.Concurrent (Waiter(..), waiter, Mailbox, copyMailbox, readMail, sendMail, newMailbox)
import Miso.Delegate (delegator, undelegator)
import Miso.Diff (diff)
import qualified Miso.FFI.Internal as FFI
import Miso.String hiding (reverse)
import Miso.Types
import Miso.Style (renderStyleSheet)
import Miso.Event (Events)
import Miso.Property (textProp)
import Miso.Effect (Sub, Sink, Effect, runEffect, io_)
initialize
:: Eq model
=> Component model action
-> (Sink action -> JSM (DOMRef, IORef VTree))
-> JSM (IORef VTree)
initialize :: forall model action.
Eq model =>
Component model action
-> (Sink action -> JSM (DOMRef, IORef VTree)) -> JSM (IORef VTree)
initialize Component {model
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View action
action -> Effect model action
model :: model
update :: action -> Effect model action
view :: model -> View action
subs :: [Sub action]
events :: Events
styles :: [CSS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
logLevel :: forall model action. Component model action -> LogLevel
mountPoint :: forall model action. Component model action -> Maybe MisoString
initialAction :: forall model action. Component model action -> Maybe action
styles :: forall model action. Component model action -> [CSS]
events :: forall model action. Component model action -> Events
subs :: forall model action. Component model action -> [Sub action]
view :: forall model action. Component model action -> model -> View action
update :: forall model action.
Component model action -> action -> Effect model action
model :: forall model action. Component model action -> model
..} Sink action -> JSM (DOMRef, IORef VTree)
getView = do
Waiter {..} <- IO Waiter -> JSM Waiter
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Waiter
waiter
componentActions <- liftIO (newIORef S.empty)
let
componentSink = \action
action -> IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
IORef (Seq action) -> (Seq action -> (Seq action, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Seq action)
componentActions ((Seq action -> (Seq action, ())) -> IO ())
-> (Seq action -> (Seq action, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Seq action
actions -> (Seq action
actions Seq action -> action -> Seq action
forall a. Seq a -> a -> Seq a
S.|> action
action, ())
IO ()
serve
componentId <- liftIO freshComponentId
(componentMount, componentVTree) <- getView componentSink
componentSubThreads <- liftIO (newIORef M.empty)
forM_ subs $ \Sub action
sub -> do
threadId <- JSM () -> JSM ThreadId
FFI.forkJSM (Sub action
sub Sink action
componentSink)
subKey <- liftIO freshSubId
liftIO $ atomicModifyIORef' componentSubThreads $ \Map MisoString ThreadId
m ->
(MisoString
-> ThreadId -> Map MisoString ThreadId -> Map MisoString ThreadId
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert MisoString
subKey ThreadId
threadId Map MisoString ThreadId
m, ())
componentModel <- liftIO (newIORef model)
let
eventLoop !model
oldModel = IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
wait JSM () -> JSM b -> JSM b
forall a b. JSM a -> JSM b -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> do
as <- IO (Seq action) -> JSM (Seq action)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Seq action) -> JSM (Seq action))
-> IO (Seq action) -> JSM (Seq action)
forall a b. (a -> b) -> a -> b
$ IORef (Seq action)
-> (Seq action -> (Seq action, Seq action)) -> IO (Seq action)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Seq action)
componentActions ((Seq action -> (Seq action, Seq action)) -> IO (Seq action))
-> (Seq action -> (Seq action, Seq action)) -> IO (Seq action)
forall a b. (a -> b) -> a -> b
$ \Seq action
actions -> (Seq action
forall a. Seq a
S.empty, Seq action
actions)
newModel <- foldEffects update Async componentId componentSink (toList as) oldModel
oldName <- liftIO $ oldModel `seq` makeStableName oldModel
newName <- liftIO $ newModel `seq` makeStableName newModel
when (oldName /= newName && oldModel /= newModel) $ do
newVTree <- runView Draw (view newModel) componentSink logLevel events
oldVTree <- liftIO (readIORef componentVTree)
void waitForAnimationFrame
diff (Just oldVTree) (Just newVTree) componentMount
liftIO $ do
atomicWriteIORef componentVTree newVTree
atomicWriteIORef componentModel newModel
syncPoint
eventLoop newModel
_ <- FFI.forkJSM (eventLoop model)
registerComponent ComponentState {..}
delegator componentMount componentVTree events (logLevel `elem` [DebugEvents, DebugAll])
forM_ initialAction componentSink
pure componentVTree
data Hydrate
= Draw
| Hydrate
deriving (Int -> Hydrate -> ShowS
[Hydrate] -> ShowS
Hydrate -> String
(Int -> Hydrate -> ShowS)
-> (Hydrate -> String) -> ([Hydrate] -> ShowS) -> Show Hydrate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Hydrate -> ShowS
showsPrec :: Int -> Hydrate -> ShowS
$cshow :: Hydrate -> String
show :: Hydrate -> String
$cshowList :: [Hydrate] -> ShowS
showList :: [Hydrate] -> ShowS
Show, Hydrate -> Hydrate -> Bool
(Hydrate -> Hydrate -> Bool)
-> (Hydrate -> Hydrate -> Bool) -> Eq Hydrate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Hydrate -> Hydrate -> Bool
== :: Hydrate -> Hydrate -> Bool
$c/= :: Hydrate -> Hydrate -> Bool
/= :: Hydrate -> Hydrate -> Bool
Eq)
data ComponentState model action
= ComponentState
{ forall model action. ComponentState model action -> MisoString
componentId :: ComponentId
, forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentSubThreads :: IORef (Map MisoString ThreadId)
, forall model action. ComponentState model action -> DOMRef
componentMount :: JSVal
, forall model action. ComponentState model action -> IORef VTree
componentVTree :: IORef VTree
, forall model action.
ComponentState model action -> action -> JSM ()
componentSink :: action -> JSM ()
, forall model action. ComponentState model action -> IORef model
componentModel :: IORef model
, forall model action.
ComponentState model action -> IORef (Seq action)
componentActions :: IORef (Seq action)
}
newtype Topic a = Topic MisoString
deriving (Eq (Topic a)
Eq (Topic a) =>
(Topic a -> Topic a -> Ordering)
-> (Topic a -> Topic a -> Bool)
-> (Topic a -> Topic a -> Bool)
-> (Topic a -> Topic a -> Bool)
-> (Topic a -> Topic a -> Bool)
-> (Topic a -> Topic a -> Topic a)
-> (Topic a -> Topic a -> Topic a)
-> Ord (Topic a)
Topic a -> Topic a -> Bool
Topic a -> Topic a -> Ordering
Topic a -> Topic a -> Topic a
forall a. Eq (Topic a)
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Topic a -> Topic a -> Bool
forall a. Topic a -> Topic a -> Ordering
forall a. Topic a -> Topic a -> Topic a
$ccompare :: forall a. Topic a -> Topic a -> Ordering
compare :: Topic a -> Topic a -> Ordering
$c< :: forall a. Topic a -> Topic a -> Bool
< :: Topic a -> Topic a -> Bool
$c<= :: forall a. Topic a -> Topic a -> Bool
<= :: Topic a -> Topic a -> Bool
$c> :: forall a. Topic a -> Topic a -> Bool
> :: Topic a -> Topic a -> Bool
$c>= :: forall a. Topic a -> Topic a -> Bool
>= :: Topic a -> Topic a -> Bool
$cmax :: forall a. Topic a -> Topic a -> Topic a
max :: Topic a -> Topic a -> Topic a
$cmin :: forall a. Topic a -> Topic a -> Topic a
min :: Topic a -> Topic a -> Topic a
Ord, Topic a -> Topic a -> Bool
(Topic a -> Topic a -> Bool)
-> (Topic a -> Topic a -> Bool) -> Eq (Topic a)
forall a. Topic a -> Topic a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Topic a -> Topic a -> Bool
== :: Topic a -> Topic a -> Bool
$c/= :: forall a. Topic a -> Topic a -> Bool
/= :: Topic a -> Topic a -> Bool
Eq, Int -> Topic a -> ShowS
[Topic a] -> ShowS
Topic a -> String
(Int -> Topic a -> ShowS)
-> (Topic a -> String) -> ([Topic a] -> ShowS) -> Show (Topic a)
forall a. Int -> Topic a -> ShowS
forall a. [Topic a] -> ShowS
forall a. Topic a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> Topic a -> ShowS
showsPrec :: Int -> Topic a -> ShowS
$cshow :: forall a. Topic a -> String
show :: Topic a -> String
$cshowList :: forall a. [Topic a] -> ShowS
showList :: [Topic a] -> ShowS
Show, Topic a -> MisoString
(Topic a -> MisoString) -> ToMisoString (Topic a)
forall a. Topic a -> MisoString
forall str. (str -> MisoString) -> ToMisoString str
$ctoMisoString :: forall a. Topic a -> MisoString
toMisoString :: Topic a -> MisoString
ToMisoString)
topic :: MisoString -> Topic a
topic :: forall a. MisoString -> Topic a
topic = MisoString -> Topic a
forall a. MisoString -> Topic a
Topic
mailboxes :: IORef (Map (Topic a) Mailbox)
{-# NOINLINE mailboxes #-}
mailboxes :: forall a. IORef (Map (Topic a) Mailbox)
mailboxes = IO (IORef (Map (Topic a) Mailbox)) -> IORef (Map (Topic a) Mailbox)
forall a. IO a -> a
unsafePerformIO (IO (IORef (Map (Topic a) Mailbox))
-> IORef (Map (Topic a) Mailbox))
-> IO (IORef (Map (Topic a) Mailbox))
-> IORef (Map (Topic a) Mailbox)
forall a b. (a -> b) -> a -> b
$ IO (IORef (Map (Topic a) Mailbox))
-> IO (IORef (Map (Topic a) Mailbox))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Map (Topic a) Mailbox -> IO (IORef (Map (Topic a) Mailbox))
forall a. a -> IO (IORef a)
newIORef Map (Topic a) Mailbox
forall a. Monoid a => a
mempty)
subscribers :: IORef (Map (ComponentId, Topic a) ThreadId)
{-# NOINLINE subscribers #-}
subscribers :: forall a. IORef (Map (MisoString, Topic a) ThreadId)
subscribers = IO (IORef (Map (MisoString, Topic a) ThreadId))
-> IORef (Map (MisoString, Topic a) ThreadId)
forall a. IO a -> a
unsafePerformIO (IO (IORef (Map (MisoString, Topic a) ThreadId))
-> IORef (Map (MisoString, Topic a) ThreadId))
-> IO (IORef (Map (MisoString, Topic a) ThreadId))
-> IORef (Map (MisoString, Topic a) ThreadId)
forall a b. (a -> b) -> a -> b
$ IO (IORef (Map (MisoString, Topic a) ThreadId))
-> IO (IORef (Map (MisoString, Topic a) ThreadId))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Map (MisoString, Topic a) ThreadId
-> IO (IORef (Map (MisoString, Topic a) ThreadId))
forall a. a -> IO (IORef a)
newIORef Map (MisoString, Topic a) ThreadId
forall a. Monoid a => a
mempty)
subscribe
:: FromJSON message
=> Topic message
-> (Result message -> action)
-> Effect model action
subscribe :: forall message action model.
FromJSON message =>
Topic message -> (Result message -> action) -> Effect model action
subscribe Topic message
topicName Result message -> action
toAction = do
vcompId <- RWST MisoString [Sink action -> JSM ()] model Identity MisoString
forall r (m :: * -> *). MonadReader r m => m r
ask
io_ $ do
subscribersMap <- liftIO (readIORef subscribers)
let key = (MisoString
vcompId, Topic message
topicName)
case M.lookup key subscribersMap of
Just ThreadId
_ ->
MisoString -> JSM ()
FFI.consoleWarn (MisoString
"Already subscribed to: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> Topic message -> MisoString
forall str. ToMisoString str => str -> MisoString
ms Topic message
topicName)
Maybe ThreadId
Nothing -> do
Topic message -> Map (Topic message) Mailbox -> Maybe Mailbox
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Topic message
topicName (Map (Topic message) Mailbox -> Maybe Mailbox)
-> JSM (Map (Topic message) Mailbox) -> JSM (Maybe Mailbox)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map (Topic message) Mailbox)
-> JSM (Map (Topic message) Mailbox)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Map (Topic message) Mailbox)
-> IO (Map (Topic message) Mailbox)
forall a. IORef a -> IO a
readIORef IORef (Map (Topic message) Mailbox)
forall a. IORef (Map (Topic a) Mailbox)
mailboxes) JSM (Maybe Mailbox) -> (Maybe Mailbox -> JSM ()) -> JSM ()
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Mailbox
Nothing -> do
mailbox <- IO Mailbox -> JSM Mailbox
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Mailbox -> JSM Mailbox) -> IO Mailbox -> JSM Mailbox
forall a b. (a -> b) -> a -> b
$ do
mailbox <- IO Mailbox
newMailbox
atomicModifyIORef' mailboxes $ \Map (Topic message) Mailbox
m -> (Topic message
-> Mailbox
-> Map (Topic message) Mailbox
-> Map (Topic message) Mailbox
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Topic message
topicName Mailbox
mailbox Map (Topic message) Mailbox
m, ())
pure mailbox
subscribeToMailbox key mailbox vcompId
Just Mailbox
mailbox -> do
(MisoString, Topic message) -> Mailbox -> MisoString -> JSM ()
forall {a}.
(MisoString, Topic a) -> Mailbox -> MisoString -> JSM ()
subscribeToMailbox (MisoString, Topic message)
key Mailbox
mailbox MisoString
vcompId
where
subscribeToMailbox :: (MisoString, Topic a) -> Mailbox -> MisoString -> JSM ()
subscribeToMailbox (MisoString, Topic a)
key Mailbox
mailbox MisoString
vcompId = do
threadId <- JSM () -> JSM ThreadId
FFI.forkJSM (JSM () -> JSM ThreadId) -> JSM () -> JSM ThreadId
forall a b. (a -> b) -> a -> b
$ do
clonedMailbox <- IO Mailbox -> JSM Mailbox
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Mailbox -> IO Mailbox
copyMailbox Mailbox
mailbox)
ComponentState {..} <- (M.! vcompId) <$> liftIO (readIORef components)
forever $ do
message <- liftIO (readMail clonedMailbox)
componentSink $ toAction (fromJSON message)
liftIO $ atomicModifyIORef' subscribers $ \Map (MisoString, Topic a) ThreadId
m ->
((MisoString, Topic a)
-> ThreadId
-> Map (MisoString, Topic a) ThreadId
-> Map (MisoString, Topic a) ThreadId
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (MisoString, Topic a)
key ThreadId
threadId Map (MisoString, Topic a) ThreadId
m, ())
unsubscribe :: Topic message -> Effect model action
unsubscribe :: forall message model action. Topic message -> Effect model action
unsubscribe Topic message
topicName = RWST MisoString [Sink action -> JSM ()] model Identity MisoString
forall r (m :: * -> *). MonadReader r m => m r
ask RWST MisoString [Sink action -> JSM ()] model Identity MisoString
-> (MisoString
-> RWST MisoString [Sink action -> JSM ()] model Identity ())
-> RWST MisoString [Sink action -> JSM ()] model Identity ()
forall a b.
RWST MisoString [Sink action -> JSM ()] model Identity a
-> (a -> RWST MisoString [Sink action -> JSM ()] model Identity b)
-> RWST MisoString [Sink action -> JSM ()] model Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= JSM () -> RWST MisoString [Sink action -> JSM ()] model Identity ()
forall model action. JSM () -> Effect model action
io_ (JSM ()
-> RWST MisoString [Sink action -> JSM ()] model Identity ())
-> (MisoString -> JSM ())
-> MisoString
-> RWST MisoString [Sink action -> JSM ()] model Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Topic message -> MisoString -> JSM ()
forall message. Topic message -> MisoString -> JSM ()
unsubscribe_ Topic message
topicName
unsubscribe_ :: Topic message -> ComponentId -> JSM ()
unsubscribe_ :: forall message. Topic message -> MisoString -> JSM ()
unsubscribe_ Topic message
topicName MisoString
vcompId = do
let key :: (MisoString, Topic message)
key = (MisoString
vcompId, Topic message
topicName)
subscribersMap <- IO (Map (MisoString, Topic message) ThreadId)
-> JSM (Map (MisoString, Topic message) ThreadId)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Map (MisoString, Topic message) ThreadId)
-> IO (Map (MisoString, Topic message) ThreadId)
forall a. IORef a -> IO a
readIORef IORef (Map (MisoString, Topic message) ThreadId)
forall a. IORef (Map (MisoString, Topic a) ThreadId)
subscribers)
case M.lookup key subscribersMap of
Just ThreadId
threadId -> do
IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
ThreadId -> IO ()
killThread ThreadId
threadId
IORef (Map (MisoString, Topic message) ThreadId)
-> (Map (MisoString, Topic message) ThreadId
-> (Map (MisoString, Topic message) ThreadId, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map (MisoString, Topic message) ThreadId)
forall a. IORef (Map (MisoString, Topic a) ThreadId)
subscribers ((Map (MisoString, Topic message) ThreadId
-> (Map (MisoString, Topic message) ThreadId, ()))
-> IO ())
-> (Map (MisoString, Topic message) ThreadId
-> (Map (MisoString, Topic message) ThreadId, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map (MisoString, Topic message) ThreadId
m ->
((MisoString, Topic message)
-> Map (MisoString, Topic message) ThreadId
-> Map (MisoString, Topic message) ThreadId
forall k a. Ord k => k -> Map k a -> Map k a
M.delete (MisoString, Topic message)
key Map (MisoString, Topic message) ThreadId
m, ())
Maybe ThreadId
Nothing ->
() -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
publish :: ToJSON message => Topic message -> message -> Effect model action
publish :: forall message model action.
ToJSON message =>
Topic message -> message -> Effect model action
publish Topic message
topicName message
value = JSM () -> Effect model action
forall model action. JSM () -> Effect model action
io_ (JSM () -> Effect model action) -> JSM () -> Effect model action
forall a b. (a -> b) -> a -> b
$ do
result <- Topic message -> Map (Topic message) Mailbox -> Maybe Mailbox
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Topic message
topicName (Map (Topic message) Mailbox -> Maybe Mailbox)
-> JSM (Map (Topic message) Mailbox) -> JSM (Maybe Mailbox)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map (Topic message) Mailbox)
-> JSM (Map (Topic message) Mailbox)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Map (Topic message) Mailbox)
-> IO (Map (Topic message) Mailbox)
forall a. IORef a -> IO a
readIORef IORef (Map (Topic message) Mailbox)
forall a. IORef (Map (Topic a) Mailbox)
mailboxes)
case result of
Just Mailbox
mailbox ->
IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ Mailbox -> Mail -> IO ()
sendMail Mailbox
mailbox (message -> Mail
forall a. ToJSON a => a -> Mail
toJSON message
value)
Maybe Mailbox
Nothing -> IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
mailbox <- IO Mailbox
newMailbox
void $ atomicModifyIORef' mailboxes $ \Map (Topic message) Mailbox
m -> (Topic message
-> Mailbox
-> Map (Topic message) Mailbox
-> Map (Topic message) Mailbox
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Topic message
topicName Mailbox
mailbox Map (Topic message) Mailbox
m, ())
subIds :: IORef Int
{-# NOINLINE subIds #-}
subIds :: IORef Int
subIds = IO (IORef Int) -> IORef Int
forall a. IO a -> a
unsafePerformIO (IO (IORef Int) -> IORef Int) -> IO (IORef Int) -> IORef Int
forall a b. (a -> b) -> a -> b
$ IO (IORef Int) -> IO (IORef Int)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0)
freshSubId :: IO MisoString
freshSubId :: IO MisoString
freshSubId = do
x <- IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
subIds ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
y -> (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
y)
pure ("miso-sub-id-" <> ms x)
componentIds :: IORef Int
{-# NOINLINE componentIds #-}
componentIds :: IORef Int
componentIds = IO (IORef Int) -> IORef Int
forall a. IO a -> a
unsafePerformIO (IO (IORef Int) -> IORef Int) -> IO (IORef Int) -> IORef Int
forall a b. (a -> b) -> a -> b
$ IO (IORef Int) -> IO (IORef Int)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0)
type ComponentId = MisoString
freshComponentId :: IO ComponentId
freshComponentId :: IO MisoString
freshComponentId = do
x <- IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
componentIds ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
y -> (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
y)
pure ("miso-component-id-" <> ms x)
components :: IORef (Map MisoString (ComponentState model action))
{-# NOINLINE components #-}
components :: forall model action.
IORef (Map MisoString (ComponentState model action))
components = IO (IORef (Map MisoString (ComponentState model action)))
-> IORef (Map MisoString (ComponentState model action))
forall a. IO a -> a
unsafePerformIO (Map MisoString (ComponentState model action)
-> IO (IORef (Map MisoString (ComponentState model action)))
forall a. a -> IO (IORef a)
newIORef Map MisoString (ComponentState model action)
forall a. Monoid a => a
mempty)
data Synchronicity
= Async
| Sync
deriving (Int -> Synchronicity -> ShowS
[Synchronicity] -> ShowS
Synchronicity -> String
(Int -> Synchronicity -> ShowS)
-> (Synchronicity -> String)
-> ([Synchronicity] -> ShowS)
-> Show Synchronicity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Synchronicity -> ShowS
showsPrec :: Int -> Synchronicity -> ShowS
$cshow :: Synchronicity -> String
show :: Synchronicity -> String
$cshowList :: [Synchronicity] -> ShowS
showList :: [Synchronicity] -> ShowS
Show, Synchronicity -> Synchronicity -> Bool
(Synchronicity -> Synchronicity -> Bool)
-> (Synchronicity -> Synchronicity -> Bool) -> Eq Synchronicity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Synchronicity -> Synchronicity -> Bool
== :: Synchronicity -> Synchronicity -> Bool
$c/= :: Synchronicity -> Synchronicity -> Bool
/= :: Synchronicity -> Synchronicity -> Bool
Eq)
syncWith :: Synchronicity -> JSM () -> JSM ()
syncWith :: Synchronicity -> JSM () -> JSM ()
syncWith Synchronicity
Sync JSM ()
x = JSM ()
x
syncWith Synchronicity
Async JSM ()
x = JSM ThreadId -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM () -> JSM ThreadId
FFI.forkJSM JSM ()
x)
foldEffects
:: (action -> Effect model action)
-> Synchronicity
-> ComponentId
-> Sink action
-> [action]
-> model
-> JSM model
foldEffects :: forall action model.
(action -> Effect model action)
-> Synchronicity
-> MisoString
-> Sink action
-> [action]
-> model
-> JSM model
foldEffects action -> Effect model action
_ Synchronicity
_ MisoString
_ Sink action
_ [] model
m = model -> JSM model
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure model
m
foldEffects action -> Effect model action
update Synchronicity
synchronicity MisoString
componentId Sink action
snk (action
e:[action]
es) model
o =
case Effect model action
-> MisoString -> model -> (model, [Sink action -> JSM ()])
forall model action.
Effect model action
-> MisoString -> model -> (model, [Sink action -> JSM ()])
runEffect (action -> Effect model action
update action
e) MisoString
componentId model
o of
(model
n, [Sink action -> JSM ()]
subs) -> do
[Sink action -> JSM ()]
-> ((Sink action -> JSM ()) -> JSM ()) -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Sink action -> JSM ()]
subs (((Sink action -> JSM ()) -> JSM ()) -> JSM ())
-> ((Sink action -> JSM ()) -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \Sink action -> JSM ()
sub -> do
Synchronicity -> JSM () -> JSM ()
syncWith Synchronicity
synchronicity (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$
Sink action -> JSM ()
sub Sink action
snk JSM () -> (SomeException -> JSM ()) -> JSM ()
forall e a.
(HasCallStack, Exception e) =>
JSM a -> (e -> JSM a) -> JSM a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (JSM () -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM () -> JSM ())
-> (SomeException -> JSM ()) -> SomeException -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> JSM ()
exception)
(action -> Effect model action)
-> Synchronicity
-> MisoString
-> Sink action
-> [action]
-> model
-> JSM model
forall action model.
(action -> Effect model action)
-> Synchronicity
-> MisoString
-> Sink action
-> [action]
-> model
-> JSM model
foldEffects action -> Effect model action
update Synchronicity
synchronicity MisoString
componentId Sink action
snk [action]
es model
n
where
exception :: SomeException -> JSM ()
exception :: SomeException -> JSM ()
exception SomeException
ex = MisoString -> JSM ()
FFI.consoleError (MisoString
"[EXCEPTION]: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> SomeException -> MisoString
forall str. ToMisoString str => str -> MisoString
ms SomeException
ex)
drawComponent
:: Hydrate
-> DOMRef
-> Component model action
-> Sink action
-> JSM (JSVal, IORef VTree)
drawComponent :: forall model action.
Hydrate
-> DOMRef
-> Component model action
-> Sink action
-> JSM (DOMRef, IORef VTree)
drawComponent Hydrate
hydrate DOMRef
mountElement Component {model
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View action
action -> Effect model action
logLevel :: forall model action. Component model action -> LogLevel
mountPoint :: forall model action. Component model action -> Maybe MisoString
initialAction :: forall model action. Component model action -> Maybe action
styles :: forall model action. Component model action -> [CSS]
events :: forall model action. Component model action -> Events
subs :: forall model action. Component model action -> [Sub action]
view :: forall model action. Component model action -> model -> View action
update :: forall model action.
Component model action -> action -> Effect model action
model :: forall model action. Component model action -> model
model :: model
update :: action -> Effect model action
view :: model -> View action
subs :: [Sub action]
events :: Events
styles :: [CSS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
..} Sink action
snk = do
vtree <- Hydrate
-> View action -> Sink action -> LogLevel -> Events -> JSM VTree
forall action.
Hydrate
-> View action -> Sink action -> LogLevel -> Events -> JSM VTree
runView Hydrate
hydrate (model -> View action
view model
model) Sink action
snk LogLevel
logLevel Events
events
when (hydrate == Draw) (diff Nothing (Just vtree) mountElement)
ref <- liftIO (newIORef vtree)
pure (mountElement, ref)
drain
:: Component model action
-> ComponentState model action
-> JSM ()
drain :: forall model action.
Component model action -> ComponentState model action -> JSM ()
drain app :: Component model action
app@Component{model
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View action
action -> Effect model action
logLevel :: forall model action. Component model action -> LogLevel
mountPoint :: forall model action. Component model action -> Maybe MisoString
initialAction :: forall model action. Component model action -> Maybe action
styles :: forall model action. Component model action -> [CSS]
events :: forall model action. Component model action -> Events
subs :: forall model action. Component model action -> [Sub action]
view :: forall model action. Component model action -> model -> View action
update :: forall model action.
Component model action -> action -> Effect model action
model :: forall model action. Component model action -> model
model :: model
update :: action -> Effect model action
view :: model -> View action
subs :: [Sub action]
events :: Events
styles :: [CSS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
..} cs :: ComponentState model action
cs@ComponentState {MisoString
IORef model
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
DOMRef
action -> JSM ()
componentActions :: forall model action.
ComponentState model action -> IORef (Seq action)
componentModel :: forall model action. ComponentState model action -> IORef model
componentSink :: forall model action.
ComponentState model action -> action -> JSM ()
componentVTree :: forall model action. ComponentState model action -> IORef VTree
componentMount :: forall model action. ComponentState model action -> DOMRef
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentId :: forall model action. ComponentState model action -> MisoString
componentId :: MisoString
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: DOMRef
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: IORef model
componentActions :: IORef (Seq action)
..} = do
actions <- IO (Seq action) -> JSM (Seq action)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Seq action) -> JSM (Seq action))
-> IO (Seq action) -> JSM (Seq action)
forall a b. (a -> b) -> a -> b
$ IORef (Seq action)
-> (Seq action -> (Seq action, Seq action)) -> IO (Seq action)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Seq action)
componentActions ((Seq action -> (Seq action, Seq action)) -> IO (Seq action))
-> (Seq action -> (Seq action, Seq action)) -> IO (Seq action)
forall a b. (a -> b) -> a -> b
$ \Seq action
actions -> (Seq action
forall a. Seq a
S.empty, Seq action
actions)
if S.null actions then pure () else go actions
where
go :: t action -> JSM ()
go t action
as = do
x <- IO model -> JSM model
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef model -> IO model
forall a. IORef a -> IO a
readIORef IORef model
componentModel)
y <- foldEffects update Sync componentId componentSink (toList as) x
liftIO (atomicWriteIORef componentModel y)
drain app cs
unmount
:: Function
-> Component model action
-> ComponentState model action
-> JSM ()
unmount :: forall model action.
Function
-> Component model action -> ComponentState model action -> JSM ()
unmount Function
mountCallback app :: Component model action
app@Component {model
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View action
action -> Effect model action
logLevel :: forall model action. Component model action -> LogLevel
mountPoint :: forall model action. Component model action -> Maybe MisoString
initialAction :: forall model action. Component model action -> Maybe action
styles :: forall model action. Component model action -> [CSS]
events :: forall model action. Component model action -> Events
subs :: forall model action. Component model action -> [Sub action]
view :: forall model action. Component model action -> model -> View action
update :: forall model action.
Component model action -> action -> Effect model action
model :: forall model action. Component model action -> model
model :: model
update :: action -> Effect model action
view :: model -> View action
subs :: [Sub action]
events :: Events
styles :: [CSS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
..} cs :: ComponentState model action
cs@ComponentState {MisoString
IORef model
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
DOMRef
action -> JSM ()
componentActions :: forall model action.
ComponentState model action -> IORef (Seq action)
componentModel :: forall model action. ComponentState model action -> IORef model
componentSink :: forall model action.
ComponentState model action -> action -> JSM ()
componentVTree :: forall model action. ComponentState model action -> IORef VTree
componentMount :: forall model action. ComponentState model action -> DOMRef
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentId :: forall model action. ComponentState model action -> MisoString
componentId :: MisoString
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: DOMRef
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: IORef model
componentActions :: IORef (Seq action)
..} = do
DOMRef -> IORef VTree -> Events -> Bool -> JSM ()
undelegator DOMRef
componentMount IORef VTree
componentVTree Events
events (LogLevel
logLevel LogLevel -> [LogLevel] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [LogLevel
DebugEvents, LogLevel
DebugAll])
Function -> JSM ()
freeFunction Function
mountCallback
IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((ThreadId -> IO ()) -> Map MisoString ThreadId -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread (Map MisoString ThreadId -> IO ())
-> IO (Map MisoString ThreadId) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Map MisoString ThreadId) -> IO (Map MisoString ThreadId)
forall a. IORef a -> IO a
readIORef IORef (Map MisoString ThreadId)
componentSubThreads)
MisoString -> JSM ()
killSubscribers MisoString
componentId
Component model action -> ComponentState model action -> JSM ()
forall model action.
Component model action -> ComponentState model action -> JSM ()
drain Component model action
app ComponentState model action
cs
IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ IORef (Map MisoString (ComponentState (ZonkAny 5) (ZonkAny 6)))
-> (Map MisoString (ComponentState (ZonkAny 5) (ZonkAny 6))
-> (Map MisoString (ComponentState (ZonkAny 5) (ZonkAny 6)), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map MisoString (ComponentState (ZonkAny 5) (ZonkAny 6)))
forall model action.
IORef (Map MisoString (ComponentState model action))
components ((Map MisoString (ComponentState (ZonkAny 5) (ZonkAny 6))
-> (Map MisoString (ComponentState (ZonkAny 5) (ZonkAny 6)), ()))
-> IO ())
-> (Map MisoString (ComponentState (ZonkAny 5) (ZonkAny 6))
-> (Map MisoString (ComponentState (ZonkAny 5) (ZonkAny 6)), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map MisoString (ComponentState (ZonkAny 5) (ZonkAny 6))
m -> (MisoString
-> Map MisoString (ComponentState (ZonkAny 5) (ZonkAny 6))
-> Map MisoString (ComponentState (ZonkAny 5) (ZonkAny 6))
forall k a. Ord k => k -> Map k a -> Map k a
M.delete MisoString
componentId Map MisoString (ComponentState (ZonkAny 5) (ZonkAny 6))
m, ())
killSubscribers :: ComponentId -> JSM ()
killSubscribers :: MisoString -> JSM ()
killSubscribers MisoString
componentId =
(Topic (ZonkAny 4) -> JSM ()) -> [Topic (ZonkAny 4)] -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Topic (ZonkAny 4) -> MisoString -> JSM ())
-> MisoString -> Topic (ZonkAny 4) -> JSM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Topic (ZonkAny 4) -> MisoString -> JSM ()
forall message. Topic message -> MisoString -> JSM ()
unsubscribe_ MisoString
componentId) ([Topic (ZonkAny 4)] -> JSM ())
-> JSM [Topic (ZonkAny 4)] -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
Map (Topic (ZonkAny 4)) Mailbox -> [Topic (ZonkAny 4)]
forall k a. Map k a -> [k]
M.keys (Map (Topic (ZonkAny 4)) Mailbox -> [Topic (ZonkAny 4)])
-> JSM (Map (Topic (ZonkAny 4)) Mailbox) -> JSM [Topic (ZonkAny 4)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map (Topic (ZonkAny 4)) Mailbox)
-> JSM (Map (Topic (ZonkAny 4)) Mailbox)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Map (Topic (ZonkAny 4)) Mailbox)
-> IO (Map (Topic (ZonkAny 4)) Mailbox)
forall a. IORef a -> IO a
readIORef IORef (Map (Topic (ZonkAny 4)) Mailbox)
forall a. IORef (Map (Topic a) Mailbox)
mailboxes)
runView
:: Hydrate
-> View action
-> Sink action
-> LogLevel
-> Events
-> JSM VTree
runView :: forall action.
Hydrate
-> View action -> Sink action -> LogLevel -> Events -> JSM VTree
runView Hydrate
hydrate (VComp [Attribute action]
attrs (SomeComponent Component model action
app)) Sink action
snk LogLevel
_ Events
_ = do
componentId <- IO MisoString -> JSM MisoString
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO MisoString
freshComponentId
mountCallback <- do
FFI.syncCallback2 $ \DOMRef
domRef DOMRef
continuation -> do
vtreeRef <- Component model action
-> (Sink action -> JSM (DOMRef, IORef VTree)) -> JSM (IORef VTree)
forall model action.
Eq model =>
Component model action
-> (Sink action -> JSM (DOMRef, IORef VTree)) -> JSM (IORef VTree)
initialize Component model action
app (Hydrate
-> DOMRef
-> Component model action
-> Sink action
-> JSM (DOMRef, IORef VTree)
forall model action.
Hydrate
-> DOMRef
-> Component model action
-> Sink action
-> JSM (DOMRef, IORef VTree)
drawComponent Hydrate
hydrate DOMRef
domRef Component model action
app)
VTree vtree <- liftIO (readIORef vtreeRef)
void $ call continuation global [vtree]
unmountCallback <- toJSVal =<< do
FFI.syncCallback $ do
M.lookup componentId <$> liftIO (readIORef components) >>= \case
Maybe (ComponentState model action)
Nothing -> () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just ComponentState model action
componentState ->
Function
-> Component model action -> ComponentState model action -> JSM ()
forall model action.
Function
-> Component model action -> ComponentState model action -> JSM ()
unmount Function
mountCallback Component model action
app ComponentState model action
componentState
vcomp <- createNode "vcomp" HTML "div"
setAttrs vcomp attrs snk (logLevel app) (events app)
flip (FFI.set "children") vcomp =<< toJSVal ([] :: [MisoString])
FFI.set "component-id" componentId vcomp
flip (FFI.set "mount") vcomp =<< toJSVal mountCallback
FFI.set "unmount" unmountCallback vcomp
pure (VTree vcomp)
runView Hydrate
hydrate (VNode NS
ns MisoString
tag [Attribute action]
attrs [View action]
kids) Sink action
snk LogLevel
logLevel Events
events = do
vnode <- MisoString -> NS -> MisoString -> JSM Object
createNode MisoString
"vnode" NS
ns MisoString
tag
setAttrs vnode attrs snk logLevel events
vchildren <- ghcjsPure . jsval =<< procreate
FFI.set "children" vchildren vnode
sync <- FFI.shouldSync =<< toJSVal vnode
FFI.set "shouldSync" sync vnode
pure $ VTree vnode
where
procreate :: JSM (SomeJSArray m)
procreate = do
kidsViews <- [View action] -> (View action -> JSM DOMRef) -> JSM [DOMRef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [View action]
kids ((View action -> JSM DOMRef) -> JSM [DOMRef])
-> (View action -> JSM DOMRef) -> JSM [DOMRef]
forall a b. (a -> b) -> a -> b
$ \View action
kid -> do
VTree (Object vtree) <- Hydrate
-> View action -> Sink action -> LogLevel -> Events -> JSM VTree
forall action.
Hydrate
-> View action -> Sink action -> LogLevel -> Events -> JSM VTree
runView Hydrate
hydrate View action
kid Sink action
snk LogLevel
logLevel Events
events
pure vtree
ghcjsPure (JSArray.fromList kidsViews)
runView Hydrate
_ (VText MisoString
t) Sink action
_ LogLevel
_ Events
_ = do
vtree <- JSM Object
create
FFI.set "type" ("vtext" :: JSString) vtree
FFI.set "ns" ("text" :: JSString) vtree
FFI.set "text" t vtree
pure $ VTree vtree
runView Hydrate
hydrate (VTextRaw MisoString
str) Sink action
snk LogLevel
logLevel Events
events =
case MisoString -> [View action]
forall a. MisoString -> [View a]
parseView MisoString
str of
[] ->
Hydrate
-> View action -> Sink action -> LogLevel -> Events -> JSM VTree
forall action.
Hydrate
-> View action -> Sink action -> LogLevel -> Events -> JSM VTree
runView Hydrate
hydrate (MisoString -> View action
forall action. MisoString -> View action
VText (MisoString
" " :: MisoString)) Sink action
snk LogLevel
logLevel Events
events
[View action
parent] ->
Hydrate
-> View action -> Sink action -> LogLevel -> Events -> JSM VTree
forall action.
Hydrate
-> View action -> Sink action -> LogLevel -> Events -> JSM VTree
runView Hydrate
hydrate View action
parent Sink action
snk LogLevel
logLevel Events
events
[View action]
kids -> do
Hydrate
-> View action -> Sink action -> LogLevel -> Events -> JSM VTree
forall action.
Hydrate
-> View action -> Sink action -> LogLevel -> Events -> JSM VTree
runView Hydrate
hydrate (NS
-> MisoString -> [Attribute action] -> [View action] -> View action
forall action.
NS
-> MisoString -> [Attribute action] -> [View action] -> View action
VNode NS
HTML MisoString
"div" [Attribute action]
forall a. Monoid a => a
mempty [View action]
kids) Sink action
snk LogLevel
logLevel Events
events
createNode :: MisoString -> NS -> MisoString -> JSM Object
createNode :: MisoString -> NS -> MisoString -> JSM Object
createNode MisoString
typ NS
ns MisoString
tag = do
vnode <- JSM Object
create
cssObj <- create
propsObj <- create
eventsObj <- create
FFI.set "css" cssObj vnode
FFI.set "type" typ vnode
FFI.set "props" propsObj vnode
FFI.set "events" eventsObj vnode
FFI.set "ns" ns vnode
FFI.set "tag" tag vnode
pure vnode
setAttrs
:: Object
-> [Attribute action]
-> Sink action
-> LogLevel
-> Events
-> JSM ()
setAttrs :: forall action.
Object
-> [Attribute action]
-> Sink action
-> LogLevel
-> Events
-> JSM ()
setAttrs Object
vnode [Attribute action]
attrs Sink action
snk LogLevel
logLevel Events
events =
[Attribute action] -> (Attribute action -> JSM ()) -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Attribute action]
attrs ((Attribute action -> JSM ()) -> JSM ())
-> (Attribute action -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \case
Property MisoString
"key" Mail
v -> do
value <- Mail -> JSM DOMRef
forall a. ToJSVal a => a -> JSM DOMRef
toJSVal Mail
v
FFI.set "key" value vnode
Property MisoString
k Mail
v -> do
value <- Mail -> JSM DOMRef
forall a. ToJSVal a => a -> JSM DOMRef
toJSVal Mail
v
o <- getProp "props" vnode
FFI.set k value (Object o)
Event Sink action -> Object -> LogLevel -> Events -> JSM ()
attr -> Sink action -> Object -> LogLevel -> Events -> JSM ()
attr Sink action
snk Object
vnode LogLevel
logLevel Events
events
Styles Map MisoString MisoString
styles -> do
cssObj <- JSString -> Object -> JSM DOMRef
getProp JSString
"css" Object
vnode
forM_ (M.toList styles) $ \(MisoString
k,MisoString
v) -> do
MisoString -> MisoString -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
FFI.set MisoString
k MisoString
v (DOMRef -> Object
Object DOMRef
cssObj)
parseView :: MisoString -> [View a]
parseView :: forall a. MisoString -> [View a]
parseView MisoString
html = [View a] -> [View a]
forall a. [a] -> [a]
reverse ([TagTree MisoString] -> [View a] -> [View a]
forall {action}.
[TagTree MisoString] -> [View action] -> [View action]
go (MisoString -> [TagTree MisoString]
forall str. StringLike str => str -> [TagTree str]
parseTree MisoString
html) [])
where
go :: [TagTree MisoString] -> [View action] -> [View action]
go [] [View action]
xs = [View action]
xs
go (TagLeaf (TagText MisoString
s) : [TagTree MisoString]
next) [View action]
views =
[TagTree MisoString] -> [View action] -> [View action]
go [TagTree MisoString]
next (MisoString -> View action
forall action. MisoString -> View action
VText MisoString
s View action -> [View action] -> [View action]
forall a. a -> [a] -> [a]
: [View action]
views)
go (TagLeaf (TagOpen MisoString
name [(MisoString, MisoString)]
attrs) : [TagTree MisoString]
next) [View action]
views =
[TagTree MisoString] -> [View action] -> [View action]
go (MisoString
-> [(MisoString, MisoString)]
-> [TagTree MisoString]
-> TagTree MisoString
forall str. str -> [Attribute str] -> [TagTree str] -> TagTree str
TagBranch MisoString
name [(MisoString, MisoString)]
attrs [] TagTree MisoString -> [TagTree MisoString] -> [TagTree MisoString]
forall a. a -> [a] -> [a]
: [TagTree MisoString]
next) [View action]
views
go (TagBranch MisoString
name [(MisoString, MisoString)]
attrs [TagTree MisoString]
kids : [TagTree MisoString]
next) [View action]
views =
let
attrs' :: [Attribute action]
attrs' = [ MisoString -> MisoString -> Attribute action
forall action. MisoString -> MisoString -> Attribute action
textProp MisoString
key MisoString
value
| (MisoString
key, MisoString
value) <- [(MisoString, MisoString)]
attrs
]
newNode :: View action
newNode =
NS
-> MisoString -> [Attribute action] -> [View action] -> View action
forall action.
NS
-> MisoString -> [Attribute action] -> [View action] -> View action
VNode NS
HTML MisoString
name [Attribute action]
forall {action}. [Attribute action]
attrs' ([View action] -> [View action]
forall a. [a] -> [a]
reverse ([TagTree MisoString] -> [View action] -> [View action]
go [TagTree MisoString]
kids []))
in
[TagTree MisoString] -> [View action] -> [View action]
go [TagTree MisoString]
next (View action
newNodeView action -> [View action] -> [View action]
forall a. a -> [a] -> [a]
:[View action]
views)
go (TagLeaf Tag MisoString
_ : [TagTree MisoString]
next) [View action]
views =
[TagTree MisoString] -> [View action] -> [View action]
go [TagTree MisoString]
next [View action]
views
registerComponent :: MonadIO m => ComponentState model action -> m ()
registerComponent :: forall (m :: * -> *) model action.
MonadIO m =>
ComponentState model action -> m ()
registerComponent ComponentState model action
componentState = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Map MisoString (ComponentState model action))
-> (Map MisoString (ComponentState model action)
-> Map MisoString (ComponentState model action))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map MisoString (ComponentState model action))
forall model action.
IORef (Map MisoString (ComponentState model action))
components
((Map MisoString (ComponentState model action)
-> Map MisoString (ComponentState model action))
-> IO ())
-> (Map MisoString (ComponentState model action)
-> Map MisoString (ComponentState model action))
-> IO ()
forall a b. (a -> b) -> a -> b
$ MisoString
-> ComponentState model action
-> Map MisoString (ComponentState model action)
-> Map MisoString (ComponentState model action)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (ComponentState model action -> MisoString
forall model action. ComponentState model action -> MisoString
componentId ComponentState model action
componentState) ComponentState model action
componentState
renderStyles :: [CSS] -> JSM ()
renderStyles :: [CSS] -> JSM ()
renderStyles [CSS]
styles =
[CSS] -> (CSS -> JSM ()) -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [CSS]
styles ((CSS -> JSM ()) -> JSM ()) -> (CSS -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \case
Href MisoString
url -> MisoString -> JSM ()
FFI.addStyleSheet MisoString
url
Style MisoString
css -> MisoString -> JSM ()
FFI.addStyle MisoString
css
Sheet StyleSheet
sheet -> MisoString -> JSM ()
FFI.addStyle (StyleSheet -> MisoString
renderStyleSheet StyleSheet
sheet)
startSub :: ToMisoString subKey => subKey -> Sub action -> Effect model action
startSub :: forall subKey action model.
ToMisoString subKey =>
subKey -> Sub action -> Effect model action
startSub subKey
subKey Sink action -> JSM ()
sub = do
compName <- RWST MisoString [Sink action -> JSM ()] model Identity MisoString
forall r (m :: * -> *). MonadReader r m => m r
ask
io_
(M.lookup compName <$> liftIO (readIORef components) >>= \case
Maybe (ComponentState (ZonkAny 0) action)
Nothing -> () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just compState :: ComponentState (ZonkAny 0) action
compState@ComponentState {MisoString
IORef (ZonkAny 0)
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
DOMRef
Sink action
componentActions :: forall model action.
ComponentState model action -> IORef (Seq action)
componentModel :: forall model action. ComponentState model action -> IORef model
componentSink :: forall model action.
ComponentState model action -> action -> JSM ()
componentVTree :: forall model action. ComponentState model action -> IORef VTree
componentMount :: forall model action. ComponentState model action -> DOMRef
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentId :: forall model action. ComponentState model action -> MisoString
componentId :: MisoString
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: DOMRef
componentVTree :: IORef VTree
componentSink :: Sink action
componentModel :: IORef (ZonkAny 0)
componentActions :: IORef (Seq action)
..} -> do
mtid <- IO (Maybe ThreadId) -> JSM (Maybe ThreadId)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MisoString -> Map MisoString ThreadId -> Maybe ThreadId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (subKey -> MisoString
forall str. ToMisoString str => str -> MisoString
ms subKey
subKey) (Map MisoString ThreadId -> Maybe ThreadId)
-> IO (Map MisoString ThreadId) -> IO (Maybe ThreadId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map MisoString ThreadId) -> IO (Map MisoString ThreadId)
forall a. IORef a -> IO a
readIORef IORef (Map MisoString ThreadId)
componentSubThreads)
case mtid of
Maybe ThreadId
Nothing ->
ComponentState (ZonkAny 0) action -> JSM ()
forall {model}. ComponentState model action -> JSM ()
startThread ComponentState (ZonkAny 0) action
compState
Just ThreadId
tid -> do
status <- IO ThreadStatus -> JSM ThreadStatus
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ThreadId -> IO ThreadStatus
threadStatus ThreadId
tid)
case status of
ThreadStatus
ThreadFinished -> ComponentState (ZonkAny 0) action -> JSM ()
forall {model}. ComponentState model action -> JSM ()
startThread ComponentState (ZonkAny 0) action
compState
ThreadStatus
ThreadDied -> ComponentState (ZonkAny 0) action -> JSM ()
forall {model}. ComponentState model action -> JSM ()
startThread ComponentState (ZonkAny 0) action
compState
ThreadStatus
_ -> () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
where
startThread :: ComponentState model action -> JSM ()
startThread ComponentState {MisoString
IORef model
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
DOMRef
Sink action
componentActions :: forall model action.
ComponentState model action -> IORef (Seq action)
componentModel :: forall model action. ComponentState model action -> IORef model
componentSink :: forall model action.
ComponentState model action -> action -> JSM ()
componentVTree :: forall model action. ComponentState model action -> IORef VTree
componentMount :: forall model action. ComponentState model action -> DOMRef
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentId :: forall model action. ComponentState model action -> MisoString
componentId :: MisoString
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: DOMRef
componentVTree :: IORef VTree
componentSink :: Sink action
componentModel :: IORef model
componentActions :: IORef (Seq action)
..} = do
tid <- JSM () -> JSM ThreadId
FFI.forkJSM (Sink action -> JSM ()
sub Sink action
componentSink)
liftIO $ atomicModifyIORef' componentSubThreads $ \Map MisoString ThreadId
m ->
(MisoString
-> ThreadId -> Map MisoString ThreadId -> Map MisoString ThreadId
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (subKey -> MisoString
forall str. ToMisoString str => str -> MisoString
ms subKey
subKey) ThreadId
tid Map MisoString ThreadId
m, ())
stopSub :: ToMisoString subKey => subKey -> Effect model action
stopSub :: forall subKey model action.
ToMisoString subKey =>
subKey -> Effect model action
stopSub subKey
subKey = do
compName <- RWST MisoString [Sink action -> JSM ()] model Identity MisoString
forall r (m :: * -> *). MonadReader r m => m r
ask
io_
(M.lookup compName <$> liftIO (readIORef components) >>= \case
Maybe (ComponentState (ZonkAny 1) (ZonkAny 2))
Nothing -> do
() -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just ComponentState {MisoString
IORef (ZonkAny 1)
IORef (Map MisoString ThreadId)
IORef (Seq (ZonkAny 2))
IORef VTree
DOMRef
ZonkAny 2 -> JSM ()
componentActions :: forall model action.
ComponentState model action -> IORef (Seq action)
componentModel :: forall model action. ComponentState model action -> IORef model
componentSink :: forall model action.
ComponentState model action -> action -> JSM ()
componentVTree :: forall model action. ComponentState model action -> IORef VTree
componentMount :: forall model action. ComponentState model action -> DOMRef
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentId :: forall model action. ComponentState model action -> MisoString
componentId :: MisoString
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: DOMRef
componentVTree :: IORef VTree
componentSink :: ZonkAny 2 -> JSM ()
componentModel :: IORef (ZonkAny 1)
componentActions :: IORef (Seq (ZonkAny 2))
..} -> do
mtid <- IO (Maybe ThreadId) -> JSM (Maybe ThreadId)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MisoString -> Map MisoString ThreadId -> Maybe ThreadId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (subKey -> MisoString
forall str. ToMisoString str => str -> MisoString
ms subKey
subKey) (Map MisoString ThreadId -> Maybe ThreadId)
-> IO (Map MisoString ThreadId) -> IO (Maybe ThreadId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map MisoString ThreadId) -> IO (Map MisoString ThreadId)
forall a. IORef a -> IO a
readIORef IORef (Map MisoString ThreadId)
componentSubThreads)
forM_ mtid $ \ThreadId
tid ->
IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
IORef (Map MisoString ThreadId)
-> (Map MisoString ThreadId -> (Map MisoString ThreadId, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map MisoString ThreadId)
componentSubThreads ((Map MisoString ThreadId -> (Map MisoString ThreadId, ()))
-> IO ())
-> (Map MisoString ThreadId -> (Map MisoString ThreadId, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map MisoString ThreadId
m -> (MisoString -> Map MisoString ThreadId -> Map MisoString ThreadId
forall k a. Ord k => k -> Map k a -> Map k a
M.delete (subKey -> MisoString
forall str. ToMisoString str => str -> MisoString
ms subKey
subKey) Map MisoString ThreadId
m, ())
ThreadId -> IO ()
killThread ThreadId
tid)