-----------------------------------------------------------------------------
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Runtime
-- Copyright   :  (C) 2016-2025 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
-----------------------------------------------------------------------------
module Miso.Runtime
  ( -- * Internal functions
    initialize
  , freshComponentId
  , runView
  , renderStyles
  , renderScripts
  , Hydrate(..)
  -- * Subscription
  , startSub
  , stopSub
  -- * Pub / Sub
  , subscribe
  , unsubscribe
  , publish
  , Topic (..)
  , topic
  -- * Component
  , getComponentId
  , getParentComponentId
  , ComponentState
  -- * Mailbox
  , mail
  ) 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           Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM
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_, withSink)
-----------------------------------------------------------------------------
-- | Helper function to abstract out initialization of @Component@ between top-level API functions.
initialize
  :: Eq model
  => Component model action
  -> (Sink action -> JSM ([DOMRef], DOMRef, IORef VTree))
  -- ^ Callback function is used to perform the creation of VTree
  -> JSM (ComponentState model action)
initialize :: forall model action.
Eq model =>
Component model action
-> (Sink action -> JSM ([DOMRef], DOMRef, IORef VTree))
-> JSM (ComponentState model action)
initialize Component {model
[JS]
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View action
action -> Effect model action
Mail -> Maybe action
model :: model
update :: action -> Effect model action
view :: model -> View action
subs :: [Sub action]
events :: Events
styles :: [CSS]
scripts :: [JS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
mailbox :: Mail -> Maybe action
mailbox :: forall model action. Component model action -> Mail -> Maybe 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
scripts :: forall model action. Component model action -> [JS]
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], 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
  (componentScripts, 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 componentMount 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)
  componentMailbox <- liftIO newMailbox
  componentMailboxThreadId <- do
    FFI.forkJSM . forever $ do
      message <- liftIO (readMail =<< copyMailbox componentMailbox)
      mapM_ componentSink (mailbox message)
  let vcomp = ComponentState {Int
[DOMRef]
ThreadId
IORef model
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
DOMRef
Mailbox
Sink action
componentActions :: IORef (Seq action)
componentSink :: Sink action
componentId :: Int
componentScripts :: [DOMRef]
componentMount :: DOMRef
componentVTree :: IORef VTree
componentSubThreads :: IORef (Map MisoString ThreadId)
componentModel :: IORef model
componentMailbox :: Mailbox
componentMailboxThreadId :: ThreadId
componentScripts :: [DOMRef]
componentMailboxThreadId :: ThreadId
componentMailbox :: Mailbox
componentActions :: IORef (Seq action)
componentModel :: IORef model
componentSink :: Sink action
componentVTree :: IORef VTree
componentMount :: DOMRef
componentSubThreads :: IORef (Map MisoString ThreadId)
componentId :: Int
..}
  registerComponent vcomp
  delegator componentMount componentVTree events (logLevel `elem` [DebugEvents, DebugAll])
  forM_ initialAction componentSink
  pure vcomp
-----------------------------------------------------------------------------
-- | 'Hydrate' avoids calling @diff@, and instead calls @hydrate@
-- 'Draw' invokes 'diff'
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)
-----------------------------------------------------------------------------
-- | @Component@ state, data associated with the lifetime of a @Component@
data ComponentState model action
  = ComponentState
  { forall model action. ComponentState model action -> Int
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)
  , forall model action. ComponentState model action -> Mailbox
componentMailbox         :: Mailbox
  , forall model action. ComponentState model action -> ThreadId
componentMailboxThreadId :: ThreadId
  , forall model action. ComponentState model action -> [DOMRef]
componentScripts         :: [DOMRef]
  }
