-----------------------------------------------------------------------------
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- 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
  , notify'
  , runView
  , sample
  , sample'
  , renderStyles
  , Hydrate(..)
  -- * Subscription
  , startSub
  , stopSub
  ) where
-----------------------------------------------------------------------------
import           Control.Exception (throwIO)
import           Control.Monad (forM, forM_, when, void)
import           Control.Monad.Reader (ask)
import           Control.Monad.IO.Class
import           Data.Foldable (toList)
import           Data.IORef (IORef, newIORef, atomicModifyIORef', readIORef, atomicWriteIORef, modifyIORef')
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import qualified Data.Sequence as S
import           Data.Sequence (Seq)
import qualified JavaScript.Array as JSArray
#ifndef GHCJS_BOTH
import           Language.Javascript.JSaddle hiding (Sync)
#else
import           Language.Javascript.JSaddle
#endif
import           GHC.TypeLits (KnownSymbol, symbolVal)
import           GHC.Conc (ThreadStatus(ThreadDied, ThreadFinished), ThreadId, killThread, threadStatus)
import           Data.Proxy (Proxy(..))
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
import           Miso.Event (Events)
import           Miso.Property (textProp)
import           Miso.Effect (Sub, Sink, Effect, runEffect, io_)
-----------------------------------------------------------------------------
-- | Helper function to abstract out initialization of @Component@ between top-level API functions.
initialize
  :: Eq model
  => Component name 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 (name :: Symbol) action.
Eq model =>
Component name model action
-> (Sink action -> JSM (MisoString, JSVal, IORef VTree))
-> JSM (IORef VTree)
initialize Component {model
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View action
action -> Effect model action
model :: model
update :: action -> Effect model action
view :: model -> View action
subs :: [Sub action]
events :: Events
styles :: [CSS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
logLevel :: forall (name :: Symbol) model action.
Component name model action -> LogLevel
mountPoint :: forall (name :: Symbol) model action.
Component name model action -> Maybe MisoString
initialAction :: forall (name :: Symbol) model action.
Component name model action -> Maybe action
styles :: forall (name :: Symbol) model action.
Component name model action -> [CSS]
events :: forall (name :: Symbol) model action.
Component name model action -> Events
subs :: forall (name :: Symbol) model action.
Component name model action -> [Sub action]
view :: forall (name :: Symbol) model action.
Component name model action -> model -> View action
update :: forall (name :: Symbol) model action.
Component name model action -> action -> Effect model action
model :: forall (name :: Symbol) model action.
Component name 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)
    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 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 Draw (view newModel) componentSink logLevel events
        oldVTree <- liftIO (readIORef componentVTree)
        void waitForAnimationFrame
        diff (Just oldVTree) (Just newVTree) componentMount
        liftIO $ do
          atomicWriteIORef componentVTree newVTree
          atomicWriteIORef componentModel newModel
      syncPoint
      eventLoop newModel
  _ <- FFI.forkJSM (eventLoop model)
  registerComponent ComponentState {..}
  delegator componentMount componentVTree events (logLevel `elem` [DebugEvents, DebugAll])
  forM_ initialAction componentSink
  pure componentVTree
-----------------------------------------------------------------------------
-- | '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 subKey model action
  = ComponentState
  { forall subKey model action.
ComponentState subKey model action -> MisoString
componentName       :: MisoString
  , forall subKey model action.
ComponentState subKey model action -> IORef (Map subKey ThreadId)
componentSubThreads :: IORef (Map subKey ThreadId)
  , forall subKey model action.
ComponentState subKey model action -> JSVal
componentMount      :: JSVal
  , forall subKey model action.
ComponentState subKey model action -> IORef VTree
componentVTree      :: IORef VTree
  , forall subKey model action.
ComponentState subKey model action -> action -> JSM ()
componentSink       :: action -> JSM ()
  , forall subKey model action.
ComponentState subKey model action -> IORef model
componentModel      :: IORef model
  , forall subKey model action.
ComponentState subKey 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 subKey model action))
{-# NOINLINE componentMap #-}
componentMap :: forall subKey model action.
IORef (Map MisoString (ComponentState subKey model action))
componentMap = IO (IORef (Map MisoString (ComponentState subKey model action)))
-> IORef (Map MisoString (ComponentState subKey model action))
forall a. IO a -> a
unsafePerformIO (Map MisoString (ComponentState subKey model action)
-> IO (IORef (Map MisoString (ComponentState subKey model action)))
forall a. a -> IO (IORef a)
newIORef Map MisoString (ComponentState subKey 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
  :: forall name model action . KnownSymbol name
  => Component name model action
  -> JSM model
sample :: forall (name :: Symbol) model action.
KnownSymbol name =>
Component name model action -> JSM model
sample Component name model action
_ = do
  componentStateMap <- IO (Map MisoString (ComponentState (ZonkAny 0) model (ZonkAny 1)))
-> JSM
     (Map MisoString (ComponentState (ZonkAny 0) model (ZonkAny 1)))
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef
  (Map MisoString (ComponentState (ZonkAny 0) model (ZonkAny 1)))
-> IO
     (Map MisoString (ComponentState (ZonkAny 0) model (ZonkAny 1)))
forall a. IORef a -> IO a
readIORef IORef
  (Map MisoString (ComponentState (ZonkAny 0) model (ZonkAny 1)))
forall subKey model action.
IORef (Map MisoString (ComponentState subKey model action))
componentMap)
  liftIO (case M.lookup name componentStateMap of
    Maybe (ComponentState (ZonkAny 0) model (ZonkAny 1))
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 (ZonkAny 0) ThreadId)
IORef (Seq (ZonkAny 1))
IORef VTree
JSVal
ZonkAny 1 -> JSM ()
componentActions :: forall subKey model action.
ComponentState subKey model action -> IORef (Seq action)
componentModel :: forall subKey model action.
ComponentState subKey model action -> IORef model
componentSink :: forall subKey model action.
ComponentState subKey model action -> action -> JSM ()
componentVTree :: forall subKey model action.
ComponentState subKey model action -> IORef VTree
componentMount :: forall subKey model action.
ComponentState subKey model action -> JSVal
componentSubThreads :: forall subKey model action.
ComponentState subKey model action -> IORef (Map subKey ThreadId)
componentName :: forall subKey model action.
ComponentState subKey model action -> MisoString
componentName :: MisoString
componentSubThreads :: IORef (Map (ZonkAny 0) ThreadId)
componentMount :: JSVal
componentVTree :: IORef VTree
componentSink :: ZonkAny 1 -> JSM ()
componentModel :: IORef model
componentActions :: IORef (Seq (ZonkAny 1))
..} -> IORef model -> IO model
forall a. IORef a -> IO a
readIORef IORef model
componentModel)
  where
    name :: MisoString
