-----------------------------------------------------------------------------
{-# 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
  , globalContext
  , setContext
  , schedulerThread
  , componentIds
  , rootComponentId
  , componentId
  , modifyComponent
  , unmountComponent
  , freeLifecycleHooks
  , componentModel
  -- ** 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           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?
  -> 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
-> 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 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
context -> props -> model -> View context 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 :: context -> props -> model -> View context 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
-> context -> props -> model -> View context 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)
_) -> do
        Bool
live <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
liveMode
        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
        props
currentProps <- (ComponentState Any props Any Any
-> Lens (ComponentState Any props Any Any) props -> props
forall record field. record -> Lens record field -> field
^. Lens (ComponentState Any props Any Any) props
forall context props model action.
Lens (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
        context
currentContext <- IORef context -> IO context
forall a. IORef a -> IO a
readIORef IORef context
forall context. IORef context
globalContext
        VTree
newVTree <-
          Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> model
-> View context model action
-> IO VTree
forall context model action.
Eq context =>
Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> model
-> View context model action
-> IO VTree
buildVTree Events
events Int
_componentParentId Int
_componentId Hydrate
Draw
            Sink action
forall {action}. action -> IO ()
_componentSink LogLevel
logLevel model
newModel (context -> props -> model -> View context model action
view context
currentContext props
currentProps 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
        { _componentEvents :: Events
_componentEvents = Events
events
        , _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 (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
_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 ()
_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
-> 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
-> Component context props m a
-> ComponentState context props m a
-> IO ()
initialDraw model
initializedModel Events
events Hydrate
hydrate Bool
isRoot 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 applying the @Props@ constructor 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 (Map MisoString ThreadId)
IORef VTree
Events
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]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_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 ()
_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]
_componentEvents :: Events
_componentUseContext :: Bool
_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 (Map MisoString ThreadId)
IORef VTree
Events
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]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_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 ()
_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]
_componentEvents :: Events
_componentUseContext :: Bool
_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
      context
currentContext <- forall a. IORef a -> IO a
readIORef @context IORef context
forall context. IORef context
globalContext
      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 (Map MisoString ThreadId)
IORef VTree
Events
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]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_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 ()
_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]
_componentEvents :: Events
_componentUseContext :: Bool
_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
          (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 a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef context
forall context. IORef context
globalContext ((context -> (context, ())) -> IO ())
-> (context -> (context, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \context
ctx -> (context -> context
f context
ctx, ())
        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
forall context. IORef context
globalContext
      -- '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 (Map MisoString ThreadId)
IORef VTree
Events
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]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_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 ()
_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]
_componentEvents :: Events
_componentUseContext :: Bool
_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
  -> 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
-> Component context props m a
-> ComponentState context props m a
-> IO ()
initialDraw m
initializedModel Events
events Hydrate
hydrate Bool
isRoot Component {m
Bool
[JS]
[CSS]
[Sub m a]
Maybe a
Maybe (IO m)
Maybe MisoString
Maybe (props -> props -> a)
LogLevel
context -> props -> m -> View context 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
-> context -> props -> model -> View context 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 :: context -> props -> m -> View context 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 (Map MisoString ThreadId)
IORef VTree
Events
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]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_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 ()
_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]
_componentEvents :: Events
_componentUseContext :: Bool
_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
forall context. IORef context
globalContext
  VTree
vtree <- Events
-> Int
-> Int
-> Hydrate
-> Sink a
-> LogLevel
-> m
-> View context m a
-> IO VTree
forall context model action.
Eq context =>
Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> model
-> View context model action
-> IO VTree
buildVTree Events
events Int
_componentParentId Int
_componentId Hydrate
hydrate Sink a
_componentSink LogLevel
logLevel
    m