-----------------------------------------------------------------------------
-- | A 'Topic' represents a place to send and receive messages. 'Topic' is used to facilitate
-- communication between 'Component'. 'Component' can 'subscribe' to or 'publish' to any 'Topic',
-- within the same 'Component' or across 'Component'.
--
-- This requires creating a custom 'ToJSON' / 'FromJSON'. Any other 'Component'
-- can 'publish' or 'subscribe' to this @Topic message@. It is a way to provide
-- loosely-coupled communication between 'Components'.
--
-- See 'publish', 'subscribe', 'unsubscribe' for more details.
--
-- When distributing 'Component' for third-party use, it is recommended to export
-- the 'Topic', where 'message' is the JSON protocol.
--
--
-- @since 1.9.0.0
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)
-----------------------------------------------------------------------------
-- | Smart constructor for creating a @Topic message@ to write to
--
-- @
--
-- data Message
--   = Increment
--   | Decrement
--   deriving (Show, Eq, Generic, ToJSON, FromJSON)
--
-- arithmetic :: Topic Message
-- arithmetic = topic "arithmetic"
--
-- data Action
--   = Notification (Result Message)
--   | Subscribe
--   | Unsubscribe
--
-- update_ :: Action -> Effect Int Action
-- update_ = \case
--   Unsubscribe ->
--     unsubscribe arithmetic
--   Subscribe ->
--     subscribe arithmetic Notification
--   Notification (Success Increment) ->
--     update_ AddOne
--   Notification (Success Decrement) ->
--     update_ SubtractOne
--   Notification (Error msg) ->
--     io_ $ consoleError ("Decode failure: " <> ms msg)
--
-- @
--
-- @since 1.9.0.0
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 (Int, Topic a) ThreadId)
subscribers = IO (IORef (Map (Int, Topic a) ThreadId))
-> IORef (Map (Int, Topic a) ThreadId)
forall a. IO a -> a
unsafePerformIO (IO (IORef (Map (Int, Topic a) ThreadId))
 -> IORef (Map (Int, Topic a) ThreadId))
-> IO (IORef (Map (Int, Topic a) ThreadId))
-> IORef (Map (Int, Topic a) ThreadId)
forall a b. (a -> b) -> a -> b
$ IO (IORef (Map (Int, Topic a) ThreadId))
-> IO (IORef (Map (Int, Topic a) ThreadId))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Map (Int, Topic a) ThreadId
-> IO (IORef (Map (Int, Topic a) ThreadId))
forall a. a -> IO (IORef a)
newIORef Map (Int, Topic a) ThreadId
forall a. Monoid a => a
mempty)
-----------------------------------------------------------------------------
-- | Subscribes to a 'Topic', provides callback function that writes to 'Component' 'Sink'
--
-- If a @Topic message@ does not exist when calling 'subscribe' it is generated dynamically.
-- Each subscriber decodes the received 'Value' using it's own 'FromJSON' instance. This provides
-- for loose-coupling between 'Component'. As long as the underlying 'Value' are identical
-- 'Component' can use their own types without serialization issues. @Topic message@ should
-- have their own JSON API specification when being distributed.
--
-- @
--
-- arithmetic :: Topic Message
-- arithmetic = topic "arithmetic"
--
-- clientComponent :: MisoString -> Component Int Action
-- clientComponent name = component 0 update_ $ \m ->
--   div_
--   []
--   [ br_ []
--   , text (name <> " : " <> ms (m ^. _id))
--   , button_ [ onClick Unsubscribe ] [ "unsubscribe" ]
--   , button_ [ onClick Subscribe ] [ "subscribe" ]
--   ] where
--       update_ :: Action -> Effect Int Action
--       update_ = \case
--         AddOne -> do
--           _id += 1
--         SubtractOne ->
--           _id -= 1
--         Unsubscribe ->
--           unsubscribe arithmetic
--         Subscribe ->
--           subscribe arithmetic Notification
--         Notification (Success Increment) -> do
--           update_ AddOne
--         Notification (Success Decrement) -> do
--           update_ SubtractOne
--         Notification (Error msg) ->
--           io_ $ consoleError ("Decode failure: " <> ms msg)
--         _ -> pure ()
--
-- @
--
-- @since 1.9.0.0
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
  domRef <- RWST DOMRef [Sink action -> JSM ()] model Identity DOMRef
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    vcompId <- FFI.getComponentId domRef
    subscribersMap <- liftIO (readIORef subscribers)
    let key = (Int
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
            -- no mailbox exists, create a new one, register it and subscribe
            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
            (Int, Topic message) -> Mailbox -> Int -> JSM ()
forall {a}. (Int, Topic a) -> Mailbox -> Int -> JSM ()
subscribeToMailbox (Int, Topic message)
key Mailbox
mailbox Int
vcompId
  where
    subscribeToMailbox :: (Int, Topic a) -> Mailbox -> Int -> JSM ()
subscribeToMailbox (Int, Topic a)
key Mailbox
mailbox Int
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 {..} <- (IM.! vcompId) <$> liftIO (readIORef components)
        forever $ do
          message <- liftIO (readMail clonedMailbox)
          componentSink $ toAction (fromJSON message)
      liftIO $ atomicModifyIORef' subscribers $ \Map (Int, Topic a) ThreadId
m ->
        ((Int, Topic a)
-> ThreadId
-> Map (Int, Topic a) ThreadId
-> Map (Int, Topic a) ThreadId
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Int, Topic a)
key ThreadId
threadId Map (Int, Topic a) ThreadId
m, ())
-----------------------------------------------------------------------------
-- Pub / Sub implementation
--
-- (Subscribe)
--
-- Check if you're already subscribed to this topic.
--
--  [true]  - If you're already subscribed, then it's a no-op (warn)
--
--  [false] - If you're not subscribed then fork a new thread that holds the duplicated topic
--            and blocks on the read end of the duplicated topic, sink messages into component sink
--
-- (Unsubscribe)
--
-- Check if you're already subscribed to this topic
--
--  [true] - Kill the thread, delete the subscriber entry
--
--  [false] - If you're not subscribed, then it's a no-op (warn)
--
-- (Publish)
--
-- Check if the Topic exists
--
--  [true] - If it exists then write the message to the topic
--
--  [false] - If it doesn't exist, create it.
--
-- N.B. Components can be both publishers and subscribers to their own topics.
-----------------------------------------------------------------------------
-- | Unsubscribe to a 'Topic'
--
-- Unsubscribes a 'Component' from receiving messages from @Topic message@
--
-- See 'subscribe' for more use.
--
-- @since 1.9.0.0
unsubscribe :: Topic message -> Effect model action
unsubscribe :: forall message model action. Topic message -> Effect model action
unsubscribe Topic message
topicName = do
  domRef <- RWST DOMRef [Sink action -> JSM ()] model Identity DOMRef
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ (unsubscribe_ topicName =<< FFI.getComponentId domRef)
-----------------------------------------------------------------------------
-- | Internal unsubscribe used in component unmounting and in 'unsubscribe'
unsubscribe_ :: Topic message -> ComponentId -> JSM ()
unsubscribe_ :: forall message. Topic message -> Int -> JSM ()
unsubscribe_ Topic message
topicName Int
vcompId = do
  let key :: (Int, Topic message)
