-----------------------------------------------------------------------------
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE OverloadedStrings   #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Internal
-- 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.Internal
  ( -- * Internal functions
    initialize
  , componentMap
  , notify
  , runView
  , sample
  , renderStyles
  , Prerender(..)
  -- * Subscription
  , start
  , start_
  , stop
  ) where
-----------------------------------------------------------------------------
import           Control.Exception (throwIO)
import           Control.Concurrent (ThreadId, killThread)
import           Control.Monad (forM, forM_, when, void)
import           Control.Monad.Reader (ask)
import           Control.Monad.IO.Class
import qualified Data.Aeson as A
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
import           Language.Javascript.JSaddle hiding (Sync)
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)
import           Miso.Delegate (delegator, undelegator)
import           Miso.Diff (diff)
import           Miso.Exception (MisoException(..), exception)
import qualified Miso.FFI.Internal as FFI
import           Miso.Html hiding (on)
import           Miso.String hiding (reverse)
import           Miso.Types hiding (componentName)
import           Miso.Event (Events)
import           Miso.Effect (Sub, SubName, Sink, Effect, runEffect, io)
-----------------------------------------------------------------------------
-- | Helper function to abstract out initialization of @App@ between top-level API functions.
initialize
  :: Eq model
  => App model action
  -> (Sink action -> JSM (MisoString, JSVal, IORef VTree))
  -- ^ Callback function is used to perform the creation of VTree
  -> JSM (IORef VTree)
initialize :: forall model action.
Eq model =>
App model action
-> (Sink action -> JSM (MisoString, JSVal, IORef VTree))
-> JSM (IORef VTree)
initialize App {model
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Map MisoString Capture
LogLevel
model -> View action
action -> Effect model action
model :: model
update :: action -> Effect model action
view :: model -> View action
subs :: [Sub action]
events :: Map MisoString Capture
styles :: [CSS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
logLevel :: forall model action. App model action -> LogLevel
mountPoint :: forall model action. App model action -> Maybe MisoString
initialAction :: forall model action. App model action -> Maybe action
styles :: forall model action. App model action -> [CSS]
events :: forall model action. App model action -> Map MisoString Capture
subs :: forall model action. App model action -> [Sub action]
view :: forall model action. App model action -> model -> View action
update :: forall model action.
App model action -> action -> Effect model action
model :: forall model action. App model action -> model
..} Sink action -> JSM (MisoString, JSVal, 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
  (componentName, 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)
    subName <- 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
subName 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 componentName componentSink (toList as) oldModel
      oldName <- liftIO $ oldModel `seq` makeStableName oldModel
      newName <- liftIO $ newModel `seq` makeStableName newModel
      when (oldName /= newName && oldModel /= newModel) $ do
        newVTree <- runView DontPrerender (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
-----------------------------------------------------------------------------
-- | Prerender avoids calling @diff@
-- and instead calls @hydrate@
data Prerender
  = DontPrerender
  | Prerender
  deriving (Int -> Prerender -> ShowS
[Prerender] -> ShowS
Prerender -> String
(Int -> Prerender -> ShowS)
-> (Prerender -> String)
-> ([Prerender] -> ShowS)
-> Show Prerender
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Prerender -> ShowS
showsPrec :: Int -> Prerender -> ShowS
$cshow :: Prerender -> String
show :: Prerender -> String
$cshowList :: [Prerender] -> ShowS
showList :: [Prerender] -> ShowS
Show, Prerender -> Prerender -> Capture
(Prerender -> Prerender -> Capture)
-> (Prerender -> Prerender -> Capture) -> Eq Prerender
forall a. (a -> a -> Capture) -> (a -> a -> Capture) -> Eq a
$c== :: Prerender -> Prerender -> Capture
== :: Prerender -> Prerender -> Capture
$c/= :: Prerender -> Prerender -> Capture
/= :: Prerender -> Prerender -> Capture
Eq)
-----------------------------------------------------------------------------
-- | @Component@ state, data associated with the lifetime of a @Component@
data ComponentState model action
  = ComponentState
  { forall model action. ComponentState model action -> MisoString
componentName       :: MisoString
  , forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentSubThreads :: IORef (Map MisoString ThreadId)
  , forall model action. ComponentState model action -> JSVal
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)
  }
-----------------------------------------------------------------------------
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 MisoString
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)
-----------------------------------------------------------------------------
-- | componentMap
--
-- This is a global @Component@ @Map@ that holds the state of all currently
-- mounted @Component@s
componentMap :: IORef (Map MisoString (ComponentState model action))
{-# NOINLINE componentMap #-}
componentMap :: forall model action.
IORef (Map MisoString (ComponentState model action))
componentMap = 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)
-----------------------------------------------------------------------------
-- | Read-only access to another @Component@'s @model@.
-- This function is safe to use when a child @Component@ wishes access
-- a parent @Components@ @model@ state. Under this circumstance the parent
-- will always be mounted and available.
--
-- Otherwise, if a sibling or parent @Component@'s @model@ state is attempted
-- to be accessed. Then we throw a @NotMountedException@, in the case the
-- @Component@ being accessed is not available.
sample
  :: Component model action
  -> JSM model
sample :: forall model action. Component model action -> JSM model
sample (Component Maybe Key
_ MisoString
name App model action
_) = do
  componentStateMap <- IO (Map MisoString (ComponentState model (ZonkAny 0)))
-> JSM (Map MisoString (ComponentState model (ZonkAny 0)))
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Map MisoString (ComponentState model (ZonkAny 0)))
-> IO (Map MisoString (ComponentState model (ZonkAny 0)))
forall a. IORef a -> IO a
readIORef IORef (Map MisoString (ComponentState model (ZonkAny 0)))
forall model action.
IORef (Map MisoString (ComponentState model action))
componentMap)
  liftIO $ case M.lookup name componentStateMap of
    Maybe (ComponentState model (ZonkAny 0))
