-----------------------------------------------------------------------------
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE BlockArguments             #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE DuplicateRecordFields      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -fno-warn-orphans       #-}
-----------------------------------------------------------------------------
#ifdef PRODUCTION
#define MISO_JS_PATH "js/miso.prod.js"
#else
#define MISO_JS_PATH "js/miso.js"
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Runtime
-- Copyright   :  (C) 2016-2026 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
-----------------------------------------------------------------------------
module Miso.Runtime
  ( -- * Internal functions
    initialize
  , freshComponentId
  , buildVTree
  , registerEventHandler
  , renderStyles
  , renderScripts
  , Hydrate(..)
  -- * Subscription
  , startSub
  , stopSub
  -- * Pub / Sub
  , subscribe
  , unsubscribe
  , publish
  , Topic (..)
  , topic
  -- * Component
  , ComponentState (..)
  , ComponentIds
  -- ** Communication
  , mail
  , checkMail
  , broadcast
  , mailParent
  , mailChildren
  , mailAncestors
  , mailDescendants
  -- ** WebSocket
  , websocketConnect
  , websocketConnectJSON
  , websocketConnectText
  , websocketConnectArrayBuffer
  , websocketConnectBLOB
  , websocketSend
  , websocketClose
  , socketState
  , emptyWebSocket
  , WebSocket (..)
  , URL
  , SocketState (..)
  , CloseCode (..)
  , Closed (..)
  -- ** EventSource
  , eventSourceConnectText
  , eventSourceConnectJSON
  , eventSourceClose
  , emptyEventSource
  , EventSource (..)
  -- ** Payload
  , Payload (..)
  , json
  , blob
  , arrayBuffer
  -- ** Internal Component state
  , components
  , modifyContextAll
  , schedulerThread
  , componentIds
  , rootComponentId
  , componentId
  , modifyComponent
  , unmountComponent
  , freeLifecycleHooks
  , componentModel
  , componentContext
  -- ** Scheduler
  , scheduler
#ifdef WASM
  , evalFile
#endif
  , topLevelComponentId
  , initComponent
  , withJS
  -- * Lynx cross-thread
  , MTS (..)
  , BTS (..)
  , getMTSContext
  , getBTSContext
  , dispatchEvent
  , mts
  , bts
  , web
  -- ** Protocol types
  , ComponentType (..)
  , COMPONENT (..)
  , EFFECT (..)
  ) where
-----------------------------------------------------------------------------
import qualified Data.IntSet as IS
import           Data.IntSet (IntSet)
#ifdef NATIVE
import qualified Data.Set as Set
#endif
import           Data.Proxy (Proxy(Proxy))
import           Control.Category ((.))
import           Control.Concurrent
import           Control.Exception (SomeException, catch)
import           Control.Monad (forM, forM_, when, void, (<=<), zipWithM_, forever, foldM, unless)
import           Control.Monad.Reader (ask, asks)
import           Control.Monad.State hiding (state)
import qualified Miso.JSON as JSON
import           Miso.JSON (FromJSON, ToJSON, Result(..), Value, encode, fromJSON, jsonStringify, toJSON, parseEither)
import           Miso.Event.Decoder (Decoder(decoder, decodeAt))

#if __GLASGOW_HASKELL__ < 910
import           Data.Foldable (foldl')
#endif
import           Control.Applicative ((<|>))
import           Data.Maybe
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import           Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM
import           Data.IORef (IORef, newIORef, atomicModifyIORef', readIORef, atomicWriteIORef)
import qualified Data.Sequence as S
import           Data.Sequence (Seq)
import           GHC.Conc (ThreadStatus(ThreadDied, ThreadFinished), threadStatus)
import           Data.Word (Word64)
import           GHC.Fingerprint (Fingerprint(..))
import           Numeric (readHex)
import           GHC.StaticPtr (StaticKey, staticKey, deRefStaticPtr)
#ifdef NATIVE
import           GHC.StaticPtr (unsafeLookupStaticPtr)
#endif
import           Prelude hiding ((.))
import           System.IO.Unsafe (unsafePerformIO)
import           System.Mem.StableName (makeStableName)
import           System.Mem (performMajorGC)
#ifdef BENCH
import           Text.Printf
#endif
-----------------------------------------------------------------------------
import           Miso.Concurrent (Waiter(..), waiter)
#ifdef NATIVE
import           Miso.Concurrent (oneshot)
#endif
import           Miso.CSS (renderStyleSheet)
import           Miso.Delegate (delegator)
import qualified Miso.Diff as Diff
import           Miso.DSL
#ifdef WASM
import           Miso.DSL.TH.File (evalFile)
#endif
import           Miso.Effect
  ( ComponentInfo(..), Sub, Sink, Effect, Schedule(..), runEffect
  , io_, withSink, Synchronicity(..)
  )
import qualified Miso.Effect as E (Thread(..))
import qualified Miso.FFI.Internal as FFI
import           Miso.FFI.Internal (Blob(..), ArrayBuffer(..))
import qualified Miso.Hydrate as Hydrate
import           Miso.Lens hiding (view)
import           Miso.String (ToMisoString(..), FromMisoString(..))
import           Miso.Types
import           Miso.Util
-----------------------------------------------------------------------------
-- | Helper function to abstract out initialization of t'Miso.Types.Component' between top-level API functions.
initialize
#ifdef NATIVE
  :: (Eq context, Eq model, Eq props, ToJSON model, ToJSON props, ToJSON action, FromJSON action)
#else
  :: (Eq context, Eq model, Eq props)
#endif
  => Events
  -> ComponentId
  -> Hydrate
  -> Bool
  -- ^ Is the root node being rendered?
  -> Bool
  -- ^ Is live-reload mode active? Gates key-based model recovery — outside
  -- hot reload, a keyed component must never inherit a previous (possibly
  -- unrelated) component's model just because it shares a t'Key'.
  -> IORef context
  -- ^ The app-global @context@ cell, created once by 'initComponent'. Children
  -- are handed the very same 'IORef' as the component building them, so there
  -- is one value for the whole app and no copy that can drift.
  -> props
  -- ^ Initial props for this component
  -> Maybe Key
  -- ^ Optional key for stable hot-reload model recovery
  -> Maybe StaticKey
  -- ^ 'StaticPtr' key for cross-thread (Lynx) child component lifecycle
  -> Component context props model action
  -> IO DOMRef
  -- ^ Callback function is used for obtaining the t'Miso.Types.Component' @DOMRef@.
  -> IO (ComponentState context props model action)
initialize :: forall context model props action.
(Eq context, Eq model, Eq props) =>
Events
-> Int
-> Hydrate
-> Bool
-> Bool
-> IORef context
-> props
-> Maybe Key
-> Maybe StaticKey
-> Component context props model action
-> IO JSVal
-> IO (ComponentState context props model action)
initialize Events
events Int
_componentParentId Hydrate
hydrate Bool
isRoot Bool
live IORef context
_componentContext props
initialProps Maybe Key
maybeKey Maybe StaticKey
_componentStaticKey comp :: Component context props model action
comp@Component {model
Bool
[JS]
[CSS]
[Sub model action]
Maybe action
Maybe (IO model)
Maybe MisoString
Maybe (props -> props -> action)
LogLevel
model -> View context props model action
action -> Effect context props model action
Value -> Maybe action
model :: model
hydrateModel :: Maybe (IO model)
update :: action -> Effect context props model action
view :: model -> View context props model action
useContext :: Bool
subs :: [Sub model action]
styles :: [CSS]
scripts :: [JS]
mountPoint :: Maybe MisoString
logLevel :: LogLevel
mailbox :: Value -> Maybe action
eventPropagation :: Bool
mount :: Maybe action
unmount :: Maybe action
onPropsChanged :: Maybe (props -> props -> action)
onPropsChanged :: forall context props model action.
Component context props model action
-> Maybe (props -> props -> action)
unmount :: forall context props model action.
Component context props model action -> Maybe action
mount :: forall context props model action.
Component context props model action -> Maybe action
eventPropagation :: forall context props model action.
Component context props model action -> Bool
mailbox :: forall context props model action.
Component context props model action -> Value -> Maybe action
logLevel :: forall context props model action.
Component context props model action -> LogLevel
mountPoint :: forall context props model action.
Component context props model action -> Maybe MisoString
scripts :: forall context props model action.
Component context props model action -> [JS]
styles :: forall context props model action.
Component context props model action -> [CSS]
subs :: forall context props model action.
Component context props model action -> [Sub model action]
useContext :: forall context props model action.
Component context props model action -> Bool
view :: forall context props model action.
Component context props model action
-> model -> View context props model action
update :: forall context props model action.
Component context props model action
-> action -> Effect context props model action
hydrateModel :: forall context props model action.
Component context props model action -> Maybe (IO model)
model :: forall context props model action.
Component context props model action -> model
..} IO JSVal
getComponentMountPoint = do
  Int
_componentId <- IO Int
freshComponentId
  let
    _componentProps :: props
_componentProps = props
initialProps
    _componentSink :: action -> IO ()
_componentSink = \action
action -> do
      IORef (Queue action)
-> (Queue action -> (Queue action, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Queue action)
forall action. IORef (Queue action)
globalQueue (\Queue action
q -> (Int -> action -> Queue action -> Queue action
forall action. Int -> action -> Queue action -> Queue action
enqueue Int
_componentId action
action Queue action
q, ()))
      Waiter -> IO ()
notify Waiter
globalWaiter

  model
initializedModel <-
    case (Hydrate
hydrate, Maybe (IO model)
hydrateModel) of
      (Hydrate
Hydrate, Just IO model
m) -> IO model
m
      (Hydrate
Draw, Maybe (IO model)
_) ->
        case (Bool
live, Maybe Key
maybeKey) of
          (Bool
True, Just Key
k) -> do
            IntMap (ComponentState Any Any model Any)
vcomps <- IORef (IntMap (ComponentState Any Any model Any))
-> IO (IntMap (ComponentState Any Any model Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState Any Any model Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
            model -> IO model
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (model -> IO model) -> model -> IO model
forall a b. (a -> b) -> a -> b
$ model -> Maybe model -> model
forall a. a -> Maybe a -> a
fromMaybe model
model (Maybe model -> model) -> Maybe model -> model
forall a b. (a -> b) -> a -> b
$ [model] -> Maybe model
forall a. [a] -> Maybe a
listToMaybe
              [ ComponentState Any Any model Any
cs ComponentState Any Any model Any
-> Lens (ComponentState Any Any model Any) model -> model
forall record field. record -> Lens record field -> field
^. Lens (ComponentState Any Any model Any) model
forall context props model action.
Lens (ComponentState context props model action) model
componentModel
              | ComponentState Any Any model Any
cs <- IntMap (ComponentState Any Any model Any)
-> [ComponentState Any Any model Any]
forall a. IntMap a -> [a]
IM.elems IntMap (ComponentState Any Any model Any)
vcomps
              , ComponentState Any Any model Any
cs ComponentState Any Any model Any
-> Lens (ComponentState Any Any model Any) (Maybe Key) -> Maybe Key
forall record field. record -> Lens record field -> field
^. Lens (ComponentState Any Any model Any) (Maybe Key)
forall context props model action.
Lens (ComponentState context props model action) (Maybe Key)
componentKey Maybe Key -> Maybe Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key -> Maybe Key
forall a. a -> Maybe a
Just Key
k
              ]
          (Bool, Maybe Key)
_ -> model -> IO model
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure model
model
      (Hydrate, Maybe (IO model))
_ -> model -> IO model
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure model
model
  [JSVal]
_componentScripts <-
    if Bool
web
    then
      Int
-> IntMap (ComponentState Any Any Any Any)
-> Maybe (ComponentState Any Any Any Any)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
_componentId (IntMap (ComponentState Any Any Any Any)
 -> Maybe (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
-> IO (Maybe (ComponentState Any Any Any Any))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState Any Any Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components IO (Maybe (ComponentState Any Any Any Any))
-> (Maybe (ComponentState Any Any Any Any) -> IO [JSVal])
-> IO [JSVal]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (ComponentState Any Any Any Any)
Nothing -> [JSVal] -> [JSVal] -> [JSVal]
forall a. [a] -> [a] -> [a]
(++) ([JSVal] -> [JSVal] -> [JSVal])
-> IO [JSVal] -> IO ([JSVal] -> [JSVal])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [JS] -> IO [JSVal]
renderScripts [JS]
scripts IO ([JSVal] -> [JSVal]) -> IO [JSVal] -> IO [JSVal]
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [CSS] -> IO [JSVal]
renderStyles [CSS]
styles
        Just ComponentState Any Any Any Any
cs -> [JSVal] -> IO [JSVal]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentState Any Any Any Any -> [JSVal]
forall context props model action.
ComponentState context props model action -> [JSVal]
_componentScripts ComponentState Any Any Any Any
cs) -- hot reload scenario, reuse already mounted scripts
    else
      [JSVal] -> IO [JSVal]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

  JSVal
_componentDOMRef <- IO JSVal
getComponentMountPoint
  IORef VTree
_componentVTree <- VTree -> IO (IORef VTree)
forall a. a -> IO (IORef a)
newIORef (Object -> VTree
VTree (JSVal -> Object
Object JSVal
jsNull))
  IORef (Map MisoString ThreadId)
_componentSubThreads <- Map MisoString ThreadId -> IO (IORef (Map MisoString ThreadId))
forall a. a -> IO (IORef a)
newIORef Map MisoString ThreadId
forall k a. Map k a
M.empty

  MVar Double
frame <- IO (MVar Double)
forall a. IO (MVar a)
newEmptyMVar :: IO (MVar Double)
  let _componentMailbox :: Seq a
_componentMailbox = Seq a
forall a. Seq a
S.empty

  JSVal
rAFCallback <-
    (JSVal -> IO ()) -> IO JSVal
asyncCallback1 ((JSVal -> IO ()) -> IO JSVal) -> (JSVal -> IO ()) -> IO JSVal
forall a b. (a -> b) -> a -> b
$ \JSVal
jsval -> do
      MVar Double -> Double -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Double
frame (Double -> IO ()) -> IO Double -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal -> IO Double
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked JSVal
jsval

  let _componentDraw :: model -> IO ()
_componentDraw = \model
newModel -> do
        ComponentState context props Any Any
current <- (IntMap (ComponentState context props Any Any)
-> Int -> ComponentState context props Any Any
forall a. IntMap a -> Int -> a
IM.! Int
_componentId) (IntMap (ComponentState context props Any Any)
 -> ComponentState context props Any Any)
-> IO (IntMap (ComponentState context props Any Any))
-> IO (ComponentState context props Any Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap (ComponentState context props Any Any))
-> IO (IntMap (ComponentState context props Any Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState context props Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
        let currentProps :: props
currentProps = ComponentState context props Any Any
current ComponentState context props Any Any
-> Lens (ComponentState context props Any Any) props -> props
forall record field. record -> Lens record field -> field
^. Lens (ComponentState context props Any Any) props
forall context props model action.
Lens (ComponentState context props model action) props
componentProps
            contextRef :: IORef context
contextRef = ComponentState context props Any Any
current ComponentState context props Any Any
-> Lens (ComponentState context props Any Any) (IORef context)
-> IORef context
forall record field. record -> Lens record field -> field
^. Lens (ComponentState context props Any Any) (IORef context)
forall context props model action.
Lens (ComponentState context props model action) (IORef context)
componentContext
        context
currentContext <- IORef context -> IO context
forall a. IORef a -> IO a
readIORef IORef context
contextRef
        VTree
newVTree <-
          Events
-> Int
-> Int
-> Hydrate
-> Bool
-> Sink action
-> LogLevel
-> IORef context
-> context
-> props
-> model
-> View context props model action
-> IO VTree
forall context props model action.
Eq context =>
Events
-> Int
-> Int
-> Hydrate
-> Bool
-> Sink action
-> LogLevel
-> IORef context
-> context
-> props
-> model
-> View context props model action
-> IO VTree
buildVTree Events
events Int
_componentParentId Int
_componentId Hydrate
Draw Bool
live
            Sink action
forall {action}. action -> IO ()
_componentSink LogLevel
logLevel IORef context
contextRef context
currentContext props
currentProps model
newModel (model -> View context props model action
view model
newModel)
        [Function]
newHandlers <- IO [Function]
collectEventHandlers
        VTree
oldVTree <- IORef VTree -> IO VTree
forall a. IORef a -> IO a
readIORef IORef VTree
_componentVTree
        Int
_frame <- JSVal -> IO Int
requestAnimationFrame JSVal
rAFCallback
        Double
_timestamp :: Double <- MVar Double -> IO Double
forall a. MVar a -> IO a
takeMVar MVar Double
frame
        Maybe VTree -> Maybe VTree -> JSVal -> IO ()
Diff.diff (VTree -> Maybe VTree
forall a. a -> Maybe a
Just VTree
oldVTree) (VTree -> Maybe VTree
forall a. a -> Maybe a
Just VTree
newVTree) JSVal
_componentDOMRef
        VTree -> VTree -> IO ()
forall val. ToJSVal val => val -> val -> IO ()
FFI.updateRef VTree
oldVTree VTree
newVTree
        IORef VTree -> VTree -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef VTree
_componentVTree VTree
newVTree
        -- The old tree can no longer dispatch; free its handler callbacks.
        -- See Note [Freeing event handler callbacks].
        Int -> [Function] -> IO ()
swapEventHandlers Int
_componentId [Function]
newHandlers
        IO ()
FFI.flush

#ifdef NATIVE
  -- N.B. all three cross-thread dispatch functions below wrap their FFI call
  -- in 'catch' / 'exception': the underlying 'postComponent' \/ 'postEffect'
  -- calls do a raw 'getMTSContext' \/ 'getBTSContext' round-trip, and an
  -- uncaught exception there (e.g. a transient bridge hiccup) would otherwise
  -- propagate out of the scheduler's 'forever' loop and silently kill it.
  let _componentHydrate = \newModel -> do
        when bts $ (postComponent MODEL_HYDRATE _componentStaticKey _componentId _componentParentId
          (Just (toJSON newModel)) Nothing) `catch` exception

  let _componentPostEffect = \action ->
        postEffect _componentStaticKey _componentId (toJSON action) `catch` exception
#else
  let _componentHydrate :: p -> IO ()
_componentHydrate = \p
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  let _componentPostEffect :: p -> IO ()
_componentPostEffect = \p
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
#endif

  let _componentApplyActions :: Seq action
-> model -> props -> context -> (model, [Schedule context action])
_componentApplyActions = \(Seq action
actions :: Seq action) model
model_ props
currentProps context
ctx -> do
        let info :: ComponentInfo context props
info = Int
-> Int -> JSVal -> props -> context -> ComponentInfo context props
forall context props.
Int
-> Int -> JSVal -> props -> context -> ComponentInfo context props
ComponentInfo Int
_componentId Int
_componentParentId JSVal
_componentDOMRef props
currentProps context
ctx
        ((model, [Schedule context action])
 -> action -> (model, [Schedule context action]))
-> (model, [Schedule context action])
-> Seq action
-> (model, [Schedule context action])
forall b a. (b -> a -> b) -> b -> Seq a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(model
m, [Schedule context action]
ss) action
action ->
          case Effect context props model action
-> ComponentInfo context props
-> model
-> (model, [Schedule context action])
forall context props model action.
Effect context props model action
-> ComponentInfo context props
-> model
-> (model, [Schedule context action])
runEffect (action -> Effect context props model action
update action
action) ComponentInfo context props
info model
m of
            (model
n, [Schedule context action]
sss) -> (model
n, [Schedule context action]
ss [Schedule context action]
-> [Schedule context action] -> [Schedule context action]
forall a. Semigroup a => a -> a -> a
<> [Schedule context action]
sss))
          (model
model_, []) Seq action
actions

  let vcomponent :: ComponentState context props model action
vcomponent = ComponentState
        { _componentKey :: Maybe Key
_componentKey = Maybe Key
maybeKey
        , _componentMailbox :: Value -> Maybe action
_componentMailbox = Value -> Maybe action
mailbox
        , _componentUseContext :: Bool
_componentUseContext = Bool
useContext
        , _componentTopics :: Map MisoString (Value -> IO ())
_componentTopics = Map MisoString (Value -> IO ())
forall a. Monoid a => a
mempty
        , _componentModelDirty :: model -> model -> Bool
_componentModelDirty = model -> model -> Bool
forall a. Eq a => a -> a -> Bool
dirtyCheck
        , _componentChildren :: ComponentIds
_componentChildren = ComponentIds
forall a. Monoid a => a
mempty
        , _componentModel :: model
_componentModel = model
initializedModel
        , _prevComponentProps :: props
_prevComponentProps = props
_componentProps
        , _componentPropsPhase :: props -> props -> IO ()
_componentPropsPhase = \props
oldProps props
newProps ->
            case Maybe (props -> props -> action)
onPropsChanged of
              Just props -> props -> action
f -> Sink action
forall {action}. action -> IO ()
_componentSink (props -> props -> action
f props
oldProps props
newProps)
              Maybe (props -> props -> action)
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        , props
Int
[JSVal]
Maybe StaticKey
IORef context
IORef (Map MisoString ThreadId)
IORef VTree
JSVal
model -> IO ()
Sink action
Seq action
-> model -> props -> context -> (model, [Schedule context action])
forall {action}. action -> IO ()
_componentParentId :: Int
_componentContext :: IORef context
_componentStaticKey :: Maybe StaticKey
_componentId :: Int
_componentProps :: props
_componentSink :: forall {action}. action -> IO ()
_componentScripts :: [JSVal]
_componentScripts :: [JSVal]
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDraw :: model -> IO ()
_componentHydrate :: forall {action}. action -> IO ()
_componentPostEffect :: forall {action}. action -> IO ()
_componentApplyActions :: Seq action
-> model -> props -> context -> (model, [Schedule context action])
_componentApplyActions :: Seq action
-> model -> props -> context -> (model, [Schedule context action])
_componentHydrate :: model -> IO ()
_componentDraw :: model -> IO ()
_componentContext :: IORef context
_componentPostEffect :: Sink action
_componentSink :: Sink action
_componentVTree :: IORef VTree
_componentDOMRef :: JSVal
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentProps :: props
_componentParentId :: Int
_componentStaticKey :: Maybe StaticKey
_componentId :: Int
..
        }

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isRoot (JSVal -> IORef VTree -> Events -> Bool -> IO ()
delegator JSVal
_componentDOMRef 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]))
  ComponentState context props model action -> IO ()
forall (m :: * -> *) context props model action.
MonadIO m =>
ComponentState context props model action -> m ()
registerComponent ComponentState context props model action
vcomponent
  IO model
getModel <- Int -> model -> IO (IO model)
forall model. Int -> model -> IO (IO model)
mkGetModel Int
_componentId model
initializedModel
  IO model
-> [Sub model action]
-> IORef (Map MisoString ThreadId)
-> Sink action
-> IO ()
forall model action.
IO model
-> [Sub model action]
-> IORef (Map MisoString ThreadId)
-> Sink action
-> IO ()
initSubs IO model
getModel [Sub model action]
subs IORef (Map MisoString ThreadId)
_componentSubThreads Sink action
forall {action}. action -> IO ()
_componentSink
  -- Runs on every thread. On Lynx the MTS paints the initial frame directly
  -- (fast first frame) while the BTS builds the same VTree but suppresses its
  -- create-patches (deterministic nodeId parity keeps both trees addressable) —
  -- both governed by the global 'initialDraw' latch in the drawing contexts,
  -- which 'initComponent' clears ONCE the whole root mount finishes (see the note
  -- there).
  model
-> Events
-> Hydrate
-> Bool
-> Bool
-> Component context props model action
-> ComponentState context props model action
-> IO ()
forall m props context a.
(Eq m, Eq props, Eq context) =>
m
-> Events
-> Hydrate
-> Bool
-> Bool
-> Component context props m a
-> ComponentState context props m a
-> IO ()
initialDraw model
initializedModel Events
events Hydrate
hydrate Bool
isRoot Bool
live Component context props model action
comp ComponentState context props model action
vcomponent
  Maybe action -> Sink action -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe action
mount Sink action
forall {action}. action -> IO ()
_componentSink
#ifdef NATIVE
  -- Ship the child's initial @props@ so the MTS can rebuild the mirror
  -- component by pairing them with the t'SomeStaticComponent' recovered from the
  -- 'StaticKey'. The no-props case serializes @()@ (JSON @null@).
  when (bts && not isRoot) $ do
    -- 'mount()' runs synchronously mid-diff (see @ts/miso/dom.ts@
    -- 'mountComponent'), so this fires before the enclosing 'Diff.diff'
    -- call's own end-of-render 'FFI.flush' — meaning, without shipping
    -- what's accumulated so far right here, MOUNT (dispatched immediately
    -- below) can reach MTS before the "Miso.patches" batch containing the
    -- 'createElement' patch for @_componentDOMRef@ itself, this component's
    -- own mount point. MTS's 'resolveNodeRef' would then miss
    -- @runtime.nodes[nodeId]@ (a silent JS property-read failure, not an
    -- exception) and mount this child against a bogus parent. Flushing here
    -- guarantees the patch creating this mount point is already applied on
    -- MTS by the time MOUNT arrives (both travel the same cross-thread
    -- queue, so send-order is preserved) — cheap since it only fires on an
    -- actual new mount, not on every render.
    FFI.flush
    postComponent MOUNT _componentStaticKey _componentId _componentParentId
      (Just (toJSON initialProps)) (Just _componentDOMRef)
#endif
  ComponentState context props model action
-> IO (ComponentState context props model action)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ComponentState context props model action
vcomponent
-----------------------------------------------------------------------------
initSubs
  :: IO model
  -> [Sub model action]
  -> IORef (Map MisoString ThreadId)
  -> Sink action
  -> IO ()
initSubs :: forall model action.
IO model
-> [Sub model action]
-> IORef (Map MisoString ThreadId)
-> Sink action
-> IO ()
initSubs IO model
getModel [Sub model action]
subs_ IORef (Map MisoString ThreadId)
_componentSubThreads Sink action
_componentSink = do
  [Sub model action] -> (Sub model action -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Sub model action]
subs_ ((Sub model action -> IO ()) -> IO ())
-> (Sub model action -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Sub model action
sub_ -> do
    ThreadId
threadId <- IO () -> IO ThreadId
forkIO (Sub model action
sub_ Sink action
_componentSink IO model
getModel)
    MisoString
subKey <- IO MisoString
freshSubId
    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
-> 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, ())
-----------------------------------------------------------------------------
-- | Builds the @IO model@ handed to each 'Sub': a total lookup of the
-- component's current model. A 'Sub' is normally killed before its component
-- is deleted from 'components', but teardown is not atomic — 'killThread'
-- returns on exception delivery, before the 'Sub' finalizer has run, so e.g.
-- a still-queued requestAnimationFrame callback can fire after the component
-- is gone. In that window the last observed model is returned rather than
-- crashing on a missing key.
mkGetModel :: ComponentId -> model -> IO (IO model)
mkGetModel :: forall model. Int -> model -> IO (IO model)
mkGetModel Int
vcompId model
initialModel = do
  IORef model
lastModel <- model -> IO (IORef model)
forall a. a -> IO (IORef a)
newIORef model
initialModel
  IO model -> IO (IO model)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO model -> IO (IO model)) -> IO model -> IO (IO model)
forall a b. (a -> b) -> a -> b
$
    Int
-> IntMap (ComponentState Any Any model Any)
-> Maybe (ComponentState Any Any model Any)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap (ComponentState Any Any model Any)
 -> Maybe (ComponentState Any Any model Any))
-> IO (IntMap (ComponentState Any Any model Any))
-> IO (Maybe (ComponentState Any Any model Any))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap (ComponentState Any Any model Any))
-> IO (IntMap (ComponentState Any Any model Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState Any Any model Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components IO (Maybe (ComponentState Any Any model Any))
-> (Maybe (ComponentState Any Any model Any) -> IO model)
-> IO model
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (ComponentState Any Any model Any)
Nothing -> IORef model -> IO model
forall a. IORef a -> IO a
readIORef IORef model
lastModel
      Just ComponentState { _componentModel :: forall context props model action.
ComponentState context props model action -> model
_componentModel = model
currentModel } -> do
        IORef model -> model -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef model
lastModel model
currentModel
        model -> IO model
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure model
currentModel
-----------------------------------------------------------------------------
-- | Diffs two values (models, props, context), returning True if they differ
-- and a redraw / propagation is necessary. Pointer equality via 'StableName'
-- is used as a fast path before falling back to 'Eq'.
dirtyCheck :: Eq a => a -> a -> Bool
dirtyCheck :: forall a. Eq a => a -> a -> Bool
dirtyCheck a
c a
n = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
  StableName a
currentName <- a
c a -> IO (StableName a) -> IO (StableName a)
forall a b. a -> b -> b
`seq` a -> IO (StableName a)
forall a. a -> IO (StableName a)
makeStableName a
c
  StableName a
updatedName <- a
n a -> IO (StableName a) -> IO (StableName a)
forall a b. a -> b -> b
`seq` a -> IO (StableName a)
forall a. a -> IO (StableName a)
makeStableName a
n
  Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StableName a
currentName StableName a -> StableName a -> Bool
forall a. Eq a => a -> a -> Bool
/= StableName a
updatedName Bool -> Bool -> Bool
&& a
c a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
n)
-----------------------------------------------------------------------------
-- | Checks if the Component is mounted before executing actions
isMounted :: ComponentId -> IO Bool
isMounted :: Int -> IO Bool
isMounted Int
vcompId = Maybe (ComponentState Any Any Any Any) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ComponentState Any Any Any Any) -> Bool)
-> (IntMap (ComponentState Any Any Any Any)
    -> Maybe (ComponentState Any Any Any Any))