key = (Int
vcompId, Topic message
topicName)
  subscribersMap <- IO (Map (Int, Topic message) ThreadId)
-> JSM (Map (Int, Topic message) ThreadId)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Map (Int, Topic message) ThreadId)
-> IO (Map (Int, Topic message) ThreadId)
forall a. IORef a -> IO a
readIORef IORef (Map (Int, Topic message) ThreadId)
forall a. IORef (Map (Int, 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 (Int, Topic message) ThreadId)
-> (Map (Int, Topic message) ThreadId
    -> (Map (Int, Topic message) ThreadId, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map (Int, Topic message) ThreadId)
forall a. IORef (Map (Int, Topic a) ThreadId)
subscribers ((Map (Int, Topic message) ThreadId
  -> (Map (Int, Topic message) ThreadId, ()))
 -> IO ())
-> (Map (Int, Topic message) ThreadId
    -> (Map (Int, Topic message) ThreadId, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map (Int, Topic message) ThreadId
m ->
          ((Int, Topic message)
-> Map (Int, Topic message) ThreadId
-> Map (Int, Topic message) ThreadId
forall k a. Ord k => k -> Map k a -> Map k a
M.delete (Int, Topic message)
key Map (Int, Topic message) ThreadId
m, ())
    Maybe ThreadId
Nothing ->
      () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
-----------------------------------------------------------------------------
-- | Publish to a @Topic message@
--
-- @Topic message@ are generated dynamically if they do not exist. When using 'publish'
-- all subscribers are immediately notified of a new message. A message is distributed as a 'Value'
-- The underlying 'ToJSON' instance is used to construct this 'Value'.
--
-- We recommend documenting a public API for the JSON protocol message when distributing a 'Component'
-- downstream to end users for consumption (be it inside a single cabal project or across multiple
-- cabal projects).
--
-- @
--
-- arithmetic :: Topic Message
-- arithmetic = topic "arithmetic"
--
-- server :: Component () Action
-- server = component () update_ $ \() ->
--   div_
--   []
--   [ "Server component"
--   , button_ [ onClick AddOne ] [ "+" ]
--   , button_ [ onClick SubtractOne ] [ "-" ]
--   , component_ (client_ "client 1")
--     [ onMountedWith Mount
--     ]
--   , component_ (client_ "client 2")
--     [ onMountedWith Mount
--     ]
--   ] where
--       update_ :: Action -> Effect () Action
--       update_ = \case
--         AddOne ->
--           publish arithmetic Increment
--         SubtractOne ->
--           publish arithemtic Decrement
--
-- @
--
-- @since 1.9.0.0
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)
-----------------------------------------------------------------------------
freshComponentId :: IO ComponentId
freshComponentId :: IO Int
freshComponentId = 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)
-----------------------------------------------------------------------------
-- | componentMap
--
-- This is a global @Component@ @Map@ that holds the state of all currently
-- mounted @Component@s
components :: IORef (IntMap (ComponentState model action))
{-# NOINLINE components #-}
components :: forall model action. IORef (IntMap (ComponentState model action))
components = IO (IORef (IntMap (ComponentState model action)))
-> IORef (IntMap (ComponentState model action))
forall a. IO a -> a
unsafePerformIO (IntMap (ComponentState model action)
-> IO (IORef (IntMap (ComponentState model action)))
forall a. a -> IO (IORef a)
newIORef IntMap (ComponentState model action)
forall a. Monoid a => a
mempty)
-----------------------------------------------------------------------------
-- | Data type to indicate if effects should be handled asynchronously
-- or synchronously.
--
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)
-----------------------------------------------------------------------------
-- | Helper for processing effects in the event loop.
foldEffects
  :: (action -> Effect model action)
  -> Synchronicity
  -> DOMRef
  -> Sink action
  -> [action]
  -> model
  -> JSM model
foldEffects :: forall action model.
(action -> Effect model action)
-> Synchronicity
-> DOMRef
-> Sink action
-> [action]
-> model
-> JSM model
foldEffects action -> Effect model action
_ Synchronicity
_ DOMRef
_ 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 DOMRef
domRef Sink action
snk (action
e:[action]
es) model
o =
  case Effect model action
-> DOMRef -> model -> (model, [Sink action -> JSM ()])
forall model action.
Effect model action
-> DOMRef -> model -> (model, [Sink action -> JSM ()])
runEffect (action -> Effect model action
update action
e) DOMRef
domRef 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
-> DOMRef
-> Sink action
-> [action]
-> model
-> JSM model
forall action model.
(action -> Effect model action)
-> Synchronicity
-> DOMRef
-> Sink action
-> [action]
-> model
-> JSM model
foldEffects action -> Effect model action
update Synchronicity
synchronicity DOMRef
domRef 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)
--------------------------------------------------
-- | Internally used for runView and startComponent
-- Initial draw helper
-- If hydrateing, bypass diff and continue copying
drawComponent
  :: Hydrate
  -> DOMRef
  -> Component model action
  -> Sink action
  -> JSM ([DOMRef], JSVal, IORef VTree)
drawComponent :: forall model action.
Hydrate
-> DOMRef
-> Component model action
-> Sink action
-> JSM ([DOMRef], DOMRef, IORef VTree)
drawComponent Hydrate
hydrate DOMRef
mountElement Component {model
[JS]
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View action
action -> Effect model action
Mail -> Maybe action
mailbox :: forall model action. Component model action -> Mail -> Maybe 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
scripts :: forall model action. Component model action -> [JS]
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]
scripts :: [JS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
mailbox :: Mail -> Maybe action
..} Sink action
snk = do
  refs <- [DOMRef] -> [DOMRef] -> [DOMRef]
forall a. [a] -> [a] -> [a]
(++) ([DOMRef] -> [DOMRef] -> [DOMRef])
-> JSM [DOMRef] -> JSM ([DOMRef] -> [DOMRef])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [JS] -> JSM [DOMRef]
renderScripts [JS]
scripts JSM ([DOMRef] -> [DOMRef]) -> JSM [DOMRef] -> JSM [DOMRef]
forall a b. JSM (a -> b) -> JSM a -> JSM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [CSS] -> JSM [DOMRef]
renderStyles [CSS]
styles
  vtree <- runView hydrate (view model) snk logLevel events
  when (hydrate == Draw) (diff Nothing (Just vtree) mountElement)
  ref <- liftIO (newIORef vtree)
  pure (refs, mountElement, ref)
-----------------------------------------------------------------------------
-- | Drains the event queue before unmounting, executed synchronously
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
[JS]
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View action
action -> Effect model action
Mail -> Maybe action
mailbox :: forall model action. Component model action -> Mail -> Maybe 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
scripts :: forall model action. Component model action -> [JS]
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]
scripts :: [JS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
mailbox :: Mail -> Maybe action
..} cs :: ComponentState model action
cs@ComponentState {Int
[DOMRef]
ThreadId
IORef model
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
DOMRef
Mailbox
action -> JSM ()
componentScripts :: forall model action. ComponentState model action -> [DOMRef]
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentMailbox :: forall model action. ComponentState model action -> Mailbox
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 -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: DOMRef
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: IORef model
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentMailboxThreadId :: ThreadId
componentScripts :: [DOMRef]
..} = 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
  unloadScripts cs
      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 componentMount componentSink (toList as) x
          liftIO (atomicWriteIORef componentModel y)
          drain app cs