name = String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (String -> MisoString) -> String -> MisoString
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)
-----------------------------------------------------------------------------
-- | Like @sample@ except used for @Component Dynamic model action@ where the component-id has been retrieved via @ask@ and generated using @onMountedWith@.
--
-- We use the @Component Dynamic model action@ argument to ensure the 'model'
-- sampled unifies with what @sample'@ returns.
--
sample'
  :: MisoString
  -> Component Dynamic model action
  -> JSM model
sample' :: forall model action.
MisoString -> Component Dynamic model action -> JSM model
sample' MisoString
name Component Dynamic model action
_ = do
  componentStateMap <- IO (Map MisoString (ComponentState (ZonkAny 2) model (ZonkAny 3)))
-> JSM
     (Map MisoString (ComponentState (ZonkAny 2) model (ZonkAny 3)))
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef
  (Map MisoString (ComponentState (ZonkAny 2) model (ZonkAny 3)))
-> IO
     (Map MisoString (ComponentState (ZonkAny 2) model (ZonkAny 3)))
forall a. IORef a -> IO a
readIORef IORef
  (Map MisoString (ComponentState (ZonkAny 2) model (ZonkAny 3)))
forall subKey model action.
IORef (Map MisoString (ComponentState subKey model action))
componentMap)
  liftIO (case M.lookup name componentStateMap of
    Maybe (ComponentState (ZonkAny 2) model (ZonkAny 3))
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 (ZonkAny 2) ThreadId)
IORef (Seq (ZonkAny 3))
IORef VTree
JSVal
ZonkAny 3 -> JSM ()
componentActions :: forall subKey model action.
ComponentState subKey model action -> IORef (Seq action)
componentModel :: forall subKey model action.
ComponentState subKey model action -> IORef model
componentSink :: forall subKey model action.
ComponentState subKey model action -> action -> JSM ()
componentVTree :: forall subKey model action.
ComponentState subKey model action -> IORef VTree
componentMount :: forall subKey model action.
ComponentState subKey model action -> JSVal
componentSubThreads :: forall subKey model action.
ComponentState subKey model action -> IORef (Map subKey ThreadId)
componentName :: forall subKey model action.
ComponentState subKey model action -> MisoString
componentName :: MisoString
componentSubThreads :: IORef (Map (ZonkAny 2) ThreadId)
componentMount :: JSVal
componentVTree :: IORef VTree
componentSink :: ZonkAny 3 -> JSM ()
componentModel :: IORef model
componentActions :: IORef (Seq (ZonkAny 3))
..} -> IORef model -> IO model
forall a. IORef a -> IO a
readIORef IORef model
componentModel)
-----------------------------------------------------------------------------
-- | Used for bidirectional communication between components.
-- Specify the mounted @Component@ you'd like to target.
--
-- This function is used to send messages to @Component@ that are mounted on
-- other parts of the DOM tree.
--
notify
  :: forall name model action . KnownSymbol name
  => Component name model action
  -> action
  -> JSM ()