-> IntMap (ComponentState Any Any Any Any)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int
-> IntMap (ComponentState Any Any Any Any)
-> Maybe (ComponentState Any Any Any Any)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap (ComponentState Any Any Any Any) -> Bool)
-> IO (IntMap (ComponentState Any Any Any Any)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState Any Any Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
-----------------------------------------------------------------------------
-- | The scheduler processes all events in the system and is responsible
-- for propagating changes across model states both asynchronously
-- and synchronously. It also is responsible for
-- top-down rendering of the UI Component tree.
scheduler
  :: forall context . Eq context => Proxy context -> IO ()
scheduler :: forall context. Eq context => Proxy context -> IO ()
scheduler Proxy context
Proxy =
  IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
#ifdef NATIVE
    when mts (wait btsReady)
#endif
    IO (Maybe (Int, Seq Any))
forall action. IO (Maybe (Int, Seq action))
getBatch IO (Maybe (Int, Seq Any))
-> (Maybe (Int, Seq Any) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (Int, Seq Any)
Nothing -> Waiter -> IO ()
wait Waiter
globalWaiter
      Just (Int
vcompId, Seq Any
S.Empty)
        | Int
vcompId Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Bounded a => a
minBound -> do
            -- context propagation, 'minBound' sentinel indicates a global
            -- context change: re-render every t'Miso.Types.Component' with 'useContext' set.
            -- 'minBound' is the one 'Int' that can be neither a real (positive)
            -- @ComponentId@ nor a negated one, so it never collides.
            IntMap (ComponentState Any Any Any Any)
vcomps <- IORef (IntMap (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState Any Any Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
            [ComponentState Any Any Any Any]
-> (ComponentState Any Any Any Any -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntMap (ComponentState Any Any Any Any)
-> [ComponentState Any Any Any Any]
forall a. IntMap a -> [a]
IM.elems IntMap (ComponentState Any Any Any Any)
vcomps) ((ComponentState Any Any Any Any -> IO ()) -> IO ())
-> (ComponentState Any Any Any Any -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ComponentState {Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
Any
IORef Any
IORef (Map MisoString ThreadId)
IORef VTree
Map MisoString (Value -> IO ())
ComponentIds
JSVal
Any -> IO ()
Any -> Any -> Bool
Any -> Any -> IO ()
Seq Any -> Any -> Any -> Any -> (Any, [Schedule Any Any])
Value -> Maybe Any
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentContext :: forall context props model action.
ComponentState context props model action -> IORef context
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: Any
_prevComponentProps :: Any
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Any -> IO ()
_componentPostEffect :: Any -> IO ()
_componentModel :: Any
_componentScripts :: [JSVal]
_componentUseContext :: Bool
_componentContext :: IORef Any
_componentMailbox :: Value -> Maybe Any
_componentDraw :: Any -> IO ()
_componentHydrate :: Any -> IO ()
_componentPropsPhase :: Any -> Any -> IO ()
_componentModelDirty :: Any -> Any -> Bool
_componentApplyActions :: Seq Any -> Any -> Any -> Any -> (Any, [Schedule Any Any])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} ->
              -- On the MTS, context-driven redraws are suppressed: the BTS ships
              -- DOM patches via the JS patch protocol, so drawing here would be a
              -- redundant second paint.
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
_componentUseContext Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
mts) (Any -> IO ()
_componentDraw Any
_componentModel)
        | Int
vcompId Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 -> do
            -- props propagation, negated @ComponentId@ indicates render-phase only.
            IntMap (ComponentState Any Any Any Any)
vcomps <- IORef (IntMap (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState Any Any Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
            Maybe (ComponentState Any Any Any Any)
-> (ComponentState Any Any Any Any -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Int
-> IntMap (ComponentState Any Any Any Any)
-> Maybe (ComponentState Any Any Any Any)
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Int -> Int
forall a. Num a => a -> a
negate Int
vcompId) IntMap (ComponentState Any Any Any Any)
vcomps) ((ComponentState Any Any Any Any -> IO ()) -> IO ())
-> (ComponentState Any Any Any Any -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ComponentState {Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
Any
IORef Any
IORef (Map MisoString ThreadId)
IORef VTree
Map MisoString (Value -> IO ())
ComponentIds
JSVal
Any -> IO ()
Any -> Any -> Bool
Any -> Any -> IO ()
Seq Any -> Any -> Any -> Any -> (Any, [Schedule Any Any])
Value -> Maybe Any
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentContext :: forall context props model action.
ComponentState context props model action -> IORef context
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: Any
_prevComponentProps :: Any
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Any -> IO ()
_componentPostEffect :: Any -> IO ()
_componentModel :: Any
_componentScripts :: [JSVal]
_componentUseContext :: Bool
_componentContext :: IORef Any
_componentMailbox :: Value -> Maybe Any
_componentDraw :: Any -> IO ()
_componentHydrate :: Any -> IO ()
_componentPropsPhase :: Any -> Any -> IO ()
_componentModelDirty :: Any -> Any -> Bool
_componentApplyActions :: Seq Any -> Any -> Any -> Any -> (Any, [Schedule Any Any])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} -> do
              -- The MTS never paints from the scheduler: props (and context) are
              -- read-only there and the BTS drives all drawing via DOM patches.
              -- Suppress the redraw.
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
mts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Any -> IO ()
_componentDraw Any
_componentModel
              Any -> Any -> IO ()
_componentPropsPhase Any
_prevComponentProps Any
_componentProps

      Just (Int
vcompId, Seq Any
actions) -> do
        Bool
mounted <- Int -> IO Bool
isMounted Int
vcompId
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
mounted (Int -> Seq Any -> IO ()
forall action. Int -> Seq action -> IO ()
run Int
vcompId Seq Any
actions)
  where
    -----------------------------------------------------------------------------
    -- | Execute the commit phase against the model, perform top-down render
    -- of the entire Component tree.
    --
    -- On the MTS the commit phase still runs (its 'IO' effects — e.g. main-thread
    -- event handlers imperatively mutating a @DOMRef@ — must fire), but the
    -- subsequent draw is suppressed: the BTS is the sole paint authority and the
    -- MTS never diffs\/patches from the scheduler.
    run :: ComponentId -> Seq action -> IO ()
    run :: forall action. Int -> Seq action -> IO ()
run Int
vcompId Seq action
actions = do
      Maybe Int
rendered <- Int -> Seq action -> IO (Maybe Int)
forall action. Int -> Seq action -> IO (Maybe Int)
commit Int
vcompId Seq action
actions
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
mts) ((Int -> IO ()) -> Maybe Int -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> IO ()
renderComponent Maybe Int
rendered)
    -----------------------------------------------------------------------------
    -- | Apply the actions across the model, evaluate async and sync IO.
    commit :: ComponentId -> Seq action -> IO (Maybe ComponentId)
    commit :: forall action. Int -> Seq action -> IO (Maybe Int)
commit Int
vcompId Seq action
events = do
      IntMap (ComponentState context Any Any action)
vcomps <- IORef (IntMap (ComponentState context Any Any action))
-> IO (IntMap (ComponentState context Any Any action))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState context Any Any action))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
      let ComponentState {Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
Any
IORef context
IORef (Map MisoString ThreadId)
IORef VTree
Map MisoString (Value -> IO ())
ComponentIds
JSVal
Sink action
Any -> IO ()
Any -> Any -> Bool
Any -> Any -> IO ()
Seq action
-> Any -> Any -> context -> (Any, [Schedule context action])
Value -> Maybe action
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentContext :: forall context props model action.
ComponentState context props model action -> IORef context
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: Any
_prevComponentProps :: Any
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink action
_componentPostEffect :: Sink action
_componentModel :: Any
_componentScripts :: [JSVal]
_componentUseContext :: Bool
_componentContext :: IORef context
_componentMailbox :: Value -> Maybe action
_componentDraw :: Any -> IO ()
_componentHydrate :: Any -> IO ()
_componentPropsPhase :: Any -> Any -> IO ()
_componentModelDirty :: Any -> Any -> Bool
_componentApplyActions :: Seq action
-> Any -> Any -> context -> (Any, [Schedule context action])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} = IntMap (ComponentState context Any Any action)
vcomps IntMap (ComponentState context Any Any action)
-> Int -> ComponentState context Any Any action
forall a. IntMap a -> Int -> a
IM.! Int
vcompId
      -- 'components' is polymorphic, so pin the cell's element type here the
      -- way the old @_componentContext :: context@ annotation did.
      context
currentContext <- IORef context -> IO context
forall a. IORef a -> IO a
readIORef IORef context
_componentContext :: IO context
      let (Any
updatedModel, [Schedule context action]
schedules) =
            Seq action
-> Any -> Any -> context -> (Any, [Schedule context action])
_componentApplyActions Seq action
events Any
_componentModel Any
_componentProps context
currentContext
      -- Route each scheduled effect. A plain t'Schedule' runs its 'IO' here, on
      -- the thread that produced it. A 'CrossThread' effect targets a specific
      -- Lynx thread: if that's the current thread it dispatches @action@ locally
      -- (same as 'issue'); otherwise it forwards @action@ to the peer thread via
      -- 'postEffect', where @action@'s @update@ runs. Only the tagged @action@
      -- crosses — sibling effects in the same @update@ stay put, so nothing is
      -- double-executed.
      [Schedule context action]
-> (Schedule context action -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Schedule context action]
schedules ((Schedule context action -> IO ()) -> IO ())
-> (Schedule context action -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
        ContextModify context -> context
f -> IORef context -> (context -> context) -> IO ()
forall context. IORef context -> (context -> context) -> IO ()
modifyContextAll IORef context
_componentContext context -> context
f
        CrossThread Thread
targetThread action
action
          | Thread -> Bool
crossThread Thread
targetThread -> Sink action
_componentPostEffect action
action
          | Bool
otherwise                -> Sink action
_componentSink action
action
        Schedule Synchronicity
synch Sink action -> IO ()
effect -> Synchronicity -> IO () -> IO ()
evalScheduled Synchronicity
synch (Sink action -> IO ()
effect Sink action
_componentSink)
      context
updatedContext <- IORef context -> IO context
forall a. IORef a -> IO a
readIORef IORef context
_componentContext
      -- 'not mts': the sentinel this enqueues is a no-op there (see the
      -- 'minBound' scheduler case) — MTS never draws context-driven changes
      -- itself (BTS ships DOM patches), so enqueueing from MTS would just be
      -- dequeued and discarded a moment later.
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
mts Bool -> Bool -> Bool
&& context -> context -> Bool
forall a. Eq a => a -> a -> Bool
dirtyCheck context
currentContext context
updatedContext) IO ()
enqueueContextPropagation
      -- BTS is the sole owner of the shared model (mirrors ReactLynx, where
      -- React state is background-thread-only). On MTS the model is a read-only
      -- replica maintained purely by 'MODEL_HYDRATE' from BTS: 'commit' here
      -- still fires the actions' 'IO' effects (e.g. main-thread event handlers
      -- mutating a @DOMRef@), but never writes 'componentModel'. An MTS handler
      -- that needs to change shared state dispatches the change to BTS with
      -- 'Miso.Effect.runOnBG' (the analog of ReactLynx's 'runOnBackground'), so
      -- the state action's @update@ runs on the BTS where the write commits; for
      -- MTS-local state that never belongs on BTS, use a 'MainThreadRef'.
      if Bool -> Bool
not Bool
mts Bool -> Bool -> Bool
&& Any -> Any -> Bool
_componentModelDirty Any
_componentModel Any
updatedModel
        then do
          Int -> State (ComponentState Any Any Any Any) () -> IO ()
forall context props model action a.
Int -> State (ComponentState context props model action) a -> IO ()
modifyComponent Int
_componentId (Lens (ComponentState Any Any Any Any) Any
forall context props model action.
Lens (ComponentState context props model action) model
componentModel Lens (ComponentState Any Any Any Any) Any
-> Any -> State (ComponentState Any Any Any Any) ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> field -> m ()
.= Any
updatedModel)
          Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
vcompId)
        else
          Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing
-----------------------------------------------------------------------------
-- | Perform a top-down rendering of the t'Miso.Types.Component' tree.
--
-- We lookup the components each time to account for unmounting.
--
renderComponent :: ComponentId -> IO ()
renderComponent :: Int -> IO ()
renderComponent Int
vcompId = Int
-> IntMap (ComponentState Any Any Any Any)
-> Maybe (ComponentState Any Any Any Any)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap (ComponentState Any Any Any Any)
 -> Maybe (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
-> IO (Maybe (ComponentState Any Any Any Any))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState Any Any Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components IO (Maybe (ComponentState Any Any Any Any))
-> (Maybe (ComponentState Any Any Any Any) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ComponentState Any Any Any Any -> IO ())
-> Maybe (ComponentState Any Any Any Any) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ \ComponentState {Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
Any
IORef Any
IORef (Map MisoString ThreadId)
IORef VTree
Map MisoString (Value -> IO ())
ComponentIds
JSVal
Any -> IO ()
Any -> Any -> Bool
Any -> Any -> IO ()
Seq Any -> Any -> Any -> Any -> (Any, [Schedule Any Any])
Value -> Maybe Any
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentContext :: forall context props model action.
ComponentState context props model action -> IORef context
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: Any
_prevComponentProps :: Any
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Any -> IO ()
_componentPostEffect :: Any -> IO ()
_componentModel :: Any
_componentScripts :: [JSVal]
_componentUseContext :: Bool
_componentContext :: IORef Any
_componentMailbox :: Value -> Maybe Any
_componentDraw :: Any -> IO ()
_componentHydrate :: Any -> IO ()
_componentPropsPhase :: Any -> Any -> IO ()
_componentModelDirty :: Any -> Any -> Bool
_componentApplyActions :: Seq Any -> Any -> Any -> Any -> (Any, [Schedule Any Any])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} -> do
  Any -> IO ()
_componentDraw Any
_componentModel
  Any -> IO ()
_componentHydrate Any
_componentModel
-----------------------------------------------------------------------------
-- | Modify a single t'Component p m a' at a @ComponentId@.
--
-- Auxiliary function
modifyComponent
  :: ComponentId
  -> State (ComponentState context props model action) a
  -> IO ()
modifyComponent :: forall context props model action a.
Int -> State (ComponentState context props model action) a -> IO ()
modifyComponent Int
vcompId State (ComponentState context props model action) a
go =
  IORef (IntMap (ComponentState context props model action))
-> (IntMap (ComponentState context props model action)
    -> (IntMap (ComponentState context props model action), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (IntMap (ComponentState context props model action))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components ((IntMap (ComponentState context props model action)
  -> (IntMap (ComponentState context props model action), ()))
 -> IO ())
-> (IntMap (ComponentState context props model action)
    -> (IntMap (ComponentState context props model action), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \IntMap (ComponentState context props model action)
vcomps ->
    ((ComponentState context props model action
 -> ComponentState context props model action)
-> Int
-> IntMap (ComponentState context props model action)
-> IntMap (ComponentState context props model action)
forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IM.adjust (State (ComponentState context props model action) a
-> ComponentState context props model action
-> ComponentState context props model action
forall s a. State s a -> s -> s
execState State (ComponentState context props model action) a
go) Int
vcompId IntMap (ComponentState context props model action)
vcomps, ())
-----------------------------------------------------------------------------
-- | The set of child t'Miso.Effect.ComponentId's a component currently has
-- mounted (the @_componentChildren@ field of 'ComponentState').
type ComponentIds = IntSet
-----------------------------------------------------------------------------
initialDraw
  :: (Eq m, Eq props, Eq context)
  => m
  -> Events
  -> Hydrate
  -> Bool
  -> Bool
  -- ^ Is live-reload mode active? Threaded into 'buildVTree' for child
  -- component initialization.
  -> Component context props m a
  -> ComponentState context props m a
  -> IO ()
initialDraw :: forall m props context a.
(Eq m, Eq props, Eq context) =>
m
-> Events
-> Hydrate
-> Bool
-> Bool
-> Component context props m a
-> ComponentState context props m a
-> IO ()
initialDraw m
initializedModel Events
events Hydrate
hydrate Bool
isRoot Bool
live Component {m
Bool
[JS]
[CSS]
[Sub m a]
Maybe a
Maybe (IO m)
Maybe MisoString
Maybe (props -> props -> a)
LogLevel
m -> View context props m a
a -> Effect context props m a
Value -> Maybe a
onPropsChanged :: forall context props model action.
Component context props model action
-> Maybe (props -> props -> action)
unmount :: forall context props model action.
Component context props model action -> Maybe action
mount :: forall context props model action.
Component context props model action -> Maybe action
eventPropagation :: forall context props model action.
Component context props model action -> Bool
mailbox :: forall context props model action.
Component context props model action -> Value -> Maybe action
logLevel :: forall context props model action.
Component context props model action -> LogLevel
mountPoint :: forall context props model action.
Component context props model action -> Maybe MisoString
scripts :: forall context props model action.
Component context props model action -> [JS]
styles :: forall context props model action.
Component context props model action -> [CSS]
subs :: forall context props model action.
Component context props model action -> [Sub model action]
useContext :: forall context props model action.
Component context props model action -> Bool
view :: forall context props model action.
Component context props model action
-> model -> View context props model action
update :: forall context props model action.
Component context props model action
-> action -> Effect context props model action
hydrateModel :: forall context props model action.
Component context props model action -> Maybe (IO model)
model :: forall context props model action.
Component context props model action -> model
model :: m
hydrateModel :: Maybe (IO m)
update :: a -> Effect context props m a
view :: m -> View context props m a
useContext :: Bool
subs :: [Sub m a]
styles :: [CSS]
scripts :: [JS]
mountPoint :: Maybe MisoString
logLevel :: LogLevel
mailbox :: Value -> Maybe a
eventPropagation :: Bool
mount :: Maybe a
unmount :: Maybe a
onPropsChanged :: Maybe (props -> props -> a)
..} ComponentState {m
props
Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
IORef context
IORef (Map MisoString ThreadId)
IORef VTree
Map MisoString (Value -> IO ())
ComponentIds
JSVal
m -> IO ()
m -> m -> Bool
props -> props -> IO ()
Sink a
Seq a -> m -> props -> context -> (m, [Schedule context a])
Value -> Maybe a
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentContext :: forall context props model action.
ComponentState context props model action -> IORef context
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: props
_prevComponentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink a
_componentPostEffect :: Sink a
_componentModel :: m
_componentScripts :: [JSVal]
_componentUseContext :: Bool
_componentContext :: IORef context
_componentMailbox :: Value -> Maybe a
_componentDraw :: m -> IO ()
_componentHydrate :: m -> IO ()
_componentPropsPhase :: props -> props -> IO ()
_componentModelDirty :: m -> m -> Bool
_componentApplyActions :: Seq a -> m -> props -> context -> (m, [Schedule context a])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} = do
#ifdef BENCH
  start <- FFI.now
#endif
  context
currentContext <- IORef context -> IO context
forall a. IORef a -> IO a
readIORef IORef context
_componentContext
  VTree
vtree <- Events
-> Int
-> Int
-> Hydrate
-> Bool
-> Sink a
-> LogLevel
-> IORef context
-> context
-> props
-> m
-> View context props m a
-> IO VTree
forall context props model action.
Eq context =>
Events
-> Int
-> Int
-> Hydrate
-> Bool
-> Sink action
-> LogLevel
-> IORef context
-> context
-> props
-> model
-> View context props model action
-> IO VTree
buildVTree Events
events Int
_componentParentId Int
_componentId Hydrate
hydrate Bool
live Sink a
_componentSink LogLevel
logLevel
    IORef context
_componentContext context
currentContext props
_componentProps m
initializedModel (m -> View context props m a
view m
initializedModel)
  [Function]
vtreeHandlers0 <- IO [Function]
collectEventHandlers
#ifdef BENCH
  end <- FFI.now
  when isRoot $ FFI.consoleLog $ ms (printf "buildVTree: %.3f ms" (end - start) :: String)
#endif
  case Hydrate
hydrate of
    Hydrate
Draw -> do
      Maybe VTree -> Maybe VTree -> JSVal -> IO ()
Diff.diff Maybe VTree
forall a. Maybe a
Nothing (VTree -> Maybe VTree
forall a. a -> Maybe a
Just VTree
vtree) JSVal
_componentDOMRef
      IORef VTree -> VTree -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef VTree
_componentVTree VTree
vtree
      Int -> [Function] -> IO ()
swapEventHandlers Int
_componentId [Function]
vtreeHandlers0
    Hydrate
Hydrate -> do
      if Bool
isRoot
        then do
          Bool
hydrated <- LogLevel -> JSVal -> VTree -> IO Bool
Hydrate.hydrate LogLevel
logLevel JSVal
_componentDOMRef VTree
vtree
          if Bool
hydrated
            then do
              IORef VTree -> VTree -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef VTree
_componentVTree VTree
vtree
              Int -> [Function] -> IO ()
swapEventHandlers Int
_componentId [Function]
vtreeHandlers0
            else do
              VTree
newTree <-
                Events
-> Int
-> Int
-> Hydrate
-> Bool
-> Sink a
-> LogLevel
-> IORef context
-> context
-> props
-> m
-> View context props m a
-> IO VTree
forall context props model action.
Eq context =>
Events
-> Int
-> Int
-> Hydrate
-> Bool
-> Sink action
-> LogLevel
-> IORef context
-> context
-> props
-> model
-> View context props model action
-> IO VTree
buildVTree Events
events Int
_componentParentId Int
_componentId Hydrate
Draw Bool
live
                  Sink a
_componentSink LogLevel
logLevel IORef context
_componentContext context
currentContext props
_componentProps m
initializedModel (m -> View context props m a
view m
initializedModel)
              [Function]
newHandlers <- IO [Function]
collectEventHandlers
              -- the discarded hydration tree's callbacks are unreachable
              (Function -> IO ()) -> [Function] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Function -> IO ()
freeFunction [Function]
vtreeHandlers0
              Maybe VTree -> Maybe VTree -> JSVal -> IO ()
Diff.diff Maybe VTree
forall a. Maybe a
Nothing (VTree -> Maybe VTree
forall a. a -> Maybe a
Just VTree
newTree) JSVal
_componentDOMRef
              IORef VTree -> VTree -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef VTree
_componentVTree VTree
newTree
              Int -> [Function] -> IO ()
swapEventHandlers Int
_componentId [Function]
newHandlers
        else do
          IORef VTree -> VTree -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef VTree
_componentVTree VTree
vtree
          Int -> [Function] -> IO ()
swapEventHandlers Int
_componentId [Function]
vtreeHandlers0
-----------------------------------------------------------------------------
-- | Pulls the next Component for processing out of the queue, along with
-- its events.
getBatch :: IO (Maybe (ComponentId, Seq action))
getBatch :: forall action. IO (Maybe (Int, Seq action))
getBatch = do
  IORef (Queue action)
-> (Queue action -> (Queue action, Maybe (Int, Seq action)))
-> IO (Maybe (Int, Seq action))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Queue action)
forall action. IORef (Queue action)
globalQueue ((Queue action -> (Queue action, Maybe (Int, Seq action)))
 -> IO (Maybe (Int, Seq action)))
-> (Queue action -> (Queue action, Maybe (Int, Seq action)))
-> IO (Maybe (Int, Seq action))
forall a b. (a -> b) -> a -> b
$ \Queue action
q ->
    case Queue action -> Maybe (Int, Seq action, Queue action)
forall action.
Queue action -> Maybe (Int, Seq action, Queue action)
dequeue Queue action
q of
      Maybe (Int, Seq action, Queue action)
Nothing -> (Queue action
q, Maybe (Int, Seq action)
forall a. Maybe a
Nothing)
      Just (Int
vcompId, Seq action
actions, Queue action
newQueue) ->
        (Queue action
newQueue, (Int, Seq action) -> Maybe (Int, Seq action)
forall a. a -> Maybe a
Just (Int
vcompId, Seq action
actions))
-----------------------------------------------------------------------------
-- | Helper for event extraction at a specific @ComponentId@
drainQueueAt :: ComponentId -> IO (Seq a)
drainQueueAt :: forall a. Int -> IO (Seq a)
drainQueueAt Int
vcompId = IORef (Queue a) -> (Queue a -> (Queue a, Seq a)) -> IO (Seq a)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Queue a)
forall action. IORef (Queue action)
globalQueue (Int -> Queue a -> (Queue a, Seq a)
forall action. Int -> Queue action -> (Queue action, Seq action)
dequeueAt Int
vcompId)
-----------------------------------------------------------------------------
-- | Data type for holding the events in the system along with
-- the schedule of what events should be processed next.
--
-- Actions enter here from two sources — a local '_componentSink' and the
-- @Miso.effects@ cross-thread transport (see 'effectListener') — but the
-- scheduler treats them identically: both are handled on /this/ thread, keeping
-- it the single writer of every model. A cross-thread 'CrossThread' effect
-- carries a distinct @action@, so a forwarded action never bounces back on its
-- own (only a genuine user-authored cross-thread cycle would).
data Queue action
  = Queue
  { forall action. Queue action -> IntMap (Seq action)
_queue :: IntMap (Seq action)
  , forall action. Queue action -> Seq Int
_queueSchedule :: Seq ComponentId
  } deriving (Int -> Queue action -> ShowS
[Queue action] -> ShowS
Queue action -> String
(Int -> Queue action -> ShowS)
-> (Queue action -> String)
-> ([Queue action] -> ShowS)
-> Show (Queue action)
forall action. Show action => Int -> Queue action -> ShowS
forall action. Show action => [Queue action] -> ShowS
forall action. Show action => Queue action -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall action. Show action => Int -> Queue action -> ShowS
showsPrec :: Int -> Queue action -> ShowS
$cshow :: forall action. Show action => Queue action -> String
show :: Queue action -> String
$cshowList :: forall action. Show action => [Queue action] -> ShowS
showList :: [Queue action] -> ShowS
Show, Queue action -> Queue action -> Bool
(Queue action -> Queue action -> Bool)
-> (Queue action -> Queue action -> Bool) -> Eq (Queue action)
forall action. Eq action => Queue action -> Queue action -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall action. Eq action => Queue action -> Queue action -> Bool
== :: Queue action -> Queue action -> Bool
$c/= :: forall action. Eq action => Queue action -> Queue action -> Bool
/= :: Queue action -> Queue action -> Bool
Eq)
-----------------------------------------------------------------------------
emptyQueue :: Queue action
emptyQueue :: forall action. Queue action
emptyQueue = Queue action
forall a. Monoid a => a
mempty
-----------------------------------------------------------------------------
instance Semigroup (Queue action) where
  Queue IntMap (Seq action)
q1 Seq Int
s1 <> :: Queue action -> Queue action -> Queue action
<> Queue IntMap (Seq action)
q2 Seq Int
s2 = IntMap (Seq action) -> Seq Int -> Queue action
forall action. IntMap (Seq action) -> Seq Int -> Queue action
Queue (IntMap (Seq action)
q1 IntMap (Seq action) -> IntMap (Seq action) -> IntMap (Seq action)
forall a. Semigroup a => a -> a -> a
<> IntMap (Seq action)
q2) (Seq Int
s1 Seq Int -> Seq Int -> Seq Int
forall a. Semigroup a => a -> a -> a
<> Seq Int
s2)
-----------------------------------------------------------------------------
instance Monoid (Queue action) where
  mempty :: Queue action
mempty = IntMap (Seq action) -> Seq Int -> Queue action
forall action. IntMap (Seq action) -> Seq Int -> Queue action
Queue IntMap (Seq action)
forall a. Monoid a => a
mempty Seq Int
forall a. Monoid a => a
mempty
-----------------------------------------------------------------------------
queue :: Lens (Queue action) (IntMap (Seq action))
queue :: forall action. Lens (Queue action) (IntMap (Seq action))
queue = (Queue action -> IntMap (Seq action))
-> (Queue action -> IntMap (Seq action) -> Queue action)
-> Lens (Queue action) (IntMap (Seq action))
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens Queue action -> IntMap (Seq action)
forall action. Queue action -> IntMap (Seq action)
_queue ((Queue action -> IntMap (Seq action) -> Queue action)
 -> Lens (Queue action) (IntMap (Seq action)))
-> (Queue action -> IntMap (Seq action) -> Queue action)
-> Lens (Queue action) (IntMap (Seq action))
forall a b. (a -> b) -> a -> b
$ \Queue action
r IntMap (Seq action)
f -> Queue action
r { _queue = f }
-----------------------------------------------------------------------------
queueSchedule :: Lens (Queue action) (Seq ComponentId)
queueSchedule :: forall action. Lens (Queue action) (Seq Int)
queueSchedule = (Queue action -> Seq Int)
-> (Queue action -> Seq Int -> Queue action)
-> Lens (Queue action) (Seq Int)
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens Queue action -> Seq Int
forall action. Queue action -> Seq Int
_queueSchedule ((Queue action -> Seq Int -> Queue action)
 -> Lens (Queue action) (Seq Int))
-> (Queue action -> Seq Int -> Queue action)
-> Lens (Queue action) (Seq Int)
forall a b. (a -> b) -> a -> b
$ \Queue action
r Seq Int
f -> Queue action
r { _queueSchedule = f }
-----------------------------------------------------------------------------
enqueue :: ComponentId -> action -> Queue action -> Queue action
enqueue :: forall action. Int -> action -> Queue action -> Queue action
enqueue Int
vcompId action
action Queue action
q =
  Queue action
q Queue action -> (Queue action -> Queue action) -> Queue action
forall a b. a -> (a -> b) -> b
& Lens (Queue action) (IntMap (Seq action))
forall action. Lens (Queue action) (IntMap (Seq action))
queue Lens (Queue action) (IntMap (Seq action))
-> (IntMap (Seq action) -> IntMap (Seq action))
-> Queue action
-> Queue action
forall record field.
Lens record field -> (field -> field) -> record -> record
%~ (Seq action -> Seq action -> Seq action)
-> Int -> Seq action -> IntMap (Seq action) -> IntMap (Seq action)
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith ((Seq action -> Seq action -> Seq action)
-> Seq action -> Seq action -> Seq action
forall a b c. (a -> b -> c) -> b -> a -> c
flip Seq action -> Seq action -> Seq action
forall a. Semigroup a => a -> a -> a
(<>)) Int
vcompId (action -> Seq action
forall a. a -> Seq a
S.singleton action
action)
    Queue action -> (Queue action -> Queue action) -> Queue action
forall a b. a -> (a -> b) -> b
& Lens (Queue action) (Seq Int)
forall action. Lens (Queue action) (Seq Int)
queueSchedule Lens (Queue action) (Seq Int)
-> (Seq Int -> Seq Int) -> Queue action -> Queue action
forall record field.
Lens record field -> (field -> field) -> record -> record
%~ (Seq Int -> Int -> Seq Int
forall a. Seq a -> a -> Seq a
S.|> Int
vcompId)
-----------------------------------------------------------------------------
-- | Used to fast track to render phase, bypassing commit phase. Used in 'Miso.Effect.props'
-- feature.
enqueueSchedule :: ComponentId -> IO ()
enqueueSchedule :: Int -> IO ()
enqueueSchedule Int
vcompId =
  IORef (Queue Any) -> (Queue Any -> (Queue Any, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Queue Any)
forall action. IORef (Queue action)
globalQueue ((Queue Any -> (Queue Any, ())) -> IO ())
-> (Queue Any -> (Queue Any, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Queue Any
q ->
     (Queue Any
q Queue Any -> (Queue Any -> Queue Any) -> Queue Any
forall a b. a -> (a -> b) -> b
& Lens (Queue Any) (Seq Int)
forall action. Lens (Queue action) (Seq Int)
queueSchedule Lens (Queue Any) (Seq Int)
-> (Seq Int -> Seq Int) -> Queue Any -> Queue Any
forall record field.
Lens record field -> (field -> field) -> record -> record
%~ (Seq Int -> Int -> Seq Int
forall a. Seq a -> a -> Seq a
S.|> Int -> Int
forall a. Num a => a -> a
negate Int
vcompId), ())
-----------------------------------------------------------------------------
-- | Enqueues the context-propagation sentinel (@'minBound' :: 'Int'@). When the
-- scheduler dequeues it, every t'Miso.Types.Component' with @useContext@ enabled
-- is re-rendered against the updated global context. Used by the @context@
-- feature (see 'Miso.Effect.modifyContext').
enqueueContextPropagation :: IO ()
enqueueContextPropagation :: IO ()
enqueueContextPropagation =
  IORef (Queue Any) -> (Queue Any -> (Queue Any, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Queue Any)
forall action. IORef (Queue action)
globalQueue ((Queue Any -> (Queue Any, ())) -> IO ())
-> (Queue Any -> (Queue Any, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Queue Any
q ->
     (Queue Any
q Queue Any -> (Queue Any -> Queue Any) -> Queue Any
forall a b. a -> (a -> b) -> b
& Lens (Queue Any) (Seq Int)
forall action. Lens (Queue action) (Seq Int)
queueSchedule Lens (Queue Any) (Seq Int)
-> (Seq Int -> Seq Int) -> Queue Any -> Queue Any
forall record field.
Lens record field -> (field -> field) -> record -> record
%~ (Seq Int -> Int -> Seq Int
forall a. Seq a -> a -> Seq a
S.|> Int
forall a. Bounded a => a
minBound), ())
-----------------------------------------------------------------------------
-- | Case on queue schedule, get first item, span on the rest of queueSchedule, get length.
-- set schedule with whatever remains.
--
-- Take the length of the queue schedule found, looking up with vcompId (from first element)
-- in the queue, splitAt the queue.
--
dequeue
  :: forall action
   . Queue action
  -> Maybe (ComponentId, Seq action, Queue action)
dequeue :: forall action.
Queue action -> Maybe (Int, Seq action, Queue action)
dequeue Queue action
q =
  case Queue action
q Queue action -> Lens (Queue action) (Seq Int) -> Seq Int
forall record field. record -> Lens record field -> field
^. Lens (Queue action) (Seq Int)
forall action. Lens (Queue action) (Seq Int)
queueSchedule of
    Seq Int
S.Empty -> Maybe (Int, Seq action, Queue action)
forall a. Maybe a
Nothing
    sched :: Seq Int
sched@(Int
vcompId S.:<| Seq Int
_) ->
      case Queue action
q Queue action
-> Lens (Queue action) (Maybe (Seq action)) -> Maybe (Seq action)
forall record field. record -> Lens record field -> field
^. Lens (Queue action) (IntMap (Seq action))
forall action. Lens (Queue action) (IntMap (Seq action))
queue Lens (Queue action) (IntMap (Seq action))
-> LensCore (Maybe (Seq action)) (IntMap (Seq action))
-> Lens (Queue action) (Maybe (Seq action))
forall b c a. LensCore b c -> LensCore a b -> LensCore a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Index (IntMap (Seq action))
-> Lens
     (IntMap (Seq action)) (Maybe (IxValue (IntMap (Seq action))))
forall at. At at => Index at -> Lens at (Maybe (IxValue at))
at Int
Index (IntMap (Seq action))
vcompId of
        Maybe (Seq action)
Nothing ->
          let (Seq Int
_, Seq Int
remaining) = (Int -> Bool) -> Seq Int -> (Seq Int, Seq Int)
forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
S.spanl (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
vcompId) Seq Int
sched
          in (Int, Seq action, Queue action)
-> Maybe (Int, Seq action, Queue action)
forall a. a -> Maybe a
Just (Int
vcompId, Seq action
forall a. Seq a
S.empty, Queue action
q Queue action -> (Queue action -> Queue action) -> Queue action
forall a b. a -> (a -> b) -> b
& Lens (Queue action) (Seq Int)
forall action. Lens (Queue action) (Seq Int)
queueSchedule Lens (Queue action) (Seq Int)
-> Seq Int -> Queue action -> Queue action
forall record field. Lens record field -> field -> record -> record
.~ Seq Int
remaining)
        Just Seq action
actions ->
          case (Int -> Bool) -> Seq Int -> (Seq Int, Seq Int)
forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
S.spanl (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
vcompId) Seq Int
sched of
            (Seq Int
scheduled, Seq Int
remaining) ->
              case Int -> Seq action -> (Seq action, Seq action)
forall a. Int -> Seq a -> (Seq a, Seq a)
S.splitAt (Seq Int -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq Int
scheduled) Seq action
actions of
                (Seq action
process, Seq action
rest) -> do
                  let updated :: Queue action
updated =
                        Queue action
q Queue action -> (Queue action -> Queue action) -> Queue action
forall a b. a -> (a -> b) -> b
& Lens (Queue action) (Seq Int)
forall action. Lens (Queue action) (Seq Int)
queueSchedule Lens (Queue action) (Seq Int)
-> Seq Int -> Queue action -> Queue action
forall record field. Lens record field -> field -> record -> record
.~ Seq Int
remaining
                          Queue action -> (Queue action -> Queue action) -> Queue action
forall a b. a -> (a -> b) -> b
& Lens (Queue action) (IntMap (Seq action))
forall action. Lens (Queue action) (IntMap (Seq action))
queueLens (Queue action) (IntMap (Seq action))
-> LensCore (Maybe (Seq action)) (IntMap (Seq action))
-> Lens (Queue action) (Maybe (Seq action))
forall b c a. LensCore b c -> LensCore a b -> LensCore a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.Index (IntMap (Seq action))
-> Lens
     (IntMap (Seq action)) (Maybe (IxValue (IntMap (Seq action))))
forall at. At at => Index at -> Lens at (Maybe (IxValue at))
at Int
Index (IntMap (Seq action))
vcompId Lens (Queue action) (Maybe (Seq action))
-> Maybe (Seq action) -> Queue action -> Queue action
forall record field. Lens record field -> field -> record -> record
.~ do if Seq action -> Bool
forall a. Seq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq action
rest then Maybe (Seq action)
forall a. Maybe a
Nothing else Seq action -> Maybe (Seq action)
forall a. a -> Maybe a
Just Seq action
rest
                  (Int, Seq action, Queue action)
-> Maybe (Int, Seq action, Queue action)
forall a. a -> Maybe a
Just (Int
vcompId, Seq action
process, Queue action
updated)
-----------------------------------------------------------------------------
-- | Dequeues everything from the Queue at a specific @ComponentId@, draining
-- both the queue events and the queue schedule.
dequeueAt
  :: forall action
   . ComponentId
  -> Queue action
  -> (Queue action, Seq action)
dequeueAt :: forall action. Int -> Queue action -> (Queue action, Seq action)
dequeueAt Int
vcompId Queue action
q =
  case Queue action
q Queue action
-> Lens (Queue action) (Maybe (Seq action)) -> Maybe (Seq action)
forall record field. record -> Lens record field -> field
^. Lens (Queue action) (IntMap (Seq action))
forall action. Lens (Queue action) (IntMap (Seq action))
queue Lens (Queue action) (IntMap (Seq action))
-> LensCore (Maybe (Seq action)) (IntMap (Seq action))
-> Lens (Queue action) (Maybe (Seq action))
forall b c a. LensCore b c -> LensCore a b -> LensCore a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Index (IntMap (Seq action))
-> Lens
     (IntMap (Seq action)) (Maybe (IxValue (IntMap (Seq action))))
forall at. At at => Index at -> Lens at (Maybe (IxValue at))
at Int
Index (IntMap (Seq action))
vcompId of
    Maybe (Seq action)
Nothing -> (Queue action
q, Seq action
forall a. Seq a
S.empty)
    Just Seq action
actions -> do
      -- dmj: remove from schedule, extract all events
      let updated :: Queue action
updated = Queue action
q Queue action -> (Queue action -> Queue action) -> Queue action
forall a b. a -> (a -> b) -> b
& Lens (Queue action) (Seq Int)
forall action. Lens (Queue action) (Seq Int)
queueSchedule Lens (Queue action) (Seq Int)
-> (Seq Int -> Seq Int) -> Queue action -> Queue action
forall record field.
Lens record field -> (field -> field) -> record -> record
%~ (Int -> Bool) -> Seq Int -> Seq Int
forall a. (a -> Bool) -> Seq a -> Seq a
S.filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=Int
vcompId)
                      Queue action -> (Queue action -> Queue action) -> Queue action
forall a b. a -> (a -> b) -> b
& Lens (Queue action) (IntMap (Seq action))
forall action. Lens (Queue action) (IntMap (Seq action))
queueLens (Queue action) (IntMap (Seq action))
-> LensCore (Maybe (Seq action)) (IntMap (Seq action))
-> Lens (Queue action) (Maybe (Seq action))
forall b c a. LensCore b c -> LensCore a b -> LensCore a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.Index (IntMap (Seq action))
-> Lens
     (IntMap (Seq action)) (Maybe (IxValue (IntMap (Seq action))))
forall at. At at => Index at -> Lens at (Maybe (IxValue at))
at Int
Index (IntMap (Seq action))
vcompId Lens (Queue action) (Maybe (Seq action))
-> Maybe (Seq action) -> Queue action -> Queue action
forall record field. Lens record field -> field -> record -> record
.~ Maybe (Seq action)
forall a. Maybe a
Nothing
      (Queue action
updated, Seq action
actions)
-----------------------------------------------------------------------------
globalWaiter :: Waiter
{-# NOINLINE globalWaiter #-}
globalWaiter :: Waiter
globalWaiter = IO Waiter -> Waiter
forall a. IO a -> a
unsafePerformIO IO Waiter
waiter
-----------------------------------------------------------------------------
-- Note [Freeing event handler callbacks]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Every 'On' attribute exports a fresh Haskell callback to JavaScript on
-- every draw ('Miso.Event.onWithOptions'). On the WASM backend an exported
-- callback pins its closure with a stable pointer that is only released
-- when JavaScript's FinalizationRegistry notices the function is
-- unreachable -- which requires a JavaScript GC and in practice lags far
-- behind, so redrawing components leak callbacks (and everything their
-- closures capture, including the model of the frame they were built in).
--
-- Instead we track ownership explicitly: 'Miso.Event.onWithOptions' calls
-- 'registerEventHandler' for every callback it exports, collecting them
-- into 'handlerCollector' for the duration of one 'buildVTree'. After the
-- new tree has been diffed in, the previous tree's callbacks can never be
-- dispatched again (event delegation always consults the current vtree),
-- so 'swapEventHandlers' frees them and records the new set. Unmounting a
-- component frees its recorded set.
--
-- Draws are serialized by the scheduler and the collector is harvested
-- before the draw awaits the next animation frame, so a child component
-- mounting synchronously mid-diff collects into an empty collector and
-- harvests it before returning.
-----------------------------------------------------------------------------
-- | Callbacks exported to JavaScript during the current 'buildVTree'.
{-# NOINLINE handlerCollector #-}
handlerCollector :: IORef [Function]
handlerCollector :: IORef [Function]
handlerCollector = IO (IORef [Function]) -> IORef [Function]
forall a. IO a -> a
unsafePerformIO ([Function] -> IO (IORef [Function])
forall a. a -> IO (IORef a)
newIORef [])
-----------------------------------------------------------------------------
-- | Event handler callbacks owned by each mounted component's current vtree.
{-# NOINLINE vtreeHandlers #-}
vtreeHandlers :: IORef (IntMap [Function])
vtreeHandlers :: IORef (IntMap [Function])
vtreeHandlers = IO (IORef (IntMap [Function])) -> IORef (IntMap [Function])
forall a. IO a -> a
unsafePerformIO (IntMap [Function] -> IO (IORef (IntMap [Function]))
forall a. a -> IO (IORef a)
newIORef IntMap [Function]
forall a. Monoid a => a
mempty)
-----------------------------------------------------------------------------
-- | Called by 'Miso.Event.onWithOptions' for every callback it exports.
-- See Note [Freeing event handler callbacks].
registerEventHandler :: JSVal -> IO ()
registerEventHandler :: JSVal -> IO ()
registerEventHandler JSVal
cb =
  IORef [Function] -> ([Function] -> ([Function], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Function]
handlerCollector (([Function] -> ([Function], ())) -> IO ())
-> ([Function] -> ([Function], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Function]
cbs -> (JSVal -> Function
Function JSVal
cb Function -> [Function] -> [Function]
forall a. a -> [a] -> [a]
: [Function]
cbs, ())
-----------------------------------------------------------------------------
-- | Take ownership of the callbacks exported by the 'buildVTree' that just
-- finished. See Note [Freeing event handler callbacks].
collectEventHandlers :: IO [Function]
collectEventHandlers :: IO [Function]
collectEventHandlers = IORef [Function]
-> ([Function] -> ([Function], [Function])) -> IO [Function]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Function]
handlerCollector (\[Function]
cbs -> ([], [Function]
cbs))
-----------------------------------------------------------------------------
-- | Record @new@ as the component's current handler set and free the
-- previous one. Call only after the new vtree has replaced the old one.
-- See Note [Freeing event handler callbacks].
swapEventHandlers :: ComponentId -> [Function] -> IO ()
swapEventHandlers :: Int -> [Function] -> IO ()
swapEventHandlers Int
vcompId [Function]
newHandlers = do
  [Function]
oldHandlers <- IORef (IntMap [Function])
-> (IntMap [Function] -> (IntMap [Function], [Function]))
-> IO [Function]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (IntMap [Function])
vtreeHandlers ((IntMap [Function] -> (IntMap [Function], [Function]))
 -> IO [Function])
-> (IntMap [Function] -> (IntMap [Function], [Function]))
-> IO [Function]
forall a b. (a -> b) -> a -> b
$ \IntMap [Function]
m ->
    (Int -> [Function] -> IntMap [Function] -> IntMap [Function]
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
vcompId [Function]
newHandlers IntMap [Function]
m, [Function] -> Int -> IntMap [Function] -> [Function]
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault [] Int
vcompId IntMap [Function]
m)
  (Function -> IO ()) -> [Function] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Function -> IO ()
freeFunction [Function]
oldHandlers
-----------------------------------------------------------------------------
-- | Free and forget a component's handler set (on unmount).
-- See Note [Freeing event handler callbacks].
freeEventHandlers :: ComponentId -> IO ()
freeEventHandlers :: Int -> IO ()
freeEventHandlers Int
vcompId = do
  [Function]
oldHandlers <- IORef (IntMap [Function])
-> (IntMap [Function] -> (IntMap [Function], [Function]))
-> IO [Function]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (IntMap [Function])
vtreeHandlers ((IntMap [Function] -> (IntMap [Function], [Function]))
 -> IO [Function])
-> (IntMap [Function] -> (IntMap [Function], [Function]))
-> IO [Function]
forall a b. (a -> b) -> a -> b
$ \IntMap [Function]
m ->
    (Int -> IntMap [Function] -> IntMap [Function]
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
vcompId IntMap [Function]
m, [Function] -> Int -> IntMap [Function] -> [Function]
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault [] Int
vcompId IntMap [Function]
m)
  (Function -> IO ()) -> [Function] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Function -> IO ()
freeFunction [Function]
oldHandlers
-----------------------------------------------------------------------------
#ifdef NATIVE
btsReady :: Waiter
{-# NOINLINE btsReady #-}
btsReady = unsafePerformIO oneshot
-----------------------------------------------------------------------------
-- | __MTS-side.__ Read \/ written only from 'componentListener', which only
-- ever runs on MTS. Set once 'READY' has been handled at least once, so a
-- retried 'READY' (BTS resends until acked — see 'sendReadyUntilAcked') only
-- ever 'notify's 'btsReady' a single time. 'notify' on a 'oneshot' t'Waiter'
-- is a blocking @putMVar@ on an already-full 'MVar' the second time around,
-- so without this guard a retried 'READY' would deadlock the MTS listener
-- callback instead of being the harmless no-op it should be.
readyReceived :: IORef Bool
{-# NOINLINE readyReceived #-}
readyReceived = unsafePerformIO (newIORef False)
-----------------------------------------------------------------------------
-- | __BTS-side.__ Read \/ written only from 'sendReadyUntilAcked' and
-- 'readyAckListener', which only ever run on BTS. Set once MTS's
-- 'READY_ACK' arrives, stopping 'sendReadyUntilAcked' from resending
-- 'READY' any further — otherwise BTS would blast the full retry budget on
-- every boot, even in the common case where the very first 'READY' lands
-- immediately.
readyAcked :: IORef Bool
{-# NOINLINE readyAcked #-}
readyAcked = unsafePerformIO (newIORef False)
#endif
-----------------------------------------------------------------------------
globalQueue :: IORef (Queue action)
{-# NOINLINE globalQueue #-}
globalQueue :: forall action. IORef (Queue action)
globalQueue = IO (IORef (Queue action)) -> IORef (Queue action)
forall a. IO a -> a
unsafePerformIO (Queue action -> IO (IORef (Queue action))
forall a. a -> IO (IORef a)
newIORef Queue action
forall action. Queue action
emptyQueue)
-----------------------------------------------------------------------------
-- | Apply a function to the app-global @context@, in one atomic update of the
-- shared cell. This is how 'Miso.Effect.modifyContext' takes effect during the
-- commit phase.
--
-- The cell is passed in rather than looked up: every caller in the commit and
-- unmount paths already holds it as '_componentContext', and taking it from
-- them keeps this exact instead of relying on all live components pointing at
-- the same cell.
--
-- 'atomicModifyIORef'' forces the new @context@ to weak head normal form on
-- every update, so a component that never redraws cannot leave this cell
-- holding an unevaluated chain of 'modifyContextAll' applications (the classic
-- lazy-@'atomicModifyIORef'@ space leak) — it does not deeply force a lazy
-- field nested inside @context@ itself. An @f@ that throws damages only this
-- cell rather than the 'components' registry.
--
-- @since 1.14.0.0
modifyContextAll :: IORef context -> (context -> context) -> IO ()
modifyContextAll :: forall context. IORef context -> (context -> context) -> IO ()
modifyContextAll IORef context
ref context -> context
f = IORef context -> (context -> (context, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef context
ref ((context -> (context, ())) -> IO ())
-> (context -> (context, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \context
ctx -> (context -> context
f context
ctx, ())
-----------------------------------------------------------------------------
componentId :: Lens (ComponentState context props model action) ComponentId
componentId :: forall context props model action.
Lens (ComponentState context props model action) Int
componentId = (ComponentState context props model action -> Int)
-> (ComponentState context props model action
    -> Int -> ComponentState context props model action)
-> Lens (ComponentState context props model action) Int
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState context props model action -> Int
forall context props model action.
ComponentState context props model action -> Int
_componentId ((ComponentState context props model action
  -> Int -> ComponentState context props model action)
 -> Lens (ComponentState context props model action) Int)
-> (ComponentState context props model action
    -> Int -> ComponentState context props model action)
-> Lens (ComponentState context props model action) Int
forall a b. (a -> b) -> a -> b
$ \ComponentState context props model action
record Int
field -> ComponentState context props model action
record { _componentId = field }
-----------------------------------------------------------------------------
componentKey :: Lens (ComponentState context props model action) (Maybe Key)
componentKey :: forall context props model action.
Lens (ComponentState context props model action) (Maybe Key)
componentKey = (ComponentState context props model action -> Maybe Key)
-> (ComponentState context props model action
    -> Maybe Key -> ComponentState context props model action)
-> Lens (ComponentState context props model action) (Maybe Key)
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState context props model action -> Maybe Key
forall context props model action.
ComponentState context props model action -> Maybe Key
_componentKey ((ComponentState context props model action
  -> Maybe Key -> ComponentState context props model action)
 -> Lens (ComponentState context props model action) (Maybe Key))
-> (ComponentState context props model action
    -> Maybe Key -> ComponentState context props model action)
-> Lens (ComponentState context props model action) (Maybe Key)
forall a b. (a -> b) -> a -> b
$ \ComponentState context props model action
record Maybe Key
field -> ComponentState context props model action
record { _componentKey = field }
-----------------------------------------------------------------------------
children :: Lens (ComponentState context props model action) ComponentIds
children :: forall context props model action.
Lens (ComponentState context props model action) ComponentIds
children = (ComponentState context props model action -> ComponentIds)
-> (ComponentState context props model action
    -> ComponentIds -> ComponentState context props model action)
-> Lens (ComponentState context props model action) ComponentIds
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState context props model action -> ComponentIds
forall context props model action.
ComponentState context props model action -> ComponentIds
_componentChildren ((ComponentState context props model action
  -> ComponentIds -> ComponentState context props model action)
 -> Lens (ComponentState context props model action) ComponentIds)
-> (ComponentState context props model action
    -> ComponentIds -> ComponentState context props model action)
-> Lens (ComponentState context props model action) ComponentIds
forall a b. (a -> b) -> a -> b
$ \ComponentState context props model action
record ComponentIds
field -> ComponentState context props model action
record { _componentChildren = field }
-----------------------------------------------------------------------------
componentTopics :: Lens (ComponentState context props model action) (Map MisoString (Value -> IO ()))
componentTopics :: forall context props model action.
Lens
  (ComponentState context props model action)
  (Map MisoString (Value -> IO ()))
componentTopics = (ComponentState context props model action
 -> Map MisoString (Value -> IO ()))
-> (ComponentState context props model action
    -> Map MisoString (Value -> IO ())
    -> ComponentState context props model action)
-> Lens
     (ComponentState context props model action)
     (Map MisoString (Value -> IO ()))
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState context props model action
-> Map MisoString (Value -> IO ())
forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentTopics ((ComponentState context props model action
  -> Map MisoString (Value -> IO ())
  -> ComponentState context props model action)
 -> Lens
      (ComponentState context props model action)
      (Map MisoString (Value -> IO ())))
-> (ComponentState context props model action
    -> Map MisoString (Value -> IO ())
    -> ComponentState context props model action)
-> Lens
     (ComponentState context props model action)
     (Map MisoString (Value -> IO ()))
forall a b. (a -> b) -> a -> b
$ \ComponentState context props model action
record Map MisoString (Value -> IO ())
field -> ComponentState context props model action
record { _componentTopics = field }
-----------------------------------------------------------------------------
componentModel :: Lens (ComponentState context props model action) model
componentModel :: forall context props model action.
Lens (ComponentState context props model action) model
componentModel = (ComponentState context props model action -> model)
-> (ComponentState context props model action
    -> model -> ComponentState context props model action)
-> Lens (ComponentState context props model action) model
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState context props model action -> model
forall context props model action.
ComponentState context props model action -> model
_componentModel ((ComponentState context props model action
  -> model -> ComponentState context props model action)
 -> Lens (ComponentState context props model action) model)
-> (ComponentState context props model action
    -> model -> ComponentState context props model action)
-> Lens (ComponentState context props model action) model
forall a b. (a -> b) -> a -> b
$ \ComponentState context props model action
record model
field -> ComponentState context props model action
record { _componentModel = field }
-----------------------------------------------------------------------------
componentProps :: Lens (ComponentState context props model action) props
componentProps :: forall context props model action.
Lens (ComponentState context props model action) props
componentProps = (ComponentState context props model action -> props)
-> (ComponentState context props model action
    -> props -> ComponentState context props model action)
-> Lens (ComponentState context props model action) props
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState context props model action -> props
forall context props model action.
ComponentState context props model action -> props
_componentProps ((ComponentState context props model action
  -> props -> ComponentState context props model action)
 -> Lens (ComponentState context props model action) props)
-> (ComponentState context props model action
    -> props -> ComponentState context props model action)
-> Lens (ComponentState context props model action) props
forall a b. (a -> b) -> a -> b
$ \ComponentState context props model action
record props
field -> ComponentState context props model action
record { _componentProps = field }
-----------------------------------------------------------------------------
componentContext :: Lens (ComponentState context props model action) (IORef context)
componentContext :: forall context props model action.
Lens (ComponentState context props model action) (IORef context)
componentContext = (ComponentState context props model action -> IORef context)
-> (ComponentState context props model action
    -> IORef context -> ComponentState context props model action)
-> Lens (ComponentState context props model action) (IORef context)
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState context props model action -> IORef context
forall context props model action.
ComponentState context props model action -> IORef context
_componentContext ((ComponentState context props model action
  -> IORef context -> ComponentState context props model action)
 -> Lens
      (ComponentState context props model action) (IORef context))
-> (ComponentState context props model action
    -> IORef context -> ComponentState context props model action)
-> Lens (ComponentState context props model action) (IORef context)
forall a b. (a -> b) -> a -> b
$ \ComponentState context props model action
record IORef context
field -> ComponentState context props model action
record { _componentContext = field }
-----------------------------------------------------------------------------
prevComponentProps :: Lens (ComponentState context props model action) props
prevComponentProps :: forall context props model action.
Lens (ComponentState context props model action) props
prevComponentProps = (ComponentState context props model action -> props)
-> (ComponentState context props model action
    -> props -> ComponentState context props model action)
-> Lens (ComponentState context props model action) props
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState context props model action -> props
forall context props model action.
ComponentState context props model action -> props
_prevComponentProps ((ComponentState context props model action
  -> props -> ComponentState context props model action)
 -> Lens (ComponentState context props model action) props)
-> (ComponentState context props model action
    -> props -> ComponentState context props model action)
-> Lens (ComponentState context props model action) props
forall a b. (a -> b) -> a -> b
$ \ComponentState context props model action
record props
field -> ComponentState context props model action
record { _prevComponentProps = field }
-----------------------------------------------------------------------------
-- | t'Miso.Types.Component' state, data associated with the lifetime of a t'Miso.Types.Component'
data ComponentState context props model action
  = ComponentState
  { forall context props model action.
ComponentState context props model action -> Int
_componentId :: ComponentId
  -- ^ The ID of the current t'Miso.Types.Component'
  , forall context props model action.
ComponentState context props model action -> Maybe Key
_componentKey :: Maybe Key
  -- ^ Optional key for stable hot-reload model recovery
  , forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentStaticKey :: Maybe StaticKey
  -- ^ 'StaticPtr' key of the originating @VComp@, used to instruct the MTS
  -- to mount, hydrate, or unmount this child across the Lynx thread boundary.
  -- 'Nothing' for the root (each thread mounts the root locally).
  , forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: ComponentId
  -- ^ The ID of the t'Miso.Types.Component''s parent
  , forall context props model action.
ComponentState context props model action -> props
_componentProps :: props
  -- ^ The current props passed to this t'Miso.Types.Component'
  , forall context props model action.
ComponentState context props model action -> props
_prevComponentProps :: props
  -- ^ The previous Component props passed to this t'Miso.Types.Component'
  , forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentSubThreads :: IORef (Map MisoString ThreadId)
  -- ^ Mapping of all 'Sub' in use by t'Miso.Types.Component'
  , forall context props model action.
ComponentState context props model action -> JSVal
_componentDOMRef :: DOMRef
  -- ^ The DOM reference the t'Miso.Types.Component' is mounted on
  , forall context props model action.
ComponentState context props model action -> IORef VTree
_componentVTree :: IORef VTree
  -- ^ A reference to the current virtual DOM (i.e. t'VTree')
  , forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: action -> IO ()
  -- ^ t'Miso.Types.Component' t'Sink' used to enter events into the system
  , forall context props model action.
ComponentState context props model action -> Sink action
_componentPostEffect :: Sink action
  -- ^ Cross-thread (Lynx) t'Sink': serializes the @action@ and ships it to the
  -- opposite thread via @postEffect@. Captures the t'Miso.Types.Component''s
  -- 'ToJSON' instance at initialization time. Used by 'CrossThread' effects
  -- ('Miso.Effect.runOnMain' \/ 'Miso.Effect.runOnBG').
  , forall context props model action.
ComponentState context props model action -> model
_componentModel :: model
  -- ^ t'Miso.Types.Component' state
  , forall context props model action.
ComponentState context props model action -> [JSVal]
_componentScripts :: [DOMRef]
  -- ^ DOM references for \<script\> and \<style\> appended to \<head\>
  , forall context props model action.
ComponentState context props model action -> Bool
_componentUseContext :: Bool
  -- ^ Whether this t'Miso.Types.Component' re-renders when the global
  --   @context@ changes.
  , forall context props model action.
ComponentState context props model action -> IORef context
_componentContext :: IORef context
  -- ^ The app-global @context@ cell. There is exactly one per running app: it
  --   is created by 'initComponent' and shared __by reference__ with every
  --   component mounted under it, so two components cannot disagree and none
  --   can hold a copy that goes stale. 'modifyContextAll' writes through it;
  --   draws and the commit phase read it.
  --
  --   On Lynx each thread runs its own 'initComponent' and so owns its own
  --   cell, which is what lets a mirror component on the MTS obtain a
  --   @context@ without consulting its parent.
  , forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentMailbox :: Value -> Maybe action
  -- ^ Mailbox for asynchronous t'Miso.Types.Component' communication
  , forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: model -> IO ()
  -- ^ Helper function for t'Miso.Types.Component' rendering
  , forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentHydrate :: model -> IO ()
  -- ^ Posts the model to the MTS for cross-thread (Lynx) hydration via
  -- @MODEL_HYDRATE@. Captures the t'Miso.Types.Component''s 'ToJSON' instance at
  -- initialization time; a no-op unless running on the background thread ('bts').
  , forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentPropsPhase :: props -> props -> IO ()
  -- ^ Helper function for t'Miso.Types.Component' props changed phase.
  , forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentModelDirty :: model -> model -> Bool
  -- ^ Model diffing
  , forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentApplyActions
      :: Seq action
      -> model
      -> props
      -> context
      -> (model, [Schedule context action])
  -- ^ t'Miso.Types.Component' actions application. Given the pending actions,
  --   current @model@ and @props@, returns the updated @model@ and the
  --   t'Schedule's to run (async \/ sync IO, cross-thread effects, and
  --   'ContextModify's).
  , forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentTopics :: Map MisoString (Value -> IO ())
  -- ^ t'Miso.Types.Component' topics using for Pub Sub async communication.
  , forall context props model action.
ComponentState context props model action -> ComponentIds
_componentChildren :: ComponentIds
  -- ^ 'IntSet' of children t'Miso.Types.ComponentId'
  }
-----------------------------------------------------------------------------
-- | A @Topic@ represents a place to send and receive messages. @Topic@ is used to facilitate
-- communication between t'Miso.Types.Component'. t'Miso.Types.Component' can 'subscribe' to or 'publish' to any @Topic@,
-- within the same t'Miso.Types.Component' or across t'Miso.Types.Component'.
--
-- This requires creating a custom 'ToJSON' / 'FromJSON'. Any other t'Miso.Types.Component'
-- can 'publish' or 'subscribe' to this @Topic message@. It is a way to provide
-- loosely-coupled communication between @Components@.
--
-- See 'publish', 'subscribe', 'unsubscribe' for more details.
--
-- When distributing t'Miso.Types.Component' for third-party use, it is recommended to export
-- the @Topic@, where message is the JSON protocol.
--
--
-- @since 1.9.0.0
newtype Topic a = Topic MisoString
  deriving stock (Eq (Topic a)
Eq (Topic a) =>
(Topic a -> Topic a -> Ordering)
-> (Topic a -> Topic a -> Bool)
-> (Topic a -> Topic a -> Bool)
-> (Topic a -> Topic a -> Bool)
-> (Topic a -> Topic a -> Bool)
-> (Topic a -> Topic a -> Topic a)
-> (Topic a -> Topic a -> Topic a)
-> Ord (Topic a)
Topic a -> Topic a -> Bool
Topic a -> Topic a -> Ordering
Topic a -> Topic a -> Topic a
forall a. Eq (Topic a)
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Topic a -> Topic a -> Bool
forall a. Topic a -> Topic a -> Ordering
forall a. Topic a -> Topic a -> Topic a
$ccompare :: forall a. Topic a -> Topic a -> Ordering
compare :: Topic a -> Topic a -> Ordering
$c< :: forall a. Topic a -> Topic a -> Bool
< :: Topic a -> Topic a -> Bool
$c<= :: forall a. Topic a -> Topic a -> Bool
<= :: Topic a -> Topic a -> Bool
$c> :: forall a. Topic a -> Topic a -> Bool
> :: Topic a -> Topic a -> Bool
$c>= :: forall a. Topic a -> Topic a -> Bool
>= :: Topic a -> Topic a -> Bool
$cmax :: forall a. Topic a -> Topic a -> Topic a
max :: Topic a -> Topic a -> Topic a
$cmin :: forall a. Topic a -> Topic a -> Topic a
min :: Topic a -> Topic a -> Topic a
Ord, Topic a -> Topic a -> Bool
(Topic a -> Topic a -> Bool)
-> (Topic a -> Topic a -> Bool) -> Eq (Topic a)
forall a. Topic a -> Topic a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Topic a -> Topic a -> Bool
== :: Topic a -> Topic a -> Bool
$c/= :: forall a. Topic a -> Topic a -> Bool
/= :: Topic a -> Topic a -> Bool
Eq, Int -> Topic a -> ShowS
[Topic a] -> ShowS
Topic a -> String
(Int -> Topic a -> ShowS)
-> (Topic a -> String) -> ([Topic a] -> ShowS) -> Show (Topic a)
forall a. Int -> Topic a -> ShowS
forall a. [Topic a] -> ShowS
forall a. Topic a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> Topic a -> ShowS
showsPrec :: Int -> Topic a -> ShowS
$cshow :: forall a. Topic a -> String
show :: Topic a -> String
$cshowList :: forall a. [Topic a] -> ShowS
showList :: [Topic a] -> ShowS
Show)
-----------------------------------------------------------------------------
instance ToMisoString (Topic a) where
  toMisoString :: Topic a -> MisoString
toMisoString (Topic MisoString
x) = MisoString
x
-----------------------------------------------------------------------------
-- | Smart constructor for creating a @Topic message@ to write to
--
-- @
--
-- data Message
--   = Increment
--   | Decrement
--   deriving (Show, Eq, Generic, ToJSON, FromJSON)
--
-- arithmetic :: Topic Message
-- arithmetic = topic "arithmetic"
--
-- data Action
--   = Notification (Result Message)
--   | Subscribe
--   | Unsubscribe
--
-- update_ :: Action -> Effect context props Int Action
-- update_ = \case
--   Unsubscribe ->
--     unsubscribe arithmetic
--   Subscribe ->
--     subscribe arithmetic Notification
--   Notification (Success Increment) ->
--     update_ AddOne
--   Notification (Success Decrement) ->
--     update_ SubtractOne
--   Notification (Error msg) ->
--     io_ $ consoleError ("Decode failure: " <> ms msg)
--
-- @
--
-- @since 1.9.0.0
topic :: MisoString -> Topic a
topic :: forall a. MisoString -> Topic a
topic = MisoString -> Topic a
forall a. MisoString -> Topic a
Topic
-----------------------------------------------------------------------------
-- | Subscribes a t'Miso.Types.Component' to a t'Topic'.
--
-- Registers a callback in the component that decodes incoming messages
-- using its own 'FromJSON' instance and dispatches them to the component's
-- 'Sink'. If the component is already subscribed to the named topic the
-- previous callback is replaced.
--
-- Because each subscriber uses its own 'FromJSON', components can use
-- different Haskell types for the same topic as long as the underlying
-- JSON is compatible, enabling loose coupling between t'Miso.Types.Component'.
--
-- @
--
-- data Message = Increment | Decrement
--   deriving (Show, Eq, Generic, ToJSON, FromJSON)
--
-- arithmetic :: Topic Message
-- arithmetic = topic "arithmetic"
--
-- data Action
--   = Notify Message
--   | NotifyError MisoString
--   | Subscribe
--   | Unsubscribe
--   | AddOne
--   | SubtractOne
--
-- update_ :: Action -> Effect context props Int Action
-- update_ = \\case
--   Subscribe ->
--     subscribe arithmetic Notify NotifyError
--   Unsubscribe ->
--     unsubscribe arithmetic
--   Notify Increment -> update_ AddOne
--   Notify Decrement -> update_ SubtractOne
--   NotifyError msg ->
--     io_ $ consoleError ("Decode failure: " <> msg)
--   AddOne -> _count += 1
--   SubtractOne -> _count -= 1
--
-- @
--
-- @since 1.9.0.0
subscribe
  :: FromJSON message
  => Topic message
  -> (message -> action)
  -> (MisoString -> action)
  -> Effect context props model action
subscribe :: forall message action context props model.
FromJSON message =>
Topic message
-> (message -> action)
-> (MisoString -> action)
-> Effect context props model action
subscribe (Topic MisoString
topicName) message -> action
successful MisoString -> action
errorful = do
  ComponentInfo {context
props
Int
JSVal
_componentInfoId :: Int
_componentInfoParentId :: Int
_componentInfoDOMRef :: JSVal
_componentInfoProps :: props
_componentInfoContext :: context
_componentInfoContext :: forall context props. ComponentInfo context props -> context
_componentInfoProps :: forall context props. ComponentInfo context props -> props
_componentInfoDOMRef :: forall context props. ComponentInfo context props -> JSVal
_componentInfoParentId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: forall context props. ComponentInfo context props -> Int
..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  (Sink action -> IO ()) -> Effect context props model action
forall action context props model.
(Sink action -> IO ()) -> Effect context props model action
withSink ((Sink action -> IO ()) -> Effect context props model action)
-> (Sink action -> IO ()) -> Effect context props model action
forall a b. (a -> b) -> a -> b
$ \Sink action
sink ->
    Int -> State (ComponentState Any Any Any Any) () -> IO ()
forall context props model action a.
Int -> State (ComponentState context props model action) a -> IO ()
modifyComponent Int
_componentInfoId (State (ComponentState Any Any Any Any) () -> IO ())
-> State (ComponentState Any Any Any Any) () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Lens
  (ComponentState Any Any Any Any) (Map MisoString (Value -> IO ()))
forall context props model action.
Lens
  (ComponentState context props model action)
  (Map MisoString (Value -> IO ()))
componentTopics Lens
  (ComponentState Any Any Any Any) (Map MisoString (Value -> IO ()))
-> (Map MisoString (Value -> IO ())
    -> Map MisoString (Value -> IO ()))
-> State (ComponentState Any Any Any Any) ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> (field -> field) -> m ()
%= do
        MisoString
-> (Value -> IO ())
-> Map MisoString (Value -> IO ())
-> Map MisoString (Value -> IO ())
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert MisoString
topicName ((Value -> IO ())
 -> Map MisoString (Value -> IO ())
 -> Map MisoString (Value -> IO ()))
-> (Value -> IO ())
-> Map MisoString (Value -> IO ())
-> Map MisoString (Value -> IO ())
forall a b. (a -> b) -> a -> b
$ \Value
value ->
          Sink action
sink (case Value -> Result message
forall a. FromJSON a => Value -> Result a
fromJSON Value
value of
                  Success message
s -> message -> action
successful message
s
                  Error MisoString
e -> MisoString -> action
errorful MisoString
e)
-----------------------------------------------------------------------------
-- | Unsubscribes a t'Miso.Types.Component' from a t'Topic'.
--
-- Removes the callback registered by 'subscribe' so the component no longer
-- receives messages published to the topic. If the component is not
-- currently subscribed this is a no-op.
--
-- See 'subscribe' for example usage.
--
-- @since 1.9.0.0
unsubscribe :: Topic message -> Effect context props model action
unsubscribe :: forall message context props model action.
Topic message -> Effect context props model action
unsubscribe (Topic MisoString
topicName) = do
  ComponentInfo {context
props
Int
JSVal
_componentInfoContext :: forall context props. ComponentInfo context props -> context
_componentInfoProps :: forall context props. ComponentInfo context props -> props
_componentInfoDOMRef :: forall context props. ComponentInfo context props -> JSVal
_componentInfoParentId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: Int
_componentInfoParentId :: Int
_componentInfoDOMRef :: JSVal
_componentInfoProps :: props
_componentInfoContext :: context
..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> Effect context props model action
forall context props model action.
IO () -> Effect context props model action
io_ (IO () -> Effect context props model action)
-> IO () -> Effect context props model action
forall a b. (a -> b) -> a -> b
$ Int -> State (ComponentState Any Any Any Any) () -> IO ()
forall context props model action a.
Int -> State (ComponentState context props model action) a -> IO ()
modifyComponent Int
_componentInfoId (State (ComponentState Any Any Any Any) () -> IO ())
-> State (ComponentState Any Any Any Any) () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Lens
  (ComponentState Any Any Any Any) (Map MisoString (Value -> IO ()))
forall context props model action.
Lens
  (ComponentState context props model action)
  (Map MisoString (Value -> IO ()))
componentTopics Lens
  (ComponentState Any Any Any Any) (Map MisoString (Value -> IO ()))
-> (Map MisoString (Value -> IO ())
    -> Map MisoString (Value -> IO ()))
-> State (ComponentState Any Any Any Any) ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> (field -> field) -> m ()
%= MisoString
-> Map MisoString (Value -> IO ())
-> Map MisoString (Value -> IO ())
forall k a. Ord k => k -> Map k a -> Map k a
M.delete MisoString
topicName
-----------------------------------------------------------------------------
-- | Publish to a t'Topic message'
--
-- t'Topic message' are generated dynamically if they do not exist. When using 'publish'
-- all subscribers are immediately notified of a new message. A message is distributed as a 'Value'
-- The underlying 'ToJSON' instance is used to construct this 'Value'.
--
-- We recommend documenting a public API for the JSON protocol message when distributing a t'Miso.Types.Component'
-- downstream to end users for consumption (be it inside a single cabal project or across multiple
-- cabal projects).
--
-- @
--
-- arithmetic :: Topic Message
-- arithmetic = topic "arithmetic"
--
-- server :: Component context props () Action
-- server = component () update_ $ \() ->
--   div_
--   []
--   [ "Server component"
--   , button_ [ onClick AddOne ] [ "+" ]
--   , button_ [ onClick SubtractOne ] [ "-" ]
--   , component_ (client_ "client 1")
--   , component_ (client_ "client 2")
--   ] where
--       update_ :: Action -> Effect context props () Action
--       update_ = \case
--         AddOne ->
--           publish arithmetic Increment
--         SubtractOne ->
--           publish arithemtic Decrement
--
-- @
--
-- @since 1.9.0.0
publish
  :: ToJSON message
  => Topic message
  -> message
  -> IO ()
publish :: forall message. ToJSON message => Topic message -> message -> IO ()
publish (Topic MisoString
topicName) message
message = (ComponentState Any Any Any Any -> IO ())
-> [ComponentState Any Any Any Any] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ComponentState Any Any Any Any -> IO ()
forall {context} {props} {model} {action}.
ComponentState context props model action -> IO ()
go ([ComponentState Any Any Any Any] -> IO ())
-> (IntMap (ComponentState Any Any Any Any)
    -> [ComponentState Any Any Any Any])
-> IntMap (ComponentState Any Any Any Any)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IntMap (ComponentState Any Any Any Any)
-> [ComponentState Any Any Any Any]
forall a. IntMap a -> [a]
IM.elems (IntMap (ComponentState Any Any Any Any) -> IO ())
-> IO (IntMap (ComponentState Any Any Any Any)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (IntMap (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState Any Any Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
  where
    go :: ComponentState context props model action -> IO ()
go ComponentState {props
model
Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
IORef context
IORef (Map MisoString ThreadId)
IORef VTree
Map MisoString (Value -> IO ())
ComponentIds
JSVal
props -> props -> IO ()
model -> IO ()
model -> model -> Bool
Sink action
Seq action
-> model -> props -> context -> (model, [Schedule context action])
Value -> Maybe action
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentContext :: forall context props model action.
ComponentState context props model action -> IORef context
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: props
_prevComponentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink action
_componentPostEffect :: Sink action
_componentModel :: model
_componentScripts :: [JSVal]
_componentUseContext :: Bool
_componentContext :: IORef context
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentHydrate :: model -> IO ()
_componentPropsPhase :: props -> props -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: Seq action
-> model -> props -> context -> (model, [Schedule context action])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} =
      case MisoString
-> Map MisoString (Value -> IO ()) -> Maybe (Value -> IO ())
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MisoString
topicName Map MisoString (Value -> IO ())
_componentTopics of
        Maybe (Value -> IO ())
Nothing ->
          () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Value -> IO ()
f ->
          Value -> IO ()
f (message -> Value
forall a. ToJSON a => a -> Value
toJSON message
message)
-----------------------------------------------------------------------------
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
$ Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
-----------------------------------------------------------------------------
freshSubId :: IO MisoString
freshSubId :: IO MisoString
freshSubId = do
  Int
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)
  MisoString -> IO MisoString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MisoString
"miso-sub-id-" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> Int -> MisoString
forall str. ToMisoString str => str -> MisoString
ms Int
x)
-----------------------------------------------------------------------------
-- | This is used to demarcate the ROOT of a page. This ID will *never*
-- exist in the `components` map.
rootComponentId :: ComponentId
rootComponentId :: Int
rootComponentId = Int
0
-----------------------------------------------------------------------------
-- | This is the top-level ComponentId, hardcoded
topLevelComponentId :: ComponentId
topLevelComponentId :: Int
topLevelComponentId = Int
1
-----------------------------------------------------------------------------
-- | The global store of @ComponentId@, for internal-use only.
--
-- Used internally @freshComponentId@ to allocate new @ComponentId@ on
-- mount.
--
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
$ Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
topLevelComponentId
-----------------------------------------------------------------------------
freshComponentId :: IO ComponentId
freshComponentId :: IO Int
freshComponentId = IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
componentIds ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
y -> (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
y)
-----------------------------------------------------------------------------
-- | 'cleanup' is used to remove previous application state (when using miso w/ GHCi).
--
-- As seen in <https://try.haskell-miso.org>
--
-- * Detect if previous t'Miso.Types.Component' tree is present.
-- * Unmount in descending order (top-level t'Miso.Types.Component' removed last), invoking finalizers
-- * Kill the scheduler thread (a new one is created on ':r').
-- * Erase all t'Miso.Types.Component'
-- * Erase t'Queue'
-- * Reset 'componentId'
-- * Recreate @DOMRef@, GCs previous event listeners in JS.
-- * Yield to the scheduler (unwind thread stacks).
-- * Perform major garbage collection (cleans out old state).
--
-- This GC should remove the previous @Notify@ / 'MVar' as well since the @sink@
-- closure should go out of scope.
--
cleanup :: forall context. Eq context => Proxy context -> Bool -> DOMRef -> IO ()
cleanup :: forall context.
Eq context =>
Proxy context -> Bool -> JSVal -> IO ()
cleanup Proxy context
Proxy Bool
live JSVal
domRef = do
  IntMap (ComponentState context Any Any Any)
vcomps <- IORef (IntMap (ComponentState context Any Any Any))
-> IO (IntMap (ComponentState context Any Any Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState context Any Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IntMap (ComponentState context Any Any Any) -> Int
forall a. IntMap a -> Int
IM.size IntMap (ComponentState context Any Any Any)
vcomps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ThreadId -> IO ()
killThread (ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef ThreadId -> IO ThreadId
forall a. IORef a -> IO a
readIORef IORef ThreadId
schedulerThread
    if Bool
live
      then do
        -- In hot reload we want to reset subs and connections, and free lifecycle hooks
        [(Int, ComponentState context Any Any Any)]
-> ((Int, ComponentState context Any Any Any) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntMap (ComponentState context Any Any Any)
-> [(Int, ComponentState context Any Any Any)]
forall a. IntMap a -> [(Int, a)]
IM.toDescList IntMap (ComponentState context Any Any Any)
vcomps) (((Int, ComponentState context Any Any Any) -> IO ()) -> IO ())
-> ((Int, ComponentState context Any Any Any) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
_, cs :: ComponentState context Any Any Any
cs@ComponentState{Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
Any
IORef context
IORef (Map MisoString ThreadId)
IORef VTree
Map MisoString (Value -> IO ())
ComponentIds
JSVal
Any -> IO ()
Any -> Any -> Bool
Any -> Any -> IO ()
Seq Any -> Any -> Any -> context -> (Any, [Schedule context Any])
Value -> Maybe Any
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentContext :: forall context props model action.
ComponentState context props model action -> IORef context
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: Any
_prevComponentProps :: Any
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Any -> IO ()
_componentPostEffect :: Any -> IO ()
_componentModel :: Any
_componentScripts :: [JSVal]
_componentUseContext :: Bool
_componentContext :: IORef context
_componentMailbox :: Value -> Maybe Any
_componentDraw :: Any -> IO ()
_componentHydrate :: Any -> IO ()
_componentPropsPhase :: Any -> Any -> IO ()
_componentModelDirty :: Any -> Any -> Bool
_componentApplyActions :: Seq Any -> Any -> Any -> context -> (Any, [Schedule context Any])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..}) -> do
          (ThreadId -> IO ()) -> Map MisoString ThreadId -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread (Map MisoString ThreadId -> IO ())
-> IO (Map MisoString ThreadId) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Map MisoString ThreadId) -> IO (Map MisoString ThreadId)
forall a. IORef a -> IO a
readIORef IORef (Map MisoString ThreadId)
_componentSubThreads
          Int -> IO ()
finalizeWebSockets Int
_componentId
          Int -> IO ()
finalizeEventSources Int
_componentId
          ComponentState context Any Any Any -> IO ()
forall {context} {props} {model} {action}.
ComponentState context props model action -> IO ()
freeLifecycleHooks ComponentState context Any Any Any
cs
      else do
        -- We can do a full unmount if we're not doing hot reload
        [(Int, ComponentState context Any Any Any)]
-> ((Int, ComponentState context Any Any Any) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntMap (ComponentState context Any Any Any)
-> [(Int, ComponentState context Any Any Any)]
forall a. IntMap a -> [(Int, a)]
IM.toDescList IntMap (ComponentState context Any Any Any)
vcomps) (((Int, ComponentState context Any Any Any) -> IO ()) -> IO ())
-> ((Int, ComponentState context Any Any Any) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
_, ComponentState context Any Any Any
_vcomp_) ->
          forall context props model action.
Eq context =>
ComponentState context props model action -> IO ()
unmountComponent @context ComponentState context Any Any Any
_vcomp_
    IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef Int
componentIds Int
topLevelComponentId
    IORef (Queue Any) -> Queue Any -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef (Queue Any)
forall action. IORef (Queue action)
globalQueue Queue Any
forall a. Monoid a => a
mempty
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
live (IORef (IntMap (ComponentState Any Any Any Any))
-> IntMap (ComponentState Any Any Any Any) -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef (IntMap (ComponentState Any Any Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components IntMap (ComponentState Any Any Any Any)
forall a. Monoid a => a
mempty)
    JSVal
abort <- JSVal
domRef JSVal -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! MisoString
"abort"
    Bool
isnull <- JSVal -> IO Bool
forall val. ToJSVal val => val -> IO Bool
isNull JSVal
abort
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isnull (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      IO JSVal -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO JSVal -> IO ()) -> IO JSVal -> IO ()
forall a b. (a -> b) -> a -> b
$ (JSVal
domRef JSVal -> MisoString -> () -> IO JSVal
forall object args.
(ToObject object, ToArgs args) =>
object -> MisoString -> args -> IO JSVal
# MisoString
"abort") ()
    IO ()
yield
    IO ()
performMajorGC
-----------------------------------------------------------------------------
-- | componentMap
--
-- This is a global t'Miso.Types.Component' @Map@ that holds the state of all currently
-- mounted t'Miso.Types.Component's
components :: IORef (IntMap (ComponentState context props model action))
{-# NOINLINE components #-}
components :: forall context props model action.
IORef (IntMap (ComponentState context props model action))
components = IO (IORef (IntMap (ComponentState context props model action)))
-> IORef (IntMap (ComponentState context props model action))
forall a. IO a -> a
unsafePerformIO (IntMap (ComponentState context props model action)
-> IO (IORef (IntMap (ComponentState context props model action)))
forall a. a -> IO (IORef a)
newIORef IntMap (ComponentState context props model action)
forall a. Monoid a => a
mempty)
-----------------------------------------------------------------------------
-- | This function evaluates effects according to 'Synchronicity'.
evalScheduled :: Synchronicity -> IO () -> IO ()
evalScheduled :: Synchronicity -> IO () -> IO ()
evalScheduled Synchronicity
Sync IO ()
x = IO ()
x IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ())
-> (SomeException -> IO ()) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. SomeException -> IO ()
exception)
evalScheduled Synchronicity
Async IO ()
x = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ThreadId
forkIO (IO ()
x IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ())
-> (SomeException -> IO ()) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. SomeException -> IO ()
exception)))
-----------------------------------------------------------------------------
exception :: SomeException -> IO ()
exception :: SomeException -> IO ()
exception SomeException
ex = MisoString -> IO ()
FFI.consoleError (MisoString
"[EXCEPTION]: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> SomeException -> MisoString
forall str. ToMisoString str => str -> MisoString
ms SomeException
ex)
-----------------------------------------------------------------------------
-- | Drains the event queue before unmounting, executed synchronously.
drain
  :: forall context props model action . Eq context
  => ComponentState context props model action
  -> IO ()
drain :: forall context props model action.
Eq context =>
ComponentState context props model action -> IO ()
drain ComponentState {props
model
Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
IORef context
IORef (Map MisoString ThreadId)
IORef VTree
Map MisoString (Value -> IO ())
ComponentIds
JSVal
props -> props -> IO ()
model -> IO ()
model -> model -> Bool
Sink action
Seq action
-> model -> props -> context -> (model, [Schedule context action])
Value -> Maybe action
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentContext :: forall context props model action.
ComponentState context props model action -> IORef context
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: props
_prevComponentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink action
_componentPostEffect :: Sink action
_componentModel :: model
_componentScripts :: [JSVal]
_componentUseContext :: Bool
_componentContext :: IORef context
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentHydrate :: model -> IO ()
_componentPropsPhase :: props -> props -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: Seq action
-> model -> props -> context -> (model, [Schedule context action])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} = do
  Int -> IO (Seq action)
forall a. Int -> IO (Seq a)
drainQueueAt Int
_componentId IO (Seq action) -> (Seq action -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Seq action
S.Empty -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Seq action
actions -> do
       -- Read through the cell. 'cleanup' snapshots 'components' once and then
       -- unmounts in a loop, so an earlier component's 'drain' may already have
       -- committed a 'ContextModify'; the record we were handed is a snapshot,
       -- but the cell it points at is live, so this is current either way.
       context
currentContext <- IORef context -> IO context
forall a. IORef a -> IO a
readIORef IORef context
_componentContext
       case Seq action
-> model -> props -> context -> (model, [Schedule context action])
_componentApplyActions Seq action
actions model
_componentModel props
_componentProps context
currentContext of
         (model
_, [Schedule context action]
schedules) -> do
           [Schedule context action]
-> (Schedule context action -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Schedule context action]
schedules ((Schedule context action -> IO ()) -> IO ())
-> (Schedule context action -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
             -- dmj: process all actions synchronously during unmount. A
             -- 'CrossThread' effect targeting the peer thread is forwarded via
             -- 'postEffect' (its @action@'s @update@ runs there); one targeting
             -- this thread is dispatched locally. Plain t'Schedule's run here.
             CrossThread Thread
targetThread action
action
               | Thread -> Bool
crossThread Thread
targetThread -> Sink action
_componentPostEffect action
action
               | Bool
otherwise                -> Sink action
_componentSink action
action
             Schedule Synchronicity
_ Sink action -> IO ()
effect ->
               Sink action -> IO ()
effect Sink action
_componentSink
                 IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> IO ()
exception
             ContextModify context -> context
f -> IORef context -> (context -> context) -> IO ()
forall context. IORef context -> (context -> context) -> IO ()
modifyContextAll IORef context
_componentContext context -> context
f
           context
newContext <- IORef context -> IO context
forall a. IORef a -> IO a
readIORef IORef context
_componentContext
           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
mts Bool -> Bool -> Bool
&& context -> context -> Bool
forall a. Eq a => a -> a -> Bool
dirtyCheck context
currentContext context
newContext) IO ()
enqueueContextPropagation
           -- dmj: One last context propagation before aborting.
           -- Don't recurse on drain, we only fire-off the last set
           -- of events for 'onBeforeUnmounted' hooks. The queue will
           -- ignore the rest of these.
-----------------------------------------------------------------------------
-- | Post unmount call to drop the <style> and <script> in <head>
unloadScripts :: ComponentState context props model action -> IO ()
unloadScripts :: forall {context} {props} {model} {action}.
ComponentState context props model action -> IO ()
unloadScripts ComponentState {props
model
Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
IORef context
IORef (Map MisoString ThreadId)
IORef VTree
Map MisoString (Value -> IO ())
ComponentIds
JSVal
props -> props -> IO ()
model -> IO ()
model -> model -> Bool
Sink action
Seq action
-> model -> props -> context -> (model, [Schedule context action])
Value -> Maybe action
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentContext :: forall context props model action.
ComponentState context props model action -> IORef context
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: props
_prevComponentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink action
_componentPostEffect :: Sink action
_componentModel :: model
_componentScripts :: [JSVal]
_componentUseContext :: Bool
_componentContext :: IORef context
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentHydrate :: model -> IO ()
_componentPropsPhase :: props -> props -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: Seq action
-> model -> props -> context -> (model, [Schedule context action])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} = do
  JSVal
head_ <- IO JSVal
FFI.getHead
  [JSVal] -> (JSVal -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [JSVal]
_componentScripts ((JSVal -> IO ()) -> IO ()) -> (JSVal -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \JSVal
domRef -> do
    Bool
contains <- JSVal -> IO Bool
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked (JSVal -> IO Bool) -> IO JSVal -> IO Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do JSVal
head_ JSVal -> MisoString -> [JSVal] -> IO JSVal
forall object args.
(ToObject object, ToArgs args) =>
object -> MisoString -> args -> IO JSVal
# MisoString
"contains" ([JSVal] -> IO JSVal) -> [JSVal] -> IO JSVal
forall a b. (a -> b) -> a -> b
$ [JSVal
domRef]
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
contains (JSVal -> JSVal -> IO ()
FFI.removeChild JSVal
head_ JSVal
domRef)
-----------------------------------------------------------------------------
-- | Helper to drop all lifecycle and mounting hooks if defined.
freeLifecycleHooks :: ComponentState context props model action -> IO ()
freeLifecycleHooks :: forall {context} {props} {model} {action}.
ComponentState context props model action -> IO ()
freeLifecycleHooks ComponentState {props
model
Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
IORef context
IORef (Map MisoString ThreadId)
IORef VTree
Map MisoString (Value -> IO ())
ComponentIds
JSVal
props -> props -> IO ()
model -> IO ()
model -> model -> Bool
Sink action
Seq action
-> model -> props -> context -> (model, [Schedule context action])
Value -> Maybe action
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentContext :: forall context props model action.
ComponentState context props model action -> IORef context
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: props
_prevComponentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink action
_componentPostEffect :: Sink action
_componentModel :: model
_componentScripts :: [JSVal]
_componentUseContext :: Bool
_componentContext :: IORef context
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentHydrate :: model -> IO ()
_componentPropsPhase :: props -> props -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: Seq action
-> model -> props -> context -> (model, [Schedule context action])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} = do
  VTree (Object JSVal
vtree) <- IORef VTree -> IO VTree
forall a. IORef a -> IO a
readIORef IORef VTree
_componentVTree
  -- The root Component's VTree never gets a "parent" link (only buildComp
  -- sets one, for a mounted child's content root) -- mirrors the "at root,
  -- do nothing" guard in ts/miso/util.ts's updateRef. FromJSVal Object
  -- returns Nothing for undefined/null, so this naturally skips the root.
  Maybe Object
maybeComp <- JSVal -> IO (Maybe Object)
forall a. FromJSVal a => JSVal -> IO (Maybe a)
fromJSVal (JSVal -> IO (Maybe Object)) -> IO JSVal -> IO (Maybe Object)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal
vtree JSVal -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! (MisoString
"parent" :: MisoString)
  Maybe Object -> (Object -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Object
maybeComp ((Object -> IO ()) -> IO ()) -> (Object -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Object JSVal
comp) -> do
    (Function -> IO ()) -> Maybe Function -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Function -> IO ()
freeFunction (Maybe Function -> IO ()) -> IO (Maybe Function) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal -> IO (Maybe Function)
forall a. FromJSVal a => JSVal -> IO (Maybe a)
fromJSVal (JSVal -> IO (Maybe Function)) -> IO JSVal -> IO (Maybe Function)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal
comp JSVal -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! (MisoString
"mount" :: MisoString)
    (Function -> IO ()) -> Maybe Function -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Function -> IO ()
freeFunction (Maybe Function -> IO ()) -> IO (Maybe Function) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal -> IO (Maybe Function)
forall a. FromJSVal a => JSVal -> IO (Maybe a)
fromJSVal (JSVal -> IO (Maybe Function)) -> IO JSVal -> IO (Maybe Function)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal
comp JSVal -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! (MisoString
"unmount" :: MisoString)
-----------------------------------------------------------------------------
-- | Helper function for cleanly destroying a t'Miso.Types.Component'
unmountComponent
  :: Eq context
  => ComponentState context props model action
  -> IO ()
unmountComponent :: forall context props model action.
Eq context =>
ComponentState context props model action -> IO ()
unmountComponent cs :: ComponentState context props model action
cs@ComponentState {props
model
Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
IORef context
IORef (Map MisoString ThreadId)
IORef VTree
Map MisoString (Value -> IO ())
ComponentIds
JSVal
props -> props -> IO ()
model -> IO ()
model -> model -> Bool
Sink action
Seq action
-> model -> props -> context -> (model, [Schedule context action])
Value -> Maybe action
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentContext :: forall context props model action.
ComponentState context props model action -> IORef context
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: props
_prevComponentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink action
_componentPostEffect :: Sink action
_componentModel :: model
_componentScripts :: [JSVal]
_componentUseContext :: Bool
_componentContext :: IORef context
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentHydrate :: model -> IO ()
_componentPropsPhase :: props -> props -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: Seq action
-> model -> props -> context -> (model, [Schedule context action])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} = do
  (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
  ComponentState context props model action -> IO ()
forall context props model action.
Eq context =>
ComponentState context props model action -> IO ()
drain ComponentState context props model action
cs
  Int -> IO ()
finalizeWebSockets Int
_componentId
  Int -> IO ()
finalizeEventSources Int
_componentId
  ComponentState context props model action -> IO ()
forall {context} {props} {model} {action}.
ComponentState context props model action -> IO ()
unloadScripts ComponentState context props model action
cs
  ComponentState context props model action -> IO ()
forall {context} {props} {model} {action}.
ComponentState context props model action -> IO ()
freeLifecycleHooks ComponentState context props model action
cs
  Int -> IO ()
freeEventHandlers Int
_componentId
  Int -> State (ComponentState Any Any Any Any) () -> IO ()
forall context props model action a.
Int -> State (ComponentState context props model action) a -> IO ()
modifyComponent Int
_componentParentId (State (ComponentState Any Any Any Any) () -> IO ())
-> State (ComponentState Any Any Any Any) () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Lens (ComponentState Any Any Any Any) ComponentIds
forall context props model action.
Lens (ComponentState context props model action) ComponentIds
childrenLens (ComponentState Any Any Any Any) ComponentIds
-> LensCore (Maybe ()) ComponentIds
-> LensCore (Maybe ()) (ComponentState Any Any Any Any)
forall b c a. LensCore b c -> LensCore a b -> LensCore a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.Index ComponentIds
-> Lens ComponentIds (Maybe (IxValue ComponentIds))
forall at. At at => Index at -> Lens at (Maybe (IxValue at))
at Int
Index ComponentIds
_componentId LensCore (Maybe ()) (ComponentState Any Any Any Any)
-> Maybe () -> State (ComponentState Any Any Any Any) ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> field -> m ()
.= Maybe ()
forall a. Maybe a
Nothing
  IORef (IntMap (ComponentState Any Any Any Any))
-> (IntMap (ComponentState Any Any Any Any)
    -> (IntMap (ComponentState Any Any Any Any), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (IntMap (ComponentState Any Any Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components ((IntMap (ComponentState Any Any Any Any)
  -> (IntMap (ComponentState Any Any Any Any), ()))
 -> IO ())
-> (IntMap (ComponentState Any Any Any Any)
    -> (IntMap (ComponentState Any Any Any Any), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \IntMap (ComponentState Any Any Any Any)
m -> (Int
-> IntMap (ComponentState Any Any Any Any)
-> IntMap (ComponentState Any Any Any Any)
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
_componentId IntMap (ComponentState Any Any Any Any)
m, ())
#ifdef NATIVE
  when bts $ do
    postComponent UNMOUNT _componentStaticKey _componentId _componentParentId Nothing Nothing
#endif
-----------------------------------------------------------------------------
-- | 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.
buildVTree
  :: forall context props model action . Eq context
  => Events
  -> ComponentId
  -> ComponentId
  -> Hydrate
  -> Bool
  -- ^ Is live-reload mode active? Passed through to 'initialize' when
  -- mounting child components.
  -> Sink action
  -> LogLevel
  -> IORef context
  -- ^ The app-global @context@ cell, handed unchanged to any child component
  -- mounted here so it shares the one cell rather than a copy.
  -> context
  -- ^ The value read out of that cell for this build, resolved by 'VContext'.
  -- Read once by the caller so the whole tree is built against one snapshot.
  -> props
  -- ^ The mounting component's current @props@, resolved by 'VProps'.
  -> model
  -- ^ The mounting component's current @model@, resolved by 'VModel'.
  -> View context props model action
  -> IO VTree
buildVTree :: forall context props model action.
Eq context =>
Events
-> Int
-> Int
-> Hydrate
-> Bool
-> Sink action
-> LogLevel
-> IORef context
-> context
-> props
-> model
-> View context props model action
-> IO VTree
buildVTree Events
events_ Int
parentId_ Int
vcompId Hydrate
hydrate Bool
live Sink action
snk LogLevel
logLevel_ IORef context
ctxRef_ context
ctx_ props
props_ model
model_ = \case
  VComp SomeComponent context
someComp -> Maybe StaticKey -> SomeComponent context -> IO VTree
buildComp Maybe StaticKey
forall a. Maybe a
Nothing SomeComponent context
someComp

  VCompStatic StaticPtr (SomeStaticComponent childProps context)
ptr childProps
props -> case StaticPtr (SomeStaticComponent childProps context)
-> SomeStaticComponent childProps context
forall a. StaticPtr a -> a
deRefStaticPtr StaticPtr (SomeStaticComponent childProps context)
ptr of
    SomeStaticComponent Component context childProps model action
comp -> Maybe StaticKey -> SomeComponent context -> IO VTree
buildComp (StaticKey -> Maybe StaticKey
forall a. a -> Maybe a
Just (StaticPtr (SomeStaticComponent childProps context) -> StaticKey
forall a. StaticPtr a -> StaticKey
staticKey StaticPtr (SomeStaticComponent childProps context)
ptr)) (Maybe Key
-> childProps
-> Component context childProps model action
-> SomeComponent context
forall context model action props.
MountConstraints context props model action =>
Maybe Key
-> props
-> Component context props model action
-> SomeComponent context
SomeComponent Maybe Key
forall a. Maybe a
Nothing childProps
props Component context childProps model action
comp)

  VNode Namespace
ns MisoString
tag [Attribute model action]
attrs [View context props model action]
kids DirectEvents
_directEvents -> do
    Object
vnode_ <- MisoString -> Namespace -> MisoString -> IO Object
createNode MisoString
"vnode" Namespace
ns MisoString
tag
    Object
-> [Attribute model action]
-> Sink action
-> Int
-> LogLevel
-> Events
-> model
-> IO ()
forall model action.
Object
-> [Attribute model action]
-> Sink action
-> Int
-> LogLevel
-> Events
-> model
-> IO ()
setAttrs Object
vnode_ [Attribute model action]
attrs Sink action
snk Int
vcompId LogLevel
logLevel_ Events
events_ model
model_
#ifdef NATIVE
    -- Only the Lynx native runtime consumes directEvents; the web/WASM diff
    -- never reads it (all HTML/SVG/MathML nodes carry an empty set anyway).
    FFI.set "directEvents" (Set.toList _directEvents) vnode_
#endif
    [(View context props model action, Object)]
children_ <- Object
-> [View context props model action]
-> IO [(View context props model action, Object)]
procreate Object
vnode_ [View context props model action]
kids
    JSVal
vchildren <- [Object] -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (((View context props model action, Object) -> Object)
-> [(View context props model action, Object)] -> [Object]
forall a b. (a -> b) -> [a] -> [b]
map (View context props model action, Object) -> Object
forall a b. (a, b) -> b
snd [(View context props model action, Object)]
children_)
    MisoString -> JSVal -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"children" JSVal
vchildren Object
vnode_
    JSVal
nodeType <- VTreeType -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal VTreeType
VNodeType
    MisoString -> JSVal -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"type" JSVal
nodeType Object
vnode_
    -- The children are now linked into the tree on the JS side; release the
    -- handles we no longer need. See Note [Freeing VTree handles].
    JSVal -> IO ()
freeJSVal JSVal
nodeType
    JSVal -> IO ()
freeJSVal JSVal
vchildren
    ((View context props model action, Object) -> IO ())
-> [(View context props model action, Object)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (View context props model action, Object) -> IO ()
freeKid [(View context props model action, Object)]
children_
    VTree -> IO VTree
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> VTree
VTree Object
vnode_)
  VText Maybe Key
key MisoString
t -> do
    Object
vtree <- IO Object
create
    (JSVal -> Object -> IO ()) -> Object -> JSVal -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (MisoString -> JSVal -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"type") Object
vtree (JSVal -> IO ()) -> IO JSVal -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< VTreeType -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal VTreeType
VTextType
    Maybe Key -> (Key -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Key
key ((Key -> IO ()) -> IO ()) -> (Key -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Key
k -> MisoString -> MisoString -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"key" (Key -> MisoString
forall str. ToMisoString str => str -> MisoString
ms Key
k) Object
vtree
    MisoString -> MisoString -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"ns" (MisoString
"text" :: MisoString) Object
vtree
    MisoString -> MisoString -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"text" MisoString
t Object
vtree
    VTree -> IO VTree
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> VTree
VTree Object
vtree)
  VFrag Maybe Key
maybeKey [View context props model action]
kids -> do
    Object
frag <- IO Object
create
    MisoString -> VTreeType -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"type" VTreeType
VFragType Object
frag
    Maybe Key -> (Key -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Key
maybeKey ((Key -> IO ()) -> IO ()) -> (Key -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Key MisoString
k) -> MisoString -> MisoString -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"key" MisoString
k Object
frag
    [(View context props model action, Object)]
children_ <- Object
-> [View context props model action]
-> IO [(View context props model action, Object)]
procreate Object
frag [View context props model action]
kids
    JSVal
vchildren <- [Object] -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (((View context props model action, Object) -> Object)
-> [(View context props model action, Object)] -> [Object]
forall a b. (a -> b) -> [a] -> [b]
map (View context props model action, Object) -> Object
forall a b. (a, b) -> b
snd [(View context props model action, Object)]
children_)
    MisoString -> JSVal -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"children" JSVal
vchildren Object
frag
    JSVal -> IO ()
freeJSVal JSVal
vchildren
    ((View context props model action, Object) -> IO ())
-> [(View context props model action, Object)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (View context props model action, Object) -> IO ()
freeKid [(View context props model action, Object)]
children_
    VTree -> IO VTree
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> VTree
VTree Object
frag)

  v :: View context props model action
v@VContext {} -> View context props model action -> IO VTree
go (View context props model action -> IO VTree)
-> IO (View context props model action) -> IO VTree
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< View context props model action
-> IO (View context props model action)
resolve View context props model action
v

  v :: View context props model action
v@VProps {} -> View context props model action -> IO VTree
go (View context props model action -> IO VTree)
-> IO (View context props model action) -> IO VTree
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< View context props model action
-> IO (View context props model action)
resolve View context props model action
v

  v :: View context props model action
v@VModel {} -> View context props model action -> IO VTree
go (View context props model action -> IO VTree)
-> IO (View context props model action) -> IO VTree
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< View context props model action
-> IO (View context props model action)
resolve View context props model action
v
  where
    -- Recurse with every argument but the 'View' unchanged.
    go :: View context props model action -> IO VTree
    go :: View context props model action -> IO VTree
go = Events
-> Int
-> Int
-> Hydrate
-> Bool
-> Sink action
-> LogLevel
-> IORef context
-> context
-> props
-> model
-> View context props model action
-> IO VTree
forall context props model action.
Eq context =>
Events
-> Int
-> Int
-> Hydrate
-> Bool
-> Sink action
-> LogLevel
-> IORef context
-> context
-> props
-> model
-> View context props model action
-> IO VTree
buildVTree Events
events_ Int
parentId_ Int
vcompId Hydrate
hydrate Bool
live Sink action
snk LogLevel
logLevel_ IORef context
ctxRef_ context
ctx_ props
props_ model
model_

    -- Look through the wrapper constructors ('VProps', 'VModel', 'VContext')
    -- to the node they resolve to. Every child goes through this before it is
    -- built, so 'freeable' decides on the real constructor and a wrapper
    -- resolving to @fragment []@ hits the empty-fragment skip in 'buildKid'.
    resolve :: View context props model action -> IO (View context props model action)
    resolve :: View context props model action
-> IO (View context props model action)
resolve = \case
      VProps props -> View context props model action
f -> View context props model action
-> IO (View context props model action)
resolve (props -> View context props model action
f props
props_)
      VContext context -> View context props model action
f -> View context props model action
-> IO (View context props model action)
resolve (context -> View context props model action
f context
ctx_)
      VModel model -> View context props model action
f -> View context props model action
-> IO (View context props model action)
resolve (model -> View context props model action
f model
model_)
      View context props model action
v -> View context props model action
-> IO (View context props model action)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure View context props model action
v

    -- Build @kids@ under @parent@ in order, link each to its next sibling,
    -- and return them paired with their JS handles for 'freeKid'.
    procreate
      :: Object
      -> [View context props model action]
      -> IO [(View context props model action, Object)]
    procreate :: Object
-> [View context props model action]
-> IO [(View context props model action, Object)]
procreate Object
parent [View context props model action]
kids = do
      [(View context props model action, Object)]
ordered <- [(View context props model action, Object)]
-> [(View context props model action, Object)]
forall a. [a] -> [a]
reverse ([(View context props model action, Object)]
 -> [(View context props model action, Object)])
-> IO [(View context props model action, Object)]
-> IO [(View context props model action, Object)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(View context props model action, Object)]
 -> View context props model action
 -> IO [(View context props model action, Object)])
-> [(View context props model action, Object)]
-> [View context props model action]
-> IO [(View context props model action, Object)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Object
-> [(View context props model action, Object)]
-> View context props model action
-> IO [(View context props model action, Object)]
buildKid Object
parent) [] [View context props model action]
kids
      (Object -> Object -> IO ()) -> [Object] -> [Object] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ ((Object -> MisoString -> Object -> IO ())
-> MisoString -> Object -> Object -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Object -> MisoString -> Object -> IO ()
forall o v.
(ToObject o, ToJSVal v) =>
o -> MisoString -> v -> IO ()
setField MisoString
"nextSibling") (((View context props model action, Object) -> Object)
-> [(View context props model action, Object)] -> [Object]
forall a b. (a -> b) -> [a] -> [b]
map (View context props model action, Object) -> Object
forall a b. (a, b) -> b
snd [(View context props model action, Object)]
ordered) (Int -> [Object] -> [Object]
forall a. Int -> [a] -> [a]
drop Int
1 (((View context props model action, Object) -> Object)
-> [(View context props model action, Object)] -> [Object]
forall a b. (a -> b) -> [a] -> [b]
map (View context props model action, Object) -> Object
forall a b. (a, b) -> b
snd [(View context props model action, Object)]
ordered))
      [(View context props model action, Object)]
-> IO [(View context props model action, Object)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(View context props model action, Object)]
ordered

    -- Build one (resolved) child and link it to @parent@; accumulates in reverse.
    buildKid
      :: Object
      -> [(View context props model action, Object)]
      -> View context props model action
      -> IO [(View context props model action, Object)]
    buildKid :: Object
-> [(View context props model action, Object)]
-> View context props model action
-> IO [(View context props model action, Object)]
buildKid Object
parent [(View context props model action, Object)]
acc View context props model action
kid0 = View context props model action
-> IO (View context props model action)
resolve View context props model action
kid0 IO (View context props model action)
-> (View context props model action
    -> IO [(View context props model action, Object)])
-> IO [(View context props model action, Object)]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      VFrag Maybe Key
_ [] -> [(View context props model action, Object)]
-> IO [(View context props model action, Object)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(View context props model action, Object)]
acc
      View context props model action
kid -> do
        VTree Object
child <- View context props model action -> IO VTree
go View context props model action
kid
        MisoString -> Object -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"parent" Object
parent Object
child
        [(View context props model action, Object)]
-> IO [(View context props model action, Object)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((View context props model action
kid, Object
child) (View context props model action, Object)
-> [(View context props model action, Object)]
-> [(View context props model action, Object)]
forall a. a -> [a] -> [a]
: [(View context props model action, Object)]
acc)

    -- Note [Freeing VTree handles]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    -- On WASM each 'JSVal' handle carries a weak pointer that every GC must
    -- evacuate before it can discover the handle is dead, so the hundreds of
    -- short-lived handles created per frame while building a vtree make GC
    -- pauses scale with the size of the tree (see 'freeJSVal'). Once a child
    -- has been linked into its parent on the JS side the JavaScript object is
    -- kept alive by the tree and the Haskell handle is dead weight, so we free
    -- it -- unless something on the Haskell side can still reach it:
    --
    --  * Nodes with event handlers: the handler closure captures the node
    --    ('onWithOptions' reads @pendingComponentId@ from it at event time).
    --  * Components: 'buildComp' installs callbacks that close over the
    --    component object.
    --
    -- The root handle is returned to the caller and is never freed here.
    freeKid :: (View context props model action, Object) -> IO ()
    freeKid :: (View context props model action, Object) -> IO ()
freeKid (View context props model action
kid, Object JSVal
child) = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (View context props model action -> Bool
freeable View context props model action
kid) (JSVal -> IO ()
freeJSVal JSVal
child)

    freeable :: View context props model action -> Bool
    freeable :: View context props model action -> Bool
freeable = \case
      VNode Namespace
_ MisoString
_ [Attribute model action]
attrs [View context props model action]
_ DirectEvents
_ -> Bool -> Bool
not ((Attribute model action -> Bool)
-> [Attribute model action] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Attribute model action -> Bool
isEvent [Attribute model action]
attrs)
      VText {} -> Bool
True
      VFrag {} -> Bool
True
      VComp {} -> Bool
False
      VCompStatic {} -> Bool
False
      -- Never reached: 'buildKid' resolves wrappers before building, so a
      -- 'freeKid' pair always holds the resolved node. Conservative anyway.
      VContext {} -> Bool
False
      VProps {} -> Bool
False
      VModel {} -> Bool
False

    isEvent :: Attribute model action -> Bool
    isEvent :: Attribute model action -> Bool
isEvent = \case
      On {} -> Bool
True
      OnStatic {} -> Bool
True
      Attribute model action
_ -> Bool
False

    -- Shared construction for @VComp@ and @VCompStatic@. The only difference is
    -- the 'StaticKey' passed to 'initialize': 'Nothing' for dynamic components,
    -- @Just (staticKey ptr)@ for statically-referenced ones.
    buildComp :: Maybe StaticKey -> SomeComponent context -> IO VTree
    buildComp :: Maybe StaticKey -> SomeComponent context -> IO VTree
buildComp Maybe StaticKey
maybeStaticKey (SomeComponent Maybe Key
maybeKey props
newProps Component context props model action
app) = do
      Object
comp <- IO Object
create
      JSVal
mountCallback <- do
        (JSVal -> IO JSVal) -> IO JSVal
syncCallback1' ((JSVal -> IO JSVal) -> IO JSVal)
-> (JSVal -> IO JSVal) -> IO JSVal
forall a b. (a -> b) -> a -> b
$ \JSVal
parent_ -> do
          -- The child is handed the cell itself, not 'ctx_'. This callback
          -- fires later than 'buildVTree', synchronously inside the enclosing
          -- 'Diff.diff', which runs unmount callbacks first — an unmounting
          -- sibling's 'drain' can commit a 'ContextModify' before we get here.
          -- Sharing the cell makes that irrelevant: there is no copy taken, so
          -- there is nothing to be stale.
          ComponentState {model
props
Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
IORef context
IORef (Map MisoString ThreadId)
IORef VTree
Map MisoString (Value -> IO ())
ComponentIds
JSVal
model -> IO ()
model -> model -> Bool
Sink action
props -> props -> IO ()
Seq action
-> model -> props -> context -> (model, [Schedule context action])
Value -> Maybe action
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentContext :: forall context props model action.
ComponentState context props model action -> IORef context
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: props
_prevComponentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink action
_componentPostEffect :: Sink action
_componentModel :: model
_componentScripts :: [JSVal]
_componentUseContext :: Bool
_componentContext :: IORef context
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentHydrate :: model -> IO ()
_componentPropsPhase :: props -> props -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: Seq action
-> model -> props -> context -> (model, [Schedule context action])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} <- Events
-> Int
-> Hydrate
-> Bool
-> Bool
-> IORef context
-> props
-> Maybe Key
-> Maybe StaticKey
-> Component context props model action
-> IO JSVal
-> IO (ComponentState context props model action)
forall context model props action.
(Eq context, Eq model, Eq props) =>
Events
-> Int
-> Hydrate
-> Bool
-> Bool
-> IORef context
-> props
-> Maybe Key
-> Maybe StaticKey
-> Component context props model action
-> IO JSVal
-> IO (ComponentState context props model action)
initialize Events
events_ Int
vcompId Hydrate
hydrate Bool
False Bool
live IORef context
ctxRef_ props
newProps Maybe Key
maybeKey Maybe StaticKey
maybeStaticKey Component context props model action
app (JSVal -> IO JSVal
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSVal
parent_)
          Int -> State (ComponentState Any Any Any Any) () -> IO ()
forall context props model action a.
Int -> State (ComponentState context props model action) a -> IO ()
modifyComponent Int
vcompId (Lens (ComponentState Any Any Any Any) ComponentIds
forall context props model action.
Lens (ComponentState context props model action) ComponentIds
children Lens (ComponentState Any Any Any Any) ComponentIds
-> (ComponentIds -> ComponentIds)
-> State (ComponentState Any Any Any Any) ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> (field -> field) -> m ()
%= Int -> ComponentIds -> ComponentIds
IS.insert Int
_componentId)
          JSVal
vtree <- VTree -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (VTree -> IO JSVal) -> IO VTree -> IO JSVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef VTree -> IO VTree
forall a. IORef a -> IO a
readIORef IORef VTree
_componentVTree
          MisoString -> Object -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"parent" Object
comp (JSVal -> Object
Object JSVal
vtree)
          Object
obj <- IO Object
create
          MisoString -> Int -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
setProp MisoString
"componentId" Int
_componentId Object
obj
          MisoString -> JSVal -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
setProp MisoString
"componentTree" JSVal
vtree Object
obj
          Object -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal Object
obj
      JSVal
unmountCallback <- JSVal -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (JSVal -> IO JSVal) -> IO JSVal -> IO JSVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
        (JSVal -> IO ()) -> IO JSVal
FFI.syncCallback1 ((JSVal -> IO ()) -> IO JSVal) -> (JSVal -> IO ()) -> IO JSVal
forall a b. (a -> b) -> a -> b
$ \JSVal
vcompId_ -> do
          Int
componentId_ <- JSVal -> IO Int
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked JSVal
vcompId_
          Int
-> IntMap (ComponentState context Any Any action)
-> Maybe (ComponentState context Any Any action)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
componentId_ (IntMap (ComponentState context Any Any action)
 -> Maybe (ComponentState context Any Any action))
-> IO (IntMap (ComponentState context Any Any action))
-> IO (Maybe (ComponentState context Any Any action))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap (ComponentState context Any Any action))
-> IO (IntMap (ComponentState context Any Any action))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState context Any Any action))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components IO (Maybe (ComponentState context Any Any action))
-> (Maybe (ComponentState context Any Any action) -> IO ())
-> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (ComponentState context Any Any action)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just ComponentState context Any Any action
componentState -> do
              Maybe action -> Sink action -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Component context props model action -> Maybe action
forall context props model action.
Component context props model action -> Maybe action
unmount Component context props model action
app) (ComponentState context Any Any action -> Sink action
forall context props model action.
ComponentState context props model action -> Sink action
_componentSink ComponentState context Any Any action
componentState)
              forall context props model action.
Eq context =>
ComponentState context props model action -> IO ()
unmountComponent @context ComponentState context Any Any action
componentState
      -- When props are present, install a diffProps callback.
      -- Comparison happens in Haskell against _componentLastProps — no round-trip.
      -- TypeScript calls diffProps() unconditionally; Haskell decides whether to dispatch.
      JSVal
diffPropsCallback <- JSVal -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (JSVal -> IO JSVal) -> IO JSVal -> IO JSVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
        IO () -> IO JSVal
syncCallback (IO () -> IO JSVal) -> IO () -> IO JSVal
forall a b. (a -> b) -> a -> b
$ do
          Int
componentId_ <- JSVal -> IO Int
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked (JSVal -> IO Int) -> IO JSVal -> IO Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Object
comp Object -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! (MisoString
"componentId" :: MisoString)
          props
currentProps <- ComponentState Any props Any Any -> props
forall context props model action.
ComponentState context props model action -> props
_componentProps (ComponentState Any props Any Any -> props)
-> (IntMap (ComponentState Any props Any Any)
    -> ComponentState Any props Any Any)
-> IntMap (ComponentState Any props Any Any)
-> props
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (IntMap (ComponentState Any props Any Any)
-> Int -> ComponentState Any props Any Any
forall a. IntMap a -> Int -> a
IM.! Int
componentId_) (IntMap (ComponentState Any props Any Any) -> props)
-> IO (IntMap (ComponentState Any props Any Any)) -> IO props
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap (ComponentState Any props Any Any))
-> IO (IntMap (ComponentState Any props Any Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState Any props Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (props -> props -> Bool
forall a. Eq a => a -> a -> Bool
dirtyCheck props
currentProps props
newProps) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Int -> State (ComponentState Any props Any Any) () -> IO ()
forall context props model action a.
Int -> State (ComponentState context props model action) a -> IO ()
modifyComponent Int
componentId_ (State (ComponentState Any props Any Any) () -> IO ())
-> State (ComponentState Any props Any Any) () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              Lens (ComponentState Any props Any Any) props
forall context props model action.
Lens (ComponentState context props model action) props
componentProps Lens (ComponentState Any props Any Any) props
-> props -> State (ComponentState Any props Any Any) ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> field -> m ()
.= props
newProps
              Lens (ComponentState Any props Any Any) props
forall context props model action.
Lens (ComponentState context props model action) props
prevComponentProps Lens (ComponentState Any props Any Any) props
-> props -> State (ComponentState Any props Any Any) ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> field -> m ()
.= props
currentProps
            Int -> IO ()
enqueueSchedule Int
componentId_
      MisoString -> JSVal -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"diffProps" JSVal
diffPropsCallback Object
comp
      MisoString -> JSVal -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"child" JSVal
jsNull Object
comp
      -- Identity for the differ (@n.key === c.key@ in @ts/miso/dom.ts@): an
      -- explicit key wins; otherwise a static mount uses its 'StaticKey',
      -- which is unique per @static@ site. Without this every static mount
      -- had @key = undefined@, so two different static components at one
      -- position compared equal and the old instance was kept — with the new
      -- node's @diffProps@ run against props of an unrelated type.
      Maybe Key -> (Key -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Maybe Key
maybeKey Maybe Key -> Maybe Key -> Maybe Key
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MisoString -> Key
Key (MisoString -> Key)
-> (StaticKey -> MisoString) -> StaticKey -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. StaticKey -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (StaticKey -> Key) -> Maybe StaticKey -> Maybe Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe StaticKey
maybeStaticKey)) ((Key -> IO ()) -> IO ()) -> (Key -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Key
key ->
        MisoString -> Key -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"key" Key
key Object
comp
      MisoString -> JSVal -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"mount" JSVal
mountCallback Object
comp
      MisoString -> JSVal -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"unmount" JSVal
unmountCallback Object
comp
      MisoString -> Bool -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"eventPropagation" (Component context props model action -> Bool
forall context props model action.
Component context props model action -> Bool
eventPropagation Component context props model action
app) Object
comp
      MisoString -> VTreeType -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"type" VTreeType
VCompType Object
comp
      VTree -> IO VTree
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> VTree
VTree Object
comp)
-----------------------------------------------------------------------------
-- | @createNode@
-- A helper function for constructing a vtree (used for @vcomp@ and @vnode@)
-- Doesn't handle children
createNode :: MisoString -> Namespace -> MisoString -> IO Object
createNode :: MisoString -> Namespace -> MisoString -> IO Object
createNode MisoString
typ Namespace
ns MisoString
tag = do
  Object
vnode_ <- IO Object
create
  Object
cssObj <- IO Object
create
  Object
propsObj <- IO Object
create
  Object
eventsObj <- IO Object
create
  Object
captures <- IO Object
create
  Object
bubbles <- IO Object
create
  MisoString -> Object -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"css" Object
cssObj Object
vnode_
  MisoString -> MisoString -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"type" MisoString
typ Object
vnode_
  MisoString -> Object -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"props" Object
propsObj Object
vnode_
  MisoString -> Object -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"events" Object
eventsObj Object
vnode_
  MisoString -> Object -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"captures" Object
captures Object
eventsObj
  MisoString -> Object -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"bubbles" Object
bubbles Object
eventsObj
  MisoString -> Namespace -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"ns" Namespace
ns Object
vnode_
  MisoString -> MisoString -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"tag" MisoString
tag Object
vnode_
  -- All five scratch objects are now reachable from the vnode on the JS
  -- side; release the Haskell handles. See Note [Freeing VTree handles].
  (Object -> IO ()) -> [Object] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (JSVal -> IO ()
freeJSVal (JSVal -> IO ()) -> (Object -> JSVal) -> Object -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Object -> JSVal
unObject) [Object
cssObj, Object
propsObj, Object
eventsObj, Object
captures, Object
bubbles]
  Object -> IO Object
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Object
vnode_
-----------------------------------------------------------------------------
-- | Helper function for populating "props" and "css" fields on a virtual
-- DOM node
setAttrs
  :: Object
  -> [Attribute model action]
  -> Sink action
  -> ComponentId
  -> LogLevel
  -> Events
  -> model
  -> IO ()
setAttrs :: forall model action.
Object
-> [Attribute model action]
-> Sink action
-> Int
-> LogLevel
-> Events
-> model
-> IO ()
setAttrs vnode_ :: Object
vnode_@(Object JSVal
jval) [Attribute model action]
attrs Sink action
snk Int
vcompId LogLevel
logLevel Events
events model
model_ = do
  [Attribute model action]
-> (Attribute model action -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Attribute model action]
attrs ((Attribute model action -> IO ()) -> IO ())
-> (Attribute model action -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
    Property MisoString
"key" Value
v -> do
      JSVal
value <- Value -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal Value
v
      MisoString -> JSVal -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"key" JSVal
value Object
vnode_
    ClassList [MisoString]
classes ->
      JSVal -> [MisoString] -> IO ()
FFI.populateClass JSVal
jval [MisoString]
classes
    Property MisoString
k Value
v -> do
      JSVal
value <- Value -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal Value
v
      JSVal
o <- MisoString -> Object -> IO JSVal
forall o. ToObject o => MisoString -> o -> IO JSVal
getProp MisoString
"props" Object
vnode_
      MisoString -> JSVal -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
k JSVal
value (JSVal -> Object
Object JSVal
o)
      JSVal -> IO ()
freeJSVal JSVal
o
      -- Only handles created by 'toJSVal' itself are ours to free: a
      -- 'String' shares the handle of its 'MisoString' and 'Null' is a
      -- shared constant. See Note [Freeing VTree handles].
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Value -> Bool
freshValue Value
v) (JSVal -> IO ()
freeJSVal JSVal
value)
    On model -> Sink action -> VTree -> LogLevel -> Events -> IO ()
callback -> do
      -- Reset any 'pendingStaticKey' \/ 'pendingMainThread' left behind by an
      -- earlier 'OnStatic' attribute on this same node — otherwise a plain
      -- 'On' handler processed after an 'OnStatic' one would inherit its
      -- sibling's stale main-thread flag and staticKey (see 'onWithOptions').
      MisoString -> Int -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"pendingComponentId" Int
vcompId Object
vnode_
      MisoString -> JSVal -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"pendingStaticKey" JSVal
jsNull Object
vnode_
      MisoString -> Bool -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"pendingMainThread" Bool
False Object
vnode_
      model -> Sink action -> VTree -> LogLevel -> Events -> IO ()
callback model
model_ Sink action
snk (Object -> VTree
VTree Object
vnode_) LogLevel
logLevel Events
events
    OnStatic StaticPtr (EventHandler model action)
ptr ->
      -- Stash the handler's 'StaticKey' and owning @ComponentId@ on the node
      -- so 'onWithOptions' can attach them to the per-event object; the native
      -- PATCH protocol ships them to the MTS for main-thread ('MTS') dispatch.
      -- Browser\/WASM never dereferences them. 'pendingMainThread' starts
      -- @False@; 'Miso.Event.mainThread' (part of @callback@) flips it 'True'
      -- so only marked handlers opt in.
      case StaticPtr (EventHandler model action) -> EventHandler model action
forall a. StaticPtr a -> a
deRefStaticPtr StaticPtr (EventHandler model action)
ptr of
        EventHandler {Decoder result
model -> Sink action -> VTree -> LogLevel -> Events -> IO ()
result -> model -> JSVal -> action
eventHandlerInstall :: model -> Sink action -> VTree -> LogLevel -> Events -> IO ()
eventHandlerDecoder :: Decoder result
eventHandlerConvert :: result -> model -> JSVal -> action
eventHandlerConvert :: ()
eventHandlerDecoder :: ()
eventHandlerInstall :: forall model action.
EventHandler model action
-> model -> Sink action -> VTree -> LogLevel -> Events -> IO ()
..} -> do
          MisoString -> StaticKey -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"pendingStaticKey" (StaticPtr (EventHandler model action) -> StaticKey
forall a. StaticPtr a -> StaticKey
staticKey StaticPtr (EventHandler model action)
ptr) Object
vnode_
          MisoString -> Int -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"pendingComponentId" Int
vcompId Object
vnode_
          MisoString -> Bool -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"pendingMainThread" Bool
False Object
vnode_
          model -> Sink action -> VTree -> LogLevel -> Events -> IO ()
eventHandlerInstall model
model_ Sink action
snk (Object -> VTree
VTree Object
vnode_) LogLevel
logLevel Events
events
    Styles Map MisoString MisoString
styles -> do
      JSVal
cssObj <- MisoString -> Object -> IO JSVal
forall o. ToObject o => MisoString -> o -> IO JSVal
getProp MisoString
"css" Object
vnode_
      [(MisoString, MisoString)]
-> ((MisoString, MisoString) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map MisoString MisoString -> [(MisoString, MisoString)]
forall k a. Map k a -> [(k, a)]
M.toList Map MisoString MisoString
styles) (((MisoString, MisoString) -> IO ()) -> IO ())
-> ((MisoString, MisoString) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(MisoString
k,MisoString
v) -> do
        MisoString -> MisoString -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
k MisoString
v (JSVal -> Object
Object JSVal
cssObj)
      JSVal -> IO ()
freeJSVal JSVal
cssObj
  where
    freshValue :: Value -> Bool
    freshValue :: Value -> Bool
freshValue = \case
      JSON.String {} -> Bool
False
      Value
JSON.Null -> Bool
False
      Value
_ -> Bool
True
-----------------------------------------------------------------------------
-- | Registers components in the global state
registerComponent :: MonadIO m => ComponentState context props model action -> m ()
registerComponent :: forall (m :: * -> *) context props model action.
MonadIO m =>
ComponentState context props model action -> m ()
registerComponent ComponentState context props model action
componentState = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
  IORef (IntMap (ComponentState context props model action))
-> (IntMap (ComponentState context props model action)
    -> (IntMap (ComponentState context props model action), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (IntMap (ComponentState context props model action))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components ((IntMap (ComponentState context props model action)
  -> (IntMap (ComponentState context props model action), ()))
 -> IO ())
-> (IntMap (ComponentState context props model action)
    -> (IntMap (ComponentState context props model action), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \IntMap (ComponentState context props model action)
vcomps' ->
    (Int
-> ComponentState context props model action
-> IntMap (ComponentState context props model action)
-> IntMap (ComponentState context props model action)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (ComponentState context props model action -> Int
forall context props model action.
ComponentState context props model action -> Int
_componentId ComponentState context props model action
componentState) ComponentState context props model action
componentState IntMap (ComponentState context props model action)
vcomps', ())
-----------------------------------------------------------------------------
-- | Renders styles
--
-- Meant for development purposes
-- Appends CSS to <head>
--
renderStyles :: [CSS] -> IO [DOMRef]
renderStyles :: [CSS] -> IO [JSVal]
renderStyles [CSS]
styles =
  [CSS] -> (CSS -> IO JSVal) -> IO [JSVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CSS]
styles ((CSS -> IO JSVal) -> IO [JSVal])
-> (CSS -> IO JSVal) -> IO [JSVal]
forall a b. (a -> b) -> a -> b
$ \case
    Href MisoString
url Bool
cacheBust -> MisoString -> Bool -> IO JSVal
FFI.addStyleSheet MisoString
url Bool
cacheBust
    Style MisoString
css -> MisoString -> IO JSVal
FFI.addStyle MisoString
css
    Sheet StyleSheet
sheet -> MisoString -> IO JSVal
FFI.addStyle (StyleSheet -> MisoString
renderStyleSheet StyleSheet
sheet)
-----------------------------------------------------------------------------
-- | Renders scripts
--
-- Meant for development purposes
-- Appends JS to <head>
--
renderScripts :: [JS] -> IO [DOMRef]
renderScripts :: [JS] -> IO [JSVal]
renderScripts [JS]
scripts =
  [JS] -> (JS -> IO JSVal) -> IO [JSVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [JS]
scripts ((JS -> IO JSVal) -> IO [JSVal]) -> (JS -> IO JSVal) -> IO [JSVal]
forall a b. (a -> b) -> a -> b
$ \case
    Src MisoString
src Bool
cacheBust ->
      MisoString -> Bool -> IO JSVal
FFI.addSrc MisoString
src Bool
cacheBust
    Script MisoString
script ->
      Bool -> MisoString -> IO JSVal
FFI.addScript Bool
False MisoString
script
    Module MisoString
src ->
      Bool -> MisoString -> IO JSVal
FFI.addScript Bool
True MisoString
src
    ImportMap [(MisoString, MisoString)]
importMap -> do
      Object
o <- IO Object
create
      Object
imports <- IO Object
create
      [(MisoString, MisoString)]
-> ((MisoString, MisoString) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(MisoString, MisoString)]
importMap (((MisoString, MisoString) -> IO ()) -> IO ())
-> ((MisoString, MisoString) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(MisoString
k,MisoString
v) ->
        MisoString -> MisoString -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
k MisoString
v Object
imports
      MisoString -> Object -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"imports" Object
imports Object
o
      MisoString -> IO JSVal
FFI.addScriptImportMap
        (MisoString -> IO JSVal) -> IO MisoString -> IO JSVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal -> IO MisoString
jsonStringify
        (JSVal -> IO MisoString) -> IO JSVal -> IO MisoString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Object -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal Object
o
-----------------------------------------------------------------------------
-- | Starts a named 'Sub' dynamically, during the life of a t'Miso.Types.Component'.
-- The 'Sub' can be stopped by calling @Ord subKey => stop subKey@ from the @update@ function.
-- All 'Sub' started will be stopped if a t'Miso.Types.Component' is unmounted.
--
-- @
-- data SubType = LoggerSub | TimerSub
--   deriving (Eq, Ord)
--
-- update Action =
--   startSub LoggerSub $ \\sink -> forever (threadDelay (secs 1) >> consoleLog "test")
-- @
--
-- @since 1.9.0.0
startSub
  :: ToMisoString subKey
  => subKey
  -- ^ The key used to track the 'Sub'
  -> Sub model action
  -- ^ The 'Sub'
  -> Effect context props model action
startSub :: forall subKey model action context props.
ToMisoString subKey =>
subKey -> Sub model action -> Effect context props model action
startSub subKey
subKey Sub model action
sub = do
  ComponentInfo {context
props
Int
JSVal
_componentInfoContext :: forall context props. ComponentInfo context props -> context
_componentInfoProps :: forall context props. ComponentInfo context props -> props
_componentInfoDOMRef :: forall context props. ComponentInfo context props -> JSVal
_componentInfoParentId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: Int
_componentInfoParentId :: Int
_componentInfoDOMRef :: JSVal
_componentInfoProps :: props
_componentInfoContext :: context
..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> Effect context props model action
forall context props model action.
IO () -> Effect context props model action
io_ (IO () -> Effect context props model action)
-> IO () -> Effect context props model action
forall a b. (a -> b) -> a -> b
$ do
    Int
-> IntMap (ComponentState Any Any model action)
-> Maybe (ComponentState Any Any model action)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
_componentInfoId (IntMap (ComponentState Any Any model action)
 -> Maybe (ComponentState Any Any model action))
-> IO (IntMap (ComponentState Any Any model action))
-> IO (Maybe (ComponentState Any Any model action))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IntMap (ComponentState Any Any model action))
-> IO (IntMap (ComponentState Any Any model action))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (IntMap (ComponentState Any Any model action))
-> IO (IntMap (ComponentState Any Any model action))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState Any Any model action))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components) IO (Maybe (ComponentState Any Any model action))
-> (Maybe (ComponentState Any Any model action) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (ComponentState Any Any model action)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just compState :: ComponentState Any Any model action
compState@ComponentState {model
Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
Any
IORef Any
IORef (Map MisoString ThreadId)
IORef VTree
Map MisoString (Value -> IO ())
ComponentIds
JSVal
model -> IO ()
model -> model -> Bool
Sink action
Any -> Any -> IO ()
Seq action -> model -> Any -> Any -> (model, [Schedule Any action])
Value -> Maybe action
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentContext :: forall context props model action.
ComponentState context props model action -> IORef context
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: Any
_prevComponentProps :: Any
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink action
_componentPostEffect :: Sink action
_componentModel :: model
_componentScripts :: [JSVal]
_componentUseContext :: Bool
_componentContext :: IORef Any
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentHydrate :: model -> IO ()
_componentPropsPhase :: Any -> Any -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: Seq action -> model -> Any -> Any -> (model, [Schedule Any action])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} -> do
        Maybe ThreadId
mtid <- IO (Maybe ThreadId) -> IO (Maybe ThreadId)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MisoString -> Map MisoString ThreadId -> Maybe ThreadId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (subKey -> MisoString
forall str. ToMisoString str => str -> MisoString
ms subKey
subKey) (Map MisoString ThreadId -> Maybe ThreadId)
-> IO (Map MisoString ThreadId) -> IO (Maybe ThreadId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map MisoString ThreadId) -> IO (Map MisoString ThreadId)
forall a. IORef a -> IO a
readIORef IORef (Map MisoString ThreadId)
_componentSubThreads)
        case Maybe ThreadId
mtid of
          Maybe ThreadId
Nothing ->
            ComponentState Any Any model action -> IO ()
forall {context} {props}.
ComponentState context props model action -> IO ()
startThread ComponentState Any Any model action
compState
          Just ThreadId
tid -> do
            ThreadStatus
status <- ThreadId -> IO ThreadStatus
threadStatus ThreadId
tid
            case ThreadStatus
status of
              ThreadStatus
ThreadFinished -> ComponentState Any Any model action -> IO ()
forall {context} {props}.
ComponentState context props model action -> IO ()
startThread ComponentState Any Any model action
compState
              ThreadStatus
ThreadDied -> ComponentState Any Any model action -> IO ()
forall {context} {props}.
ComponentState context props model action -> IO ()
startThread ComponentState Any Any model action
compState
              ThreadStatus
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    startThread :: ComponentState context props model action -> IO ()
startThread ComponentState
      { _componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId = Int
vcompId
      , _componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink = Sink action
vcompSink
      , _componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentSubThreads = IORef (Map MisoString ThreadId)
subThreads
      , _componentModel :: forall context props model action.
ComponentState context props model action -> model
_componentModel = model
currentModel
      } = do
        IO model
getModel <- Int -> model -> IO (IO model)
forall model. Int -> model -> IO (IO model)
mkGetModel Int
vcompId model
currentModel
        ThreadId
tid <- IO () -> IO ThreadId
forkIO (Sub model action
sub Sink action
vcompSink IO model
getModel)
        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)
subThreads ((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
-> ThreadId -> Map MisoString ThreadId -> Map MisoString ThreadId
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (subKey -> MisoString
forall str. ToMisoString str => str -> MisoString
ms subKey
subKey) ThreadId
tid Map MisoString ThreadId
m, ())
-----------------------------------------------------------------------------
-- | Stops a named 'Sub' dynamically, during the life of a t'Miso.Types.Component'.
-- All 'Sub' started will be stopped automatically if a t'Miso.Types.Component' is unmounted.
--
-- @
-- data SubType = LoggerSub | TimerSub
--   deriving (Eq, Ord)
--
-- update Action = do
--   stopSub LoggerSub
-- @
--
-- @since 1.9.0.0
stopSub
  :: ToMisoString subKey
  => subKey
  -- ^ The key used to stop the 'Sub'
  -> Effect context props model action
stopSub :: forall subKey context props model action.
ToMisoString subKey =>
subKey -> Effect context props model action
stopSub subKey
subKey = do
  Int
vcompId <- (ComponentInfo context props -> Int)
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     model
     Identity
     Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ComponentInfo context props -> Int
forall context props. ComponentInfo context props -> Int
_componentInfoId
  IO () -> Effect context props model action
forall context props model action.
IO () -> Effect context props model action
io_ (IO () -> Effect context props model action)
-> IO () -> Effect context props model action
forall a b. (a -> b) -> a -> b
$ do
    Int
-> IntMap (ComponentState Any Any Any Any)
-> Maybe (ComponentState Any Any Any Any)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap (ComponentState Any Any Any Any)
 -> Maybe (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
-> IO (Maybe (ComponentState Any Any Any Any))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState Any Any Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components IO (Maybe (ComponentState Any Any Any Any))
-> (Maybe (ComponentState Any Any Any Any) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (ComponentState Any Any Any Any)
Nothing -> do
        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just ComponentState {Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
Any
IORef Any
IORef (Map MisoString ThreadId)
IORef VTree
Map MisoString (Value -> IO ())
ComponentIds
JSVal
Any -> IO ()
Any -> Any -> Bool
Any -> Any -> IO ()
Seq Any -> Any -> Any -> Any -> (Any, [Schedule Any Any])
Value -> Maybe Any
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentContext :: forall context props model action.
ComponentState context props model action -> IORef context
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: Any
_prevComponentProps :: Any
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Any -> IO ()
_componentPostEffect :: Any -> IO ()
_componentModel :: Any
_componentScripts :: [JSVal]
_componentUseContext :: Bool
_componentContext :: IORef Any
_componentMailbox :: Value -> Maybe Any
_componentDraw :: Any -> IO ()
_componentHydrate :: Any -> IO ()
_componentPropsPhase :: Any -> Any -> IO ()
_componentModelDirty :: Any -> Any -> Bool
_componentApplyActions :: Seq Any -> Any -> Any -> Any -> (Any, [Schedule Any Any])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} -> do
        Maybe ThreadId
mtid <- IO (Maybe ThreadId) -> IO (Maybe ThreadId)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MisoString -> Map MisoString ThreadId -> Maybe ThreadId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (subKey -> MisoString
forall str. ToMisoString str => str -> MisoString
ms subKey
subKey) (Map MisoString ThreadId -> Maybe ThreadId)
-> IO (Map MisoString ThreadId) -> IO (Maybe ThreadId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map MisoString ThreadId) -> IO (Map MisoString ThreadId)
forall a. IORef a -> IO a
readIORef IORef (Map MisoString ThreadId)
_componentSubThreads)
        Maybe ThreadId -> (ThreadId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe ThreadId
mtid ((ThreadId -> IO ()) -> IO ()) -> (ThreadId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ThreadId
tid ->
          IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            IORef (Map MisoString ThreadId)
-> (Map MisoString ThreadId -> (Map MisoString ThreadId, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map MisoString ThreadId)
_componentSubThreads ((Map MisoString ThreadId -> (Map MisoString ThreadId, ()))
 -> IO ())
-> (Map MisoString ThreadId -> (Map MisoString ThreadId, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map MisoString ThreadId
m -> (MisoString -> Map MisoString ThreadId -> Map MisoString ThreadId
forall k a. Ord k => k -> Map k a -> Map k a
M.delete (subKey -> MisoString
forall str. ToMisoString str => str -> MisoString
ms subKey
subKey) Map MisoString ThreadId
m, ())
            ThreadId -> IO ()
killThread ThreadId
tid
-----------------------------------------------------------------------------
-- | Send any @ToJSON message => message@ to a t'Miso.Types.Component' mailbox, by @ComponentId@
--
-- @
-- io_ $ mail componentId ("test message" :: MisoString) :: Effect context props model action
-- @
--
-- @since 1.9.0.0
mail
  :: ToJSON message
  => ComponentId
  -- ^ @ComponentId@ to receive 'mail'
  -> message
  -- ^ The message to send
  -> IO ()
mail :: forall message. ToJSON message => Int -> message -> IO ()
mail Int
vcompId message
msg =
  Int
-> IntMap (ComponentState Any Any Any Any)
-> Maybe (ComponentState Any Any Any Any)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap (ComponentState Any Any Any Any)
 -> Maybe (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
-> IO (Maybe (ComponentState Any Any Any Any))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState Any Any Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components IO (Maybe (ComponentState Any Any Any Any))
-> (Maybe (ComponentState Any Any Any Any) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (ComponentState Any Any Any Any)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just ComponentState{Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
Any
IORef Any
IORef (Map MisoString ThreadId)
IORef VTree
Map MisoString (Value -> IO ())
ComponentIds
JSVal
Any -> IO ()
Any -> Any -> Bool
Any -> Any -> IO ()
Seq Any -> Any -> Any -> Any -> (Any, [Schedule Any Any])
Value -> Maybe Any
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentContext :: forall context props model action.
ComponentState context props model action -> IORef context
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: Any
_prevComponentProps :: Any
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Any -> IO ()
_componentPostEffect :: Any -> IO ()
_componentModel :: Any
_componentScripts :: [JSVal]
_componentUseContext :: Bool
_componentContext :: IORef Any
_componentMailbox :: Value -> Maybe Any
_componentDraw :: Any -> IO ()
_componentHydrate :: Any -> IO ()
_componentPropsPhase :: Any -> Any -> IO ()
_componentModelDirty :: Any -> Any -> Bool
_componentApplyActions :: Seq Any -> Any -> Any -> Any -> (Any, [Schedule Any Any])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} ->
      case Value -> Maybe Any
_componentMailbox (message -> Value
forall a. ToJSON a => a -> Value
toJSON message
msg) of
        Maybe Any
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Any
action ->
          Any -> IO ()
_componentSink Any
action
-----------------------------------------------------------------------------
-- | Send any @ToJSON message => message@ to the parent's t'Miso.Types.Component' mailbox
--
-- @
-- mailParent ("test message" :: MisoString) :: Effect context props model action
-- @
--
-- @since 1.9.0.0
mailParent
  :: ToJSON message
  => message
  -- ^ Message to send
  -> Effect context props model action
mailParent :: forall message context props model action.
ToJSON message =>
message -> Effect context props model action
mailParent message
msg = do
  ComponentInfo {context
props
Int
JSVal
_componentInfoContext :: forall context props. ComponentInfo context props -> context
_componentInfoProps :: forall context props. ComponentInfo context props -> props
_componentInfoDOMRef :: forall context props. ComponentInfo context props -> JSVal
_componentInfoParentId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: Int
_componentInfoParentId :: Int
_componentInfoDOMRef :: JSVal
_componentInfoProps :: props
_componentInfoContext :: context
..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> Effect context props model action
forall context props model action.
IO () -> Effect context props model action
io_ (Int -> message -> IO ()
forall message. ToJSON message => Int -> message -> IO ()
mail Int
_componentInfoParentId message
msg)
-----------------------------------------------------------------------------
-- | Send any @ToJSON message => message@ to all ancestor t'Miso.Types.Component' 'mailbox'.
--
-- This function walks the t'Miso.Types.Component' ancestor hierarchy, delivering mail
-- along the way.
--
-- @
-- mailAncestors ("test message" :: MisoString) :: Effect context props model action
-- @
--
-- @since 1.11.0.0
mailAncestors
  :: ToJSON message
  => message
  -- ^ Message to send
  -> Effect context props model action
mailAncestors :: forall message context props model action.
ToJSON message =>
message -> Effect context props model action
mailAncestors message
msg = do
  ComponentInfo {context
props
Int
JSVal
_componentInfoContext :: forall context props. ComponentInfo context props -> context
_componentInfoProps :: forall context props. ComponentInfo context props -> props
_componentInfoDOMRef :: forall context props. ComponentInfo context props -> JSVal
_componentInfoParentId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: Int
_componentInfoParentId :: Int
_componentInfoDOMRef :: JSVal
_componentInfoProps :: props
_componentInfoContext :: context
..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> Effect context props model action
forall context props model action.
IO () -> Effect context props model action
io_ (Int -> IO ()
climb Int
_componentInfoParentId)
    where
      climb :: Int -> IO ()
climb Int
vcompId = do
        Int -> message -> IO ()
forall message. ToJSON message => Int -> message -> IO ()
mail Int
vcompId message
msg
        Int
-> IntMap (ComponentState Any Any Any Any)
-> Maybe (ComponentState Any Any Any Any)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap (ComponentState Any Any Any Any)
 -> Maybe (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
-> IO (Maybe (ComponentState Any Any Any Any))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState Any Any Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components IO (Maybe (ComponentState Any Any Any Any))
-> (Maybe (ComponentState Any Any Any Any) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe (ComponentState Any Any Any Any)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just ComponentState Any Any Any Any
cs -> Int -> IO ()
climb (ComponentState Any Any Any Any -> Int
forall context props model action.
ComponentState context props model action -> Int
_componentParentId ComponentState Any Any Any Any
cs)
-----------------------------------------------------------------------------
-- | Send any @ToJSON message => message@ to the children's t'Miso.Types.Component' mailbox
--
-- N.B. this is only relevant for immediate descendants (not all descendants).
--
-- @
-- mailChildren ("test message" :: MisoString) :: Effect context props model action
-- @
--
-- @since 1.9.0.0
mailChildren
  :: ToJSON message
  => message
  -- ^ Message to send
  -> Effect context props model action
mailChildren :: forall message context props model action.
ToJSON message =>
message -> Effect context props model action
mailChildren message
msg = do
  ComponentInfo {context
props
Int
JSVal
_componentInfoContext :: forall context props. ComponentInfo context props -> context
_componentInfoProps :: forall context props. ComponentInfo context props -> props
_componentInfoDOMRef :: forall context props. ComponentInfo context props -> JSVal
_componentInfoParentId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: Int
_componentInfoParentId :: Int
_componentInfoDOMRef :: JSVal
_componentInfoProps :: props
_componentInfoContext :: context
..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> Effect context props model action
forall context props model action.
IO () -> Effect context props model action
io_ (IO () -> Effect context props model action)
-> IO () -> Effect context props model action
forall a b. (a -> b) -> a -> b
$ do
    ComponentState {Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
Any
IORef Any
IORef (Map MisoString ThreadId)
IORef VTree
Map MisoString (Value -> IO ())
ComponentIds
JSVal
Any -> IO ()
Any -> Any -> Bool
Any -> Any -> IO ()
Seq Any -> Any -> Any -> Any -> (Any, [Schedule Any Any])
Value -> Maybe Any
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentContext :: forall context props model action.
ComponentState context props model action -> IORef context
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: Any
_prevComponentProps :: Any
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Any -> IO ()
_componentPostEffect :: Any -> IO ()
_componentModel :: Any
_componentScripts :: [JSVal]
_componentUseContext :: Bool
_componentContext :: IORef Any
_componentMailbox :: Value -> Maybe Any
_componentDraw :: Any -> IO ()
_componentHydrate :: Any -> IO ()
_componentPropsPhase :: Any -> Any -> IO ()
_componentModelDirty :: Any -> Any -> Bool
_componentApplyActions :: Seq Any -> Any -> Any -> Any -> (Any, [Schedule Any Any])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} <- (IntMap (ComponentState Any Any Any Any)
-> Int -> ComponentState Any Any Any Any
forall a. IntMap a -> Int -> a
IM.! Int
_componentInfoId) (IntMap (ComponentState Any Any Any Any)
 -> ComponentState Any Any Any Any)
-> IO (IntMap (ComponentState Any Any Any Any))
-> IO (ComponentState Any Any Any Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState Any Any Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
    [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ComponentIds -> [Int]
IS.toList ComponentIds
_componentChildren) ((Int -> message -> IO ()) -> message -> Int -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> message -> IO ()
forall message. ToJSON message => Int -> message -> IO ()
mail message
msg)
-----------------------------------------------------------------------------
-- | Send any @ToJSON message => message@ to all descendants t'Miso.Types.Component' mailbox
--
-- Unlike 'mailChildren', this is relevant for all descendants t'Miso.Types.Component'.
--
-- @
-- mailDescendants ("test message" :: MisoString) :: Effect context props model action
-- @
--
-- @since 1.12.0.0
mailDescendants
  :: ToJSON message
  => message
  -- ^ Message to send
  -> Effect context props model action
mailDescendants :: forall message context props model action.
ToJSON message =>
message -> Effect context props model action
mailDescendants message
msg = do
  ComponentInfo {context
props
Int
JSVal
_componentInfoContext :: forall context props. ComponentInfo context props -> context
_componentInfoProps :: forall context props. ComponentInfo context props -> props
_componentInfoDOMRef :: forall context props. ComponentInfo context props -> JSVal
_componentInfoParentId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: Int
_componentInfoParentId :: Int
_componentInfoDOMRef :: JSVal
_componentInfoProps :: props
_componentInfoContext :: context
..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> Effect context props model action
forall context props model action.
IO () -> Effect context props model action
io_ (IO () -> Effect context props model action)
-> IO () -> Effect context props model action
forall a b. (a -> b) -> a -> b
$ do
    ComponentState Any Any Any Any
cs <- (IntMap (ComponentState Any Any Any Any)
-> Int -> ComponentState Any Any Any Any
forall a. IntMap a -> Int -> a
IM.! Int
_componentInfoId) (IntMap (ComponentState Any Any Any Any)
 -> ComponentState Any Any Any Any)
-> IO (IntMap (ComponentState Any Any Any Any))
-> IO (ComponentState Any Any Any Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState Any Any Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
    [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ComponentIds -> [Int]
IS.toList (ComponentState Any Any Any Any -> ComponentIds
forall context props model action.
ComponentState context props model action -> ComponentIds
_componentChildren ComponentState Any Any Any Any
cs)) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
child -> do
      ComponentState Any Any Any Any -> IO ()
forall {context} {props} {model} {action}.
ComponentState context props model action -> IO ()
walk (ComponentState Any Any Any Any -> IO ())
-> (IntMap (ComponentState Any Any Any Any)
    -> ComponentState Any Any Any Any)
-> IntMap (ComponentState Any Any Any Any)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (IntMap (ComponentState Any Any Any Any)
-> Int -> ComponentState Any Any Any Any
forall a. IntMap a -> Int -> a
IM.! Int
child) (IntMap (ComponentState Any Any Any Any) -> IO ())
-> IO (IntMap (ComponentState Any Any Any Any)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (IntMap (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState Any Any Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
  where
    walk :: ComponentState context props model action -> IO ()
walk ComponentState {props
model
Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
IORef context
IORef (Map MisoString ThreadId)
IORef VTree
Map MisoString (Value -> IO ())
ComponentIds
JSVal
props -> props -> IO ()
model -> IO ()
model -> model -> Bool
Sink action
Seq action
-> model -> props -> context -> (model, [Schedule context action])
Value -> Maybe action
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentContext :: forall context props model action.
ComponentState context props model action -> IORef context
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: props
_prevComponentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink action
_componentPostEffect :: Sink action
_componentModel :: model
_componentScripts :: [JSVal]
_componentUseContext :: Bool
_componentContext :: IORef context
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentHydrate :: model -> IO ()
_componentPropsPhase :: props -> props -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: Seq action
-> model -> props -> context -> (model, [Schedule context action])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} = do
      Int -> message -> IO ()
forall message. ToJSON message => Int -> message -> IO ()
mail Int
_componentId message
msg
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ComponentIds -> [Int]
IS.toList ComponentIds
_componentChildren) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
child -> do
        ComponentState context props model action -> IO ()
walk (ComponentState context props model action -> IO ())
-> (IntMap (ComponentState context props model action)
    -> ComponentState context props model action)
-> IntMap (ComponentState context props model action)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (IntMap (ComponentState context props model action)
-> Int -> ComponentState context props model action
forall a. IntMap a -> Int -> a
IM.! Int
child) (IntMap (ComponentState context props model action) -> IO ())
-> IO (IntMap (ComponentState context props model action)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (IntMap (ComponentState context props model action))
-> IO (IntMap (ComponentState context props model action))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState context props model action))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
----------------------------------------------------------------------------
-- | Helper function for processing @Mail@ from 'mail'.
--
-- @
--
-- data Action
--   = ParsedMail Message
--   | ErrorMail MisoString
--
-- main :: IO ()
-- main = app { mailbox = checkMail ParsedMail ErrorMail }
-- @
--
-- @since 1.9.0.0
checkMail
  :: FromJSON value
  => (value -> action)
  -- ^ Successful callback
  -> (MisoString -> action)
  -- ^ Errorful callback
  -> Value
  -- ^ The message received to parse.
  -> Maybe action
checkMail :: forall value action.
FromJSON value =>
(value -> action)
-> (MisoString -> action) -> Value -> Maybe action
checkMail value -> action
successful MisoString -> action
errorful Value
value =
  action -> Maybe action
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (action -> Maybe action) -> action -> Maybe action
forall a b. (a -> b) -> a -> b
$ case Value -> Result value
forall a. FromJSON a => Value -> Result a
fromJSON Value
value of
    Success value
x -> value -> action
successful value
x
    Error MisoString
err -> MisoString -> action
errorful (MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
ms MisoString
err)
-----------------------------------------------------------------------------
-- | Sends a message to all t'Miso.Types.Component' 'mailbox', excluding oneself.
--
-- @
--
-- update :: action -> Effect context props model action
-- update _ = broadcast (String "public service announcement")
-- @
--
-- @since 1.9.0.0
broadcast
  :: Eq model
  => ToJSON message
  => message
  -- ^ Message to broadcast to all other t'Miso.Types.Component'
  -> Effect context props model action
broadcast :: forall model message context props action.
(Eq model, ToJSON message) =>
message -> Effect context props model action
broadcast message
msg = do
  ComponentInfo {context
props
Int
JSVal
_componentInfoContext :: forall context props. ComponentInfo context props -> context
_componentInfoProps :: forall context props. ComponentInfo context props -> props
_componentInfoDOMRef :: forall context props. ComponentInfo context props -> JSVal
_componentInfoParentId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: Int
_componentInfoParentId :: Int
_componentInfoDOMRef :: JSVal
_componentInfoProps :: props
_componentInfoContext :: context
..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> Effect context props model action
forall context props model action.
IO () -> Effect context props model action
io_ (IO () -> Effect context props model action)
-> IO () -> Effect context props model action
forall a b. (a -> b) -> a -> b
$ do
    [Int]
vcompIds <- IntMap (ComponentState Any Any Any Any) -> [Int]
forall a. IntMap a -> [Int]
IM.keys (IntMap (ComponentState Any Any Any Any) -> [Int])
-> IO (IntMap (ComponentState Any Any Any Any)) -> IO [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState Any Any Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
    [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
vcompIds ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
vcompId ->
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
_componentInfoId Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
vcompId) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Int
-> IntMap (ComponentState Any Any Any Any)
-> Maybe (ComponentState Any Any Any Any)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap (ComponentState Any Any Any Any)
 -> Maybe (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
-> IO (Maybe (ComponentState Any Any Any Any))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap (ComponentState Any Any Any Any))
-> IO (IntMap (ComponentState Any Any Any Any))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState Any Any Any Any))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components IO (Maybe (ComponentState Any Any Any Any))
-> (Maybe (ComponentState Any Any Any Any) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe (ComponentState Any Any Any Any)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just ComponentState{Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
Any
IORef Any
IORef (Map MisoString ThreadId)
IORef VTree
Map MisoString (Value -> IO ())
ComponentIds
JSVal
Any -> IO ()
Any -> Any -> Bool
Any -> Any -> IO ()
Seq Any -> Any -> Any -> Any -> (Any, [Schedule Any Any])
Value -> Maybe Any
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentContext :: forall context props model action.
ComponentState context props model action -> IORef context
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: Any
_prevComponentProps :: Any
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Any -> IO ()
_componentPostEffect :: Any -> IO ()
_componentModel :: Any
_componentScripts :: [JSVal]
_componentUseContext :: Bool
_componentContext :: IORef Any
_componentMailbox :: Value -> Maybe Any
_componentDraw :: Any -> IO ()
_componentHydrate :: Any -> IO ()
_componentPropsPhase :: Any -> Any -> IO ()
_componentModelDirty :: Any -> Any -> Bool
_componentApplyActions :: Seq Any -> Any -> Any -> Any -> (Any, [Schedule Any Any])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} ->
            case Value -> Maybe Any
_componentMailbox (message -> Value
forall a. ToJSON a => a -> Value
toJSON message
msg) of
              Maybe Any
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Just Any
action -> Any -> IO ()
_componentSink Any
action
-----------------------------------------------------------------------------
type Socket = JSVal
-----------------------------------------------------------------------------
type WebSockets = IM.IntMap (IM.IntMap Socket)
-----------------------------------------------------------------------------
type EventSources = IM.IntMap (IM.IntMap Socket)
-----------------------------------------------------------------------------
websocketConnections :: IORef WebSockets
{-# NOINLINE websocketConnections #-}
websocketConnections :: IORef WebSockets
websocketConnections = IO (IORef WebSockets) -> IORef WebSockets
forall a. IO a -> a
unsafePerformIO (WebSockets -> IO (IORef WebSockets)
forall a. a -> IO (IORef a)
newIORef WebSockets
forall a. IntMap a
IM.empty)
-----------------------------------------------------------------------------
websocketConnectionIds :: IORef Int
{-# NOINLINE websocketConnectionIds #-}
websocketConnectionIds :: IORef Int
websocketConnectionIds = IO (IORef Int) -> IORef Int
forall a. IO a -> a
unsafePerformIO (Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int))
-----------------------------------------------------------------------------
websocketConnectText
  :: URL
  -- ^ t'WebSocket' 'URL'
  -> (WebSocket -> action)
  -- ^ onOpen
  -> (Closed -> action)
  -- ^ onClosed
  -> (MisoString -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect context props model action
websocketConnectText :: forall action context props model.
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (MisoString -> action)
-> (MisoString -> action)
-> Effect context props model action
websocketConnectText MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed MisoString -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> IO JSVal)
-> Effect context props model action
forall action context props model.
(WebSocket -> Sink action -> IO JSVal)
-> Effect context props model action
websocketCore ((WebSocket -> Sink action -> IO JSVal)
 -> Effect context props model action)
-> (WebSocket -> Sink action -> IO JSVal)
-> Effect context props model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> IO ()
-> (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> (JSVal -> IO ())
-> Bool
-> IO JSVal
FFI.websocketConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ WebSocket -> action
onOpen WebSocket
webSocketId)
      (Sink action
sink Sink action -> (Closed -> action) -> Closed -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Closed -> action
onClosed (Closed -> IO ()) -> (JSVal -> IO Closed) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO Closed
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. MisoString -> action
onMessage (MisoString -> IO ()) -> (JSVal -> IO MisoString) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked))
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. MisoString -> action
onError (MisoString -> IO ()) -> (JSVal -> IO MisoString) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Bool
True
-----------------------------------------------------------------------------
websocketConnectBLOB
  :: URL
  -- ^ t'WebSocket' 'URL'
  -> (WebSocket -> action)
  -- ^ onOpen
  -> (Closed -> action)
  -- ^ onClosed
  -> (Blob -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect context props model action
websocketConnectBLOB :: forall action context props model.
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (Blob -> action)
-> (MisoString -> action)
-> Effect context props model action
websocketConnectBLOB MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed Blob -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> IO JSVal)
-> Effect context props model action
forall action context props model.
(WebSocket -> Sink action -> IO JSVal)
-> Effect context props model action
websocketCore ((WebSocket -> Sink action -> IO JSVal)
 -> Effect context props model action)
-> (WebSocket -> Sink action -> IO JSVal)
-> Effect context props model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> IO ()
-> (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> (JSVal -> IO ())
-> Bool
-> IO JSVal
FFI.websocketConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ WebSocket -> action
onOpen WebSocket
webSocketId)
      (Sink action
sink Sink action -> (Closed -> action) -> Closed -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Closed -> action
onClosed (Closed -> IO ()) -> (JSVal -> IO Closed) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO Closed
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (JSVal -> action) -> JSVal -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Blob -> action
onMessage (Blob -> action) -> (JSVal -> Blob) -> JSVal -> action
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. JSVal -> Blob
Blob))
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. MisoString -> action
onError (MisoString -> IO ()) -> (JSVal -> IO MisoString) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Bool
False
-----------------------------------------------------------------------------
websocketConnectArrayBuffer
  :: URL
  -- ^ t'WebSocket' 'URL'
  -> (WebSocket -> action)
  -- ^ onOpen
  -> (Closed -> action)
  -- ^ onClosed
  -> (ArrayBuffer -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect context props model action
websocketConnectArrayBuffer :: forall action context props model.
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (ArrayBuffer -> action)
-> (MisoString -> action)
-> Effect context props model action
websocketConnectArrayBuffer MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed ArrayBuffer -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> IO JSVal)
-> Effect context props model action
forall action context props model.
(WebSocket -> Sink action -> IO JSVal)
-> Effect context props model action
websocketCore ((WebSocket -> Sink action -> IO JSVal)
 -> Effect context props model action)
-> (WebSocket -> Sink action -> IO JSVal)
-> Effect context props model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> IO ()
-> (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> (JSVal -> IO ())
-> Bool
-> IO JSVal
FFI.websocketConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ WebSocket -> action
onOpen WebSocket
webSocketId)
      (Sink action
sink Sink action -> (Closed -> action) -> Closed -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Closed -> action
onClosed (Closed -> IO ()) -> (JSVal -> IO Closed) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO Closed
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (JSVal -> action) -> JSVal -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ArrayBuffer -> action
onMessage (ArrayBuffer -> action)
-> (JSVal -> ArrayBuffer) -> JSVal -> action
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. JSVal -> ArrayBuffer
ArrayBuffer))
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. MisoString -> action
onError (MisoString -> IO ()) -> (JSVal -> IO MisoString) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Bool
False
-----------------------------------------------------------------------------
websocketConnectJSON
  :: FromJSON json
  => URL
  -- ^ WebSocket URL
  -> (WebSocket -> action)
  -- ^ onOpen
  -> (Closed -> action)
  -- ^ onClosed
  -> (json -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect context props model action
websocketConnectJSON :: forall json action context props model.
FromJSON json =>
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (json -> action)
-> (MisoString -> action)
-> Effect context props model action
websocketConnectJSON MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed json -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> IO JSVal)
-> Effect context props model action
forall action context props model.
(WebSocket -> Sink action -> IO JSVal)
-> Effect context props model action
websocketCore ((WebSocket -> Sink action -> IO JSVal)
 -> Effect context props model action)
-> (WebSocket -> Sink action -> IO JSVal)
-> Effect context props model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> IO ()
-> (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> (JSVal -> IO ())
-> Bool
-> IO JSVal
FFI.websocketConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ WebSocket -> action
onOpen WebSocket
webSocketId)
      (Sink action
sink Sink action -> (Closed -> action) -> Closed -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Closed -> action
onClosed (Closed -> IO ()) -> (JSVal -> IO Closed) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO Closed
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\JSVal
bytes -> do
          Value
value :: Value <- JSVal -> IO Value
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked JSVal
bytes
          case Value -> Result json
forall a. FromJSON a => Value -> Result a
fromJSON Value
value of
            Error MisoString
msg -> Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ MisoString -> action
onError (MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
ms MisoString
msg)
            Success json
x -> Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ json -> action
onMessage json
x))
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. MisoString -> action
onError (MisoString -> IO ()) -> (JSVal -> IO MisoString) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Bool
False
-----------------------------------------------------------------------------
websocketConnect
  :: FromJSON json
  => URL
  -- ^ WebSocket URL
  -> (WebSocket -> action)
  -- ^ onOpen
  -> (Closed -> action)
  -- ^ onClosed
  -> (Payload json -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect context props model action
websocketConnect :: forall json action context props model.
FromJSON json =>
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (Payload json -> action)
-> (MisoString -> action)
-> Effect context props model action
websocketConnect MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed Payload json -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> IO JSVal)
-> Effect context props model action
forall action context props model.
(WebSocket -> Sink action -> IO JSVal)
-> Effect context props model action
websocketCore ((WebSocket -> Sink action -> IO JSVal)
 -> Effect context props model action)
-> (WebSocket -> Sink action -> IO JSVal)
-> Effect context props model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> IO ()
-> (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> (JSVal -> IO ())
-> Bool
-> IO JSVal
FFI.websocketConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ WebSocket -> action
onOpen WebSocket
webSocketId)
      (Sink action
sink Sink action -> (Closed -> action) -> Closed -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Closed -> action
onClosed (Closed -> IO ()) -> (JSVal -> IO Closed) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO Closed
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Payload json -> action
onMessage (Payload json -> action)
-> (MisoString -> Payload json) -> MisoString -> action
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. MisoString -> Payload json
forall value. MisoString -> Payload value
TEXT (MisoString -> IO ()) -> (JSVal -> IO MisoString) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked))
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\JSVal
bytes -> do
          Value
value :: Value <- JSVal -> IO Value
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked JSVal
bytes
          case Value -> Result json
forall a. FromJSON a => Value -> Result a
fromJSON Value
value of
            Error MisoString
msg -> Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ MisoString -> action
onError (MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
ms MisoString
msg)
            Success json
x -> Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ Payload json -> action
onMessage (json -> Payload json
forall value. value -> Payload value
JSON json
x)))
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (JSVal -> action) -> JSVal -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Payload json -> action
onMessage (Payload json -> action)
-> (JSVal -> Payload json) -> JSVal -> action
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Blob -> Payload json
forall value. Blob -> Payload value
BLOB (Blob -> Payload json) -> (JSVal -> Blob) -> JSVal -> Payload json
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. JSVal -> Blob
Blob))
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (JSVal -> action) -> JSVal -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Payload json -> action
onMessage (Payload json -> action)
-> (JSVal -> Payload json) -> JSVal -> action
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ArrayBuffer -> Payload json
forall value. ArrayBuffer -> Payload value
BUFFER (ArrayBuffer -> Payload json)
-> (JSVal -> ArrayBuffer) -> JSVal -> Payload json
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. JSVal -> ArrayBuffer
ArrayBuffer))
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. MisoString -> action
onError (MisoString -> IO ()) -> (JSVal -> IO MisoString) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Bool
False
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/WebSocket/WebSocket>
websocketCore
  :: (WebSocket -> Sink action -> IO Socket)
  -> Effect context props model action
websocketCore :: forall action context props model.
(WebSocket -> Sink action -> IO JSVal)
-> Effect context props model action
websocketCore WebSocket -> Sink action -> IO JSVal
core = do
  ComponentInfo {context
props
Int
JSVal
_componentInfoContext :: forall context props. ComponentInfo context props -> context
_componentInfoProps :: forall context props. ComponentInfo context props -> props
_componentInfoDOMRef :: forall context props. ComponentInfo context props -> JSVal
_componentInfoParentId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: Int
_componentInfoParentId :: Int
_componentInfoDOMRef :: JSVal
_componentInfoProps :: props
_componentInfoContext :: context
..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  (Sink action -> IO ()) -> Effect context props model action
forall action context props model.
(Sink action -> IO ()) -> Effect context props model action
withSink ((Sink action -> IO ()) -> Effect context props model action)
-> (Sink action -> IO ()) -> Effect context props model action
forall a b. (a -> b) -> a -> b
$ \Sink action
sink -> do
    WebSocket
webSocketId <- IO WebSocket
freshWebSocket
    JSVal
socket <- WebSocket -> Sink action -> IO JSVal
core WebSocket
webSocketId Sink action
sink
    Int -> WebSocket -> JSVal -> IO ()
insertWebSocket Int
_componentInfoId WebSocket
webSocketId JSVal
socket
  where
    insertWebSocket :: ComponentId -> WebSocket -> Socket -> IO ()
    insertWebSocket :: Int -> WebSocket -> JSVal -> IO ()
insertWebSocket Int
componentId_ (WebSocket Int
socketId) JSVal
socket =
      IORef WebSockets -> (WebSockets -> (WebSockets, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef WebSockets
websocketConnections ((WebSockets -> (WebSockets, ())) -> IO ())
-> (WebSockets -> (WebSockets, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WebSockets
websockets ->
          (WebSockets -> WebSockets
update WebSockets
websockets, ())
      where
        update :: WebSockets -> WebSockets
update WebSockets
websockets =
          (IntMap JSVal -> IntMap JSVal -> IntMap JSVal)
-> WebSockets -> WebSockets -> WebSockets
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith IntMap JSVal -> IntMap JSVal -> IntMap JSVal
forall a. IntMap a -> IntMap a -> IntMap a
IM.union WebSockets
websockets
            (WebSockets -> WebSockets) -> WebSockets -> WebSockets
forall a b. (a -> b) -> a -> b
$ Int -> IntMap JSVal -> WebSockets
forall a. Int -> a -> IntMap a
IM.singleton Int
componentId_
            (IntMap JSVal -> WebSockets) -> IntMap JSVal -> WebSockets
forall a b. (a -> b) -> a -> b
$ Int -> JSVal -> IntMap JSVal
forall a. Int -> a -> IntMap a
IM.singleton Int
socketId JSVal
socket

    freshWebSocket :: IO WebSocket
    freshWebSocket :: IO WebSocket
freshWebSocket = Int -> WebSocket
WebSocket (Int -> WebSocket) -> IO Int -> IO WebSocket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
websocketConnectionIds (\Int
x -> (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
x))
-----------------------------------------------------------------------------
getWebSocket :: ComponentId -> WebSocket -> WebSockets -> Maybe Socket
getWebSocket :: Int -> WebSocket -> WebSockets -> Maybe JSVal
getWebSocket Int
vcompId (WebSocket Int
websocketId) =
  Int -> IntMap JSVal -> Maybe JSVal
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
websocketId (IntMap JSVal -> Maybe JSVal)
-> (WebSockets -> Maybe (IntMap JSVal))
-> WebSockets
-> Maybe JSVal
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId
-----------------------------------------------------------------------------
finalizeWebSockets :: ComponentId -> IO ()
finalizeWebSockets :: Int -> IO ()
finalizeWebSockets Int
vcompId = do
  (IntMap JSVal -> IO ()) -> Maybe (IntMap JSVal) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((JSVal -> IO ()) -> [JSVal] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ JSVal -> IO ()
FFI.websocketClose ([JSVal] -> IO ())
-> (IntMap JSVal -> [JSVal]) -> IntMap JSVal -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IntMap JSVal -> [JSVal]
forall a. IntMap a -> [a]
IM.elems) (Maybe (IntMap JSVal) -> IO ())
-> (WebSockets -> Maybe (IntMap JSVal)) -> WebSockets -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
    Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (WebSockets -> IO ()) -> IO WebSockets -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef WebSockets -> IO WebSockets
forall a. IORef a -> IO a
readIORef IORef WebSockets
websocketConnections
  IO ()
dropComponentWebSockets
    where
      dropComponentWebSockets :: IO ()
      dropComponentWebSockets :: IO ()
dropComponentWebSockets =
        IORef WebSockets -> (WebSockets -> (WebSockets, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef WebSockets
websocketConnections ((WebSockets -> (WebSockets, ())) -> IO ())
-> (WebSockets -> (WebSockets, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WebSockets
websockets ->
          (Int -> WebSockets -> WebSockets
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
vcompId WebSockets
websockets, ())
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/WebSocket/close>
websocketClose :: WebSocket -> Effect context props model action
websocketClose :: forall context props model action.
WebSocket -> Effect context props model action
websocketClose WebSocket
socketId = do
  ComponentInfo {context
props
Int
JSVal
_componentInfoContext :: forall context props. ComponentInfo context props -> context
_componentInfoProps :: forall context props. ComponentInfo context props -> props
_componentInfoDOMRef :: forall context props. ComponentInfo context props -> JSVal
_componentInfoParentId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: Int
_componentInfoParentId :: Int
_componentInfoDOMRef :: JSVal
_componentInfoProps :: props
_componentInfoContext :: context
..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> Effect context props model action
forall context props model action.
IO () -> Effect context props model action
io_ (IO () -> Effect context props model action)
-> IO () -> Effect context props model action
forall a b. (a -> b) -> a -> b
$ do
    Maybe JSVal
result <-
      IORef WebSockets
-> (WebSockets -> (WebSockets, Maybe JSVal)) -> IO (Maybe JSVal)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef WebSockets
websocketConnections ((WebSockets -> (WebSockets, Maybe JSVal)) -> IO (Maybe JSVal))
-> (WebSockets -> (WebSockets, Maybe JSVal)) -> IO (Maybe JSVal)
forall a b. (a -> b) -> a -> b
$ \WebSockets
imap ->
        Int -> WebSocket -> WebSockets -> WebSockets
dropWebSocket Int
_componentInfoId WebSocket
socketId WebSockets
imap WebSockets -> Maybe JSVal -> (WebSockets, Maybe JSVal)
forall k v. k -> v -> (k, v)
=:
          Int -> WebSocket -> WebSockets -> Maybe JSVal
getWebSocket Int
_componentInfoId WebSocket
socketId WebSockets
imap
    case Maybe JSVal
result of
      Maybe JSVal
Nothing ->
        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just JSVal
socket ->
        JSVal -> IO ()
FFI.websocketClose JSVal
socket
  where
    dropWebSocket :: ComponentId -> WebSocket -> WebSockets -> WebSockets
    dropWebSocket :: Int -> WebSocket -> WebSockets -> WebSockets
dropWebSocket Int
vcompId (WebSocket Int
websocketId) WebSockets
websockets = do
      case Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId WebSockets
websockets of
        Maybe (IntMap JSVal)
Nothing ->
          WebSockets
websockets
        Just IntMap JSVal
componentSockets ->
          Int -> IntMap JSVal -> WebSockets -> WebSockets
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
vcompId (Int -> IntMap JSVal -> IntMap JSVal
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
websocketId IntMap JSVal
componentSockets) WebSockets
websockets
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/WebSocket/send>
websocketSend
  :: ToJSON value
  => WebSocket
  -> Payload value
  -> Effect context props model action
websocketSend :: forall value context props model action.
ToJSON value =>
WebSocket -> Payload value -> Effect context props model action
websocketSend WebSocket
socketId Payload value
msg = do
  ComponentInfo {context
props
Int
JSVal
_componentInfoContext :: forall context props. ComponentInfo context props -> context
_componentInfoProps :: forall context props. ComponentInfo context props -> props
_componentInfoDOMRef :: forall context props. ComponentInfo context props -> JSVal
_componentInfoParentId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: Int
_componentInfoParentId :: Int
_componentInfoDOMRef :: JSVal
_componentInfoProps :: props
_componentInfoContext :: context
..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> Effect context props model action
forall context props model action.
IO () -> Effect context props model action
io_ (IO () -> Effect context props model action)
-> IO () -> Effect context props model action
forall a b. (a -> b) -> a -> b
$ do
    Int -> WebSocket -> WebSockets -> Maybe JSVal
getWebSocket Int
_componentInfoId WebSocket
socketId (WebSockets -> Maybe JSVal) -> IO WebSockets -> IO (Maybe JSVal)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef WebSockets -> IO WebSockets
forall a. IORef a -> IO a
readIORef IORef WebSockets
websocketConnections IO (Maybe JSVal) -> (Maybe JSVal -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe JSVal
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just JSVal
socket ->
        case Payload value
msg of
          JSON value
json_ ->
            JSVal -> JSVal -> IO ()
FFI.websocketSend JSVal
socket (JSVal -> IO ()) -> IO JSVal -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (value -> MisoString
forall a. ToJSON a => a -> MisoString
encode value
json_)
          BUFFER ArrayBuffer
arrayBuffer_ -> do
            JSVal -> JSVal -> IO ()
FFI.websocketSend JSVal
socket (JSVal -> IO ()) -> IO JSVal -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ArrayBuffer -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal ArrayBuffer
arrayBuffer_
          TEXT MisoString
txt ->
            JSVal -> JSVal -> IO ()
FFI.websocketSend JSVal
socket (JSVal -> IO ()) -> IO JSVal -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal MisoString
txt
          BLOB Blob
blob_ ->
            JSVal -> JSVal -> IO ()
FFI.websocketSend JSVal
socket (JSVal -> IO ()) -> IO JSVal -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Blob -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal Blob
blob_
-----------------------------------------------------------------------------
-- | Retrieves current status of t'WebSocket'
--
-- If the t'WebSocket' identifier does not exist a 'CLOSED' is returned.
--
socketState :: WebSocket -> (SocketState -> action) -> Effect context props model action
socketState :: forall action context props model.
WebSocket
-> (SocketState -> action) -> Effect context props model action
socketState WebSocket
socketId SocketState -> action
callback = do
  ComponentInfo {context
props
Int
JSVal
_componentInfoContext :: forall context props. ComponentInfo context props -> context
_componentInfoProps :: forall context props. ComponentInfo context props -> props
_componentInfoDOMRef :: forall context props. ComponentInfo context props -> JSVal
_componentInfoParentId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: Int
_componentInfoParentId :: Int
_componentInfoDOMRef :: JSVal
_componentInfoProps :: props
_componentInfoContext :: context
..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  (Sink action -> IO ()) -> Effect context props model action
forall action context props model.
(Sink action -> IO ()) -> Effect context props model action
withSink ((Sink action -> IO ()) -> Effect context props model action)
-> (Sink action -> IO ()) -> Effect context props model action
forall a b. (a -> b) -> a -> b
$ \Sink action
sink -> do
     Int -> WebSocket -> WebSockets -> Maybe JSVal
getWebSocket Int
_componentInfoId WebSocket
socketId (WebSockets -> Maybe JSVal) -> IO WebSockets -> IO (Maybe JSVal)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef WebSockets -> IO WebSockets
forall a. IORef a -> IO a
readIORef IORef WebSockets
websocketConnections IO (Maybe JSVal) -> (Maybe JSVal -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just JSVal
socket -> do
        JSVal
x <- JSVal
socket JSVal -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! (MisoString
"socketState" :: MisoString)
        SocketState
socketstate <- Int -> SocketState
forall a. Enum a => Int -> a
toEnum (Int -> SocketState) -> IO Int -> IO SocketState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSVal -> IO Int
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked JSVal
x
        Sink action
sink (SocketState -> action
callback SocketState
socketstate)
      Maybe JSVal
Nothing ->
        Sink action
sink (SocketState -> action
callback SocketState
CLOSED)
-----------------------------------------------------------------------------
codeToCloseCode :: Int -> CloseCode
codeToCloseCode :: Int -> CloseCode
codeToCloseCode = \case
  Int
1000 -> CloseCode
CLOSE_NORMAL
  Int
1001 -> CloseCode
CLOSE_GOING_AWAY
  Int
1002 -> CloseCode
CLOSE_PROTOCOL_ERROR
  Int
1003 -> CloseCode
CLOSE_UNSUPPORTED
  Int
1005 -> CloseCode
CLOSE_NO_STATUS
  Int
1006 -> CloseCode
CLOSE_ABNORMAL
  Int
1007 -> CloseCode
Unsupported_Data
  Int
1008 -> CloseCode
Policy_Violation
  Int
1009 -> CloseCode
CLOSE_TOO_LARGE
  Int
1010 -> CloseCode
Missing_Extension
  Int
1011 -> CloseCode
Internal_Error
  Int
1012 -> CloseCode
Service_Restart
  Int
1013 -> CloseCode
Try_Again_Later
  Int
1015 -> CloseCode
TLS_Handshake
  Int
n    -> Int -> CloseCode
OtherCode Int
n
-----------------------------------------------------------------------------
-- | Closed message is sent when a t'WebSocket' has closed
data Closed
  = Closed
  { Closed -> CloseCode
closedCode :: CloseCode
    -- ^ The code used to indicate why a socket closed
  , Closed -> Bool
wasClean :: Bool
    -- ^ If the connection was closed cleanly, or forcefully.
  , Closed -> MisoString
reason :: MisoString
    -- ^ The reason for socket closure.
  } deriving (Closed -> Closed -> Bool
(Closed -> Closed -> Bool)
-> (Closed -> Closed -> Bool) -> Eq Closed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Closed -> Closed -> Bool
== :: Closed -> Closed -> Bool
$c/= :: Closed -> Closed -> Bool
/= :: Closed -> Closed -> Bool
Eq, Int -> Closed -> ShowS
[Closed] -> ShowS
Closed -> String
(Int -> Closed -> ShowS)
-> (Closed -> String) -> ([Closed] -> ShowS) -> Show Closed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Closed -> ShowS
showsPrec :: Int -> Closed -> ShowS
$cshow :: Closed -> String
show :: Closed -> String
$cshowList :: [Closed] -> ShowS
showList :: [Closed] -> ShowS
Show)
-----------------------------------------------------------------------------
instance FromJSVal Closed where
  fromJSVal :: JSVal -> IO (Maybe Closed)
fromJSVal JSVal
o = do
    Maybe CloseCode
closed_ <- (Int -> CloseCode) -> Maybe Int -> Maybe CloseCode
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> CloseCode
codeToCloseCode (Maybe Int -> Maybe CloseCode)
-> IO (Maybe Int) -> IO (Maybe CloseCode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do JSVal -> IO (Maybe Int)
forall a. FromJSVal a => JSVal -> IO (Maybe a)
fromJSVal (JSVal -> IO (Maybe Int)) -> IO JSVal -> IO (Maybe Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal
o JSVal -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! (MisoString
"code" :: MisoString)
    Maybe Bool
wasClean_ <- JSVal -> IO (Maybe Bool)
forall a. FromJSVal a => JSVal -> IO (Maybe a)
fromJSVal (JSVal -> IO (Maybe Bool)) -> IO JSVal -> IO (Maybe Bool)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal
o JSVal -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! (MisoString
"wasClean" :: MisoString)
    Maybe MisoString
reason_ <- JSVal -> IO (Maybe MisoString)
forall a. FromJSVal a => JSVal -> IO (Maybe a)
fromJSVal (JSVal -> IO (Maybe MisoString))
-> IO JSVal -> IO (Maybe MisoString)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal
o JSVal -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! (MisoString
"reason" :: MisoString)
    Maybe Closed -> IO (Maybe Closed)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CloseCode -> Bool -> MisoString -> Closed
Closed (CloseCode -> Bool -> MisoString -> Closed)
-> Maybe CloseCode -> Maybe (Bool -> MisoString -> Closed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CloseCode
closed_ Maybe (Bool -> MisoString -> Closed)
-> Maybe Bool -> Maybe (MisoString -> Closed)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Bool
wasClean_ Maybe (MisoString -> Closed) -> Maybe MisoString -> Maybe Closed
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe MisoString
reason_)
-----------------------------------------------------------------------------
-- | URL that the t'WebSocket' will @connect@ to
type URL = MisoString
-----------------------------------------------------------------------------
-- | 'SocketState' corresponding to current t'WebSocket' connection
data SocketState
  = CONNECTING -- ^ 0
  | OPEN       -- ^ 1
  | CLOSING    -- ^ 2
  | CLOSED     -- ^ 3
  deriving (Int -> SocketState -> ShowS
[SocketState] -> ShowS
SocketState -> String
(Int -> SocketState -> ShowS)
-> (SocketState -> String)
-> ([SocketState] -> ShowS)
-> Show SocketState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SocketState -> ShowS
showsPrec :: Int -> SocketState -> ShowS
$cshow :: SocketState -> String
show :: SocketState -> String
$cshowList :: [SocketState] -> ShowS
showList :: [SocketState] -> ShowS
Show, SocketState -> SocketState -> Bool
(SocketState -> SocketState -> Bool)
-> (SocketState -> SocketState -> Bool) -> Eq SocketState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SocketState -> SocketState -> Bool
== :: SocketState -> SocketState -> Bool
$c/= :: SocketState -> SocketState -> Bool
/= :: SocketState -> SocketState -> Bool
Eq, Eq SocketState
Eq SocketState =>
(SocketState -> SocketState -> Ordering)
-> (SocketState -> SocketState -> Bool)
-> (SocketState -> SocketState -> Bool)
-> (SocketState -> SocketState -> Bool)
-> (SocketState -> SocketState -> Bool)
-> (SocketState -> SocketState -> SocketState)
-> (SocketState -> SocketState -> SocketState)
-> Ord SocketState
SocketState -> SocketState -> Bool
SocketState -> SocketState -> Ordering
SocketState -> SocketState -> SocketState
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SocketState -> SocketState -> Ordering
compare :: SocketState -> SocketState -> Ordering
$c< :: SocketState -> SocketState -> Bool
< :: SocketState -> SocketState -> Bool
$c<= :: SocketState -> SocketState -> Bool
<= :: SocketState -> SocketState -> Bool
$c> :: SocketState -> SocketState -> Bool
> :: SocketState -> SocketState -> Bool
$c>= :: SocketState -> SocketState -> Bool
>= :: SocketState -> SocketState -> Bool
$cmax :: SocketState -> SocketState -> SocketState
max :: SocketState -> SocketState -> SocketState
$cmin :: SocketState -> SocketState -> SocketState
min :: SocketState -> SocketState -> SocketState
Ord, Int -> SocketState
SocketState -> Int
SocketState -> [SocketState]
SocketState -> SocketState
SocketState -> SocketState -> [SocketState]
SocketState -> SocketState -> SocketState -> [SocketState]
(SocketState -> SocketState)
-> (SocketState -> SocketState)
-> (Int -> SocketState)
-> (SocketState -> Int)
-> (SocketState -> [SocketState])
-> (SocketState -> SocketState -> [SocketState])
-> (SocketState -> SocketState -> [SocketState])
-> (SocketState -> SocketState -> SocketState -> [SocketState])
-> Enum SocketState
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: SocketState -> SocketState
succ :: SocketState -> SocketState
$cpred :: SocketState -> SocketState
pred :: SocketState -> SocketState
$ctoEnum :: Int -> SocketState
toEnum :: Int -> SocketState
$cfromEnum :: SocketState -> Int
fromEnum :: SocketState -> Int
$cenumFrom :: SocketState -> [SocketState]
enumFrom :: SocketState -> [SocketState]
$cenumFromThen :: SocketState -> SocketState -> [SocketState]
enumFromThen :: SocketState -> SocketState -> [SocketState]
$cenumFromTo :: SocketState -> SocketState -> [SocketState]
enumFromTo :: SocketState -> SocketState -> [SocketState]
$cenumFromThenTo :: SocketState -> SocketState -> SocketState -> [SocketState]
enumFromThenTo :: SocketState -> SocketState -> SocketState -> [SocketState]
Enum)
-----------------------------------------------------------------------------
-- | Code corresponding to a closed connection
-- https://developer.mozilla.org/en-US/docs/Web/API/CloseEvent
data CloseCode
  = CLOSE_NORMAL
   -- ^ 1000, Normal closure; the connection successfully completed whatever purpose for which it was created.
  | CLOSE_GOING_AWAY
   -- ^ 1001, The endpoint is going away, either because of a server failure or because the browser is navigating away from the page that opened the connection.
  | CLOSE_PROTOCOL_ERROR
   -- ^ 1002, The endpoint is terminating the connection due to a protocol error.
  | CLOSE_UNSUPPORTED
   -- ^ 1003, The connection is being terminated because the endpoint received data of a type it cannot accept (for example, a textonly endpoint received binary data).
  | CLOSE_NO_STATUS
   -- ^ 1005, Reserved.  Indicates that no status code was provided even though one was expected.
  | CLOSE_ABNORMAL
   -- ^ 1006, Reserved. Used to indicate that a connection was closed abnormally (that is, with no close frame being sent) when a status code is expected.
  | Unsupported_Data
   -- ^ 1007, The endpoint is terminating the connection because a message was received that contained inconsistent data (e.g., nonUTF8 data within a text message).
  | Policy_Violation
   -- ^ 1008, The endpoint is terminating the connection because it received a message that violates its policy. This is a generic status code, used when codes 1003 and 1009 are not suitable.
  | CLOSE_TOO_LARGE
   -- ^ 1009, The endpoint is terminating the connection because a data frame was received that is too large.
  | Missing_Extension
   -- ^ 1010, The client is terminating the connection because it expected the server to negotiate one or more extension, but the server didn't.
  | Internal_Error
   -- ^ 1011, The server is terminating the connection because it encountered an unexpected condition that prevented it from fulfilling the request.
  | Service_Restart
   -- ^ 1012, The server is terminating the connection because it is restarting.
  | Try_Again_Later
   -- ^ 1013, The server is terminating the connection due to a temporary condition, e.g. it is overloaded and is casting off some of its clients.
  | TLS_Handshake
   -- ^ 1015, Reserved. Indicates that the connection was closed due to a failure to perform a TLS handshake (e.g., the server certificate can't be verified).
  | OtherCode Int
   -- ^ OtherCode that is reserved and not in the range 0999
  deriving (Int -> CloseCode -> ShowS
[CloseCode] -> ShowS
CloseCode -> String
(Int -> CloseCode -> ShowS)
-> (CloseCode -> String)
-> ([CloseCode] -> ShowS)
-> Show CloseCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CloseCode -> ShowS
showsPrec :: Int -> CloseCode -> ShowS
$cshow :: CloseCode -> String
show :: CloseCode -> String
$cshowList :: [CloseCode] -> ShowS
showList :: [CloseCode] -> ShowS
Show, CloseCode -> CloseCode -> Bool
(CloseCode -> CloseCode -> Bool)
-> (CloseCode -> CloseCode -> Bool) -> Eq CloseCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CloseCode -> CloseCode -> Bool
== :: CloseCode -> CloseCode -> Bool
$c/= :: CloseCode -> CloseCode -> Bool
/= :: CloseCode -> CloseCode -> Bool
Eq)
-----------------------------------------------------------------------------
-- | Type for holding a t'WebSocket' file descriptor.
newtype WebSocket = WebSocket Int
  deriving stock WebSocket -> WebSocket -> Bool
(WebSocket -> WebSocket -> Bool)
-> (WebSocket -> WebSocket -> Bool) -> Eq WebSocket
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WebSocket -> WebSocket -> Bool
== :: WebSocket -> WebSocket -> Bool
$c/= :: WebSocket -> WebSocket -> Bool
/= :: WebSocket -> WebSocket -> Bool
Eq
  deriving newtype (WebSocket -> IO JSVal
(WebSocket -> IO JSVal) -> ToJSVal WebSocket
forall a. (a -> IO JSVal) -> ToJSVal a
$ctoJSVal :: WebSocket -> IO JSVal
toJSVal :: WebSocket -> IO JSVal
ToJSVal, Integer -> WebSocket
WebSocket -> WebSocket
WebSocket -> WebSocket -> WebSocket
(WebSocket -> WebSocket -> WebSocket)
-> (WebSocket -> WebSocket -> WebSocket)
-> (WebSocket -> WebSocket -> WebSocket)
-> (WebSocket -> WebSocket)
-> (WebSocket -> WebSocket)
-> (WebSocket -> WebSocket)
-> (Integer -> WebSocket)
-> Num WebSocket
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: WebSocket -> WebSocket -> WebSocket
+ :: WebSocket -> WebSocket -> WebSocket
$c- :: WebSocket -> WebSocket -> WebSocket
- :: WebSocket -> WebSocket -> WebSocket
$c* :: WebSocket -> WebSocket -> WebSocket
* :: WebSocket -> WebSocket -> WebSocket
$cnegate :: WebSocket -> WebSocket
negate :: WebSocket -> WebSocket
$cabs :: WebSocket -> WebSocket
abs :: WebSocket -> WebSocket
$csignum :: WebSocket -> WebSocket
signum :: WebSocket -> WebSocket
$cfromInteger :: Integer -> WebSocket
fromInteger :: Integer -> WebSocket
Num)
-----------------------------------------------------------------------------
-- | A null t'WebSocket' is one with a negative descriptor.
emptyWebSocket :: WebSocket
emptyWebSocket :: WebSocket
emptyWebSocket = -WebSocket
1
-----------------------------------------------------------------------------
-- | A type for holding an t'EventSource' descriptor.
newtype EventSource = EventSource Int
  deriving stock EventSource -> EventSource -> Bool
(EventSource -> EventSource -> Bool)
-> (EventSource -> EventSource -> Bool) -> Eq EventSource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EventSource -> EventSource -> Bool
== :: EventSource -> EventSource -> Bool
$c/= :: EventSource -> EventSource -> Bool
/= :: EventSource -> EventSource -> Bool
Eq
  deriving newtype (Integer -> EventSource
EventSource -> EventSource
EventSource -> EventSource -> EventSource
(EventSource -> EventSource -> EventSource)
-> (EventSource -> EventSource -> EventSource)
-> (EventSource -> EventSource -> EventSource)
-> (EventSource -> EventSource)
-> (EventSource -> EventSource)
-> (EventSource -> EventSource)
-> (Integer -> EventSource)
-> Num EventSource
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: EventSource -> EventSource -> EventSource
+ :: EventSource -> EventSource -> EventSource
$c- :: EventSource -> EventSource -> EventSource
- :: EventSource -> EventSource -> EventSource
$c* :: EventSource -> EventSource -> EventSource
* :: EventSource -> EventSource -> EventSource
$cnegate :: EventSource -> EventSource
negate :: EventSource -> EventSource
$cabs :: EventSource -> EventSource
abs :: EventSource -> EventSource
$csignum :: EventSource -> EventSource
signum :: EventSource -> EventSource
$cfromInteger :: Integer -> EventSource
fromInteger :: Integer -> EventSource
Num, EventSource -> IO JSVal
(EventSource -> IO JSVal) -> ToJSVal EventSource
forall a. (a -> IO JSVal) -> ToJSVal a
$ctoJSVal :: EventSource -> IO JSVal
toJSVal :: EventSource -> IO JSVal
ToJSVal)
-----------------------------------------------------------------------------
-- | A null t'EventSource' is one with a negative descriptor.
emptyEventSource :: EventSource
emptyEventSource :: EventSource
emptyEventSource = -EventSource
1
-----------------------------------------------------------------------------
eventSourceConnections :: IORef EventSources
{-# NOINLINE eventSourceConnections #-}
eventSourceConnections :: IORef WebSockets
eventSourceConnections = IO (IORef WebSockets) -> IORef WebSockets
forall a. IO a -> a
unsafePerformIO (WebSockets -> IO (IORef WebSockets)
forall a. a -> IO (IORef a)
newIORef WebSockets
forall a. IntMap a
IM.empty)
-----------------------------------------------------------------------------
eventSourceConnectionIds :: IORef Int
{-# NOINLINE eventSourceConnectionIds #-}
eventSourceConnectionIds :: IORef Int
eventSourceConnectionIds = IO (IORef Int) -> IORef Int
forall a. IO a -> a
unsafePerformIO (Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int))
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/EventSource/EventSource>
eventSourceConnectText
  :: URL
  -- ^ EventSource URL
  -> (EventSource -> action)
  -- ^ onOpen
  -> (MisoString -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect context props model action
eventSourceConnectText :: forall action context props model.
MisoString
-> (EventSource -> action)
-> (MisoString -> action)
-> (MisoString -> action)
-> Effect context props model action
eventSourceConnectText MisoString
url EventSource -> action
onOpen MisoString -> action
onMessage MisoString -> action
onError =
  (EventSource -> Sink action -> IO JSVal)
-> Effect context props model action
forall action context props model.
(EventSource -> Sink action -> IO JSVal)
-> Effect context props model action
eventSourceCore ((EventSource -> Sink action -> IO JSVal)
 -> Effect context props model action)
-> (EventSource -> Sink action -> IO JSVal)
-> Effect context props model action
forall a b. (a -> b) -> a -> b
$ \EventSource
eventSourceId Sink action
sink -> do
    MisoString
-> IO ()
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> (JSVal -> IO ())
-> Bool
-> IO JSVal
FFI.eventSourceConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ EventSource -> action
onOpen EventSource
eventSourceId)
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((JSVal -> IO ()) -> Maybe (JSVal -> IO ()))
-> (JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a b. (a -> b) -> a -> b
$ \JSVal
e -> do
          MisoString
txt <- JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked JSVal
e
          Sink action
sink (MisoString -> action
onMessage MisoString
txt))
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. MisoString -> action
onError (MisoString -> IO ()) -> (JSVal -> IO MisoString) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Bool
True
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/EventSource/EventSource>
eventSourceConnectJSON
  :: FromJSON json
  => URL
  -- ^ EventSource URL
  -> (EventSource -> action)
  -- ^ onOpen
  -> (json -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect context props model action
eventSourceConnectJSON :: forall json action context props model.
FromJSON json =>
MisoString
-> (EventSource -> action)
-> (json -> action)
-> (MisoString -> action)
-> Effect context props model action
eventSourceConnectJSON MisoString
url EventSource -> action
onOpen json -> action
onMessage MisoString -> action
onError =
  (EventSource -> Sink action -> IO JSVal)
-> Effect context props model action
forall action context props model.
(EventSource -> Sink action -> IO JSVal)
-> Effect context props model action
eventSourceCore ((EventSource -> Sink action -> IO JSVal)
 -> Effect context props model action)
-> (EventSource -> Sink action -> IO JSVal)
-> Effect context props model action
forall a b. (a -> b) -> a -> b
$ \EventSource
eventSourceId Sink action
sink -> do
    MisoString
-> IO ()
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> (JSVal -> IO ())
-> Bool
-> IO JSVal
FFI.eventSourceConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ EventSource -> action
onOpen EventSource
eventSourceId)
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((JSVal -> IO ()) -> Maybe (JSVal -> IO ()))
-> (JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a b. (a -> b) -> a -> b
$ \JSVal
e ->
         Value -> Result json
forall a. FromJSON a => Value -> Result a
fromJSON (Value -> Result json) -> IO Value -> IO (Result json)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSVal -> IO Value
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked JSVal
e IO (Result json) -> (Result json -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Error MisoString
errMsg -> Sink action
sink (MisoString -> action
onError (MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
ms MisoString
errMsg))
            Success json
json_ -> Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ json -> action
onMessage json
json_)
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. MisoString -> action
onError (MisoString -> IO ()) -> (JSVal -> IO MisoString) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Bool
False
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/EventSource/EventSource>
eventSourceCore
  :: (EventSource -> Sink action -> IO Socket)
  -> Effect context props model action
eventSourceCore :: forall action context props model.
(EventSource -> Sink action -> IO JSVal)
-> Effect context props model action
eventSourceCore EventSource -> Sink action -> IO JSVal
core = do
  ComponentInfo {context
props
Int
JSVal
_componentInfoContext :: forall context props. ComponentInfo context props -> context
_componentInfoProps :: forall context props. ComponentInfo context props -> props
_componentInfoDOMRef :: forall context props. ComponentInfo context props -> JSVal
_componentInfoParentId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: Int
_componentInfoParentId :: Int
_componentInfoDOMRef :: JSVal
_componentInfoProps :: props
_componentInfoContext :: context
..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  (Sink action -> IO ()) -> Effect context props model action
forall action context props model.
(Sink action -> IO ()) -> Effect context props model action
withSink ((Sink action -> IO ()) -> Effect context props model action)
-> (Sink action -> IO ()) -> Effect context props model action
forall a b. (a -> b) -> a -> b
$ \Sink action
sink -> do
    EventSource
eventSourceId <- IO EventSource
freshEventSource
    JSVal
socket <- EventSource -> Sink action -> IO JSVal
core EventSource
eventSourceId Sink action
sink
    Int -> EventSource -> JSVal -> IO ()
insertEventSource Int
_componentInfoId EventSource
eventSourceId JSVal
socket
  where
    insertEventSource :: ComponentId -> EventSource -> Socket -> IO ()
    insertEventSource :: Int -> EventSource -> JSVal -> IO ()
insertEventSource Int
componentId_ (EventSource Int
socketId) JSVal
socket =
      IORef WebSockets -> (WebSockets -> (WebSockets, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef WebSockets
eventSourceConnections ((WebSockets -> (WebSockets, ())) -> IO ())
-> (WebSockets -> (WebSockets, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WebSockets
eventSources ->
        (WebSockets -> WebSockets
update WebSockets
eventSources, ())
      where
        update :: WebSockets -> WebSockets
update WebSockets
eventSources =
          (IntMap JSVal -> IntMap JSVal -> IntMap JSVal)
-> WebSockets -> WebSockets -> WebSockets
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith IntMap JSVal -> IntMap JSVal -> IntMap JSVal
forall a. IntMap a -> IntMap a -> IntMap a
IM.union WebSockets
eventSources
            (WebSockets -> WebSockets) -> WebSockets -> WebSockets
forall a b. (a -> b) -> a -> b
$ Int -> IntMap JSVal -> WebSockets
forall a. Int -> a -> IntMap a
IM.singleton Int
componentId_
            (IntMap JSVal -> WebSockets) -> IntMap JSVal -> WebSockets
forall a b. (a -> b) -> a -> b
$ Int -> JSVal -> IntMap JSVal
forall a. Int -> a -> IntMap a
IM.singleton Int
socketId JSVal
socket

    freshEventSource :: IO EventSource
    freshEventSource :: IO EventSource
freshEventSource = Int -> EventSource
EventSource (Int -> EventSource) -> IO Int -> IO EventSource
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
eventSourceConnectionIds (\Int
x -> (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
x))
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/EventSource/close>
eventSourceClose :: EventSource -> Effect context props model action
eventSourceClose :: forall context props model action.
EventSource -> Effect context props model action
eventSourceClose EventSource
socketId = do
  ComponentInfo {context
props
Int
JSVal
_componentInfoContext :: forall context props. ComponentInfo context props -> context
_componentInfoProps :: forall context props. ComponentInfo context props -> props
_componentInfoDOMRef :: forall context props. ComponentInfo context props -> JSVal
_componentInfoParentId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: forall context props. ComponentInfo context props -> Int
_componentInfoId :: Int
_componentInfoParentId :: Int
_componentInfoDOMRef :: JSVal
_componentInfoProps :: props
_componentInfoContext :: context
..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> Effect context props model action
forall context props model action.
IO () -> Effect context props model action
io_ (IO () -> Effect context props model action)
-> IO () -> Effect context props model action
forall a b. (a -> b) -> a -> b
$ do
    Maybe JSVal
result <-
      IORef WebSockets
-> (WebSockets -> (WebSockets, Maybe JSVal)) -> IO (Maybe JSVal)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef WebSockets
eventSourceConnections ((WebSockets -> (WebSockets, Maybe JSVal)) -> IO (Maybe JSVal))
-> (WebSockets -> (WebSockets, Maybe JSVal)) -> IO (Maybe JSVal)
forall a b. (a -> b) -> a -> b
$ \WebSockets
imap ->
        Int -> EventSource -> WebSockets -> WebSockets
dropEventSource Int
_componentInfoId EventSource
socketId WebSockets
imap WebSockets -> Maybe JSVal -> (WebSockets, Maybe JSVal)
forall k v. k -> v -> (k, v)
=:
          Int -> EventSource -> WebSockets -> Maybe JSVal
getEventSource Int
_componentInfoId EventSource
socketId WebSockets
imap
    case Maybe JSVal
result of
      Maybe JSVal
Nothing ->
        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just JSVal
socket ->
        JSVal -> IO ()
FFI.eventSourceClose JSVal
socket
  where
    dropEventSource :: ComponentId -> EventSource -> EventSources -> EventSources
    dropEventSource :: Int -> EventSource -> WebSockets -> WebSockets
dropEventSource Int
vcompId (EventSource Int
eventSourceId) WebSockets
eventSources = do
      case Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId WebSockets
eventSources of
        Maybe (IntMap JSVal)
Nothing ->
          WebSockets
eventSources
        Just IntMap JSVal
componentSockets ->
          Int -> IntMap JSVal -> WebSockets -> WebSockets
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
vcompId (Int -> IntMap JSVal -> IntMap JSVal
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
eventSourceId IntMap JSVal
componentSockets) WebSockets
eventSources

    getEventSource :: ComponentId -> EventSource -> EventSources -> Maybe Socket
    getEventSource :: Int -> EventSource -> WebSockets -> Maybe JSVal
getEventSource Int
vcompId (EventSource Int
eventSourceId) =
      Int -> IntMap JSVal -> Maybe JSVal
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
eventSourceId (IntMap JSVal -> Maybe JSVal)
-> (WebSockets -> Maybe (IntMap JSVal))
-> WebSockets
-> Maybe JSVal
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId
-----------------------------------------------------------------------------
finalizeEventSources :: ComponentId -> IO ()
finalizeEventSources :: Int -> IO ()
finalizeEventSources Int
vcompId = do
  (IntMap JSVal -> IO ()) -> Maybe (IntMap JSVal) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((JSVal -> IO ()) -> [JSVal] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ JSVal -> IO ()
FFI.eventSourceClose ([JSVal] -> IO ())
-> (IntMap JSVal -> [JSVal]) -> IntMap JSVal -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IntMap JSVal -> [JSVal]
forall a. IntMap a -> [a]
IM.elems) (Maybe (IntMap JSVal) -> IO ())
-> (WebSockets -> Maybe (IntMap JSVal)) -> WebSockets -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
    Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (WebSockets -> IO ()) -> IO WebSockets -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef WebSockets -> IO WebSockets
forall a. IORef a -> IO a
readIORef IORef WebSockets
eventSourceConnections
  IO ()
dropComponentEventSources
    where
      dropComponentEventSources :: IO ()
      dropComponentEventSources :: IO ()
dropComponentEventSources =
        IORef WebSockets -> (WebSockets -> (WebSockets, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef WebSockets
eventSourceConnections ((WebSockets -> (WebSockets, ())) -> IO ())
-> (WebSockets -> (WebSockets, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WebSockets
eventSources ->
          (Int -> WebSockets -> WebSockets
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
vcompId WebSockets
eventSources, ())
-----------------------------------------------------------------------------
-- | Payload is used as the potential source of data when working with t'EventSource'
data Payload value
  = JSON value
  -- ^ JSON-encoded data
  | BLOB Blob
  -- ^ Binary encoded data
  | TEXT MisoString
  -- ^ Text encoded data
  | BUFFER ArrayBuffer
  -- ^ Buffered data
-----------------------------------------------------------------------------
-- | Smart constructor for sending JSON encoded data via an t'EventSource'
json :: ToJSON value => value -> Payload value
json :: forall value. ToJSON value => value -> Payload value
json = value -> Payload value
forall value. value -> Payload value
JSON
-----------------------------------------------------------------------------
-- | Smart constructor for sending binary encoded data via an t'EventSource'
blob :: Blob -> Payload value
blob :: forall value. Blob -> Payload value
blob = Blob -> Payload value
forall value. Blob -> Payload value
BLOB
-----------------------------------------------------------------------------
-- | Smart constructor for sending an @ArrayBuffer@ via an t'EventSource'
arrayBuffer :: ArrayBuffer -> Payload value
arrayBuffer :: forall value. ArrayBuffer -> Payload value
arrayBuffer = ArrayBuffer -> Payload value
forall value. ArrayBuffer -> Payload value
BUFFER
-----------------------------------------------------------------------------
#ifdef WASM
loadedJS :: IORef Bool
{-# NOINLINE loadedJS #-}
loadedJS = unsafePerformIO (newIORef False)
#endif
-----------------------------------------------------------------------------
initComponent
#ifdef NATIVE
  :: forall context props model action . (Eq context, Eq model, Eq props, ToJSON model, ToJSON props, ToJSON action, FromJSON action)
#else
  :: forall context props model action . (Eq context, Eq model, Eq props)
#endif
  => Events
  -> Hydrate
  -> Bool
  -> context
  -- ^ Initial global @context@
  -> Component context props model action
  -> Maybe Key
  -> props
  -> Maybe StaticKey
  -> IO ()
initComponent :: forall context props model action.
(Eq context, Eq model, Eq props) =>
Events
-> Hydrate
-> Bool
-> context
-> Component context props model action
-> Maybe Key
-> props
-> Maybe StaticKey
-> IO ()
initComponent Events
events Hydrate
hydrate Bool
live context
initialContext comp_ :: Component context props model action
comp_@Component {model
Bool
[JS]
[CSS]
[Sub model action]
Maybe action
Maybe (IO model)
Maybe MisoString
Maybe (props -> props -> action)
LogLevel
model -> View context props model action
action -> Effect context props model action
Value -> Maybe action
onPropsChanged :: forall context props model action.
Component context props model action
-> Maybe (props -> props -> action)
unmount :: forall context props model action.
Component context props model action -> Maybe action
mount :: forall context props model action.
Component context props model action -> Maybe action
eventPropagation :: forall context props model action.
Component context props model action -> Bool
mailbox :: forall context props model action.
Component context props model action -> Value -> Maybe action
logLevel :: forall context props model action.
Component context props model action -> LogLevel
mountPoint :: forall context props model action.
Component context props model action -> Maybe MisoString
scripts :: forall context props model action.
Component context props model action -> [JS]
styles :: forall context props model action.
Component context props model action -> [CSS]
subs :: forall context props model action.
Component context props model action -> [Sub model action]
useContext :: forall context props model action.
Component context props model action -> Bool
view :: forall context props model action.
Component context props model action
-> model -> View context props model action
update :: forall context props model action.
Component context props model action
-> action -> Effect context props model action
hydrateModel :: forall context props model action.
Component context props model action -> Maybe (IO model)
model :: forall context props model action.
Component context props model action -> model
model :: model
hydrateModel :: Maybe (IO model)
update :: action -> Effect context props model action
view :: model -> View context props model action
useContext :: Bool
subs :: [Sub model action]
styles :: [CSS]
scripts :: [JS]
mountPoint :: Maybe MisoString
logLevel :: LogLevel
mailbox :: Value -> Maybe action
eventPropagation :: Bool
mount :: Maybe action
unmount :: Maybe action
onPropsChanged :: Maybe (props -> props -> action)
..} Maybe Key
key props
props Maybe StaticKey
sk = do
#ifdef WASM
      $(evalFile MISO_JS_PATH)
      atomicWriteIORef loadedJS True
#endif
      IO () -> IO ()
forall a. IO a -> IO a
withJS (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let proxy :: Proxy context
proxy = Proxy context
forall {k} (t :: k). Proxy t
Proxy :: Proxy context
        -- The one @context@ cell for this app, created before anything that
        -- needs it. Every component mounted below shares this reference, and
        -- on Lynx so does the MTS wire listener, so there is a single value to
        -- read and write and nothing has to go looking for it.
        IORef context
contextRef <- context -> IO (IORef context)
forall a. a -> IO (IORef a)
newIORef context
initialContext
#ifdef NATIVE
        when bts $ do
          effectListener proxy =<< getMTSContext
          readyAckListener =<< getMTSContext
          void $ forkIO (sendReadyUntilAcked sk)
        when mts $ do
          effectListener proxy =<< getBTSContext
          componentListener contextRef live =<< getBTSContext
          registerMainThreadDispatch
#endif
        JSVal
root <- MisoString -> IO JSVal
Diff.mountElement (Maybe MisoString -> MisoString
getMountPoint Maybe MisoString
mountPoint)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
web (Proxy context -> Bool -> JSVal -> IO ()
forall context.
Eq context =>
Proxy context -> Bool -> JSVal -> IO ()
cleanup Proxy context
proxy Bool
live JSVal
root)
        -- dmj: top-level Component always responsive to Context changes
        let comp_' :: Component context props model action
comp_' = Component context props model action
comp_ { useContext = True }
        IO (ComponentState context props model action) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ComponentState context props model action) -> IO ())
-> IO (ComponentState context props model action) -> IO ()
forall a b. (a -> b) -> a -> b
$ Events
-> Int
-> Hydrate
-> Bool
-> Bool
-> IORef context
-> props
-> Maybe Key
-> Maybe StaticKey
-> Component context props model action
-> IO JSVal
-> IO (ComponentState context props model action)
forall context model props action.
(Eq context, Eq model, Eq props) =>
Events
-> Int
-> Hydrate
-> Bool
-> Bool
-> IORef context
-> props
-> Maybe Key
-> Maybe StaticKey
-> Component context props model action
-> IO JSVal
-> IO (ComponentState context props model action)
initialize Events
events Int
rootComponentId Hydrate
hydrate Bool
True Bool
live IORef context
contextRef props
props Maybe Key
key Maybe StaticKey
sk Component context props model action
comp_' (JSVal -> IO JSVal
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSVal
root)
#ifdef NATIVE
        -- The root mount (root + every nested component drawn synchronously above)
        -- is now complete on this thread, so clear the global 'initialDraw' latch
        -- exactly ONCE. This flips the drawing contexts out of initial-frame mode:
        -- the MTS stops self-assigning nodeIds (later nodes arrive via update
        -- patches carrying their id) and the BTS stops suppressing patch emission
        -- and starts shipping updates. Doing this here — rather than inside the
        -- contexts' 'flush' — is the fix for the doubled render: the initial draw
        -- performs one 'flush' per mounted component, so a per-'flush' flip tripped
        -- on the first nested child and leaked the rest of the frame as patches.
        do gt <- jsg ("globalThis" :: MisoString)
           FFI.set "initialDraw" False (Object gt)
#endif
        IORef ThreadId -> ThreadId -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef ThreadId
schedulerThread (ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO () -> IO ThreadId
forkIO (Proxy context -> IO ()
forall context. Eq context => Proxy context -> IO ()
scheduler Proxy context
proxy)
----------------------------------------------------------------------------
#ifdef NATIVE
-- | Used for bidirectional cross-thread communication.
effectListener :: forall context jsval . (Eq context, ToJSVal jsval) => Proxy context -> jsval -> IO ()
effectListener Proxy jsval = void $ do
  ctx <- toJSVal jsval
  FFI.addEventListener ctx "Miso.effects" $ \msgEvent ->
    flip catch (\(e :: SomeException) ->
        FFI.consoleError ("[effectListener]: exception in callback: " <> ms (show e))) $ do
      msg <- Object msgEvent ! "data"
      EFFECT {..} <- fromJSValUnchecked msg :: IO EFFECT
      case effectStaticKey of
        Nothing -> FFI.consoleError "[effectListener]: must use 'static' keyword when mounting Component w/ native"
        Just key_ -> do
          unsafeLookupStaticPtr key_ >>= \case
            Nothing ->
              FFI.consoleError "[effectListener]: staticPtr NOT found for effectStaticKey"
            Just ptr ->
              -- The t'SomeStaticComponent' carries the child's dictionaries, so the
              -- @action@ type (and its 'FromJSON') is in scope from the key alone.
              case deRefStaticPtr ptr of
                SomeStaticComponent (_ :: Component context props model action) ->
                  case fromJSON effectAction :: Result action of
                    Success action -> do
                      comps <- readIORef components
                      case IM.lookup effectComponentId comps of
                        Nothing ->
                          FFI.consoleError $ ms $
                            "[effectListener]: ComponentId NOT registered:" <> ms effectComponentId
                        Just _ -> do
                          FFI.consoleLog "[effectListener]: Sinking action into Component"
                          -- dmj: enqueue the cross-thread action onto the ordinary
                          -- 'globalQueue' rather than replaying @update@ inline here.
                          -- This keeps the scheduler the sole writer of every model
                          -- (no read-modify-write race with the scheduler's own
                          -- 'commit') and preserves ordering relative to any actions
                          -- already queued for this component. The action's @update@
                          -- runs only on this thread; it does not ping-pong back
                          -- because only an explicit 'CrossThread' effect crosses.
                          atomicModifyIORef' globalQueue $ \q ->
                            (enqueue effectComponentId action q, ())
                          notify globalWaiter
                    Error e ->
                      FFI.consoleError ("[effectListener]: action decode error: " <> ms e)
#endif
----------------------------------------------------------------------------
#ifdef NATIVE
-- | BTS -> MTS 'READY' dispatch is fire-and-forget over an async cross-thread
-- transport, and BTS's bootstrap (which sends 'READY') and MTS's bootstrap
-- (which registers the listener that receives it) run on independently
-- scheduled threads with no ordering guarantee between them — a genuine race
-- where 'READY' can arrive before anything on MTS is listening, in which case
-- it is lost for good (no re-delivery to a listener that registers later).
-- Since MTS's scheduler blocks on 'wait btsReady' until 'READY' arrives, a
-- lost message hangs the MTS scheduler forever.
--
-- Retried here on a short interval, capped, until MTS's 'READY_ACK' (sent
-- from 'componentListener'\'s 'READY' case) sets 'readyAcked' — so the common
-- case, where MTS's listener is already up, costs one round-trip and stops,
-- not the full retry budget. Runs on its own forked thread so it never
-- blocks 'initComponent'\'s own startup, and that thread exits as soon as
-- acked rather than lingering for the whole retry window.
sendReadyUntilAcked :: Maybe StaticKey -> IO ()
sendReadyUntilAcked sk = go (0 :: Int)
  where
    maxAttempts = 20    -- ~1s of retrying at 50ms intervals
    intervalMicros = 50000
    go attempts = do
      postComponent READY sk topLevelComponentId rootComponentId Nothing Nothing
      threadDelay intervalMicros
      acked <- readIORef readyAcked -- BTS-side flag, set by 'readyAckListener'
      if acked
        then pure ()
        else if attempts < maxAttempts
          then go (attempts + 1)
          -- Budget exhausted without an ack. Under the current boot profile this
          -- should never happen (MTS registers its listener well under the ~1s
          -- window), so treat it as a diagnosable fault rather than a silent
          -- hang: the MTS scheduler is now blocked on 'wait btsReady' forever
          -- with no re-delivery. Surface it so a boot regression (larger bundle,
          -- slower device) is obvious in the log instead of a mystery freeze.
          else FFI.consoleError $ ms $
            "[sendReadyUntilAcked]: MTS never acked READY after "
              <> ms (show maxAttempts) <> " attempts (~1s); MTS scheduler is "
              <> "likely blocked on 'wait btsReady'. MTS boot exceeded the retry budget."
-----------------------------------------------------------------------------
-- | Registered on BTS to receive MTS's 'READY_ACK'. The only message BTS
-- ever receives via the 'postComponent' \/ 'componentListener' machinery,
-- since that protocol is otherwise BTS -> MTS only; every other
-- 'ComponentType' is ignored here.
readyAckListener :: MTS -> IO ()
readyAckListener (MTS ctx) = void $ do
  FFI.addEventListener ctx "Miso.components" $ \msgEvent -> do
    msg <- Object msgEvent ! "data"
    COMPONENT {..} <- fromJSValUnchecked msg :: IO COMPONENT
    case componentComponentType of
      READY_ACK -> atomicWriteIORef readyAcked True
      _ -> pure ()
#endif
----------------------------------------------------------------------------
-- | Used for unidirectional BTS -> MTS communication
--
-- dmj: This only runs on the MTS.
--
#ifdef NATIVE
-- | Resolves a BTS-supplied @{ nodeId }@ @DOMRef@ to the live MTS element
-- registered at @globalThis.runtime.nodes[nodeId]@ (see @ts/miso/native/mts.ts@).
resolveNodeRef :: DOMRef -> IO DOMRef
resolveNodeRef domRef = do
  nodeId <- fromJSValUnchecked =<< domRef ! "nodeId" :: IO Int
  nodes  <- jsg "runtime" >>= (! "nodes")
  nodes ! ms nodeId
-----------------------------------------------------------------------------
componentListener :: forall context . Eq context => IORef context -> Bool -> BTS -> IO ()
componentListener contextRef live (BTS ctx) = void $ do
  FFI.addEventListener ctx "Miso.components" $ \msgEvent ->
    flip catch (\(e :: SomeException) ->
        FFI.consoleError ("[componentListener]: exception in callback: " <> ms (show e))) $ do
    msg <- Object msgEvent ! "data"
    COMPONENT {..} <- fromJSValUnchecked msg :: IO COMPONENT
    case componentComponentStaticKey of
      Nothing -> FFI.consoleError "[COMPONENT]: must use 'static' keyword for Component mounting"
      Just key_ ->
        -- 'READY' never needs the 'StaticPtr' and must be handled BEFORE the
        -- lookup: it only unblocks the MTS scheduler and rides no component
        -- 'StaticKey', so it can't (and mustn't) do the deref the other
        -- messages require.
        case componentComponentType of
          READY -> do
            -- dmj: BTS retries 'READY' until acked (see 'sendReadyUntilAcked'),
            -- so this can fire more than once. Guard 'notify' — a second
            -- 'putMVar' on the already-full 'oneshot' 'btsReady' would block
            -- this listener callback forever instead of being a no-op — and
            -- always ack in response, even on a repeat, since BTS can't know
            -- whether an earlier ack of ours reached it.
            already <- atomicModifyIORef' readyReceived (\r -> (True, r)) -- MTS-side flag
            unless already (notify btsReady) -- dmj: unblocks main thread scheduler
            dispatchEvent ctx "Miso.components"
              (COMPONENT READY_ACK Nothing minBound minBound Nothing Nothing)
          _ ->
            unsafeLookupStaticPtr key_ >>= \case
              Nothing ->
                FFI.consoleError "[COMPONENT]: staticPtr NOT found for componentStaticKey"
              Just ptr ->
                case deRefStaticPtr ptr of
                  SomeStaticComponent (comp_ :: Component context props model action) ->
                    case componentComponentType of
                      MOUNT ->
                        -- The MTS paints the initial frame itself, so any child that is part
                        -- of that frame is already mounted+registered here by the root
                        -- 'initialDraw' (nodeIds in lockstep with the BTS, so updates land on
                        -- it). The BTS still posts @MOUNT@ for every non-root child; re-running
                        -- 'initialize' for one we already have would paint a SECOND, orphaned
                        -- copy — the doubled 'vcomp'. So mount only children we don't yet know:
                        -- that is exactly the components created later, during a BTS update,
                        -- which the MTS learns about solely through this message.
                        IM.member componentComponentId <$> readIORef components >>= \case
                          True -> pure ()
                          False ->
                            -- The BTS always ships its @{ nodeId }@ @DOMRef@ alongside @MOUNT@
                            -- (see 'postComponent' MOUNT); 'Nothing' here means the wire
                            -- invariant broke, so error out rather than silently mounting
                            -- against a bogus synthesized parent.
                            case componentComponentDOMRef of
                              Nothing ->
                                FFI.consoleError "[COMPONENT]: MOUNT missing domRef payload"
                              Just domRef -> do
                                -- Resolve the shipped @DOMRef@ to the real native element via
                                -- @globalThis.runtime.nodes[nodeId]@ so the MTS t'ComponentInfo'
                                -- Reader ('componentInfoDOMRef') holds a live ref.
                                parent_ <- resolveNodeRef domRef
                                -- Recover the child's initial @props@ from the wire (the BTS ships
                                -- them on @MOUNT@), decoded at the @props@ type recovered above.
                                case componentComponentPayload of
                                  Just pv | Success initProps <- (fromJSON pv :: Result props) ->
                                    -- 'contextRef' is this thread's own @context@ cell, closed
                                    -- over from 'initComponent'. Nothing is looked up: the cell
                                    -- exists before this listener is installed, and the mirror
                                    -- component shares it exactly as a locally built one does.
                                    --
                                    -- This is also why the parent is not consulted. 'postComponent'
                                    -- MOUNT fires at the end of 'initialize', after 'initialDraw'
                                    -- has built the children, so a nested subtree posts the child's
                                    -- MOUNT ahead of its parent's and the parent is routinely not
                                    -- here yet.
                                    void $ initialize mempty componentComponentId Draw False live contextRef initProps
                                      Nothing (Just (staticKey ptr)) comp_ (pure parent_)
                                  _ ->
                                    FFI.consoleError "[COMPONENT]: MOUNT missing/invalid props payload"
                      UNMOUNT ->
                        IM.lookup componentComponentId <$> readIORef components >>= \case
                          Nothing ->
                            FFI.consoleError $ "[COMPONENT]: Couldn't find Component to unmount " <>
                              ms (show componentComponentId)
                          Just c -> unmountComponent @context c
                      MODEL_HYDRATE -> do
                        case componentComponentPayload of
                          Nothing ->
                            FFI.consoleError "[COMPONENT]: No model to hydrate"
                          Just m ->
                            case fromJSON m :: Result model of
                              Success newModel ->
                                modifyComponent componentComponentId $ do
                                  componentModel .= newModel
                              Error e ->
                                FFI.consoleError ("[COMPONENT]: Could not decode model: " <> e)
                      -- 'READY' handled above (no deref), so GHC's long-distance
                      -- info knows it can't reach here — no catch-all needed.
                      -- 'READY_ACK' flows MTS -> BTS only (see 'readyAckListener');
                      -- 'componentListener' only runs on MTS, so this never
                      -- actually fires — kept as a no-op so the match stays total.
                      READY_ACK -> pure ()
#endif
----------------------------------------------------------------------------
-- | Dispatch a main-thread ('MTS') event on the Haskell layer.
--
-- Invoked synchronously by the MTS delegator (see @ts\/miso\/native\/mts\/context.ts@)
-- with a @{ componentId, staticKey, event, target }@ object. Recovers the event
-- handler by its 'StaticKey', runs it against the owning component's 'Sink' to
-- install its decode+dispatch closure on a scratch node, then invokes that
-- closure with the live event and target @DOMRef@. No BTS round-trip — the
-- handler runs entirely on the main thread, and its @update@\/effects run there
-- (the scheduler suppresses the redraw; see 'scheduler').
--
-- N.B. 'unsafeLookupStaticPtr' recovers the handler at the component's @action@
-- type. This is sound because the @(componentId, staticKey)@ pair is emitted
-- together from the same component's 'setAttrs'; the handler's @action@ unifies
-- with the sink's via the quantified 'components' CAF (no @unsafeCoerce@).
#ifdef NATIVE
dispatchMainThreadEvent :: JSVal -> IO ()
dispatchMainThreadEvent arg =
  flip catch (\(e :: SomeException) ->
      FFI.consoleError ("[MTS dispatch] exception: " <> ms (show e))) $ do
    let o = Object arg
    compId    <- fromJSValUnchecked =<< o ! "componentId" :: IO ComponentId
    skHex     <- fromJSValUnchecked =<< o ! "staticKey"   :: IO MisoString
    eventVal  <- o ! "event"
    targetVal <- o ! "target"
    unsafeLookupStaticPtr (fromMisoString skHex) >>= \case
      Nothing ->
        FFI.consoleError ("[MTS dispatch] no handler for staticKey " <> skHex)
      -- Fully-applied 'On' handlers resolve to a runnable t'EventHandler', so the
      -- MTS rebuilds them from the 'StaticKey' alone. An 'OnWith' handler's key
      -- resolves to a @payload -> EventHandler@ constructor; running it on the
      -- MTS additionally requires the forwarded @pendingPayload@ decoded at the
      -- @payload@ type — see note below (not yet wired end-to-end).
      Just ehPtr -> case deRefStaticPtr ehPtr of
        EventHandler {..} -> do
          comps <- readIORef components
          case IM.lookup compId comps of
            Nothing ->
              FFI.consoleError ("[MTS dispatch] no component " <> ms (show compId))
            Just ComponentState {..} -> do
              -- Decode + dispatch directly from the captured t'Decoder' \/
              -- convert pair — no JS installer round-trip (no scratch node,
              -- no throwaway 'asyncCallback2') needed on this, the hot path
              -- for every main-thread event.
              decodeAtVal <- toJSVal (decodeAt eventHandlerDecoder)
              mv <- fromJSVal =<< FFI.eventJSON decodeAtVal eventVal
              case mv of
                Nothing ->
                  FFI.consoleError "[MTS dispatch] eventJSON returned no value"
                Just v -> case parseEither (decoder eventHandlerDecoder) v of
                  Left msg ->
                    FFI.consoleError ("[MTS dispatch] decode error: " <> ms msg)
                  Right result ->
                    _componentSink (eventHandlerConvert result _componentModel targetVal)
-----------------------------------------------------------------------------
-- | Register 'dispatchMainThreadEvent' on @globalThis.runtime@ so the MTS
-- delegator can invoke it synchronously. MTS only.
registerMainThreadDispatch :: IO ()
registerMainThreadDispatch = do
  cb <- FFI.syncCallback1 dispatchMainThreadEvent
  runtimeObj <- jsg "runtime"
  FFI.set "dispatchMainThreadEvent" cb (Object runtimeObj)
#endif
----------------------------------------------------------------------------
-- | Dispatches a t'COMPONENT' lifecycle message (BTS → MTS) on the
-- @\"Miso.components\"@ channel. No-op for components without a 'StaticKey'
-- (e.g. the root), since the MTS locates the component via 'unsafeLookupStaticPtr'.
#ifdef NATIVE
postComponent
  :: ComponentType
  -> Maybe StaticKey
  -> ComponentId
  -> ComponentId
  -> Maybe Value
  -> Maybe DOMRef
  -> IO ()
postComponent _ Nothing _ _ _ _ = pure ()
postComponent componentType_ sk@(Just _) componentId_ parentId_ model_ domRef_ = do
  ctx <- getMTSContext
  dispatchEvent ctx "Miso.components"
    (COMPONENT componentType_ sk componentId_ parentId_ model_ domRef_)
#endif
----------------------------------------------------------------------------
-- | Dispatches an t'EFFECT' message carrying a serialized @action@ across the
-- Lynx thread boundary on the @\"Miso.effects\"@ channel:
--
--   * MTS → BTS when called on the main thread ('mts').
--   * BTS → MTS when called on the background thread ('bts').
--
-- A no-op on plain web builds (neither 'mts' nor 'bts').
#ifdef NATIVE
postEffect :: Maybe StaticKey -> ComponentId -> Value -> IO ()
postEffect sk componentId_ action_ = do
  when mts $ do
    ctx <- getBTSContext
    dispatchEvent ctx "Miso.effects" (EFFECT componentId_ action_ sk)
  when bts $ do
    ctx <- getMTSContext
    dispatchEvent ctx "Miso.effects" (EFFECT componentId_ action_ sk)
#endif
----------------------------------------------------------------------------
-- | Global variable to hold the scheduler thread
--
-- N.B. 'undefined' is safe here, it will always get populated.
-- Also, we use this in @cleanup@ when interactive mode (GHCi) is detected
-- in that circumstance 'schedulerThread' will always be populated. It's an
-- invariant.
--
schedulerThread :: IORef ThreadId
{-# NOINLINE schedulerThread #-}
schedulerThread :: IORef ThreadId
schedulerThread = IO (IORef ThreadId) -> IORef ThreadId
forall a. IO a -> a
unsafePerformIO (ThreadId -> IO (IORef ThreadId)
forall a. a -> IO (IORef a)
newIORef ThreadId
forall a. HasCallStack => a
undefined)
----------------------------------------------------------------------------
-- | Whether this JS execution context is the Lynx main thread, background
-- thread, or a plain web build.
--
-- N.B. this is invariant for the lifetime of a given JS context, so it's
-- safe to compute once and cache via 'unsafePerformIO' rather than making
-- an FFI call on every component initialization.
--
mts, bts, web :: Bool
{-# NOINLINE mts #-}
{-# NOINLINE bts #-}
{-# NOINLINE web #-}
(Bool
mts, Bool
bts, Bool
web) = IO (Bool, Bool, Bool) -> (Bool, Bool, Bool)
forall a. IO a -> a
unsafePerformIO IO (Bool, Bool, Bool)
FFI.getThreads
-----------------------------------------------------------------------------
-- | 'True' when a 'CrossThread' effect targets the /opposite/ Lynx thread and
-- must therefore be forwarded (via 'postEffect') rather than dispatched locally.
-- @False@ when the target is the current thread, or on a plain web build (where
-- there is a single thread), so the action is handled here.
crossThread :: E.Thread -> Bool
crossThread :: Thread -> Bool
crossThread = \case
  Thread
E.BTS -> Bool
mts   -- want BTS, currently on MTS
  Thread
E.MTS -> Bool
bts   -- want MTS, currently on BTS
-----------------------------------------------------------------------------
instance FromJSVal Fingerprint where
  fromJSVal :: JSVal -> IO (Maybe StaticKey)
fromJSVal JSVal
x = (Maybe MisoString -> Maybe StaticKey)
-> IO (Maybe MisoString) -> IO (Maybe StaticKey)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((MisoString -> StaticKey) -> Maybe MisoString -> Maybe StaticKey
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MisoString -> StaticKey
forall a. FromMisoString a => MisoString -> a
fromMisoString) (JSVal -> IO (Maybe MisoString)
forall a. FromJSVal a => JSVal -> IO (Maybe a)
fromJSVal JSVal
x :: IO (Maybe MisoString))
  {-# INLINE fromJSVal #-}
-----------------------------------------------------------------------------
-- | Serializes a 'StaticKey' as a 32-character hex string (two zero-padded 'Word64' values).
instance ToMisoString Fingerprint where
  toMisoString :: StaticKey -> MisoString
toMisoString StaticKey
fp = String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (StaticKey -> String
forall a. Show a => a -> String
show StaticKey
fp)
  {-# INLINE toMisoString #-}
-----------------------------------------------------------------------------
-- | Parses a 'StaticKey' from its 32-character hex 'MisoString' representation.
instance FromMisoString Fingerprint where
  fromMisoStringEither :: MisoString -> Either String StaticKey
fromMisoStringEither MisoString
s =
    let str :: String
str      = MisoString -> String
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
s :: String
        (String
h1, String
h2) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
16 String
str
        parseHex :: String -> Either String Word64
parseHex String
h = case (ReadS Word64
forall a. (Eq a, Num a) => ReadS a
readHex String
h :: [(Word64, String)]) of
          [(Word64
w, String
"")] -> Word64 -> Either String Word64
forall a b. b -> Either a b
Right Word64
w
          [(Word64, String)]
_         -> String -> Either String Word64
forall a b. a -> Either a b
Left (String
"fromMisoString StaticKey: invalid hex chunk " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
h)
    in Word64 -> Word64 -> StaticKey
Fingerprint (Word64 -> Word64 -> StaticKey)
-> Either String Word64 -> Either String (Word64 -> StaticKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either String Word64
parseHex String
h1 Either String (Word64 -> StaticKey)
-> Either String Word64 -> Either String StaticKey
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Either String Word64
parseHex String
h2
  {-# INLINE fromMisoStringEither #-}
-----------------------------------------------------------------------------
-- | Serializes a 'Fingerprint' ('StaticKey') to its 'Show' representation.
instance ToJSVal Fingerprint where
  toJSVal :: StaticKey -> IO JSVal
toJSVal StaticKey
fp = MisoString -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (StaticKey -> MisoString
forall str. ToMisoString str => str -> MisoString
ms StaticKey
fp :: MisoString)
  {-# INLINE toJSVal #-}
-----------------------------------------------------------------------------
-- | The operation carried by a t'COMPONENT' message.
data ComponentType
  = MOUNT | UNMOUNT | MODEL_HYDRATE | READY | READY_ACK
  deriving (Int -> ComponentType -> ShowS
[ComponentType] -> ShowS
ComponentType -> String
(Int -> ComponentType -> ShowS)
-> (ComponentType -> String)
-> ([ComponentType] -> ShowS)
-> Show ComponentType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ComponentType -> ShowS
showsPrec :: Int -> ComponentType -> ShowS
$cshow :: ComponentType -> String
show :: ComponentType -> String
$cshowList :: [ComponentType] -> ShowS
showList :: [ComponentType] -> ShowS
Show, ComponentType -> ComponentType -> Bool
(ComponentType -> ComponentType -> Bool)
-> (ComponentType -> ComponentType -> Bool) -> Eq ComponentType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ComponentType -> ComponentType -> Bool
== :: ComponentType -> ComponentType -> Bool
$c/= :: ComponentType -> ComponentType -> Bool
/= :: ComponentType -> ComponentType -> Bool
Eq)
-----------------------------------------------------------------------------
instance ToJSVal ComponentType where
  toJSVal :: ComponentType -> IO JSVal
toJSVal = \case
    ComponentType
MOUNT -> MisoString -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (MisoString
"mount"   :: MisoString)
    ComponentType
UNMOUNT -> MisoString -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (MisoString
"unmount" :: MisoString)
    ComponentType
MODEL_HYDRATE -> MisoString -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (MisoString
"model_hydrate" :: MisoString)
    ComponentType
READY -> MisoString -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (MisoString
"ready" :: MisoString)
    ComponentType
READY_ACK -> MisoString -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (MisoString
"ready_ack" :: MisoString)
  {-# INLINE toJSVal #-}
-----------------------------------------------------------------------------
instance FromJSVal ComponentType where
  fromJSVal :: JSVal -> IO (Maybe ComponentType)
fromJSVal JSVal
x = do
    JSVal -> IO (Maybe MisoString)
forall a. FromJSVal a => JSVal -> IO (Maybe a)
fromJSVal JSVal
x IO (Maybe MisoString)
-> (Maybe MisoString -> IO (Maybe ComponentType))
-> IO (Maybe ComponentType)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just (MisoString
"mount" :: MisoString) -> Maybe ComponentType -> IO (Maybe ComponentType)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentType -> Maybe ComponentType
forall a. a -> Maybe a
Just ComponentType
MOUNT)
      Just MisoString
"unmount" -> Maybe ComponentType -> IO (Maybe ComponentType)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentType -> Maybe ComponentType
forall a. a -> Maybe a
Just ComponentType
UNMOUNT)
      Just MisoString
"model_hydrate" -> Maybe ComponentType -> IO (Maybe ComponentType)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentType -> Maybe ComponentType
forall a. a -> Maybe a
Just ComponentType
MODEL_HYDRATE)
      Just MisoString
"ready" -> Maybe ComponentType -> IO (Maybe ComponentType)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentType -> Maybe ComponentType
forall a. a -> Maybe a
Just ComponentType
READY)
      Just MisoString
"ready_ack" -> Maybe ComponentType -> IO (Maybe ComponentType)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentType -> Maybe ComponentType
forall a. a -> Maybe a
Just ComponentType
READY_ACK)
      Maybe MisoString
_ -> Maybe ComponentType -> IO (Maybe ComponentType)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ComponentType
forall a. Maybe a
Nothing
  {-# INLINE fromJSVal #-}
-----------------------------------------------------------------------------
-- | Cross-thread component lifecycle message (BTS → MTS).
data COMPONENT = COMPONENT
  { COMPONENT -> ComponentType
componentComponentType :: ComponentType
  , COMPONENT -> Maybe StaticKey
componentComponentStaticKey :: Maybe StaticKey
  , COMPONENT -> Int
componentComponentId :: ComponentId
  , COMPONENT -> Int
componentComponentParentId :: ComponentId
  , COMPONENT -> Maybe Value
componentComponentPayload :: Maybe Value
  -- ^ Serialized payload carried by hydrate messages: the @model@ for
  -- 'MODEL_HYDRATE', and the initial @props@ for @MOUNT@. 'Nothing' for
  -- 'UNMOUNT' \/ 'READY'.
  , COMPONENT -> Maybe JSVal
componentComponentDOMRef :: Maybe DOMRef
  -- ^ Mount point for the mirrored MTS component, carried by @MOUNT@. In Lynx
  -- a @DOMRef@ is a JS object holding a single @nodeId@ field, so it serializes
  -- across the thread boundary. 'Nothing' for every other message.
  } deriving COMPONENT -> COMPONENT -> Bool
(COMPONENT -> COMPONENT -> Bool)
-> (COMPONENT -> COMPONENT -> Bool) -> Eq COMPONENT
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: COMPONENT -> COMPONENT -> Bool
== :: COMPONENT -> COMPONENT -> Bool
$c/= :: COMPONENT -> COMPONENT -> Bool
/= :: COMPONENT -> COMPONENT -> Bool
Eq
-----------------------------------------------------------------------------
instance ToJSVal COMPONENT where
  toJSVal :: COMPONENT -> IO JSVal
toJSVal COMPONENT {Int
Maybe StaticKey
Maybe JSVal
Maybe Value
ComponentType
componentComponentType :: COMPONENT -> ComponentType
componentComponentStaticKey :: COMPONENT -> Maybe StaticKey
componentComponentId :: COMPONENT -> Int
componentComponentParentId :: COMPONENT -> Int
componentComponentPayload :: COMPONENT -> Maybe Value
componentComponentDOMRef :: COMPONENT -> Maybe JSVal
componentComponentType :: ComponentType
componentComponentStaticKey :: Maybe StaticKey
componentComponentId :: Int
componentComponentParentId :: Int
componentComponentPayload :: Maybe Value
componentComponentDOMRef :: Maybe JSVal
..} = do
    Object
o <- IO Object
create
    Object -> MisoString -> ComponentType -> IO ()
forall o v.
(ToObject o, ToJSVal v) =>
o -> MisoString -> v -> IO ()
setField Object
o MisoString
"componentType" ComponentType
componentComponentType
    Object -> MisoString -> Maybe StaticKey -> IO ()
forall o v.
(ToObject o, ToJSVal v) =>
o -> MisoString -> v -> IO ()
setField Object
o MisoString
"staticKey" Maybe StaticKey
componentComponentStaticKey
    Object -> MisoString -> Int -> IO ()
forall o v.
(ToObject o, ToJSVal v) =>
o -> MisoString -> v -> IO ()
setField Object
o MisoString
"compId" Int
componentComponentId
    Object -> MisoString -> Int -> IO ()
forall o v.
(ToObject o, ToJSVal v) =>
o -> MisoString -> v -> IO ()
setField Object
o MisoString
"compParentId" Int
componentComponentParentId
    Object -> MisoString -> Maybe Value -> IO ()
forall o v.
(ToObject o, ToJSVal v) =>
o -> MisoString -> v -> IO ()
setField Object
o MisoString
"payload" Maybe Value
componentComponentPayload
    Object -> MisoString -> Maybe JSVal -> IO ()
forall o v.
(ToObject o, ToJSVal v) =>
o -> MisoString -> v -> IO ()
setField Object
o MisoString
"domRef" Maybe JSVal
componentComponentDOMRef
    Object -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal Object
o
  {-# INLINE toJSVal #-}
-----------------------------------------------------------------------------
instance FromJSVal COMPONENT where
  fromJSVal :: JSVal -> IO (Maybe COMPONENT)
fromJSVal JSVal
x = do
    let o :: Object
o = JSVal -> Object
Object JSVal
x
    Maybe ComponentType
mct  <- JSVal -> IO (Maybe ComponentType)
forall a. FromJSVal a => JSVal -> IO (Maybe a)
fromJSVal (JSVal -> IO (Maybe ComponentType))
-> IO JSVal -> IO (Maybe ComponentType)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> Object -> IO JSVal
forall o. ToObject o => MisoString -> o -> IO JSVal
getProp MisoString
"componentType" Object
o
    Maybe (Maybe MisoString)
msk  <- JSVal -> IO (Maybe (Maybe MisoString))
forall a. FromJSVal a => JSVal -> IO (Maybe a)
fromJSVal (JSVal -> IO (Maybe (Maybe MisoString)))
-> IO JSVal -> IO (Maybe (Maybe MisoString))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> Object -> IO JSVal
forall o. ToObject o => MisoString -> o -> IO JSVal
getProp MisoString
"staticKey" Object
o
    let key :: Maybe (Maybe StaticKey)
key = (MisoString -> StaticKey) -> Maybe MisoString -> Maybe StaticKey
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MisoString -> StaticKey
forall a. FromMisoString a => MisoString -> a
fromMisoString (Maybe MisoString -> Maybe StaticKey)
-> Maybe (Maybe MisoString) -> Maybe (Maybe StaticKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Maybe MisoString)
msk
    Maybe Int
mcid <- JSVal -> IO (Maybe Int)
forall a. FromJSVal a => JSVal -> IO (Maybe a)
fromJSVal (JSVal -> IO (Maybe Int)) -> IO JSVal -> IO (Maybe Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> Object -> IO JSVal
forall o. ToObject o => MisoString -> o -> IO JSVal
getProp MisoString
"compId" Object
o
    Maybe Int
mcpid <- JSVal -> IO (Maybe Int)
forall a. FromJSVal a => JSVal -> IO (Maybe a)
fromJSVal (JSVal -> IO (Maybe Int)) -> IO JSVal -> IO (Maybe Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> Object -> IO JSVal
forall o. ToObject o => MisoString -> o -> IO JSVal
getProp MisoString
"compParentId" Object
o
    Maybe (Maybe Value)
mp   <- JSVal -> IO (Maybe (Maybe Value))
forall a. FromJSVal a => JSVal -> IO (Maybe a)
fromJSVal (JSVal -> IO (Maybe (Maybe Value)))
-> IO JSVal -> IO (Maybe (Maybe Value))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> Object -> IO JSVal
forall o. ToObject o => MisoString -> o -> IO JSVal
getProp MisoString
"payload" Object
o
    Maybe (Maybe JSVal)
mdr  <- JSVal -> IO (Maybe (Maybe JSVal))
forall a. FromJSVal a => JSVal -> IO (Maybe a)
fromJSVal (JSVal -> IO (Maybe (Maybe JSVal)))
-> IO JSVal -> IO (Maybe (Maybe JSVal))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> Object -> IO JSVal
forall o. ToObject o => MisoString -> o -> IO JSVal
getProp MisoString
"domRef" Object
o
    Maybe COMPONENT -> IO (Maybe COMPONENT)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentType
-> Maybe StaticKey
-> Int
-> Int
-> Maybe Value
-> Maybe JSVal
-> COMPONENT
COMPONENT (ComponentType
 -> Maybe StaticKey
 -> Int
 -> Int
 -> Maybe Value
 -> Maybe JSVal
 -> COMPONENT)
-> Maybe ComponentType
-> Maybe
     (Maybe StaticKey
      -> Int -> Int -> Maybe Value -> Maybe JSVal -> COMPONENT)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ComponentType
mct Maybe
  (Maybe StaticKey
   -> Int -> Int -> Maybe Value -> Maybe JSVal -> COMPONENT)
-> Maybe (Maybe StaticKey)
-> Maybe (Int -> Int -> Maybe Value -> Maybe JSVal -> COMPONENT)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Maybe StaticKey)
key Maybe (Int -> Int -> Maybe Value -> Maybe JSVal -> COMPONENT)
-> Maybe Int
-> Maybe (Int -> Maybe Value -> Maybe JSVal -> COMPONENT)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int
mcid Maybe (Int -> Maybe Value -> Maybe JSVal -> COMPONENT)
-> Maybe Int -> Maybe (Maybe Value -> Maybe JSVal -> COMPONENT)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int
mcpid Maybe (Maybe Value -> Maybe JSVal -> COMPONENT)
-> Maybe (Maybe Value) -> Maybe (Maybe JSVal -> COMPONENT)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Maybe Value)
mp Maybe (Maybe JSVal -> COMPONENT)
-> Maybe (Maybe JSVal) -> Maybe COMPONENT
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Maybe JSVal)
mdr)
  {-# INLINE fromJSVal #-}
-----------------------------------------------------------------------------
-- | Cross-thread effect message (MTS → BTS or BTS → MTS).
data EFFECT = EFFECT
  { EFFECT -> Int
effectComponentId :: ComponentId
  , EFFECT -> Value
effectAction :: Value
  , EFFECT -> Maybe StaticKey
effectStaticKey :: Maybe StaticKey
  } deriving (Int -> EFFECT -> ShowS
[EFFECT] -> ShowS
EFFECT -> String
(Int -> EFFECT -> ShowS)
-> (EFFECT -> String) -> ([EFFECT] -> ShowS) -> Show EFFECT
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EFFECT -> ShowS
showsPrec :: Int -> EFFECT -> ShowS
$cshow :: EFFECT -> String
show :: EFFECT -> String
$cshowList :: [EFFECT] -> ShowS
showList :: [EFFECT] -> ShowS
Show, EFFECT -> EFFECT -> Bool
(EFFECT -> EFFECT -> Bool)
-> (EFFECT -> EFFECT -> Bool) -> Eq EFFECT
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EFFECT -> EFFECT -> Bool
== :: EFFECT -> EFFECT -> Bool
$c/= :: EFFECT -> EFFECT -> Bool
/= :: EFFECT -> EFFECT -> Bool
Eq)
-----------------------------------------------------------------------------
instance ToJSVal EFFECT where
  toJSVal :: EFFECT -> IO JSVal
toJSVal EFFECT {Int
Maybe StaticKey
Value
effectComponentId :: EFFECT -> Int
effectAction :: EFFECT -> Value
effectStaticKey :: EFFECT -> Maybe StaticKey
effectComponentId :: Int
effectAction :: Value
effectStaticKey :: Maybe StaticKey
..} = do
    Object
o <- IO Object
create
    Object -> MisoString -> Int -> IO ()
forall o v.
(ToObject o, ToJSVal v) =>
o -> MisoString -> v -> IO ()
setField Object
o MisoString
"componentId" Int
effectComponentId
    Object -> MisoString -> Value -> IO ()
forall o v.
(ToObject o, ToJSVal v) =>
o -> MisoString -> v -> IO ()
setField Object
o MisoString
"action" Value
effectAction
    Object -> MisoString -> Maybe StaticKey -> IO ()
forall o v.
(ToObject o, ToJSVal v) =>
o -> MisoString -> v -> IO ()
setField Object
o MisoString
"staticKey" Maybe StaticKey
effectStaticKey
    Object -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal Object
o
  {-# INLINE toJSVal #-}
-----------------------------------------------------------------------------
instance FromJSVal EFFECT where
  fromJSVal :: JSVal -> IO (Maybe EFFECT)
fromJSVal JSVal
x = do
    let o :: Object
o = JSVal -> Object
Object JSVal
x
    Maybe Int
mcid <- JSVal -> IO (Maybe Int)
forall a. FromJSVal a => JSVal -> IO (Maybe a)
fromJSVal (JSVal -> IO (Maybe Int)) -> IO JSVal -> IO (Maybe Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> Object -> IO JSVal
forall o. ToObject o => MisoString -> o -> IO JSVal
getProp MisoString
"componentId" Object
o
    Maybe Value
maction <- JSVal -> IO (Maybe Value)
forall a. FromJSVal a => JSVal -> IO (Maybe a)
fromJSVal (JSVal -> IO (Maybe Value)) -> IO JSVal -> IO (Maybe Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> Object -> IO JSVal
forall o. ToObject o => MisoString -> o -> IO JSVal
getProp MisoString
"action" Object
o
    Maybe (Maybe StaticKey)
mk <- JSVal -> IO (Maybe (Maybe StaticKey))
forall a. FromJSVal a => JSVal -> IO (Maybe a)
fromJSVal (JSVal -> IO (Maybe (Maybe StaticKey)))
-> IO JSVal -> IO (Maybe (Maybe StaticKey))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> Object -> IO JSVal
forall o. ToObject o => MisoString -> o -> IO JSVal
getProp MisoString
"staticKey" Object
o
    Maybe EFFECT -> IO (Maybe EFFECT)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Value -> Maybe StaticKey -> EFFECT
EFFECT (Int -> Value -> Maybe StaticKey -> EFFECT)
-> Maybe Int -> Maybe (Value -> Maybe StaticKey -> EFFECT)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
mcid Maybe (Value -> Maybe StaticKey -> EFFECT)
-> Maybe Value -> Maybe (Maybe StaticKey -> EFFECT)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Value
maction Maybe (Maybe StaticKey -> EFFECT)
-> Maybe (Maybe StaticKey) -> Maybe EFFECT
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Maybe StaticKey)
mk)
  {-# INLINE fromJSVal #-}
-----------------------------------------------------------------------------
-- | Opaque handle to the Lynx Main Thread (MTS) context proxy.
-- Obtained via 'getMTSContext' on the background thread.
newtype MTS = MTS JSVal
  deriving stock MTS -> MTS -> Bool
(MTS -> MTS -> Bool) -> (MTS -> MTS -> Bool) -> Eq MTS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MTS -> MTS -> Bool
== :: MTS -> MTS -> Bool
$c/= :: MTS -> MTS -> Bool
/= :: MTS -> MTS -> Bool
Eq
  deriving newtype MTS -> IO JSVal
(MTS -> IO JSVal) -> ToJSVal MTS
forall a. (a -> IO JSVal) -> ToJSVal a
$ctoJSVal :: MTS -> IO JSVal
toJSVal :: MTS -> IO JSVal
ToJSVal
-----------------------------------------------------------------------------
-- | Opaque handle to the Lynx Background Thread (BTS) context proxy.
-- Obtained via 'getBTSContext' on the main thread.
newtype BTS = BTS JSVal
  deriving stock BTS -> BTS -> Bool
(BTS -> BTS -> Bool) -> (BTS -> BTS -> Bool) -> Eq BTS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BTS -> BTS -> Bool
== :: BTS -> BTS -> Bool
$c/= :: BTS -> BTS -> Bool
/= :: BTS -> BTS -> Bool
Eq
  deriving newtype BTS -> IO JSVal
(BTS -> IO JSVal) -> ToJSVal BTS
forall a. (a -> IO JSVal) -> ToJSVal a
$ctoJSVal :: BTS -> IO JSVal
toJSVal :: BTS -> IO JSVal
ToJSVal
-----------------------------------------------------------------------------
-- | The MTS context proxy (@lynx.getCoreContext()@), cached.
--
-- N.B. Lynx hands back a handle to the same underlying @ContextProxy@ on
-- every call for the lifetime of a given JS context (one instance per
-- origin\/target pair), so — like 'mts' \/ 'bts' \/ 'web' above — it's safe
-- to compute once via 'unsafePerformIO' rather than round-tripping the FFI
-- on every 'postComponent' \/ 'postEffect'.
mtsContext :: MTS
{-# NOINLINE mtsContext #-}
mtsContext :: MTS
mtsContext = IO MTS -> MTS
forall a. IO a -> a
unsafePerformIO (JSVal -> MTS
MTS (JSVal -> MTS) -> IO JSVal -> IO MTS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MisoString -> IO JSVal
jsg MisoString
"lynx" IO JSVal -> MisoString -> () -> IO JSVal
forall object args.
(ToObject object, ToArgs args) =>
object -> MisoString -> args -> IO JSVal
# MisoString
"getCoreContext" (() -> IO JSVal) -> () -> IO JSVal
forall a b. (a -> b) -> a -> b
$ ()))
-----------------------------------------------------------------------------
-- | The BTS context proxy (@lynx.getJSContext()@), cached. See 'mtsContext'.
btsContext :: BTS
{-# NOINLINE btsContext #-}
btsContext :: BTS
btsContext = IO BTS -> BTS
forall a. IO a -> a
unsafePerformIO (JSVal -> BTS
BTS (JSVal -> BTS) -> IO JSVal -> IO BTS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MisoString -> IO JSVal
jsg MisoString
"lynx" IO JSVal -> MisoString -> () -> IO JSVal
forall object args.
(ToObject object, ToArgs args) =>
object -> MisoString -> args -> IO JSVal
# MisoString
"getJSContext" (() -> IO JSVal) -> () -> IO JSVal
forall a b. (a -> b) -> a -> b
$ ()))
-----------------------------------------------------------------------------
-- | Returns the MTS context proxy. Call from the background thread to
-- dispatch messages to the main thread.
getMTSContext :: IO MTS
{-# INLINABLE getMTSContext #-}
getMTSContext :: IO MTS
getMTSContext = MTS -> IO MTS
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MTS
mtsContext
-----------------------------------------------------------------------------
-- | Returns the BTS context proxy. Call from the main thread to dispatch
-- messages to the background thread.
getBTSContext :: IO BTS
{-# INLINABLE getBTSContext #-}
getBTSContext :: IO BTS
getBTSContext = BTS -> IO BTS
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BTS
btsContext
-----------------------------------------------------------------------------
-- | Dispatches a cross-thread message to the BTS via @context.dispatchEvent@.
-- The @protocol@ string names the channel (e.g. @\"Miso.patches\"@).
dispatchEvent :: (ToJSVal ctx, ToJSVal a) => ctx -> MisoString -> a -> IO ()
{-# INLINABLE dispatchEvent #-}
dispatchEvent :: forall ctx a.
(ToJSVal ctx, ToJSVal a) =>
ctx -> MisoString -> a -> IO ()
dispatchEvent ctx
ctx MisoString
protocol a
payload = do
  JSVal
ctx_ <- ctx -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal ctx
ctx
  Object
o <- IO Object
create
  Object -> MisoString -> MisoString -> IO ()
forall o v.
(ToObject o, ToJSVal v) =>
o -> MisoString -> v -> IO ()
setField Object
o MisoString
"type" MisoString
protocol
  Object -> MisoString -> JSVal -> IO ()
forall o v.
(ToObject o, ToJSVal v) =>
o -> MisoString -> v -> IO ()
setField Object
o MisoString
"data" (JSVal -> IO ()) -> IO JSVal -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal a
payload
  JSVal
_ <- JSVal -> Object
Object JSVal
ctx_ Object -> MisoString -> [Object] -> IO JSVal
forall object args.
(ToObject object, ToArgs args) =>
object -> MisoString -> args -> IO JSVal
# MisoString
"dispatchEvent" ([Object] -> IO JSVal) -> [Object] -> IO JSVal
forall a b. (a -> b) -> a -> b
$ [Object
o]
  () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
----------------------------------------------------------------------------
-- | Loads miso's JavaScript (if not already loaded) and runs an 'IO' action.
--
-- On WASM, @miso.js@ is evaluated once on first call and skipped on subsequent calls.
-- It is safe to call 'withJS' directly (e.g. when implementing WASM tests in Playwright);
-- 'Miso.startApp' \/ 'Miso.miso' call it for you.
--
withJS
  :: IO a
  -- ^ 'IO' action to execute in between 'evalFile'
  -> IO a
withJS :: forall a. IO a -> IO a
withJS IO a
action = do
#ifdef WASM
  loaded <- readIORef loadedJS
  unless loaded $(evalFile MISO_JS_PATH)
  atomicWriteIORef loadedJS True
#endif
  IO a
action
-----------------------------------------------------------------------------