-----------------------------------------------------------------------------
-- | Post unmount call to drop the <style> and <script> in <head>
unloadScripts :: ComponentState model action -> JSM ()
unloadScripts :: forall model action. ComponentState model action -> JSM ()
unloadScripts ComponentState {Int
[DOMRef]
ThreadId
IORef model
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
DOMRef
Mailbox
action -> JSM ()
componentScripts :: forall model action. ComponentState model action -> [DOMRef]
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentMailbox :: forall model action. ComponentState model action -> Mailbox
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 -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: DOMRef
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: IORef model
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentMailboxThreadId :: ThreadId
componentScripts :: [DOMRef]
..} = do
  [DOMRef] -> (DOMRef -> JSM DOMRef) -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DOMRef]
componentScripts ((DOMRef -> JSM DOMRef) -> JSM ())
-> (DOMRef -> JSM DOMRef) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \DOMRef
domRef ->
    -- dmj: abstract this out into context
    forall a. ToJSString a => a -> JSM DOMRef
jsg @MisoString MisoString
"document"
      JSM DOMRef -> MisoString -> JSM DOMRef
forall this name.
(MakeObject this, ToJSString name) =>
this -> name -> JSM DOMRef
! (MisoString
"head" :: MisoString)
      # ("removeChild" :: MisoString)
      ([DOMRef] -> JSM DOMRef) -> [DOMRef] -> JSM DOMRef