notify :: forall (name :: Symbol) model action.
KnownSymbol name =>
Component name model action -> action -> JSM ()
notify Component {model
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View action
action -> Effect model action
logLevel :: forall (name :: Symbol) model action.
Component name model action -> LogLevel
mountPoint :: forall (name :: Symbol) model action.
Component name model action -> Maybe MisoString
initialAction :: forall (name :: Symbol) model action.
Component name model action -> Maybe action
styles :: forall (name :: Symbol) model action.
Component name model action -> [CSS]
events :: forall (name :: Symbol) model action.
Component name model action -> Events
subs :: forall (name :: Symbol) model action.
Component name model action -> [Sub action]
view :: forall (name :: Symbol) model action.
Component name model action -> model -> View action
update :: forall (name :: Symbol) model action.
Component name model action -> action -> Effect model action
model :: forall (name :: Symbol) model action.
Component name model action -> model
model :: model
update :: action -> Effect model action
view :: model -> View action
subs :: [Sub action]
events :: Events
styles :: [CSS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
..} action
action = do
  componentStateMap <- IO (Map MisoString (ComponentState (ZonkAny 4) (ZonkAny 5) action))
-> JSM
     (Map MisoString (ComponentState (ZonkAny 4) (ZonkAny 5) action))
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef
  (Map MisoString (ComponentState (ZonkAny 4) (ZonkAny 5) action))
-> IO
     (Map MisoString (ComponentState (ZonkAny 4) (ZonkAny 5) action))
forall a. IORef a -> IO a
readIORef IORef
  (Map MisoString (ComponentState (ZonkAny 4) (ZonkAny 5) action))
forall subKey model action.
IORef (Map MisoString (ComponentState subKey model action))
componentMap)
  case M.lookup name componentStateMap of
    Maybe (ComponentState (ZonkAny 4) (ZonkAny 5) action)
Nothing -> do
      Bool -> JSM () -> JSM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (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
DebugNotify, LogLevel
DebugAll]) (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
        MisoString -> JSM ()
FFI.consoleWarn (MisoString -> JSM ()) -> MisoString -> JSM ()
forall a b. (a -> b) -> a -> b
$
          MisoString
"[DEBUG_NOTIFY] Could not find component named: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
name
    Just ComponentState {MisoString
IORef (ZonkAny 5)
IORef (Map (ZonkAny 4) ThreadId)
IORef (Seq action)
IORef VTree
JSVal
action -> JSM ()
componentActions :: forall subKey model action.
ComponentState subKey model action -> IORef (Seq action)
componentModel :: forall subKey model action.
ComponentState subKey model action -> IORef model
componentSink :: forall subKey model action.
ComponentState subKey model action -> action -> JSM ()
componentVTree :: forall subKey model action.
ComponentState subKey model action -> IORef VTree
componentMount :: forall subKey model action.
ComponentState subKey model action -> JSVal
componentSubThreads :: forall subKey model action.
ComponentState subKey model action -> IORef (Map subKey ThreadId)
componentName :: forall subKey model action.
ComponentState subKey model action -> MisoString
componentName :: MisoString
componentSubThreads :: IORef (Map (ZonkAny 4) ThreadId)
componentMount :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: IORef (ZonkAny 5)
componentActions :: IORef (Seq action)
..} ->
      action -> JSM ()
componentSink action
action
  where
    name :: MisoString
name = String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (String -> MisoString) -> String -> MisoString
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)
-----------------------------------------------------------------------------
-- | Like @notify@ except used for dynamic @Component@ where the /component-id/
-- has been retrieved via @ask@ and generated from @onMountedWith@.
--
-- We use the @Component Dynamic model action@ argument to ensure the 'action'
-- being used unified with what the component expects.
--
notify'
  :: MisoString
  -> Component Dynamic model action
  -> action
  -> JSM ()