Nothing -> MisoException -> IO model
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (MisoString -> MisoException
NotMountedException MisoString
name)
    Just ComponentState {MisoString
IORef model
IORef (Map MisoString ThreadId)
IORef (Seq (ZonkAny 0))
IORef VTree
JSVal
ZonkAny 0 -> 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 -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentName :: forall model action. ComponentState model action -> MisoString
componentName :: MisoString
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: JSVal
componentVTree :: IORef VTree
componentSink :: ZonkAny 0 -> JSM ()
componentModel :: IORef model
componentActions :: IORef (Seq (ZonkAny 0))
..} -> IORef model -> IO model
forall a. IORef a -> IO a
readIORef IORef model
componentModel
-----------------------------------------------------------------------------
-- | Used for bidirectional communication between components.
-- Specify the mounted @Component@'s 'App' you'd like to target.
-- This function is used to send messages to @Component@s on other parts of the application
notify
  :: Component model action
  -> action
  -> JSM ()
notify :: forall model action. Component model action -> action -> JSM ()
notify (Component Maybe Key
_ MisoString
name App model action
_) action
action = do
  componentStateMap <- IO (Map MisoString (ComponentState (ZonkAny 1) action))
-> JSM (Map MisoString (ComponentState (ZonkAny 1) action))
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Map MisoString (ComponentState (ZonkAny 1) action))
-> IO (Map MisoString (ComponentState (ZonkAny 1) action))
forall a. IORef a -> IO a
readIORef IORef (Map MisoString (ComponentState (ZonkAny 1) action))
forall model action.
IORef (Map MisoString (ComponentState model action))
componentMap)
  forM_ (M.lookup name componentStateMap) $ \ComponentState {MisoString
IORef (ZonkAny 1)
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
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 -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentName :: forall model action. ComponentState model action -> MisoString
componentName :: MisoString
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: IORef (ZonkAny 1)
componentActions :: IORef (Seq action)
..} ->
    action -> JSM ()
componentSink action
action
-----------------------------------------------------------------------------
-- | Sychronicity
--
-- 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 -> Capture
(Synchronicity -> Synchronicity -> Capture)
-> (Synchronicity -> Synchronicity -> Capture) -> Eq Synchronicity
forall a. (a -> a -> Capture) -> (a -> a -> Capture) -> Eq a
$c== :: Synchronicity -> Synchronicity -> Capture
== :: Synchronicity -> Synchronicity -> Capture
$c/= :: Synchronicity -> Synchronicity -> Capture
/= :: Synchronicity -> Synchronicity -> Capture
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
  -> MisoString
  -> 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