forall a b. (a -> b) -> a -> b
$ [DOMRef
domRef]
-----------------------------------------------------------------------------
-- | Helper function for cleanly destroying a @Component@
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
[JS]
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View action
action -> Effect model action
Mail -> Maybe action
mailbox :: forall model action. Component model action -> Mail -> Maybe 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
scripts :: forall model action. Component model action -> [JS]
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]
scripts :: [JS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
mailbox :: Mail -> Maybe action
..} cs :: ComponentState model action
cs@ComponentState {Int
[DOMRef]
ThreadId
IORef model
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
DOMRef
Mailbox
action -> JSM ()
componentScripts :: forall model action. ComponentState model action -> [DOMRef]
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentMailbox :: forall model action. ComponentState model action -> Mailbox
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 -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: DOMRef
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: IORef model
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentMailboxThreadId :: ThreadId
componentScripts :: [DOMRef]
..} = 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 ()
killThread ThreadId
componentMailboxThreadId)
  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)
  Int -> JSM ()
killSubscribers Int
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 (IntMap (ComponentState (ZonkAny 7) (ZonkAny 8)))
-> (IntMap (ComponentState (ZonkAny 7) (ZonkAny 8))
    -> (IntMap (ComponentState (ZonkAny 7) (ZonkAny 8)), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (IntMap (ComponentState (ZonkAny 7) (ZonkAny 8)))
forall model action. IORef (IntMap (ComponentState model action))
components ((IntMap (ComponentState (ZonkAny 7) (ZonkAny 8))
  -> (IntMap (ComponentState (ZonkAny 7) (ZonkAny 8)), ()))
 -> IO ())
-> (IntMap (ComponentState (ZonkAny 7) (ZonkAny 8))
    -> (IntMap (ComponentState (ZonkAny 7) (ZonkAny 8)), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \IntMap (ComponentState (ZonkAny 7) (ZonkAny 8))
m -> (Int
-> IntMap (ComponentState (ZonkAny 7) (ZonkAny 8))
-> IntMap (ComponentState (ZonkAny 7) (ZonkAny 8))
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
componentId IntMap (ComponentState (ZonkAny 7) (ZonkAny 8))
m, ())
  ComponentState model action -> JSM ()
forall model action. ComponentState model action -> JSM ()
unloadScripts ComponentState model action
cs
-----------------------------------------------------------------------------
killSubscribers :: ComponentId -> JSM ()
killSubscribers :: Int -> JSM ()
killSubscribers Int
componentId =
  (Topic (ZonkAny 6) -> JSM ()) -> [Topic (ZonkAny 6)] -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Topic (ZonkAny 6) -> Int -> JSM ())
-> Int -> Topic (ZonkAny 6) -> JSM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Topic (ZonkAny 6) -> Int -> JSM ()
forall message. Topic message -> Int -> JSM ()
unsubscribe_ Int
componentId) ([Topic (ZonkAny 6)] -> JSM ())
-> JSM [Topic (ZonkAny 6)] -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Map (Topic (ZonkAny 6)) Mailbox -> [Topic (ZonkAny 6)]
forall k a. Map k a -> [k]
M.keys (Map (Topic (ZonkAny 6)) Mailbox -> [Topic (ZonkAny 6)])
-> JSM (Map (Topic (ZonkAny 6)) Mailbox) -> JSM [Topic (ZonkAny 6)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map (Topic (ZonkAny 6)) Mailbox)
-> JSM (Map (Topic (ZonkAny 6)) Mailbox)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Map (Topic (ZonkAny 6)) Mailbox)
-> IO (Map (Topic (ZonkAny 6)) Mailbox)
forall a. IORef a -> IO a
readIORef IORef (Map (Topic (ZonkAny 6)) Mailbox)
forall a. IORef (Map (Topic a) Mailbox)
mailboxes)
-----------------------------------------------------------------------------
-- | Internal function for construction of a Virtual DOM.
--
-- Component mounting should be synchronous.
-- Mounting causes a recursive diffing to occur
-- (creating sub components as detected), setting up
-- infrastructure for each sub-component. During this
-- process we go between the Haskell heap and the JS heap.
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 NS
ns MisoString
tag [Attribute action]
attrs (SomeComponent Component model action
app)) Sink action
snk LogLevel
_ Events
_ = do
  mountCallback <- do
    (DOMRef -> DOMRef -> JSM ()) -> JSM Function