initializedModel (context -> props -> m -> View context m a
view context
currentContext props
_componentProps 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
-> Sink a
-> LogLevel
-> m
-> View context m a
-> IO VTree
forall context model action.
Eq context =>
Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> model
-> View context model action
-> IO VTree
buildVTree Events
events Int
_componentParentId Int
_componentId Hydrate
Draw
                  Sink a
_componentSink LogLevel
logLevel m
initializedModel (context -> props -> m -> View context m a
view context
currentContext props
_componentProps 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)
-----------------------------------------------------------------------------
-- | The global React-style @context@. Seeded in 'initComponent' (via
-- 'Miso.startAppWithContext', defaulting to @()@) and mutated by
-- 'Miso.Effect.modifyContext' during the scheduler's commit phase.
--
-- N.B. like 'components', this holds a single value whose type is fixed for the
-- lifetime of the application; it is written before any draw occurs.
globalContext :: IORef context
{-# NOINLINE globalContext #-}
globalContext :: forall context. IORef context
globalContext = IO (IORef context) -> IORef context
forall a. IO a -> a
unsafePerformIO (context -> IO (IORef context)
forall a. a -> IO (IORef a)
newIORef context
forall a. HasCallStack => a
undefined)
-----------------------------------------------------------------------------
-- | Seed the global @context@ 'IORef' with a value.
--
-- 'Miso.startAppWithContext' seeds this before the first draw, so client
-- applications never call it. It exists for __server-side rendering__, where a
-- t'Miso.Types.View' is serialized to HTML without ever starting the runtime
-- and the global @context@ cell would otherwise still hold @undefined@. See
-- 'Miso.setContext' for the full explanation.
--
-- @since 1.13.0.0
setContext :: Eq context => context -> IO ()
setContext :: forall context. Eq context => context -> IO ()
setContext = IORef context -> context -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef context
forall context. IORef context
globalContext
-----------------------------------------------------------------------------
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 }
-----------------------------------------------------------------------------
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 -> Events
_componentEvents :: Events
  -- ^ List of events a t'Miso.Types.Component' listens on
  , 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 -> 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 (Map MisoString ThreadId)
IORef VTree
Events
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]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_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 ()
_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]
_componentEvents :: Events
_componentUseContext :: Bool
_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 (Map MisoString ThreadId)
IORef VTree
Events
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]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_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 ()
_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]
_componentEvents :: Events
_componentUseContext :: Bool
_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)
-----------------------------------------------------------------------------
-- | Set once in 'initComponent' from its @live@ argument. Gates key-based
-- model recovery in 'initialize' — outside hot reload, a keyed component
-- must never inherit a previous (possibly unrelated) component's model just
-- because it shares a t'Key'.
liveMode :: IORef Bool
{-# NOINLINE liveMode #-}
liveMode :: IORef Bool
liveMode = IO (IORef Bool) -> IORef Bool
forall a. IO a -> a
unsafePerformIO (Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False)
-----------------------------------------------------------------------------
-- | 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 (Map MisoString ThreadId)
IORef VTree
Events
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]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_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 ()
_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]
_componentEvents :: Events
_componentUseContext :: Bool
_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
       context
currentContext <- forall a. IORef a -> IO a
readIORef @context IORef context
forall context. IORef context
globalContext
       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 a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef context
forall context. IORef context
globalContext ((context -> (context, ())) -> IO ())
-> (context -> (context, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \context
ctx -> (context -> context
f context
ctx, ())
           context
newContext <- IORef context -> IO context
forall a. IORef a -> IO a
readIORef IORef context
forall context. IORef context
globalContext
           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 (Map MisoString ThreadId)
IORef VTree
Events
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]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_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 ()
_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]
_componentEvents :: Events
_componentUseContext :: Bool
_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 (Map MisoString ThreadId)
IORef VTree
Events
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]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_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 ()
_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]
_componentEvents :: Events
_componentUseContext :: Bool
_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 (Map MisoString ThreadId)
IORef VTree
Events
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]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_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 ()
_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]
_componentEvents :: Events
_componentUseContext :: Bool
_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 model action . Eq context
  => Events
  -> ComponentId
  -> ComponentId
  -> Hydrate
  -> Sink action
  -> LogLevel
  -> model
  -> View context model action
  -> IO VTree