notify' :: forall model action.
MisoString -> Component Dynamic model action -> action -> JSM ()
notify' MisoString
name Component {model
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View action
action -> Effect model action
logLevel :: forall (name :: Symbol) model action.
Component name model action -> LogLevel
mountPoint :: forall (name :: Symbol) model action.
Component name model action -> Maybe MisoString
initialAction :: forall (name :: Symbol) model action.
Component name model action -> Maybe action
styles :: forall (name :: Symbol) model action.
Component name model action -> [CSS]
events :: forall (name :: Symbol) model action.
Component name model action -> Events
subs :: forall (name :: Symbol) model action.
Component name model action -> [Sub action]
view :: forall (name :: Symbol) model action.
Component name model action -> model -> View action
update :: forall (name :: Symbol) model action.
Component name model action -> action -> Effect model action
model :: forall (name :: Symbol) model action.
Component name model action -> model
model :: model
update :: action -> Effect model action
view :: model -> View action
subs :: [Sub action]
events :: Events
styles :: [CSS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
..} action
action = do
  componentStateMap <- IO (Map MisoString (ComponentState (ZonkAny 6) (ZonkAny 7) action))
-> JSM
     (Map MisoString (ComponentState (ZonkAny 6) (ZonkAny 7) action))
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef
  (Map MisoString (ComponentState (ZonkAny 6) (ZonkAny 7) action))
-> IO
     (Map MisoString (ComponentState (ZonkAny 6) (ZonkAny 7) action))
forall a. IORef a -> IO a
readIORef IORef
  (Map MisoString (ComponentState (ZonkAny 6) (ZonkAny 7) action))
forall subKey model action.
IORef (Map MisoString (ComponentState subKey model action))
componentMap)
  case M.lookup name componentStateMap of
    Maybe (ComponentState (ZonkAny 6) (ZonkAny 7) action)