FFI.syncCallback2 ((DOMRef -> DOMRef -> JSM ()) -> JSM Function)
-> (DOMRef -> DOMRef -> JSM ()) -> JSM Function
forall a b. (a -> b) -> a -> b
$ \DOMRef
domRef DOMRef
continuation -> do
      ComponentState {..} <- Component model action
-> ((action -> JSM ()) -> JSM ([DOMRef], DOMRef, IORef VTree))
-> JSM (ComponentState model action)
forall model action.
Eq model =>
Component model action
-> (Sink action -> JSM ([DOMRef], DOMRef, IORef VTree))
-> JSM (ComponentState model action)
initialize Component model action
app (Hydrate
-> DOMRef
-> Component model action
-> (action -> JSM ())
-> JSM ([DOMRef], DOMRef, IORef VTree)
forall model action.
Hydrate
-> DOMRef
-> Component model action
-> Sink action
-> JSM ([DOMRef], DOMRef, IORef VTree)
drawComponent Hydrate
hydrate DOMRef
domRef Component model action
app)
      vtree <- toJSVal =<< liftIO (readIORef componentVTree)
      vcompId <- toJSVal componentId
      void $ call continuation global [vcompId, vtree]
  unmountCallback <- toJSVal =<< do
    FFI.syncCallback1 $ \DOMRef
domRef -> do
      componentId <- JSM Int -> JSM Int
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (DOMRef -> JSM Int
FFI.getComponentId DOMRef
domRef)
      IM.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" ns tag
  setAttrs vcomp attrs snk (logLevel app) (events app)
  flip (FFI.set "children") vcomp =<< toJSVal ([] :: [MisoString])
  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@
-- A helper function for constructing a vtree (used for 'vcomp' and 'vnode')
-- Doesn't handle children
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
-----------------------------------------------------------------------------
-- | Helper function for populating "props" and "css" fields on a virtual
-- DOM node
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 -> VTree -> LogLevel -> Events -> JSM ()
callback ->
      Sink action -> VTree -> LogLevel -> Events -> JSM ()
callback Sink action
snk (Object -> VTree
VTree 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)
-----------------------------------------------------------------------------
-- | Used to support RawText, inlining of HTML.
-- Filters tree to only branches and leaves w/ Text tags.
-- converts to View a. Note: if HTML is malformed,
-- (e.g. closing tags and opening tags are present) they will
-- be removed.
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
-----------------------------------------------------------------------------
-- | Registers components in the global state
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 (IntMap (ComponentState model action))
-> (IntMap (ComponentState model action)
    -> IntMap (ComponentState model action))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (IntMap (ComponentState model action))
forall model action. IORef (IntMap (ComponentState model action))
components
  ((IntMap (ComponentState model action)
  -> IntMap (ComponentState model action))
 -> IO ())
-> (IntMap (ComponentState model action)
    -> IntMap (ComponentState model action))
-> IO ()
forall a b. (a -> b) -> a -> b
$ Int
-> ComponentState model action
-> IntMap (ComponentState model action)
-> IntMap (ComponentState model action)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (ComponentState model action -> Int
forall model action. ComponentState model action -> Int
componentId ComponentState model action
componentState) ComponentState model action
componentState
-----------------------------------------------------------------------------
-- | Renders styles
--
-- Meant for development purposes
-- Appends CSS to <head>
--
renderStyles :: [CSS] -> JSM [JSVal]
renderStyles :: [CSS] -> JSM [DOMRef]
renderStyles [CSS]
styles =
  [CSS] -> (CSS -> JSM DOMRef) -> JSM [DOMRef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CSS]