buildVTree :: forall context model action.
Eq context =>
Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> model
-> View context model action
-> IO VTree
buildVTree Events
events_ Int
parentId_ Int
vcompId Hydrate
hydrate Sink action
snk LogLevel
logLevel_ 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 props context)
ptr props
props -> case StaticPtr (SomeStaticComponent props context)
-> SomeStaticComponent props context
forall a. StaticPtr a -> a
deRefStaticPtr StaticPtr (SomeStaticComponent props context)
ptr of
    SomeStaticComponent props -> SomeComponent context
mk -> Maybe StaticKey -> SomeComponent context -> IO VTree
buildComp (StaticKey -> Maybe StaticKey
forall a. a -> Maybe a
Just (StaticPtr (SomeStaticComponent props context) -> StaticKey
forall a. StaticPtr a -> StaticKey
staticKey StaticPtr (SomeStaticComponent props context)
ptr)) (props -> SomeComponent context
mk props
props)

  VNode Namespace
ns MisoString
tag [Attribute model action]
attrs [View context 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 model action, Object)]
children_ <- Object -> IO [(View context model action, Object)]
forall {v}.
ToJSVal v =>
v -> IO [(View context model action, Object)]
procreate Object
vnode_
    JSVal
vchildren <- [Object] -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (((View context model action, Object) -> Object)
-> [(View context model action, Object)] -> [Object]
forall a b. (a -> b) -> [a] -> [b]
map (View context model action, Object) -> Object
forall a b. (a, b) -> b
snd [(View context 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 model action, Object) -> IO ())
-> [(View context model action, Object)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (View context model action, Object) -> IO ()
freeKid [(View context 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_)
      where
        procreate :: v -> IO [(View context model action, Object)]
procreate v
parentVTree = do
          [(View context model action, Object)]
kidsViews <- ([(View context model action, Object)]
 -> View context model action
 -> IO [(View context model action, Object)])
-> [(View context model action, Object)]
-> [View context model action]
-> IO [(View context model action, Object)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (v
-> [(View context model action, Object)]
-> View context model action
-> IO [(View context model action, Object)]
forall {context} {v}.
(Eq context, ToJSVal v) =>
v
-> [(View context model action, Object)]
-> View context model action
-> IO [(View context model action, Object)]
buildKid v
parentVTree) [] [View context model action]
kids
          let ordered :: [(View context model action, Object)]
ordered = [(View context model action, Object)]
-> [(View context model action, Object)]
forall a. [a] -> [a]
reverse [(View context model action, Object)]
kidsViews
          [Object] -> IO ()
forall {b}. (ToObject b, ToJSVal b) => [b] -> IO ()
setNextSibling (((View context model action, Object) -> Object)
-> [(View context model action, Object)] -> [Object]
forall a b. (a -> b) -> [a] -> [b]
map (View context model action, Object) -> Object
forall a b. (a, b) -> b
snd [(View context model action, Object)]
ordered)
          [(View context model action, Object)]
-> IO [(View context model action, Object)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(View context model action, Object)]
ordered
            where
              setNextSibling :: [b] -> IO ()
setNextSibling [b]
xs =
                (b -> b -> IO ()) -> [b] -> [b] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ ((b -> MisoString -> b -> IO ()) -> MisoString -> b -> b -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> MisoString -> b -> IO ()
forall o v.
(ToObject o, ToJSVal v) =>
o -> MisoString -> v -> IO ()
setField MisoString
"nextSibling")
                  [b]
xs (Int -> [b] -> [b]
forall a. Int -> [a] -> [a]
drop Int
1 [b]
xs)
              buildKid :: v
-> [(View context model action, Object)]
-> View context model action
-> IO [(View context model action, Object)]
buildKid v
_ [(View context model action, Object)]
acc (VFrag Maybe Key
_ []) = [(View context model action, Object)]
-> IO [(View context model action, Object)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(View context model action, Object)]
acc
              buildKid v
p [(View context model action, Object)]
acc View context model action
kid = do
                VTree Object
child <- Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> model
-> View context model action
-> IO VTree
forall context model action.
Eq context =>
Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> model
-> View context model action
-> IO VTree
buildVTree Events
events_ Int
parentId_ Int
vcompId Hydrate
hydrate Sink action
snk LogLevel
logLevel_ model
model_ View context model action
kid
                MisoString -> v -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"parent" v
p Object
child
                [(View context model action, Object)]
-> IO [(View context model action, Object)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((View context model action
kid, Object
child) (View context model action, Object)
-> [(View context model action, Object)]
-> [(View context model action, Object)]
forall a. a -> [a] -> [a]
: [(View context model action, Object)]
acc)
  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 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 model action, Object)]
children_ <- Object -> IO [(View context model action, Object)]
forall {v}.
ToJSVal v =>
v -> IO [(View context model action, Object)]
procreateFragChildren Object
frag
    JSVal
vchildren <- [Object] -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (((View context model action, Object) -> Object)
-> [(View context model action, Object)] -> [Object]
forall a b. (a -> b) -> [a] -> [b]
map (View context model action, Object) -> Object
forall a b. (a, b) -> b
snd [(View context 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 model action, Object) -> IO ())
-> [(View context model action, Object)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (View context model action, Object) -> IO ()
freeKid [(View context 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)
      where
        procreateFragChildren :: p -> IO [(View context model action, Object)]
procreateFragChildren p
parentVTree = do
          [(View context model action, Object)]
kidsViews <- ([(View context model action, Object)]
 -> View context model action
 -> IO [(View context model action, Object)])
-> [(View context model action, Object)]
-> [View context model action]
-> IO [(View context model action, Object)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [(View context model action, Object)]
-> View context model action
-> IO [(View context model action, Object)]
forall {context}.
Eq context =>
[(View context model action, Object)]
-> View context model action
-> IO [(View context model action, Object)]
buildKid [] [View context model action]
kids
          let ordered :: [(View context model action, Object)]
ordered = [(View context model action, Object)]
-> [(View context model action, Object)]
forall a. [a] -> [a]
reverse [(View context model action, Object)]
kidsViews
          (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 model action, Object) -> Object)
-> [(View context model action, Object)] -> [Object]
forall a b. (a -> b) -> [a] -> [b]
map (View context model action, Object) -> Object
forall a b. (a, b) -> b
snd [(View context model action, Object)]
ordered) (Int -> [Object] -> [Object]
forall a. Int -> [a] -> [a]
drop Int
1 (((View context model action, Object) -> Object)
-> [(View context model action, Object)] -> [Object]
forall a b. (a -> b) -> [a] -> [b]
map (View context model action, Object) -> Object
forall a b. (a, b) -> b
snd [(View context model action, Object)]
ordered))
          [(View context model action, Object)]
-> IO [(View context model action, Object)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(View context model action, Object)]
ordered
            where
              buildKid :: [(View context model action, Object)]
-> View context model action
-> IO [(View context model action, Object)]
buildKid [(View context model action, Object)]
acc (VFrag Maybe Key
_ []) = [(View context model action, Object)]
-> IO [(View context model action, Object)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(View context model action, Object)]
acc
              buildKid [(View context model action, Object)]
acc View context model action
kid = do
                VTree Object
child <- Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> model
-> View context model action
-> IO VTree
forall context model action.
Eq context =>
Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> model
-> View context model action
-> IO VTree
buildVTree Events
events_ Int
parentId_ Int
vcompId Hydrate
hydrate Sink action
snk LogLevel
logLevel_ model
model_ View context model action
kid
                MisoString -> p -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"parent" p
parentVTree Object
child
                [(View context model action, Object)]
-> IO [(View context model action, Object)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((View context model action
kid, Object
child) (View context model action, Object)
-> [(View context model action, Object)]
-> [(View context model action, Object)]
forall a. a -> [a] -> [a]
: [(View context model action, Object)]
acc)
  where
    -- 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 model action, Object) -> IO ()
    freeKid :: (View context model action, Object) -> IO ()
freeKid (View context model action
kid, Object JSVal
child) = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (View context model action -> Bool
freeable View context model action
kid) (JSVal -> IO ()
freeJSVal JSVal
child)

    freeable :: View context model action -> Bool
    freeable :: View context model action -> Bool
freeable = \case
      VNode Namespace
_ MisoString
_ [Attribute model action]
attrs [View context 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

    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
          ComponentState {model
props
Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
IORef (Map MisoString ThreadId)
IORef VTree
Events
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]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_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 ()
_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]
_componentEvents :: Events
_componentUseContext :: Bool
_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
-> 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
-> 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 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
      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
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 (Map MisoString ThreadId)
IORef VTree
Events
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]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_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 ()
_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]
_componentEvents :: Events
_componentUseContext :: Bool
_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 (Map MisoString ThreadId)
IORef VTree
Events
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]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_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 ()
_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]
_componentEvents :: Events
_componentUseContext :: Bool
_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 (Map MisoString ThreadId)
IORef VTree
Events
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]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_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 ()
_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]
_componentEvents :: Events
_componentUseContext :: Bool
_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 (Map MisoString ThreadId)
IORef VTree
Events
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]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_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 ()
_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]
_componentEvents :: Events
_componentUseContext :: Bool
_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 (Map MisoString ThreadId)
IORef VTree
Events
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]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_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 ()
_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]
_componentEvents :: Events
_componentUseContext :: Bool
_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 (Map MisoString ThreadId)
IORef VTree
Events
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]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_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 ()
_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]
_componentEvents :: Events
_componentUseContext :: Bool
_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
context -> props -> model -> View context 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
-> context -> props -> model -> View context 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 :: context -> props -> model -> View context 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
#ifdef NATIVE
        when bts $ do
          effectListener proxy =<< getMTSContext
          readyAckListener =<< getMTSContext
          void $ forkIO (sendReadyUntilAcked sk)
        when mts $ do
          effectListener proxy =<< getBTSContext
          componentListener proxy =<< getBTSContext
          registerMainThreadDispatch
#endif
        IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef Bool
liveMode Bool
live
        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)
        IORef context -> context -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef context
forall context. IORef context
globalContext context
initialContext
        -- 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
-> 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
-> 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 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)
----------------------------------------------------------------------------
-- | Placeholder passed to a @Props@ constructor when only the resulting
-- t'SomeComponent'\'s /types/ (@model@ \/ @props@ \/ @action@) are needed, not a
-- real @props@ value — e.g. to recover the @action@ type for decoding. Safe
-- because every @Props@ built by @mount_@ \/ @mountWithProps@ \/ @(+>)@ is lazy
-- in its @props@ argument, so applying it never forces this.
#ifdef NATIVE
propsTypeOnly :: props
propsTypeOnly = error "Miso.Runtime: props forced during type-only Props application"
-----------------------------------------------------------------------------
-- | 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 ->
              case deRefStaticPtr ptr of
               SomeStaticComponent mk -> case mk propsTypeOnly of
                SomeComponent _key _props (_ :: 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 => Proxy context -> BTS -> IO ()
componentListener Proxy (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 mk -> case mk propsTypeOnly of
                  SomeComponent _key _props (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) ->
                                    void $ initialize mempty componentComponentId Draw False 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
-----------------------------------------------------------------------------