Nothing ->
      Bool -> JSM () -> JSM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (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
DebugNotify, LogLevel
DebugAll]) (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
        MisoString -> JSM ()
FFI.consoleWarn (MisoString -> JSM ()) -> MisoString -> JSM ()
forall a b. (a -> b) -> a -> b
$
          MisoString
"[DEBUG_NOTIFY'] Could not find component named: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
name
    Just ComponentState {MisoString
IORef (ZonkAny 7)
IORef (Map (ZonkAny 6) ThreadId)
IORef (Seq action)
IORef VTree
JSVal
action -> JSM ()
componentActions :: forall subKey model action.
ComponentState subKey model action -> IORef (Seq action)
componentModel :: forall subKey model action.
ComponentState subKey model action -> IORef model
componentSink :: forall subKey model action.
ComponentState subKey model action -> action -> JSM ()
componentVTree :: forall subKey model action.
ComponentState subKey model action -> IORef VTree
componentMount :: forall subKey model action.
ComponentState subKey model action -> JSVal
componentSubThreads :: forall subKey model action.
ComponentState subKey model action -> IORef (Map subKey ThreadId)
componentName :: forall subKey model action.
ComponentState subKey model action -> MisoString
componentName :: MisoString
componentSubThreads :: IORef (Map (ZonkAny 6) ThreadId)
componentMount :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: IORef (ZonkAny 7)
componentActions :: IORef (Seq action)
..} ->
      action -> JSM ()
componentSink action
action
-----------------------------------------------------------------------------
-- | 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
  -> 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 startComponent
-- Initial draw helper
-- If hydrateing, bypass diff and continue copying
drawComponent
  :: Hydrate
  -> MisoString
  -> Component name model action
  -> Sink action
  -> JSM (MisoString, JSVal, IORef VTree)
drawComponent :: forall (name :: Symbol) model action.
Hydrate
-> MisoString
-> Component name model action
-> Sink action
-> JSM (MisoString, JSVal, IORef VTree)
drawComponent Hydrate
hydrate MisoString
name Component {model
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View action
action -> Effect model action
logLevel :: forall (name :: Symbol) model action.
Component name model action -> LogLevel
mountPoint :: forall (name :: Symbol) model action.
Component name model action -> Maybe MisoString
initialAction :: forall (name :: Symbol) model action.
Component name model action -> Maybe action
styles :: forall (name :: Symbol) model action.
Component name model action -> [CSS]
events :: forall (name :: Symbol) model action.
Component name model action -> Events
subs :: forall (name :: Symbol) model action.
Component name model action -> [Sub action]
view :: forall (name :: Symbol) model action.
Component name model action -> model -> View action
update :: forall (name :: Symbol) model action.
Component name model action -> action -> Effect model action
model :: forall (name :: Symbol) model action.
Component name model action -> model
model :: model
update :: action -> Effect model action
view :: model -> View action
subs :: [Sub action]
events :: Events
styles :: [CSS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
..} Sink action
snk = do
  vtree <- Hydrate
-> View action -> Sink action -> LogLevel -> Events -> JSM VTree
forall action.
Hydrate
-> View action -> Sink action -> LogLevel -> Events -> JSM VTree
runView Hydrate
hydrate (model -> View action
view model
model) Sink action
snk LogLevel
logLevel Events
events
  mountElement <- FFI.getComponent name
  when (hydrate == Draw) (diff Nothing (Just vtree) mountElement)
  ref <- liftIO (newIORef vtree)
  pure (name, mountElement, ref)
-----------------------------------------------------------------------------
-- | Drains the event queue before unmounting, executed synchronously
drain
  :: Component name model action
  -> ComponentState subKey model action
  -> JSM ()
drain :: forall (name :: Symbol) model action subKey.
Component name model action
-> ComponentState subKey model action -> JSM ()
drain app :: Component name model action
app@Component{model
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View action
action -> Effect model action
logLevel :: forall (name :: Symbol) model action.
Component name model action -> LogLevel
mountPoint :: forall (name :: Symbol) model action.
Component name model action -> Maybe MisoString
initialAction :: forall (name :: Symbol) model action.
Component name model action -> Maybe action
styles :: forall (name :: Symbol) model action.
Component name model action -> [CSS]
events :: forall (name :: Symbol) model action.
Component name model action -> Events
subs :: forall (name :: Symbol) model action.
Component name model action -> [Sub action]
view :: forall (name :: Symbol) model action.
Component name model action -> model -> View action
update :: forall (name :: Symbol) model action.
Component name model action -> action -> Effect model action
model :: forall (name :: Symbol) model action.
Component name model action -> model
model :: model
update :: action -> Effect model action
view :: model -> View action
subs :: [Sub action]
events :: Events
styles :: [CSS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
..} cs :: ComponentState subKey model action
cs@ComponentState {MisoString
IORef model
IORef (Map subKey ThreadId)
IORef (Seq action)
IORef VTree
JSVal
action -> JSM ()
componentActions :: forall subKey model action.
ComponentState subKey model action -> IORef (Seq action)
componentModel :: forall subKey model action.
ComponentState subKey model action -> IORef model
componentSink :: forall subKey model action.
ComponentState subKey model action -> action -> JSM ()
componentVTree :: forall subKey model action.
ComponentState subKey model action -> IORef VTree
componentMount :: forall subKey model action.
ComponentState subKey model action -> JSVal
componentSubThreads :: forall subKey model action.
ComponentState subKey model action -> IORef (Map subKey ThreadId)
componentName :: forall subKey model action.
ComponentState subKey model action -> MisoString
componentName :: MisoString
componentSubThreads :: IORef (Map subKey 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
  -> Component name model action
  -> ComponentState subKey model action
  -> JSM ()
unmount :: forall (name :: Symbol) model action subKey.
Function
-> Component name model action
-> ComponentState subKey model action
-> JSM ()
unmount Function
mountCallback app :: Component name model action
app@Component {model
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View action
action -> Effect model action
logLevel :: forall (name :: Symbol) model action.
Component name model action -> LogLevel
mountPoint :: forall (name :: Symbol) model action.
Component name model action -> Maybe MisoString
initialAction :: forall (name :: Symbol) model action.
Component name model action -> Maybe action
styles :: forall (name :: Symbol) model action.
Component name model action -> [CSS]
events :: forall (name :: Symbol) model action.
Component name model action -> Events
subs :: forall (name :: Symbol) model action.
Component name model action -> [Sub action]
view :: forall (name :: Symbol) model action.
Component name model action -> model -> View action
update :: forall (name :: Symbol) model action.
Component name model action -> action -> Effect model action
model :: forall (name :: Symbol) model action.
Component name model action -> model
model :: model
update :: action -> Effect model action
view :: model -> View action
subs :: [Sub action]
events :: Events
styles :: [CSS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
..} cs :: ComponentState subKey model action
cs@ComponentState {MisoString
IORef model
IORef (Map subKey ThreadId)
IORef (Seq action)
IORef VTree
JSVal
action -> JSM ()
componentActions :: forall subKey model action.
ComponentState subKey model action -> IORef (Seq action)
componentModel :: forall subKey model action.
ComponentState subKey model action -> IORef model
componentSink :: forall subKey model action.
ComponentState subKey model action -> action -> JSM ()
componentVTree :: forall subKey model action.
ComponentState subKey model action -> IORef VTree
componentMount :: forall subKey model action.
ComponentState subKey model action -> JSVal
componentSubThreads :: forall subKey model action.
ComponentState subKey model action -> IORef (Map subKey ThreadId)
componentName :: forall subKey model action.
ComponentState subKey model action -> MisoString
componentName :: MisoString
componentSubThreads :: IORef (Map subKey ThreadId)
componentMount :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: IORef model
componentActions :: IORef (Seq action)
..} = do
  JSVal -> IORef VTree -> Events -> Bool -> JSM ()
undelegator JSVal
componentMount IORef VTree
componentVTree Events
events (LogLevel
logLevel LogLevel -> [LogLevel] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [LogLevel
DebugEvents, LogLevel
DebugAll])
  Function -> JSM ()
freeFunction Function
mountCallback
  IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((ThreadId -> IO ()) -> Map subKey ThreadId -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread (Map subKey ThreadId -> IO ()) -> IO (Map subKey ThreadId) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Map subKey ThreadId) -> IO (Map subKey ThreadId)
forall a. IORef a -> IO a
readIORef IORef (Map subKey ThreadId)
componentSubThreads)
  Component name model action
-> ComponentState subKey model action -> JSM ()
forall (name :: Symbol) model action subKey.
Component name model action
-> ComponentState subKey model action -> JSM ()
drain Component name model action
app ComponentState subKey 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 8) (ZonkAny 9) (ZonkAny 10)))
-> (Map
      MisoString (ComponentState (ZonkAny 8) (ZonkAny 9) (ZonkAny 10))
    -> (Map
          MisoString (ComponentState (ZonkAny 8) (ZonkAny 9) (ZonkAny 10)),
        ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef
  (Map
     MisoString (ComponentState (ZonkAny 8) (ZonkAny 9) (ZonkAny 10)))
forall subKey model action.
IORef (Map MisoString (ComponentState subKey model action))
componentMap ((Map
    MisoString (ComponentState (ZonkAny 8) (ZonkAny 9) (ZonkAny 10))
  -> (Map
        MisoString (ComponentState (ZonkAny 8) (ZonkAny 9) (ZonkAny 10)),
      ()))
 -> IO ())
-> (Map
      MisoString (ComponentState (ZonkAny 8) (ZonkAny 9) (ZonkAny 10))
    -> (Map
          MisoString (ComponentState (ZonkAny 8) (ZonkAny 9) (ZonkAny 10)),
        ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map
  MisoString (ComponentState (ZonkAny 8) (ZonkAny 9) (ZonkAny 10))
m -> (MisoString
-> Map
     MisoString (ComponentState (ZonkAny 8) (ZonkAny 9) (ZonkAny 10))
-> Map
     MisoString (ComponentState (ZonkAny 8) (ZonkAny 9) (ZonkAny 10))
forall k a. Ord k => k -> Map k a -> Map k a
M.delete MisoString
componentName Map
  MisoString (ComponentState (ZonkAny 8) (ZonkAny 9) (ZonkAny 10))
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
  :: 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 MisoString
name [Attribute action]
attrs (SomeComponent Component name model action
app)) Sink action
snk LogLevel
_ Events
_ = do
  compName <-
    if MisoString -> Bool
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 <- Component name model action
-> (Sink action -> JSM (MisoString, JSVal, IORef VTree))
-> JSM (IORef VTree)
forall model (name :: Symbol) action.
Eq model =>
Component name model action
-> (Sink action -> JSM (MisoString, JSVal, IORef VTree))
-> JSM (IORef VTree)
initialize Component name model action
app (Hydrate
-> MisoString
-> Component name model action
-> Sink action
-> JSM (MisoString, JSVal, IORef VTree)
forall (name :: Symbol) model action.
Hydrate
-> MisoString
-> Component name model action
-> Sink action
-> JSM (MisoString, JSVal, IORef VTree)
drawComponent Hydrate
hydrate MisoString
compName Component name 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 (ZonkAny 15) model action)
Nothing -> () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just ComponentState (ZonkAny 15) model action
componentState ->
          Function
-> Component name model action
-> ComponentState (ZonkAny 15) model action
-> JSM ()
forall (name :: Symbol) model action subKey.
Function
-> Component name model action
-> ComponentState subKey model action
-> JSM ()
unmount Function
mountCallback Component name model action
app ComponentState (ZonkAny 15) model action
componentState
  vcomp <- createNode "vcomp" HTML "div"
  setAttrs vcomp attrs snk (logLevel app) (events app)
  flip (FFI.set "children") vcomp =<< toJSVal ([] :: [MisoString])
  FFI.set "data-component-id" compName vcomp
  flip (FFI.set "mount") vcomp =<< toJSVal mountCallback
  FFI.set "unmount" unmountCallback vcomp
  pure (VTree vcomp)
runView Hydrate
hydrate (VNode NS
ns MisoString
tag [Attribute action]
attrs [View action]
kids) Sink action
snk LogLevel
logLevel Events
events = do
  vnode <- MisoString -> NS -> MisoString -> JSM Object
createNode MisoString
"vnode" NS
ns MisoString
tag
  setAttrs vnode attrs snk logLevel events
  vchildren <- ghcjsPure . jsval =<< procreate
  FFI.set "children" vchildren vnode
  sync <- FFI.shouldSync =<< toJSVal vnode
  FFI.set "shouldSync" sync vnode
  pure $ VTree vnode
    where
      procreate :: JSM (SomeJSArray m)
procreate = do
        kidsViews <- [View action] -> (View action -> JSM 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) <- 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" Value
v -> do
      value <- Value -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal Value
v
      FFI.set "key" value vnode
    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 -> Events -> JSM ()
attr -> Sink action -> Object -> LogLevel -> Events -> JSM ()
attr Sink action
snk Object
vnode LogLevel
logLevel Events
events
    Styles Map MisoString MisoString
styles -> do
      cssObj <- JSString -> Object -> JSM 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
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 subKey model action -> m ()
registerComponent :: forall (m :: * -> *) subKey model action.
MonadIO m =>
ComponentState subKey model action -> m ()
registerComponent ComponentState subKey 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 subKey model action))
-> (Map MisoString (ComponentState subKey model action)
    -> Map MisoString (ComponentState subKey model action))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map MisoString (ComponentState subKey model action))
forall subKey model action.
IORef (Map MisoString (ComponentState subKey model action))
componentMap
  ((Map MisoString (ComponentState subKey model action)
  -> Map MisoString (ComponentState subKey model action))
 -> IO ())
-> (Map MisoString (ComponentState subKey model action)
    -> Map MisoString (ComponentState subKey model action))
-> IO ()
forall a b. (a -> b) -> a -> b
$ MisoString
-> ComponentState subKey model action
-> Map MisoString (ComponentState subKey model action)
-> Map MisoString (ComponentState subKey model action)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (ComponentState subKey model action -> MisoString
forall subKey model action.
ComponentState subKey model action -> MisoString
componentName ComponentState subKey model action
componentState) ComponentState subKey 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
-----------------------------------------------------------------------------
-- | 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")
-- @
startSub :: Ord subKey => subKey -> Sub action -> Effect model action
startSub :: forall subKey action model.
Ord subKey =>
subKey -> Sub action -> Effect model action
startSub subKey
subKey Sink action -> JSM ()
sub = do
  compName <- RWST MisoString [Sink action -> JSM ()] model Identity MisoString
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_
    (M.lookup compName <$> liftIO (readIORef componentMap) >>= \case
      Maybe (ComponentState subKey (ZonkAny 11) action)
Nothing -> () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just compState :: ComponentState subKey (ZonkAny 11) action
compState@ComponentState {MisoString
IORef (ZonkAny 11)
IORef (Map subKey ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Sink action
componentActions :: forall subKey model action.
ComponentState subKey model action -> IORef (Seq action)
componentModel :: forall subKey model action.
ComponentState subKey model action -> IORef model
componentSink :: forall subKey model action.
ComponentState subKey model action -> action -> JSM ()
componentVTree :: forall subKey model action.
ComponentState subKey model action -> IORef VTree
componentMount :: forall subKey model action.
ComponentState subKey model action -> JSVal
componentSubThreads :: forall subKey model action.
ComponentState subKey model action -> IORef (Map subKey ThreadId)
componentName :: forall subKey model action.
ComponentState subKey model action -> MisoString
componentName :: MisoString
componentSubThreads :: IORef (Map subKey ThreadId)
componentMount :: JSVal
componentVTree :: IORef VTree
componentSink :: Sink action
componentModel :: IORef (ZonkAny 11)
componentActions :: IORef (Seq action)
..} -> do
        mtid <- IO (Maybe ThreadId) -> JSM (Maybe ThreadId)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (subKey -> Map subKey ThreadId -> Maybe ThreadId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup subKey
subKey (Map subKey ThreadId -> Maybe ThreadId)
-> IO (Map subKey ThreadId) -> IO (Maybe ThreadId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map subKey ThreadId) -> IO (Map subKey ThreadId)
forall a. IORef a -> IO a
readIORef IORef (Map subKey ThreadId)
componentSubThreads)
        case mtid of
          Maybe ThreadId
Nothing ->
            ComponentState subKey (ZonkAny 11) action -> JSM ()
forall {model}. ComponentState subKey model action -> JSM ()
startThread ComponentState subKey (ZonkAny 11) 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 subKey (ZonkAny 11) action -> JSM ()
forall {model}. ComponentState subKey model action -> JSM ()
startThread ComponentState subKey (ZonkAny 11) action
compState
              ThreadStatus
ThreadDied -> ComponentState subKey (ZonkAny 11) action -> JSM ()
forall {model}. ComponentState subKey model action -> JSM ()
startThread ComponentState subKey (ZonkAny 11) action
compState
              ThreadStatus
_ -> () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  where
    startThread :: ComponentState subKey model action -> JSM ()
startThread ComponentState {MisoString
IORef model
IORef (Map subKey ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Sink action
componentActions :: forall subKey model action.
ComponentState subKey model action -> IORef (Seq action)
componentModel :: forall subKey model action.
ComponentState subKey model action -> IORef model
componentSink :: forall subKey model action.
ComponentState subKey model action -> action -> JSM ()
componentVTree :: forall subKey model action.
ComponentState subKey model action -> IORef VTree
componentMount :: forall subKey model action.
ComponentState subKey model action -> JSVal
componentSubThreads :: forall subKey model action.
ComponentState subKey model action -> IORef (Map subKey ThreadId)
componentName :: forall subKey model action.
ComponentState subKey model action -> MisoString
componentName :: MisoString
componentSubThreads :: IORef (Map subKey ThreadId)
componentMount :: JSVal
componentVTree :: IORef VTree
componentSink :: Sink action
componentModel :: IORef model
componentActions :: IORef (Seq action)
..} = do
      tid <- JSM () -> JSM ThreadId
FFI.forkJSM (Sink action -> JSM ()
sub Sink action
componentSink)
      liftIO $ atomicModifyIORef' componentSubThreads $ \Map subKey ThreadId
m ->
        (subKey -> ThreadId -> Map subKey ThreadId -> Map subKey ThreadId
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert subKey
subKey ThreadId
tid Map subKey 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
-- @
stopSub :: Ord subKey => subKey -> Effect model action
stopSub :: forall subKey model action.
Ord subKey =>
subKey -> Effect model action
stopSub subKey
subKey = do
  compName <- RWST MisoString [Sink action -> JSM ()] model Identity MisoString
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_
    (M.lookup compName <$> liftIO (readIORef componentMap) >>= \case
      Maybe (ComponentState subKey (ZonkAny 12) (ZonkAny 13))
Nothing -> do
        () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just ComponentState {MisoString
IORef (ZonkAny 12)
IORef (Map subKey ThreadId)
IORef (Seq (ZonkAny 13))
IORef VTree
JSVal
ZonkAny 13 -> JSM ()
componentActions :: forall subKey model action.
ComponentState subKey model action -> IORef (Seq action)
componentModel :: forall subKey model action.
ComponentState subKey model action -> IORef model
componentSink :: forall subKey model action.
ComponentState subKey model action -> action -> JSM ()
componentVTree :: forall subKey model action.
ComponentState subKey model action -> IORef VTree
componentMount :: forall subKey model action.
ComponentState subKey model action -> JSVal
componentSubThreads :: forall subKey model action.
ComponentState subKey model action -> IORef (Map subKey ThreadId)
componentName :: forall subKey model action.
ComponentState subKey model action -> MisoString
componentName :: MisoString
componentSubThreads :: IORef (Map subKey ThreadId)
componentMount :: JSVal
componentVTree :: IORef VTree
componentSink :: ZonkAny 13 -> JSM ()
componentModel :: IORef (ZonkAny 12)
componentActions :: IORef (Seq (ZonkAny 13))
..} -> do
        mtid <- IO (Maybe ThreadId) -> JSM (Maybe ThreadId)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (subKey -> Map subKey ThreadId -> Maybe ThreadId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup subKey
subKey (Map subKey ThreadId -> Maybe ThreadId)
-> IO (Map subKey ThreadId) -> IO (Maybe ThreadId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map subKey ThreadId) -> IO (Map subKey ThreadId)
forall a. IORef a -> IO a
readIORef IORef (Map subKey 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 subKey ThreadId)
-> (Map subKey ThreadId -> (Map subKey ThreadId, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map subKey ThreadId)
componentSubThreads ((Map subKey ThreadId -> (Map subKey ThreadId, ())) -> IO ())
-> (Map subKey ThreadId -> (Map subKey ThreadId, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Map subKey ThreadId
m -> (subKey -> Map subKey ThreadId -> Map subKey ThreadId
forall k a. Ord k => k -> Map k a -> Map k a
M.delete subKey
subKey Map subKey ThreadId
m, ())
            ThreadId -> IO ()
killThread ThreadId
tid)
-----------------------------------------------------------------------------