styles ((CSS -> JSM DOMRef) -> JSM [DOMRef])
-> (CSS -> JSM DOMRef) -> JSM [DOMRef]
forall a b. (a -> b) -> a -> b
$ \case
    Href MisoString
url -> MisoString -> JSM DOMRef
FFI.addStyleSheet MisoString
url
    Style MisoString
css -> MisoString -> JSM DOMRef
FFI.addStyle MisoString
css
    Sheet StyleSheet
sheet -> MisoString -> JSM DOMRef
FFI.addStyle (StyleSheet -> MisoString
renderStyleSheet StyleSheet
sheet)
-----------------------------------------------------------------------------
-- | Renders scripts
--
-- Meant for development purposes
-- Appends JS to <head>
--
renderScripts :: [JS] -> JSM [JSVal]
renderScripts :: [JS] -> JSM [DOMRef]
renderScripts [JS]
scripts =
  [JS] -> (JS -> JSM DOMRef) -> JSM [DOMRef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [JS]
scripts ((JS -> JSM DOMRef) -> JSM [DOMRef])
-> (JS -> JSM DOMRef) -> JSM [DOMRef]
forall a b. (a -> b) -> a -> b
$ \case
    Src MisoString
src -> MisoString -> JSM DOMRef
FFI.addSrc MisoString
src
    Script MisoString
script -> MisoString -> JSM DOMRef
FFI.addScript MisoString
script
-----------------------------------------------------------------------------
-- | Starts a named 'Sub' dynamically, during the life of a 'Component'.
-- The 'Sub' can be stopped by calling @Ord subKey => stop subKey@ from the 'update' function.
-- All 'Sub' started will be stopped if a 'Component' is unmounted.
--
-- @
-- data SubType = LoggerSub | TimerSub
--   deriving (Eq, Ord)
--
-- update Action =
--   startSub LoggerSub $ \sink -> forever (threadDelay (secs 1) >> consoleLog "test")
-- @
--
-- @since 1.9.0.0
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
  domRef <- RWST DOMRef [Sink action -> JSM ()] model Identity DOMRef
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    vcompId <- FFI.getComponentId domRef
    (IM.lookup vcompId <$> 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 {Int
[DOMRef]
ThreadId
IORef (ZonkAny 0)
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
DOMRef
Mailbox
Sink action
componentScripts :: forall model action. ComponentState model action -> [DOMRef]
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentMailbox :: forall model action. ComponentState model action -> Mailbox
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 -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: DOMRef
componentVTree :: IORef VTree
componentSink :: Sink action
componentModel :: IORef (ZonkAny 0)
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentMailboxThreadId :: ThreadId
componentScripts :: [DOMRef]
..} -> 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 {Int
[DOMRef]
ThreadId
IORef model
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
DOMRef
Mailbox
Sink action
componentScripts :: forall model action. ComponentState model action -> [DOMRef]
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentMailbox :: forall model action. ComponentState model action -> Mailbox
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 -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: DOMRef
componentVTree :: IORef VTree
componentSink :: Sink action
componentModel :: IORef model
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentMailboxThreadId :: ThreadId
componentScripts :: [DOMRef]
..} = 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, ())
-----------------------------------------------------------------------------
-- | Stops a named 'Sub' dynamically, during the life of a 'Component'.
-- All 'Sub' started will be stopped automatically if a 'Component' is unmounted.
--
-- @
-- data SubType = LoggerSub | TimerSub
--   deriving (Eq, Ord)
--
-- update Action = do
--   stopSub LoggerSub
-- @
--
-- @since 1.9.0.0
stopSub :: ToMisoString subKey => subKey -> Effect model action
stopSub :: forall subKey model action.
ToMisoString subKey =>
subKey -> Effect model action
stopSub subKey
subKey = do
  domRef <- RWST DOMRef [Sink action -> JSM ()] model Identity DOMRef
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    vcompId <- FFI.getComponentId domRef
    (IM.lookup vcompId <$> 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 {Int
[DOMRef]
ThreadId
IORef (ZonkAny 1)
IORef (Map MisoString ThreadId)
IORef (Seq (ZonkAny 2))
IORef VTree
DOMRef
Mailbox
ZonkAny 2 -> JSM ()
componentScripts :: forall model action. ComponentState model action -> [DOMRef]
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentMailbox :: forall model action. ComponentState model action -> Mailbox
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 -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: DOMRef
componentVTree :: IORef VTree
componentSink :: ZonkAny 2 -> JSM ()
componentModel :: IORef (ZonkAny 1)
componentActions :: IORef (Seq (ZonkAny 2))
componentMailbox :: Mailbox
componentMailboxThreadId :: ThreadId
componentScripts :: [DOMRef]
..} -> 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)
-----------------------------------------------------------------------------
-- | Used to acquire the 'ComponentId' of the current 'Component'
getComponentId
  :: (ComponentId -> action)
  -> Effect model action 
getComponentId :: forall action model. (Int -> action) -> Effect model action
getComponentId Int -> action
callback = do
  domRef <- RWST DOMRef [Sink action -> JSM ()] model Identity DOMRef
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink -> do
    componentId <- DOMRef -> JSM Int
FFI.getComponentId DOMRef
domRef
    sink (callback componentId)
-----------------------------------------------------------------------------
-- | Used to acquire the parent 'ComponentId' of the current 'Component'
-- This is commonly used in situations to send messages or receive messages
-- between components.
getParentComponentId
  :: (ComponentId -> action)
  -- ^ Successful callback (with parent ComponentId)
  -> action
  -- ^ Errorful callback (without ComponentId)
  -> Effect model action 
getParentComponentId :: forall action model.
(Int -> action) -> action -> Effect model action
getParentComponentId Int -> action
successful action
errorful = do
  domRef <- RWST DOMRef [Sink action -> JSM ()] model Identity DOMRef
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink -> do
    DOMRef -> JSM (Maybe Int)
FFI.getParentComponentId DOMRef
domRef JSM (Maybe Int) -> (Maybe Int -> 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 Int
Nothing ->
        Sink action
sink action
errorful
      Just Int
parentComponentId ->
        Sink action
sink (Int -> action
successful Int
parentComponentId)
-----------------------------------------------------------------------------
-- | Send any 'ToJSON message => message' to a 'Component' mailbox, by 'ComponentId'
--
-- @
-- mail componentId ("test message" :: MisoString) :: Effect model action
-- @
-- 
-- @since 1.9.0.0
mail
  :: ToJSON message
  => ComponentId
  -> message
  -> Effect model action
mail :: forall message model action.
ToJSON message =>
Int -> message -> Effect model action
mail Int
vcompId message
message = 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
$
  Int
-> IntMap (ComponentState (ZonkAny 3) (ZonkAny 4))
-> Maybe (ComponentState (ZonkAny 3) (ZonkAny 4))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap (ComponentState (ZonkAny 3) (ZonkAny 4))
 -> Maybe (ComponentState (ZonkAny 3) (ZonkAny 4)))
-> JSM (IntMap (ComponentState (ZonkAny 3) (ZonkAny 4)))
-> JSM (Maybe (ComponentState (ZonkAny 3) (ZonkAny 4)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IntMap (ComponentState (ZonkAny 3) (ZonkAny 4)))
-> JSM (IntMap (ComponentState (ZonkAny 3) (ZonkAny 4)))
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (IntMap (ComponentState (ZonkAny 3) (ZonkAny 4)))
-> IO (IntMap (ComponentState (ZonkAny 3) (ZonkAny 4)))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState (ZonkAny 3) (ZonkAny 4)))
forall model action. IORef (IntMap (ComponentState model action))
components) JSM (Maybe (ComponentState (ZonkAny 3) (ZonkAny 4)))
-> (Maybe (ComponentState (ZonkAny 3) (ZonkAny 4)) -> 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 (ComponentState (ZonkAny 3) (ZonkAny 4))
Nothing ->
      -- dmj: TODO add DebugMail here
      () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just ComponentState {Int
[DOMRef]
ThreadId
IORef (ZonkAny 3)
IORef (Map MisoString ThreadId)
IORef (Seq (ZonkAny 4))
IORef VTree
DOMRef
Mailbox
ZonkAny 4 -> JSM ()
componentScripts :: forall model action. ComponentState model action -> [DOMRef]
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentMailbox :: forall model action. ComponentState model action -> Mailbox
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 -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: DOMRef
componentVTree :: IORef VTree
componentSink :: ZonkAny 4 -> JSM ()
componentModel :: IORef (ZonkAny 3)
componentActions :: IORef (Seq (ZonkAny 4))
componentMailbox :: Mailbox
componentMailboxThreadId :: ThreadId
componentScripts :: [DOMRef]
..} ->
      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
componentMailbox (message -> Mail
forall a. ToJSON a => a -> Mail
toJSON message
message)
-----------------------------------------------------------------------------