name 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
name 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 JSVal -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM JSVal -> JSM ())
-> (SomeException -> JSM JSVal) -> SomeException -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> JSM JSVal
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
name Sink action
snk [action]
es model
n
--------------------------------------------------
-- | Internally used for runView and startApp
-- Initial draw helper
-- If prerendering, bypass diff and continue copying
drawComponent
  :: Prerender
  -> MisoString
  -> App model action
  -> Sink action
  -> JSM (MisoString, JSVal, IORef VTree)
drawComponent :: forall model action.
Prerender
-> MisoString
-> App model action
-> Sink action
-> JSM (MisoString, JSVal, IORef VTree)
drawComponent Prerender
prerender MisoString
name App {model
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Map MisoString Capture
LogLevel
model -> View action
action -> Effect model action
logLevel :: forall model action. App model action -> LogLevel
mountPoint :: forall model action. App model action -> Maybe MisoString
initialAction :: forall model action. App model action -> Maybe action
styles :: forall model action. App model action -> [CSS]
events :: forall model action. App model action -> Map MisoString Capture
subs :: forall model action. App model action -> [Sub action]
view :: forall model action. App model action -> model -> View action
update :: forall model action.
App model action -> action -> Effect model action
model :: forall model action. App model action -> model
model :: model
update :: action -> Effect model action
view :: model -> View action
subs :: [Sub action]
events :: Map MisoString Capture
styles :: [CSS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
..} Sink action
snk = do
  vtree <- Prerender
-> View action
-> Sink action
-> LogLevel
-> Map MisoString Capture
-> JSM VTree
forall action.
Prerender
-> View action
-> Sink action
-> LogLevel
-> Map MisoString Capture
-> JSM VTree
runView Prerender
prerender (model -> View action
view model
model) Sink action
snk LogLevel
logLevel Map MisoString Capture
events
  mountElement <- FFI.getComponent name
  when (prerender == DontPrerender) (diff Nothing (Just vtree) mountElement)
  ref <- liftIO (newIORef vtree)
  pure (name, mountElement, ref)
-----------------------------------------------------------------------------
-- | Drains the event queue before unmounting, executed synchronously
drain
  :: App model action
  -> ComponentState model action
  -> JSM ()
drain :: forall model action.
App model action -> ComponentState model action -> JSM ()
drain app :: App model action
app@App{model
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Map MisoString Capture
LogLevel
model -> View action
action -> Effect model action
logLevel :: forall model action. App model action -> LogLevel
mountPoint :: forall model action. App model action -> Maybe MisoString
initialAction :: forall model action. App model action -> Maybe action
styles :: forall model action. App model action -> [CSS]
events :: forall model action. App model action -> Map MisoString Capture
subs :: forall model action. App model action -> [Sub action]
view :: forall model action. App model action -> model -> View action
update :: forall model action.
App model action -> action -> Effect model action
model :: forall model action. App model action -> model
model :: model
update :: action -> Effect model action
view :: model -> View action
subs :: [Sub action]
events :: Map MisoString Capture
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
JSVal
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 -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentName :: forall model action. ComponentState model action -> MisoString
componentName :: MisoString
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: JSVal
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 componentName componentSink (toList as) x
        liftIO (atomicWriteIORef componentModel y)
        drain app cs
-----------------------------------------------------------------------------
-- | Helper function for cleanly destroying a @Component@
unmount
  :: Function
  -> App model action
  -> ComponentState model action
  -> JSM ()
unmount :: forall model action.
Function
-> App model action -> ComponentState model action -> JSM ()
unmount Function
mountCallback app :: App model action
app@App {model
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Map MisoString Capture
LogLevel
model -> View action
action -> Effect model action
logLevel :: forall model action. App model action -> LogLevel
mountPoint :: forall model action. App model action -> Maybe MisoString
initialAction :: forall model action. App model action -> Maybe action
styles :: forall model action. App model action -> [CSS]
events :: forall model action. App model action -> Map MisoString Capture
subs :: forall model action. App model action -> [Sub action]
view :: forall model action. App model action -> model -> View action
update :: forall model action.
App model action -> action -> Effect model action
model :: forall model action. App model action -> model
model :: model
update :: action -> Effect model action
view :: model -> View action
subs :: [Sub action]
events :: Map MisoString Capture
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
JSVal
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 -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentName :: forall model action. ComponentState model action -> MisoString
componentName :: MisoString
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: IORef model
componentActions :: IORef (Seq action)
..} = do
  JSVal -> IORef VTree -> Map MisoString Capture -> Capture -> JSM ()
undelegator JSVal
componentMount IORef VTree
componentVTree Map MisoString Capture
events (LogLevel
logLevel LogLevel -> [LogLevel] -> Capture
forall a. Eq a => a -> [a] -> Capture
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Capture
`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)
  App model action -> ComponentState model action -> JSM ()
forall model action.
App model action -> ComponentState model action -> JSM ()
drain App 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 2) (ZonkAny 3)))
-> (Map MisoString (ComponentState (ZonkAny 2) (ZonkAny 3))
    -> (Map MisoString (ComponentState (ZonkAny 2) (ZonkAny 3)), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map MisoString (ComponentState (ZonkAny 2) (ZonkAny 3)))
forall model action.
IORef (Map MisoString (ComponentState model action))
componentMap ((Map MisoString (ComponentState (ZonkAny 2) (ZonkAny 3))
  -> (Map MisoString (ComponentState (ZonkAny 2) (ZonkAny 3)), ()))
 -> IO ())
-> (Map MisoString (ComponentState (ZonkAny 2) (ZonkAny 3))
    -> (Map MisoString (ComponentState (ZonkAny 2) (ZonkAny 3)), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map MisoString (ComponentState (ZonkAny 2) (ZonkAny 3))
m -> (MisoString
-> Map MisoString (ComponentState (ZonkAny 2) (ZonkAny 3))
-> Map MisoString (ComponentState (ZonkAny 2) (ZonkAny 3))
forall k a. Ord k => k -> Map k a -> Map k a
M.delete MisoString
componentName Map MisoString (ComponentState (ZonkAny 2) (ZonkAny 3))
m, ())
-----------------------------------------------------------------------------
-- | 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
  :: Prerender
  -> View action
  -> Sink action
  -> LogLevel
  -> Events
  -> JSM VTree
runView :: forall action.
Prerender
-> View action
-> Sink action
-> LogLevel
-> Map MisoString Capture
-> JSM VTree
runView Prerender
prerender (Embed [Attribute action]
attributes (SomeComponent (Component Maybe Key
key MisoString
name App model action
app))) Sink action
snk LogLevel
_ Map MisoString Capture
_ = do
  compName <-
    if MisoString -> Capture
null MisoString
name
    then IO MisoString -> JSM MisoString
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO MisoString
freshComponentId
    else MisoString -> JSM MisoString
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MisoString
name
  mountCallback <- do
    FFI.syncCallback1 $ \JSVal
continuation -> do
      vtreeRef <- App model action
-> (Sink action -> JSM (MisoString, JSVal, IORef VTree))
-> JSM (IORef VTree)
forall model action.
Eq model =>
App model action
-> (Sink action -> JSM (MisoString, JSVal, IORef VTree))
-> JSM (IORef VTree)
initialize App model action
app (Prerender
-> MisoString
-> App model action
-> Sink action
-> JSM (MisoString, JSVal, IORef VTree)
forall model action.
Prerender
-> MisoString
-> App model action
-> Sink action
-> JSM (MisoString, JSVal, IORef VTree)
drawComponent Prerender
prerender MisoString
compName App model action
app)
      VTree vtree <- liftIO (readIORef vtreeRef)
      void $ call continuation global [vtree]
  unmountCallback <- toJSVal =<< do
    FFI.syncCallback $ do
      M.lookup compName <$> liftIO (readIORef componentMap) >>= \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
-> App model action -> ComponentState model action -> JSM ()
forall model action.
Function
-> App model action -> ComponentState model action -> JSM ()
unmount Function
mountCallback App model action
app ComponentState model action
componentState
  vcomp <- createNode "vcomp" HTML key "div"
  setAttrs vcomp attributes snk (logLevel app) (events app)
  flip (FFI.set "children") vcomp =<< toJSVal ([] :: [MisoString])
  FFI.set "data-component-id" compName vcomp
  flip (FFI.set "mount") vcomp =<< toJSVal mountCallback
  FFI.set "unmount" unmountCallback vcomp
  pure (VTree vcomp)
runView Prerender
prerender (Node NS
ns MisoString
tag Maybe Key
key [Attribute action]
attrs [View action]
kids) Sink action
snk LogLevel
logLevel Map MisoString Capture
events = do
  vnode <- MisoString -> NS -> Maybe Key -> MisoString -> JSM Object
createNode MisoString
"vnode" NS
ns Maybe Key
key 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 JSVal) -> JSM [JSVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [View action]
kids ((View action -> JSM JSVal) -> JSM [JSVal])
-> (View action -> JSM JSVal) -> JSM [JSVal]
forall a b. (a -> b) -> a -> b
$ \View action
kid -> do
          VTree (Object vtree) <- Prerender
-> View action
-> Sink action
-> LogLevel
-> Map MisoString Capture
-> JSM VTree
forall action.
Prerender
-> View action
-> Sink action
-> LogLevel
-> Map MisoString Capture
-> JSM VTree
runView Prerender
prerender View action
kid Sink action
snk LogLevel
logLevel Map MisoString Capture
events
          pure vtree
        ghcjsPure (JSArray.fromList kidsViews)
runView Prerender
_ (Text MisoString
t) Sink action
_ LogLevel
_ Map MisoString Capture
_ = 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 Prerender
prerender (TextRaw MisoString
str) Sink action
snk LogLevel
logLevel Map MisoString Capture
events =
  case MisoString -> [View action]
forall a. MisoString -> [View a]
parseView MisoString
str of
    [] ->
      Prerender
-> View action
-> Sink action
-> LogLevel
-> Map MisoString Capture
-> JSM VTree
forall action.
Prerender
-> View action
-> Sink action
-> LogLevel
-> Map MisoString Capture
-> JSM VTree
runView Prerender
prerender (MisoString -> View action
forall action. MisoString -> View action
Text (MisoString
" " :: MisoString)) Sink action
snk LogLevel
logLevel Map MisoString Capture
events
    [View action
parent] ->
      Prerender
-> View action
-> Sink action
-> LogLevel
-> Map MisoString Capture
-> JSM VTree
forall action.
Prerender
-> View action
-> Sink action
-> LogLevel
-> Map MisoString Capture
-> JSM VTree
runView Prerender
prerender View action
parent Sink action
snk LogLevel
logLevel Map MisoString Capture
events
    [View action]
kids -> do
      Prerender
-> View action
-> Sink action
-> LogLevel
-> Map MisoString Capture
-> JSM VTree
forall action.
Prerender
-> View action
-> Sink action
-> LogLevel
-> Map MisoString Capture
-> JSM VTree
runView Prerender
prerender (NS
-> MisoString
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
forall action.
NS
-> MisoString
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
Node NS
HTML MisoString
"div" Maybe Key
forall a. Maybe a
Nothing [Attribute action]
forall a. Monoid a => a
mempty [View action]
kids) Sink action
snk LogLevel
logLevel Map MisoString Capture
events
-----------------------------------------------------------------------------
-- | @createNode@
-- A helper function for constructing a vtree (used for 'vcomp' and 'vnode')
-- Doesn't handle children
createNode :: MisoString -> NS -> Maybe Key -> MisoString -> JSM Object
createNode :: MisoString -> NS -> Maybe Key -> MisoString -> JSM Object
createNode MisoString
typ NS
ns Maybe Key
key 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
  FFI.set "key" key 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
-> Map MisoString Capture
-> JSM ()
setAttrs Object
vnode [Attribute action]
attrs Sink action
snk LogLevel
logLevel Map MisoString Capture
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
k Value
v -> do
      value <- Value -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal Value
v
      o <- getProp "props" vnode
      FFI.set k value (Object o)
    Event Sink action
-> Object -> LogLevel -> Map MisoString Capture -> JSM ()
attr -> Sink action
-> Object -> LogLevel -> Map MisoString Capture -> JSM ()
attr Sink action
snk Object
vnode LogLevel
logLevel Map MisoString Capture
events
    Styles Map MisoString MisoString
styles -> do
      cssObj <- JSString -> Object -> JSM JSVal
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 (JSVal -> Object
Object JSVal
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
Text 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 -> Value -> Attribute action
forall action. MisoString -> Value -> Attribute action
Property MisoString
key (Value -> Attribute action) -> Value -> Attribute action
forall a b. (a -> b) -> a -> b
$ MisoString -> Value
A.String (MisoString -> MisoString
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
value)
                 | (MisoString
key, MisoString
value) <- [(MisoString, MisoString)]
attrs
                 ]
        newNode :: View action
newNode =
          NS
-> MisoString
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
forall action.
NS
-> MisoString
-> Maybe Key
-> [Attribute action]
-> [View action]
-> View action
Node NS
HTML MisoString
name Maybe Key
forall a. Maybe a
Nothing [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 (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))
componentMap
  ((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
componentName ComponentState model action
componentState) ComponentState model action
componentState
-----------------------------------------------------------------------------
-- | Registers components in the global state
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
-----------------------------------------------------------------------------
-- | 'start_'
--
-- Starts an unnamed 'Sub' dynamically, during the lifetime of a 'Component'.
--
-- 'Sub' that are unnamed have their names autogenerated and cannot be
-- stopped. This is useful for long-running actions that do not need to
-- be stopped.
--
start_ :: Sub action -> Effect action model
start_ :: forall action model. Sub action -> Effect action model
start_ Sub action
sub = do
  compName <- EffectCore action model MisoString
forall r (m :: * -> *). MonadReader r m => m r
ask
  io $ do
    M.lookup compName <$> liftIO (readIORef componentMap) >>= \case
      Maybe (ComponentState (ZonkAny 7) action)
Nothing -> () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just ComponentState {MisoString
IORef (ZonkAny 7)
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
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 -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentName :: forall model action. ComponentState model action -> MisoString
componentName :: MisoString
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: IORef (ZonkAny 7)
componentActions :: IORef (Seq action)
..} -> do
        tid <- JSM () -> JSM ThreadId
FFI.forkJSM (Sub action
sub action -> JSM ()
componentSink)
        subName <- liftIO freshSubId
        liftIO $ do
          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
subName ThreadId
tid Map MisoString ThreadId
m, ())
-----------------------------------------------------------------------------
-- | 'start'
--
-- Starts a named 'Sub' dynamically, during the life of a 'Component'.
-- The 'Sub' can be stopped by calling @stop subName@ from the 'update' function.
-- All 'Sub' started will be stopped if a 'Component' is unmounted.
--
start :: SubName -> Sub action -> Effect action model
start :: forall action model.
MisoString -> Sub action -> Effect action model
start MisoString
subName Sub action
sub = do
  compName <- EffectCore action model MisoString
forall r (m :: * -> *). MonadReader r m => m r
ask
  io $ do
    M.lookup compName <$> liftIO (readIORef componentMap) >>= \case
      Maybe (ComponentState (ZonkAny 4) action)
Nothing -> () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just ComponentState {MisoString
IORef (ZonkAny 4)
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
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 -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentName :: forall model action. ComponentState model action -> MisoString
componentName :: MisoString
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: IORef (ZonkAny 4)
componentActions :: IORef (Seq action)
..} -> do
        tid <- JSM () -> JSM ThreadId
FFI.forkJSM (Sub action
sub action -> JSM ()
componentSink)
        liftIO $ do
          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
subName ThreadId
tid Map MisoString ThreadId
m, ())
-----------------------------------------------------------------------------
-- | 'stop'
--
-- Stops a named 'Sub' dynamically, during the life of a 'Component'.
-- All 'Sub' started will be stopped automatically if a 'Component' is unmounted.
--
stop :: SubName -> Effect action model
stop :: forall action model. MisoString -> Effect action model
stop MisoString
subName = do
  compName <- EffectCore action model MisoString
forall r (m :: * -> *). MonadReader r m => m r
ask
  io $ do
    M.lookup compName <$> liftIO (readIORef componentMap) >>= \case
      Maybe (ComponentState (ZonkAny 5) (ZonkAny 6))
Nothing -> () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just ComponentState {MisoString
IORef (ZonkAny 5)
IORef (Map MisoString ThreadId)
IORef (Seq (ZonkAny 6))
IORef VTree
JSVal
ZonkAny 6 -> 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 -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentName :: forall model action. ComponentState model action -> MisoString
componentName :: MisoString
componentSubThreads :: IORef (Map MisoString ThreadId)
componentMount :: JSVal
componentVTree :: IORef VTree
componentSink :: ZonkAny 6 -> JSM ()
componentModel :: IORef (ZonkAny 5)
componentActions :: IORef (Seq (ZonkAny 6))
..} -> 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
          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 MisoString
subName Map MisoString ThreadId
m, ())
-----------------------------------------------------------------------------