-----------------------------------------------------------------------------
{-# 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
  , renderStyles
  , renderScripts
  , Hydrate(..)
  -- * Subscription
  , startSub
  , stopSub
  -- * Pub / Sub
  , subscribe
  , unsubscribe
  , publish
  , Topic (..)
  , topic
  -- * Component
  , ComponentState (..)
  -- ** 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
  , 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           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, ToJSON model, ToJSON props,
 ToJSON action, FromJSON action) =>
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 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 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 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
  _componentId <- IO Int
freshComponentId
  let
    _componentProps = props
initialProps
    _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

  initializedModel <-
    case (hydrate, hydrateModel) of
      (Hydrate
Hydrate, Just IO model
m) -> IO model
m
      (Hydrate
Draw, Maybe (IO model)
_) -> do
        live <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
liveMode
        case (live, maybeKey) of
          (Bool
True, Just Key
k) -> do
            vcomps <- IORef
  (IntMap
     (ComponentState (ZonkAny 108) (ZonkAny 109) model (ZonkAny 110)))
-> IO
     (IntMap
        (ComponentState (ZonkAny 108) (ZonkAny 109) model (ZonkAny 110)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState (ZonkAny 108) (ZonkAny 109) model (ZonkAny 110)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
            pure $ fromMaybe model $ listToMaybe
              [ cs ^. componentModel
              | cs <- IM.elems vcomps
              , cs ^. componentKey == Just 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
  _componentScripts <-
    if web
    then
      IM.lookup _componentId <$> readIORef components >>= \case
        Maybe
  (ComponentState
     (ZonkAny 111) (ZonkAny 112) (ZonkAny 113) (ZonkAny 114))
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
  (ZonkAny 111) (ZonkAny 112) (ZonkAny 113) (ZonkAny 114)
cs -> [JSVal] -> IO [JSVal]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentState
  (ZonkAny 111) (ZonkAny 112) (ZonkAny 113) (ZonkAny 114)
-> [JSVal]
forall context props model action.
ComponentState context props model action -> [JSVal]
_componentScripts ComponentState
  (ZonkAny 111) (ZonkAny 112) (ZonkAny 113) (ZonkAny 114)
cs) -- hot reload scenario, reuse already mounted scripts
    else
      pure []

  _componentDOMRef <- getComponentMountPoint
  _componentVTree <- newIORef (VTree (Object jsNull))
  _componentSubThreads <- newIORef M.empty

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

  rAFCallback <-
    asyncCallback1 $ \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
newModel -> do
        currentProps <- (ComponentState (ZonkAny 115) props (ZonkAny 116) (ZonkAny 117)
-> Lens
     (ComponentState (ZonkAny 115) props (ZonkAny 116) (ZonkAny 117))
     props
-> props
forall record field. record -> Lens record field -> field
^. Lens
  (ComponentState (ZonkAny 115) props (ZonkAny 116) (ZonkAny 117))
  props
forall context props model action.
Lens (ComponentState context props model action) props
componentProps) (ComponentState (ZonkAny 115) props (ZonkAny 116) (ZonkAny 117)
 -> props)
-> (IntMap
      (ComponentState (ZonkAny 115) props (ZonkAny 116) (ZonkAny 117))
    -> ComponentState (ZonkAny 115) props (ZonkAny 116) (ZonkAny 117))
-> IntMap
     (ComponentState (ZonkAny 115) props (ZonkAny 116) (ZonkAny 117))
-> 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 (ZonkAny 115) props (ZonkAny 116) (ZonkAny 117))
-> Int
-> ComponentState (ZonkAny 115) props (ZonkAny 116) (ZonkAny 117)
forall a. IntMap a -> Int -> a
IM.! Int
_componentId) (IntMap
   (ComponentState (ZonkAny 115) props (ZonkAny 116) (ZonkAny 117))
 -> props)
-> IO
     (IntMap
        (ComponentState (ZonkAny 115) props (ZonkAny 116) (ZonkAny 117)))
-> IO props
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState (ZonkAny 115) props (ZonkAny 116) (ZonkAny 117)))
-> IO
     (IntMap
        (ComponentState (ZonkAny 115) props (ZonkAny 116) (ZonkAny 117)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState (ZonkAny 115) props (ZonkAny 116) (ZonkAny 117)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
        currentContext <- readIORef globalContext
        newVTree <-
          buildVTree events _componentParentId _componentId Draw
            _componentSink logLevel newModel (view currentContext currentProps newModel)
        oldVTree <- readIORef _componentVTree
        _frame <- requestAnimationFrame rAFCallback
        _timestamp :: Double <- takeMVar frame
        Diff.diff (Just oldVTree) (Just newVTree) _componentDOMRef
        FFI.updateRef oldVTree newVTree
        atomicWriteIORef _componentVTree newVTree
        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 = \model
newModel -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
bts (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (ComponentType
-> Maybe StaticKey
-> Int
-> Int
-> Maybe Value
-> Maybe JSVal
-> IO ()
postComponent ComponentType
MODEL_HYDRATE Maybe StaticKey
_componentStaticKey Int
_componentId Int
_componentParentId
          (Value -> Maybe Value
forall a. a -> Maybe a
Just (model -> Value
forall a. ToJSON a => a -> Value
toJSON model
newModel)) Maybe JSVal
forall a. Maybe a
Nothing) IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> IO ()
exception

  let _componentPostEffect = \action
action ->
        Maybe StaticKey -> Int -> Value -> IO ()
postEffect Maybe StaticKey
_componentStaticKey Int
_componentId (action -> Value
forall a. ToJSON a => a -> Value
toJSON action
action) IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> IO ()
exception
#else
  let _componentHydrate = \_ -> pure ()
  let _componentPostEffect = \_ -> pure ()
#endif

  let _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
        { _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
modelCheck
        , _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 :: model -> IO ()
_componentPostEffect :: Sink action
_componentApplyActions :: Seq action
-> model -> props -> context -> (model, [Schedule context action])
_componentApplyActions :: Seq action
-> model -> props -> context -> (model, [Schedule context action])
_componentDOMRef :: JSVal
_componentDraw :: model -> IO ()
_componentHydrate :: model -> IO ()
_componentId :: Int
_componentParentId :: Int
_componentPostEffect :: Sink action
_componentProps :: props
_componentSink :: Sink action
_componentStaticKey :: Maybe StaticKey
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentVTree :: IORef VTree
..
        }

  when isRoot (delegator _componentDOMRef _componentVTree events (logLevel `elem` [DebugEvents, DebugAll]))
  registerComponent vcomponent
  initSubs subs _componentSubThreads _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).
  initialDraw initializedModel events hydrate isRoot comp vcomponent
  forM_ mount _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
  pure vcomponent
-----------------------------------------------------------------------------
initSubs :: [Sub action] -> IORef (Map MisoString ThreadId) -> Sink action -> IO ()
initSubs :: forall action.
[Sub action] -> IORef (Map MisoString ThreadId) -> Sub action
initSubs [Sub action]
subs_ IORef (Map MisoString ThreadId)
_componentSubThreads Sink action
_componentSink = do
  [Sub action] -> (Sub action -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Sub action]
subs_ ((Sub action -> IO ()) -> IO ()) -> (Sub action -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Sub action
sub_ -> do
    threadId <- IO () -> IO ThreadId
forkIO (Sub action
sub_ Sink action
_componentSink)
    subKey <- freshSubId
    atomicModifyIORef' _componentSubThreads $ \Map MisoString ThreadId
m ->
      (MisoString
-> ThreadId -> Map MisoString ThreadId -> Map MisoString ThreadId
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert MisoString
subKey ThreadId
threadId Map MisoString ThreadId
m, ())
-----------------------------------------------------------------------------
-- | Diffs two models, returning True if a redraw is necessary
modelCheck :: Eq model => model -> model -> Bool
modelCheck :: forall a. Eq a => a -> a -> Bool
modelCheck model
c model
n = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
  currentName <- model
c model -> IO (StableName model) -> IO (StableName model)
forall a b. a -> b -> b
`seq` model -> IO (StableName model)
forall a. a -> IO (StableName a)
makeStableName model
c
  updatedName <- n `seq` makeStableName n
  pure (currentName /= updatedName && c /= n)
-----------------------------------------------------------------------------
-- | Checks if the Component is mounted before executing actions
isMounted :: ComponentId -> IO Bool
isMounted :: Int -> IO Bool
isMounted Int
vcompId = Maybe
  (ComponentState
     (ZonkAny 78) (ZonkAny 79) (ZonkAny 80) (ZonkAny 81))
-> Bool
forall a. Maybe a -> Bool
isJust (Maybe
   (ComponentState
      (ZonkAny 78) (ZonkAny 79) (ZonkAny 80) (ZonkAny 81))
 -> Bool)
-> (IntMap
      (ComponentState
         (ZonkAny 78) (ZonkAny 79) (ZonkAny 80) (ZonkAny 81))
    -> Maybe
         (ComponentState
            (ZonkAny 78) (ZonkAny 79) (ZonkAny 80) (ZonkAny 81)))
-> IntMap
     (ComponentState
        (ZonkAny 78) (ZonkAny 79) (ZonkAny 80) (ZonkAny 81))
-> 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
        (ZonkAny 78) (ZonkAny 79) (ZonkAny 80) (ZonkAny 81))
-> Maybe
     (ComponentState
        (ZonkAny 78) (ZonkAny 79) (ZonkAny 80) (ZonkAny 81))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap
   (ComponentState
      (ZonkAny 78) (ZonkAny 79) (ZonkAny 80) (ZonkAny 81))
 -> Bool)
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 78) (ZonkAny 79) (ZonkAny 80) (ZonkAny 81)))
-> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState
        (ZonkAny 78) (ZonkAny 79) (ZonkAny 80) (ZonkAny 81)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 78) (ZonkAny 79) (ZonkAny 80) (ZonkAny 81)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 78) (ZonkAny 79) (ZonkAny 80) (ZonkAny 81)))
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
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
mts (Waiter -> IO ()
wait Waiter
btsReady)
#endif
    IO (Maybe (Int, Seq (ZonkAny 87)))
forall action. IO (Maybe (Int, Seq action))
getBatch IO (Maybe (Int, Seq (ZonkAny 87)))
-> (Maybe (Int, Seq (ZonkAny 87)) -> 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 (ZonkAny 87))
Nothing -> Waiter -> IO ()
wait Waiter
globalWaiter
      Just (Int
vcompId, Seq (ZonkAny 87)
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 '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.
            vcomps <- IORef
  (IntMap
     (ComponentState
        (ZonkAny 88) (ZonkAny 89) (ZonkAny 90) (ZonkAny 91)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 88) (ZonkAny 89) (ZonkAny 90) (ZonkAny 91)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 88) (ZonkAny 89) (ZonkAny 90) (ZonkAny 91)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
            forM_ (IM.elems vcomps) $ \ComponentState {Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
ZonkAny 89
ZonkAny 90
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
ZonkAny 89 -> ZonkAny 89 -> IO ()
ZonkAny 90 -> IO ()
ZonkAny 90 -> ZonkAny 90 -> Bool
Sink (ZonkAny 91)
Seq (ZonkAny 91)
-> ZonkAny 90
-> ZonkAny 89
-> ZonkAny 88
-> (ZonkAny 90, [Schedule (ZonkAny 88) (ZonkAny 91)])
Value -> Maybe (ZonkAny 91)
_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])
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: ZonkAny 89
_prevComponentProps :: ZonkAny 89
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink (ZonkAny 91)
_componentPostEffect :: Sink (ZonkAny 91)
_componentModel :: ZonkAny 90
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe (ZonkAny 91)
_componentDraw :: ZonkAny 90 -> IO ()
_componentHydrate :: ZonkAny 90 -> IO ()
_componentPropsPhase :: ZonkAny 89 -> ZonkAny 89 -> IO ()
_componentModelDirty :: ZonkAny 90 -> ZonkAny 90 -> Bool
_componentApplyActions :: Seq (ZonkAny 91)
-> ZonkAny 90
-> ZonkAny 89
-> ZonkAny 88
-> (ZonkAny 90, [Schedule (ZonkAny 88) (ZonkAny 91)])
_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) (ZonkAny 90 -> IO ()
_componentDraw ZonkAny 90
_componentModel)
        | Int
vcompId Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 -> do
            -- props propagation, negated 'ComponentId' indicates render-phase only.
            vcomps <- IORef
  (IntMap
     (ComponentState
        (ZonkAny 92) (ZonkAny 93) (ZonkAny 94) (ZonkAny 95)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 92) (ZonkAny 93) (ZonkAny 94) (ZonkAny 95)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 92) (ZonkAny 93) (ZonkAny 94) (ZonkAny 95)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
            forM_ (IM.lookup (negate vcompId) vcomps) $ \ComponentState {Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
ZonkAny 93
ZonkAny 94
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
ZonkAny 93 -> ZonkAny 93 -> IO ()
ZonkAny 94 -> IO ()
ZonkAny 94 -> ZonkAny 94 -> Bool
Sink (ZonkAny 95)
Seq (ZonkAny 95)
-> ZonkAny 94
-> ZonkAny 93
-> ZonkAny 92
-> (ZonkAny 94, [Schedule (ZonkAny 92) (ZonkAny 95)])
Value -> Maybe (ZonkAny 95)
_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])
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: ZonkAny 93
_prevComponentProps :: ZonkAny 93
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink (ZonkAny 95)
_componentPostEffect :: Sink (ZonkAny 95)
_componentModel :: ZonkAny 94
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe (ZonkAny 95)
_componentDraw :: ZonkAny 94 -> IO ()
_componentHydrate :: ZonkAny 94 -> IO ()
_componentPropsPhase :: ZonkAny 93 -> ZonkAny 93 -> IO ()
_componentModelDirty :: ZonkAny 94 -> ZonkAny 94 -> Bool
_componentApplyActions :: Seq (ZonkAny 95)
-> ZonkAny 94
-> ZonkAny 93
-> ZonkAny 92
-> (ZonkAny 94, [Schedule (ZonkAny 92) (ZonkAny 95)])
_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
$ ZonkAny 94 -> IO ()
_componentDraw ZonkAny 94
_componentModel
              ZonkAny 93 -> ZonkAny 93 -> IO ()
_componentPropsPhase ZonkAny 93
_prevComponentProps ZonkAny 93
_componentProps

      Just (Int
vcompId, Seq (ZonkAny 87)
actions) -> do
        mounted <- Int -> IO Bool
isMounted Int
vcompId
        when mounted (run vcompId 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
      rendered <- Int -> Seq action -> IO (Maybe Int)
forall action. Int -> Seq action -> IO (Maybe Int)
commit Int
vcompId Seq action
actions
      when (not mts) (mapM_ renderComponent 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
      currentContext <- forall a. IORef a -> IO a
readIORef @context IORef context
forall context. IORef context
globalContext
      vcomps <- readIORef components
      let ComponentState {..} = vcomps IM.! vcompId
          (updatedModel, schedules) =
            _componentApplyActions events _componentModel _componentProps currentContext
      -- Route each scheduled effect. A plain '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.
      forM_ schedules $ \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)
      updatedContext <- readIORef 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.
      when (not mts && currentContext /= updatedContext) 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 not mts && _componentModelDirty _componentModel updatedModel
        then do
          modifyComponent _componentId (componentModel .= updatedModel)
          pure (Just vcompId)
        else
          pure Nothing
-----------------------------------------------------------------------------
-- | Perform a top-down rendering of the 'Component' tree.
--
-- We lookup the components each time to account for unmounting.
--
renderComponent :: ComponentId -> IO ()
renderComponent :: Int -> IO ()
renderComponent Int
vcompId = Int
-> IntMap
     (ComponentState
        (ZonkAny 74) (ZonkAny 75) (ZonkAny 76) (ZonkAny 77))
-> Maybe
     (ComponentState
        (ZonkAny 74) (ZonkAny 75) (ZonkAny 76) (ZonkAny 77))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap
   (ComponentState
      (ZonkAny 74) (ZonkAny 75) (ZonkAny 76) (ZonkAny 77))
 -> Maybe
      (ComponentState
         (ZonkAny 74) (ZonkAny 75) (ZonkAny 76) (ZonkAny 77)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 74) (ZonkAny 75) (ZonkAny 76) (ZonkAny 77)))
-> IO
     (Maybe
        (ComponentState
           (ZonkAny 74) (ZonkAny 75) (ZonkAny 76) (ZonkAny 77)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState
        (ZonkAny 74) (ZonkAny 75) (ZonkAny 76) (ZonkAny 77)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 74) (ZonkAny 75) (ZonkAny 76) (ZonkAny 77)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 74) (ZonkAny 75) (ZonkAny 76) (ZonkAny 77)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components IO
  (Maybe
     (ComponentState
        (ZonkAny 74) (ZonkAny 75) (ZonkAny 76) (ZonkAny 77)))
-> (Maybe
      (ComponentState
         (ZonkAny 74) (ZonkAny 75) (ZonkAny 76) (ZonkAny 77))
    -> 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 (ZonkAny 74) (ZonkAny 75) (ZonkAny 76) (ZonkAny 77)
 -> IO ())
-> Maybe
     (ComponentState
        (ZonkAny 74) (ZonkAny 75) (ZonkAny 76) (ZonkAny 77))
-> 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
ZonkAny 75
ZonkAny 76
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
ZonkAny 75 -> ZonkAny 75 -> IO ()
ZonkAny 76 -> IO ()
ZonkAny 76 -> ZonkAny 76 -> Bool
Sink (ZonkAny 77)
Seq (ZonkAny 77)
-> ZonkAny 76
-> ZonkAny 75
-> ZonkAny 74
-> (ZonkAny 76, [Schedule (ZonkAny 74) (ZonkAny 77)])
Value -> Maybe (ZonkAny 77)
_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])
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: ZonkAny 75
_prevComponentProps :: ZonkAny 75
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink (ZonkAny 77)
_componentPostEffect :: Sink (ZonkAny 77)
_componentModel :: ZonkAny 76
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe (ZonkAny 77)
_componentDraw :: ZonkAny 76 -> IO ()
_componentHydrate :: ZonkAny 76 -> IO ()
_componentPropsPhase :: ZonkAny 75 -> ZonkAny 75 -> IO ()
_componentModelDirty :: ZonkAny 76 -> ZonkAny 76 -> Bool
_componentApplyActions :: Seq (ZonkAny 77)
-> ZonkAny 76
-> ZonkAny 75
-> ZonkAny 74
-> (ZonkAny 76, [Schedule (ZonkAny 74) (ZonkAny 77)])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} -> do
  ZonkAny 76 -> IO ()
_componentDraw ZonkAny 76
_componentModel
  ZonkAny 76 -> IO ()
_componentHydrate ZonkAny 76
_componentModel
-----------------------------------------------------------------------------
-- | Modify a single t'Component p m a' at a t'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, ())
-----------------------------------------------------------------------------
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 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 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 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])
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_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
  currentContext <- IORef context -> IO context
forall a. IORef a -> IO a
readIORef IORef context
forall context. IORef context
globalContext
  vtree <- buildVTree events _componentParentId _componentId hydrate _componentSink logLevel
    initializedModel (view currentContext _componentProps initializedModel)
#ifdef BENCH
  end <- FFI.now
  when isRoot $ FFI.consoleLog $ ms (printf "buildVTree: %.3f ms" (end - start) :: String)
#endif
  case 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
    Hydrate
Hydrate -> do
      if Bool
isRoot
        then do
          hydrated <- LogLevel -> JSVal -> VTree -> IO Bool
Hydrate.hydrate LogLevel
logLevel JSVal
_componentDOMRef VTree
vtree
          if hydrated
            then do
              atomicWriteIORef _componentVTree vtree
            else do
              newTree <-
                buildVTree events _componentParentId _componentId Draw
                  _componentSink logLevel initializedModel (view currentContext _componentProps initializedModel)
              Diff.diff Nothing (Just newTree) _componentDOMRef
              atomicWriteIORef _componentVTree newTree
        else
          IORef VTree -> VTree -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef VTree
_componentVTree VTree
vtree
-----------------------------------------------------------------------------
-- | 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 'props'
-- feature.
enqueueSchedule :: ComponentId -> IO ()
enqueueSchedule :: Int -> IO ()
enqueueSchedule Int
vcompId =
  IORef (Queue (ZonkAny 43))
-> (Queue (ZonkAny 43) -> (Queue (ZonkAny 43), ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Queue (ZonkAny 43))
forall action. IORef (Queue action)
globalQueue ((Queue (ZonkAny 43) -> (Queue (ZonkAny 43), ())) -> IO ())
-> (Queue (ZonkAny 43) -> (Queue (ZonkAny 43), ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Queue (ZonkAny 43)
q ->
     (Queue (ZonkAny 43)
q Queue (ZonkAny 43)
-> (Queue (ZonkAny 43) -> Queue (ZonkAny 43)) -> Queue (ZonkAny 43)
forall a b. a -> (a -> b) -> b
& Lens (Queue (ZonkAny 43)) (Seq Int)
forall action. Lens (Queue action) (Seq Int)
queueSchedule Lens (Queue (ZonkAny 43)) (Seq Int)
-> (Seq Int -> Seq Int) -> Queue (ZonkAny 43) -> Queue (ZonkAny 43)
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 (ZonkAny 44))
-> (Queue (ZonkAny 44) -> (Queue (ZonkAny 44), ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Queue (ZonkAny 44))
forall action. IORef (Queue action)
globalQueue ((Queue (ZonkAny 44) -> (Queue (ZonkAny 44), ())) -> IO ())
-> (Queue (ZonkAny 44) -> (Queue (ZonkAny 44), ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Queue (ZonkAny 44)
q ->
     (Queue (ZonkAny 44)
q Queue (ZonkAny 44)
-> (Queue (ZonkAny 44) -> Queue (ZonkAny 44)) -> Queue (ZonkAny 44)
forall a b. a -> (a -> b) -> b
& Lens (Queue (ZonkAny 44)) (Seq Int)
forall action. Lens (Queue action) (Seq Int)
queueSchedule Lens (Queue (ZonkAny 44)) (Seq Int)
-> (Seq Int -> Seq Int) -> Queue (ZonkAny 44) -> Queue (ZonkAny 44)
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 t'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
-----------------------------------------------------------------------------
#ifdef NATIVE
btsReady :: Waiter
{-# NOINLINE btsReady #-}
btsReady :: Waiter
btsReady = IO Waiter -> Waiter
forall a. IO a -> a
unsafePerformIO IO Waiter
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' '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 :: IORef Bool
readyReceived = IO (IORef Bool) -> IORef Bool
forall a. IO a -> a
unsafePerformIO (Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
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 :: IORef Bool
readyAcked = IO (IORef Bool) -> IORef Bool
forall a. IO a -> a
unsafePerformIO (Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
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 'globalContext' cell would otherwise still hold @undefined@. See
-- 'Miso.setContext' for the full explanation.
--
-- @since 1.12.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 t'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 'initialize' 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
  -- 'initialize' 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
  --   '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 {..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink ->
    Int
-> State
     (ComponentState
        (ZonkAny 50) (ZonkAny 51) (ZonkAny 52) (ZonkAny 53))
     ()
-> IO ()
forall context props model action a.
Int -> State (ComponentState context props model action) a -> IO ()
modifyComponent Int
_componentInfoId (State
   (ComponentState
      (ZonkAny 50) (ZonkAny 51) (ZonkAny 52) (ZonkAny 53))
   ()
 -> IO ())
-> State
     (ComponentState
        (ZonkAny 50) (ZonkAny 51) (ZonkAny 52) (ZonkAny 53))
     ()
-> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Lens
  (ComponentState
     (ZonkAny 50) (ZonkAny 51) (ZonkAny 52) (ZonkAny 53))
  (Map MisoString (Value -> IO ()))
forall context props model action.
Lens
  (ComponentState context props model action)
  (Map MisoString (Value -> IO ()))
componentTopics Lens
  (ComponentState
     (ZonkAny 50) (ZonkAny 51) (ZonkAny 52) (ZonkAny 53))
  (Map MisoString (Value -> IO ()))
-> (Map MisoString (Value -> IO ())
    -> Map MisoString (Value -> IO ()))
-> State
     (ComponentState
        (ZonkAny 50) (ZonkAny 51) (ZonkAny 52) (ZonkAny 53))
     ()
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 {..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ modifyComponent _componentInfoId $ do
    componentTopics %= M.delete 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 (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)
 -> IO ())
-> [ComponentState
      (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)]
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ComponentState (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)
-> IO ()
forall {context} {props} {model} {action}.
ComponentState context props model action -> IO ()
go ([ComponentState
    (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)]
 -> IO ())
-> (IntMap
      (ComponentState
         (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42))
    -> [ComponentState
          (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)])
-> IntMap
     (ComponentState
        (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42))
-> 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
     (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42))
-> [ComponentState
      (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)]
forall a. IntMap a -> [a]
IM.elems (IntMap
   (ComponentState
      (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42))
 -> IO ())
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)))
-> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef
  (IntMap
     (ComponentState
        (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)))
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])
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_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
  x <- IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
subIds ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
y -> (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
y)
  pure ("miso-sub-id-" <> ms x)
-----------------------------------------------------------------------------
-- | 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 'Component' tree is present.
-- * Unmount in descending order (top-level 'Component' removed last), invoking finalizers
-- * Kill the scheduler thread (a new one is created on ':r').
-- * Erase all 'Component'
-- * Erase '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
  vcomps <- IORef
  (IntMap
     (ComponentState context (ZonkAny 71) (ZonkAny 72) (ZonkAny 73)))
-> IO
     (IntMap
        (ComponentState context (ZonkAny 71) (ZonkAny 72) (ZonkAny 73)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState context (ZonkAny 71) (ZonkAny 72) (ZonkAny 73)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
  when (IM.size vcomps > 0) $ do
    killThread =<< readIORef schedulerThread
    if live
      then do
        -- In hot reload we want to reset subs and connections, and free lifecycle hooks
        forM_ (IM.toDescList vcomps) $ \(Int
_, cs :: ComponentState context (ZonkAny 71) (ZonkAny 72) (ZonkAny 73)
cs@ComponentState{Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
ZonkAny 71
ZonkAny 72
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
ZonkAny 71 -> ZonkAny 71 -> IO ()
ZonkAny 72 -> IO ()
ZonkAny 72 -> ZonkAny 72 -> Bool
Sink (ZonkAny 73)
Seq (ZonkAny 73)
-> ZonkAny 72
-> ZonkAny 71
-> context
-> (ZonkAny 72, [Schedule context (ZonkAny 73)])
Value -> Maybe (ZonkAny 73)
_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])
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: ZonkAny 71
_prevComponentProps :: ZonkAny 71
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink (ZonkAny 73)
_componentPostEffect :: Sink (ZonkAny 73)
_componentModel :: ZonkAny 72
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe (ZonkAny 73)
_componentDraw :: ZonkAny 72 -> IO ()
_componentHydrate :: ZonkAny 72 -> IO ()
_componentPropsPhase :: ZonkAny 71 -> ZonkAny 71 -> IO ()
_componentModelDirty :: ZonkAny 72 -> ZonkAny 72 -> Bool
_componentApplyActions :: Seq (ZonkAny 73)
-> ZonkAny 72
-> ZonkAny 71
-> context
-> (ZonkAny 72, [Schedule context (ZonkAny 73)])
_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 (ZonkAny 71) (ZonkAny 72) (ZonkAny 73)
-> IO ()
forall {context} {props} {model} {action}.
ComponentState context props model action -> IO ()
freeLifecycleHooks ComponentState context (ZonkAny 71) (ZonkAny 72) (ZonkAny 73)
cs
      else do
        -- We can do a full unmount if we're not doing hot reload
        forM_ (IM.toDescList vcomps) $ \(Int
_, ComponentState context (ZonkAny 71) (ZonkAny 72) (ZonkAny 73)
_vcomp_) ->
          forall context props model action.
Eq context =>
ComponentState context props model action -> IO ()
unmountComponent @context ComponentState context (ZonkAny 71) (ZonkAny 72) (ZonkAny 73)
_vcomp_
    atomicWriteIORef componentIds topLevelComponentId
    atomicWriteIORef globalQueue mempty
    unless live (atomicWriteIORef components mempty)
    abort <- domRef ! "abort"
    isnull <- isNull abort
    unless isnull $ do
      void $ (domRef # "abort") ()
    yield
    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 '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])
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_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
       currentContext <- forall a. IORef a -> IO a
readIORef @context IORef context
forall context. IORef context
globalContext
       case _componentApplyActions actions _componentModel _componentProps 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 '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, ())
           newContext <- IORef context -> IO context
forall a. IORef a -> IO a
readIORef IORef context
forall context. IORef context
globalContext
           when (not mts && currentContext /= newContext) 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])
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_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
  head_ <- IO JSVal
FFI.getHead
  forM_ _componentScripts $ \JSVal
domRef -> do
    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]
    when contains (FFI.removeChild head_ 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])
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_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 comp) <- IORef VTree -> IO VTree
forall a. IORef a -> IO a
readIORef IORef VTree
_componentVTree
  mapM_ freeFunction =<< fromJSVal =<< comp ! ("mount" :: MisoString)
  mapM_ freeFunction =<< fromJSVal =<< comp ! ("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])
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_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
-> State
     (ComponentState
        (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61))
     ()
-> IO ()
forall context props model action a.
Int -> State (ComponentState context props model action) a -> IO ()
modifyComponent Int
_componentParentId (State
   (ComponentState
      (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61))
   ()
 -> IO ())
-> State
     (ComponentState
        (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61))
     ()
-> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Lens
  (ComponentState
     (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61))
  ComponentIds
forall context props model action.
Lens (ComponentState context props model action) ComponentIds
childrenLens
  (ComponentState
     (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61))
  ComponentIds
-> LensCore (Maybe ()) ComponentIds
-> LensCore
     (Maybe ())
     (ComponentState
        (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61))
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
     (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61))
-> Maybe ()
-> State
     (ComponentState
        (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61))
     ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> field -> m ()
.= Maybe ()
forall a. Maybe a
Nothing
  IORef
  (IntMap
     (ComponentState
        (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65)))
-> (IntMap
      (ComponentState
         (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65))
    -> (IntMap
          (ComponentState
             (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65)),
        ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef
  (IntMap
     (ComponentState
        (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components ((IntMap
    (ComponentState
       (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65))
  -> (IntMap
        (ComponentState
           (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65)),
      ()))
 -> IO ())
-> (IntMap
      (ComponentState
         (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65))
    -> (IntMap
          (ComponentState
             (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65)),
        ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \IntMap
  (ComponentState
     (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65))
m -> (Int
-> IntMap
     (ComponentState
        (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65))
-> IntMap
     (ComponentState
        (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65))
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
_componentId IntMap
  (ComponentState
     (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65))
m, ())
#ifdef NATIVE
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
bts (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ComponentType
-> Maybe StaticKey
-> Int
-> Int
-> Maybe Value
-> Maybe JSVal
-> IO ()
postComponent ComponentType
UNMOUNT Maybe StaticKey
_componentStaticKey Int
_componentId Int
_componentParentId Maybe Value
forall a. Maybe a
Nothing Maybe JSVal
forall a. Maybe a
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
    vnode_ <- MisoString -> Namespace -> MisoString -> IO Object
createNode MisoString
"vnode" Namespace
ns MisoString
tag
    setAttrs vnode_ attrs snk vcompId logLevel_ events_ 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
    vchildren <- toJSVal =<< procreate vnode_
    FFI.set "children" vchildren vnode_
    flip (FFI.set "type") vnode_ =<< toJSVal VNodeType
    pure (VTree vnode_)
      where
        procreate :: v -> IO [Object]
procreate v
parentVTree = do
          kidsViews <- ([Object] -> View context model action -> IO [Object])
-> [Object] -> [View context model action] -> IO [Object]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (v -> [Object] -> View context model action -> IO [Object]
forall {context} {v}.
(Eq context, ToJSVal v) =>
v -> [Object] -> View context model action -> IO [Object]
buildKid v
parentVTree) [] [View context model action]
kids
          let ordered = [Object] -> [Object]
forall a. [a] -> [a]
reverse [Object]
kidsViews
          setNextSibling ordered
          pure 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 -> [Object] -> View context model action -> IO [Object]
buildKid v
_ [Object]
acc (VFrag Maybe Key
_ []) = [Object] -> IO [Object]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Object]
acc
              buildKid v
p [Object]
acc View context model action
kid = do
                VTree 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
                FFI.set "parent" p child
                pure (child : acc)
  VText Maybe Key
key MisoString
t -> do
    vtree <- IO Object
create
    flip (FFI.set "type") vtree =<< toJSVal VTextType
    forM_ key $ \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
    FFI.set "ns" ("text" :: MisoString) vtree
    FFI.set "text" t vtree
    pure (VTree vtree)
  VFrag Maybe Key
maybeKey [View context model action]
kids -> do
    frag <- IO Object
create
    FFI.set "type" VFragType frag
    forM_ maybeKey $ \(Key MisoString
k) -> MisoString -> MisoString -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"key" MisoString
k Object
frag
    vchildren <- toJSVal =<< procreateFragChildren frag
    FFI.set "children" vchildren frag
    pure (VTree frag)
      where
        procreateFragChildren :: p -> IO [Object]
procreateFragChildren p
parentVTree = do
          kidsViews <- ([Object] -> View context model action -> IO [Object])
-> [Object] -> [View context model action] -> IO [Object]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [Object] -> View context model action -> IO [Object]
forall {context}.
Eq context =>
[Object] -> View context model action -> IO [Object]
buildKid [] [View context model action]
kids
          let ordered = [Object] -> [Object]
forall a. [a] -> [a]
reverse [Object]
kidsViews
          zipWithM_ (flip setField "nextSibling") ordered (drop 1 ordered)
          pure ordered
            where
              buildKid :: [Object] -> View context model action -> IO [Object]
buildKid [Object]
acc (VFrag Maybe Key
_ []) = [Object] -> IO [Object]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Object]
acc
              buildKid [Object]
acc View context model action
kid = do
                VTree 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
                FFI.set "parent" parentVTree child
                pure (child : acc)
  where
    -- 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
      comp <- IO Object
create
      mountCallback <- do
        syncCallback1' $ \JSVal
parent_ -> do
          ComponentState {..} <- 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, ToJSON model, ToJSON props,
 ToJSON action, FromJSON action) =>
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_)
          modifyComponent vcompId (children %= IS.insert _componentId)
          vtree <- toJSVal =<< readIORef _componentVTree
          FFI.set "parent" comp (Object vtree)
          obj <- create
          setProp "componentId" _componentId obj
          setProp "componentTree" vtree obj
          toJSVal obj
      unmountCallback <- toJSVal =<< do
        FFI.syncCallback1 $ \JSVal
vcompId_ -> do
          componentId_ <- JSVal -> IO Int
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked JSVal
vcompId_
          IM.lookup componentId_ <$> readIORef components >>= \case
            Maybe (ComponentState context (ZonkAny 103) (ZonkAny 104) action)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just ComponentState context (ZonkAny 103) (ZonkAny 104) 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 (ZonkAny 103) (ZonkAny 104) action
-> Sink action
forall context props model action.
ComponentState context props model action -> Sink action
_componentSink ComponentState context (ZonkAny 103) (ZonkAny 104) action
componentState)
              forall context props model action.
Eq context =>
ComponentState context props model action -> IO ()
unmountComponent @context ComponentState context (ZonkAny 103) (ZonkAny 104) 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.
      diffPropsCallback <- toJSVal =<< do
        syncCallback $ do
          componentId_ <- fromJSValUnchecked =<< comp ! ("componentId" :: MisoString)
          currentProps <- _componentProps . (IM.! componentId_) <$> readIORef components
          when (currentProps /= newProps) $ do
            modifyComponent componentId_ $ do
              componentProps .= newProps
              prevComponentProps .= currentProps
            enqueueSchedule componentId_
      FFI.set "diffProps" diffPropsCallback comp
      FFI.set "child" jsNull comp
      forM_ maybeKey (\Key
key -> MisoString -> Key -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"key" Key
key Object
comp)
      FFI.set "mount" mountCallback comp
      FFI.set "unmount" unmountCallback comp
      FFI.set "eventPropagation" (eventPropagation app) comp
      FFI.set "type" VCompType comp
      pure (VTree 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
  vnode_ <- IO Object
create
  cssObj <- create
  propsObj <- create
  eventsObj <- create
  captures <- create
  bubbles <- create
  FFI.set "css" cssObj vnode_
  FFI.set "type" typ vnode_
  FFI.set "props" propsObj vnode_
  FFI.set "events" eventsObj vnode_
  FFI.set "captures" captures eventsObj
  FFI.set "bubbles" bubbles eventsObj
  FFI.set "ns" ns vnode_
  FFI.set "tag" tag vnode_
  pure vnode_
-----------------------------------------------------------------------------
-- | Helper function for populating "props" and "css" fields on a virtual
-- DOM node
setAttrs
  :: Object
  -> [Attribute 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
      value <- Value -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal Value
v
      FFI.set "key" value vnode_
    ClassList [MisoString]
classes ->
      JSVal -> [MisoString] -> IO ()
FFI.populateClass JSVal
jval [MisoString]
classes
    Property MisoString
k Value
v -> do
      value <- Value -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal Value
v
      o <- getProp "props" vnode_
      FFI.set k value (Object o)
    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
      cssObj <- MisoString -> Object -> IO JSVal
forall o. ToObject o => MisoString -> o -> IO JSVal
getProp MisoString
"css" Object
vnode_
      forM_ (M.toList styles) $ \(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)
-----------------------------------------------------------------------------
-- | 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
      o <- IO Object
create
      imports <- create
      forM_ importMap $ \(MisoString
k,MisoString
v) ->
        MisoString -> MisoString -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
k MisoString
v Object
imports
      FFI.set "imports" imports o
      FFI.addScriptImportMap
        =<< jsonStringify
        =<< toJSVal 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 action
  -- ^ The 'Sub'
  -> Effect context props model action
startSub :: forall subKey action context props model.
ToMisoString subKey =>
subKey -> Sub action -> Effect context props model action
startSub subKey
subKey Sub action
sub = do
  ComponentInfo {..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    IM.lookup _componentInfoId <$> liftIO (readIORef components) >>= \case
      Maybe (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) action)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just compState :: ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) action
compState@ComponentState {Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
ZonkAny 1
ZonkAny 2
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
Sink action
ZonkAny 1 -> ZonkAny 1 -> IO ()
ZonkAny 2 -> IO ()
ZonkAny 2 -> ZonkAny 2 -> Bool
Seq action
-> ZonkAny 2
-> ZonkAny 1
-> ZonkAny 0
-> (ZonkAny 2, [Schedule (ZonkAny 0) 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])
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: ZonkAny 1
_prevComponentProps :: ZonkAny 1
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink action
_componentPostEffect :: Sink action
_componentModel :: ZonkAny 2
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe action
_componentDraw :: ZonkAny 2 -> IO ()
_componentHydrate :: ZonkAny 2 -> IO ()
_componentPropsPhase :: ZonkAny 1 -> ZonkAny 1 -> IO ()
_componentModelDirty :: ZonkAny 2 -> ZonkAny 2 -> Bool
_componentApplyActions :: Seq action
-> ZonkAny 2
-> ZonkAny 1
-> ZonkAny 0
-> (ZonkAny 2, [Schedule (ZonkAny 0) action])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} -> do
        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 mtid of
          Maybe ThreadId
Nothing ->
            ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) action -> IO ()
forall {context} {props} {model}.
ComponentState context props model action -> IO ()
startThread ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) action
compState
          Just ThreadId
tid -> do
            status <- ThreadId -> IO ThreadStatus
threadStatus ThreadId
tid
            case status of
              ThreadStatus
ThreadFinished -> ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) action -> IO ()
forall {context} {props} {model}.
ComponentState context props model action -> IO ()
startThread ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) action
compState
              ThreadStatus
ThreadDied -> ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) action -> IO ()
forall {context} {props} {model}.
ComponentState context props model action -> IO ()
startThread ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) 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 {props
model
Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
Sink action
props -> props -> IO ()
model -> IO ()
model -> model -> Bool
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])
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_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
      tid <- IO () -> IO ThreadId
forkIO (Sub action
sub Sink action
_componentSink)
      atomicModifyIORef' _componentSubThreads $ \Map MisoString ThreadId
m ->
        (MisoString
-> ThreadId -> Map MisoString ThreadId -> Map MisoString ThreadId
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (subKey -> MisoString
forall str. ToMisoString str => str -> MisoString
ms subKey
subKey) ThreadId
tid Map MisoString ThreadId
m, ())
-----------------------------------------------------------------------------
-- | Stops a named 'Sub' dynamically, during the life of a 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
  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_ $ do
    IM.lookup vcompId <$> readIORef components >>= \case
      Maybe
  (ComponentState (ZonkAny 3) (ZonkAny 4) (ZonkAny 5) (ZonkAny 6))
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
ZonkAny 4
ZonkAny 5
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
ZonkAny 4 -> ZonkAny 4 -> IO ()
ZonkAny 5 -> IO ()
ZonkAny 5 -> ZonkAny 5 -> Bool
Sink (ZonkAny 6)
Seq (ZonkAny 6)
-> ZonkAny 5
-> ZonkAny 4
-> ZonkAny 3
-> (ZonkAny 5, [Schedule (ZonkAny 3) (ZonkAny 6)])
Value -> Maybe (ZonkAny 6)
_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])
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: ZonkAny 4
_prevComponentProps :: ZonkAny 4
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink (ZonkAny 6)
_componentPostEffect :: Sink (ZonkAny 6)
_componentModel :: ZonkAny 5
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe (ZonkAny 6)
_componentDraw :: ZonkAny 5 -> IO ()
_componentHydrate :: ZonkAny 5 -> IO ()
_componentPropsPhase :: ZonkAny 4 -> ZonkAny 4 -> IO ()
_componentModelDirty :: ZonkAny 5 -> ZonkAny 5 -> Bool
_componentApplyActions :: Seq (ZonkAny 6)
-> ZonkAny 5
-> ZonkAny 4
-> ZonkAny 3
-> (ZonkAny 5, [Schedule (ZonkAny 3) (ZonkAny 6)])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} -> do
        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)
        forM_ mtid $ \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 (ZonkAny 7) (ZonkAny 8) (ZonkAny 9) (ZonkAny 10))
-> Maybe
     (ComponentState (ZonkAny 7) (ZonkAny 8) (ZonkAny 9) (ZonkAny 10))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap
   (ComponentState (ZonkAny 7) (ZonkAny 8) (ZonkAny 9) (ZonkAny 10))
 -> Maybe
      (ComponentState (ZonkAny 7) (ZonkAny 8) (ZonkAny 9) (ZonkAny 10)))
-> IO
     (IntMap
        (ComponentState (ZonkAny 7) (ZonkAny 8) (ZonkAny 9) (ZonkAny 10)))
-> IO
     (Maybe
        (ComponentState (ZonkAny 7) (ZonkAny 8) (ZonkAny 9) (ZonkAny 10)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState (ZonkAny 7) (ZonkAny 8) (ZonkAny 9) (ZonkAny 10)))
-> IO
     (IntMap
        (ComponentState (ZonkAny 7) (ZonkAny 8) (ZonkAny 9) (ZonkAny 10)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState (ZonkAny 7) (ZonkAny 8) (ZonkAny 9) (ZonkAny 10)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components IO
  (Maybe
     (ComponentState (ZonkAny 7) (ZonkAny 8) (ZonkAny 9) (ZonkAny 10)))
-> (Maybe
      (ComponentState (ZonkAny 7) (ZonkAny 8) (ZonkAny 9) (ZonkAny 10))
    -> 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 (ZonkAny 7) (ZonkAny 8) (ZonkAny 9) (ZonkAny 10))
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
ZonkAny 8
ZonkAny 9
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
ZonkAny 8 -> ZonkAny 8 -> IO ()
ZonkAny 9 -> IO ()
ZonkAny 9 -> ZonkAny 9 -> Bool
Sink (ZonkAny 10)
Seq (ZonkAny 10)
-> ZonkAny 9
-> ZonkAny 8
-> ZonkAny 7
-> (ZonkAny 9, [Schedule (ZonkAny 7) (ZonkAny 10)])
Value -> Maybe (ZonkAny 10)
_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])
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: ZonkAny 8
_prevComponentProps :: ZonkAny 8
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink (ZonkAny 10)
_componentPostEffect :: Sink (ZonkAny 10)
_componentModel :: ZonkAny 9
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe (ZonkAny 10)
_componentDraw :: ZonkAny 9 -> IO ()
_componentHydrate :: ZonkAny 9 -> IO ()
_componentPropsPhase :: ZonkAny 8 -> ZonkAny 8 -> IO ()
_componentModelDirty :: ZonkAny 9 -> ZonkAny 9 -> Bool
_componentApplyActions :: Seq (ZonkAny 10)
-> ZonkAny 9
-> ZonkAny 8
-> ZonkAny 7
-> (ZonkAny 9, [Schedule (ZonkAny 7) (ZonkAny 10)])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} ->
      case Value -> Maybe (ZonkAny 10)
_componentMailbox (message -> Value
forall a. ToJSON a => a -> Value
toJSON message
msg) of
        Maybe (ZonkAny 10)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just ZonkAny 10
action ->
          Sink (ZonkAny 10)
_componentSink ZonkAny 10
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 {..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ (mail _componentInfoParentId 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 {..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ (climb _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
        (ZonkAny 11) (ZonkAny 12) (ZonkAny 13) (ZonkAny 14))
-> Maybe
     (ComponentState
        (ZonkAny 11) (ZonkAny 12) (ZonkAny 13) (ZonkAny 14))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap
   (ComponentState
      (ZonkAny 11) (ZonkAny 12) (ZonkAny 13) (ZonkAny 14))
 -> Maybe
      (ComponentState
         (ZonkAny 11) (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 11) (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)))
-> IO
     (Maybe
        (ComponentState
           (ZonkAny 11) (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState
        (ZonkAny 11) (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 11) (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 11) (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components IO
  (Maybe
     (ComponentState
        (ZonkAny 11) (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)))
-> (Maybe
      (ComponentState
         (ZonkAny 11) (ZonkAny 12) (ZonkAny 13) (ZonkAny 14))
    -> 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
     (ZonkAny 11) (ZonkAny 12) (ZonkAny 13) (ZonkAny 14))
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just ComponentState (ZonkAny 11) (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)
cs -> Int -> IO ()
climb (ComponentState (ZonkAny 11) (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)
-> Int
forall context props model action.
ComponentState context props model action -> Int
_componentParentId ComponentState (ZonkAny 11) (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)
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 {..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    ComponentState {..} <- (IM.! _componentInfoId) <$> readIORef components
    forM_ (IS.toList _componentChildren) (flip mail msg)
-----------------------------------------------------------------------------
-- | Send any @ToJSON message => message@ to all descendants t'Miso.Types.Component' mailbox
--
-- Unlike 'mailChildren', this is relevant for all descendants '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 {..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    cs <- (IM.! _componentInfoId) <$> readIORef components
    forM_ (IS.toList (_componentChildren cs)) $ \Int
child -> do
      ComponentState (ZonkAny 23) (ZonkAny 24) (ZonkAny 25) (ZonkAny 26)
-> IO ()
forall {context} {props} {model} {action}.
ComponentState context props model action -> IO ()
walk (ComponentState (ZonkAny 23) (ZonkAny 24) (ZonkAny 25) (ZonkAny 26)
 -> IO ())
-> (IntMap
      (ComponentState
         (ZonkAny 23) (ZonkAny 24) (ZonkAny 25) (ZonkAny 26))
    -> ComponentState
         (ZonkAny 23) (ZonkAny 24) (ZonkAny 25) (ZonkAny 26))
-> IntMap
     (ComponentState
        (ZonkAny 23) (ZonkAny 24) (ZonkAny 25) (ZonkAny 26))
-> 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
     (ZonkAny 23) (ZonkAny 24) (ZonkAny 25) (ZonkAny 26))
-> Int
-> ComponentState
     (ZonkAny 23) (ZonkAny 24) (ZonkAny 25) (ZonkAny 26)
forall a. IntMap a -> Int -> a
IM.! Int
child) (IntMap
   (ComponentState
      (ZonkAny 23) (ZonkAny 24) (ZonkAny 25) (ZonkAny 26))
 -> IO ())
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 23) (ZonkAny 24) (ZonkAny 25) (ZonkAny 26)))
-> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef
  (IntMap
     (ComponentState
        (ZonkAny 23) (ZonkAny 24) (ZonkAny 25) (ZonkAny 26)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 23) (ZonkAny 24) (ZonkAny 25) (ZonkAny 26)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 23) (ZonkAny 24) (ZonkAny 25) (ZonkAny 26)))
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])
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_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 '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 {..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    vcompIds <- IM.keys <$> readIORef components
    forM_ vcompIds $ \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
        (ZonkAny 31) (ZonkAny 32) (ZonkAny 33) (ZonkAny 34))
-> Maybe
     (ComponentState
        (ZonkAny 31) (ZonkAny 32) (ZonkAny 33) (ZonkAny 34))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap
   (ComponentState
      (ZonkAny 31) (ZonkAny 32) (ZonkAny 33) (ZonkAny 34))
 -> Maybe
      (ComponentState
         (ZonkAny 31) (ZonkAny 32) (ZonkAny 33) (ZonkAny 34)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 31) (ZonkAny 32) (ZonkAny 33) (ZonkAny 34)))
-> IO
     (Maybe
        (ComponentState
           (ZonkAny 31) (ZonkAny 32) (ZonkAny 33) (ZonkAny 34)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState
        (ZonkAny 31) (ZonkAny 32) (ZonkAny 33) (ZonkAny 34)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 31) (ZonkAny 32) (ZonkAny 33) (ZonkAny 34)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 31) (ZonkAny 32) (ZonkAny 33) (ZonkAny 34)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components IO
  (Maybe
     (ComponentState
        (ZonkAny 31) (ZonkAny 32) (ZonkAny 33) (ZonkAny 34)))
-> (Maybe
      (ComponentState
         (ZonkAny 31) (ZonkAny 32) (ZonkAny 33) (ZonkAny 34))
    -> 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
     (ZonkAny 31) (ZonkAny 32) (ZonkAny 33) (ZonkAny 34))
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
ZonkAny 32
ZonkAny 33
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
ZonkAny 32 -> ZonkAny 32 -> IO ()
ZonkAny 33 -> IO ()
ZonkAny 33 -> ZonkAny 33 -> Bool
Sink (ZonkAny 34)
Seq (ZonkAny 34)
-> ZonkAny 33
-> ZonkAny 32
-> ZonkAny 31
-> (ZonkAny 33, [Schedule (ZonkAny 31) (ZonkAny 34)])
Value -> Maybe (ZonkAny 34)
_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])
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: ZonkAny 32
_prevComponentProps :: ZonkAny 32
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink (ZonkAny 34)
_componentPostEffect :: Sink (ZonkAny 34)
_componentModel :: ZonkAny 33
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe (ZonkAny 34)
_componentDraw :: ZonkAny 33 -> IO ()
_componentHydrate :: ZonkAny 33 -> IO ()
_componentPropsPhase :: ZonkAny 32 -> ZonkAny 32 -> IO ()
_componentModelDirty :: ZonkAny 33 -> ZonkAny 33 -> Bool
_componentApplyActions :: Seq (ZonkAny 34)
-> ZonkAny 33
-> ZonkAny 32
-> ZonkAny 31
-> (ZonkAny 33, [Schedule (ZonkAny 31) (ZonkAny 34)])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} ->
            case Value -> Maybe (ZonkAny 34)
_componentMailbox (message -> Value
forall a. ToJSON a => a -> Value
toJSON message
msg) of
              Maybe (ZonkAny 34)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Just ZonkAny 34
action -> Sink (ZonkAny 34)
_componentSink ZonkAny 34
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 <- JSVal -> IO Value
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked JSVal
bytes
          case fromJSON 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 <- JSVal -> IO Value
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked JSVal
bytes
          case fromJSON 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 {..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink -> do
    webSocketId <- IO WebSocket
freshWebSocket
    socket <- core webSocketId sink
    insertWebSocket _componentInfoId webSocketId 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 {..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    result <-
      atomicModifyIORef' websocketConnections $ \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 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 {..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    getWebSocket _componentInfoId socketId <$> readIORef websocketConnections >>= \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 {..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \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
        x <- JSVal
socket JSVal -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! (MisoString
"socketState" :: MisoString)
        socketstate <- toEnum <$> fromJSValUnchecked x
        sink (callback 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
    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)
    wasClean_ <- fromJSVal =<< o ! ("wasClean" :: MisoString)
    reason_ <- fromJSVal =<< o ! ("reason" :: MisoString)
    pure (Closed <$> closed_ <*> wasClean_ <*> 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
          txt <- JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked JSVal
e
          sink (onMessage 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 {..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink -> do
    eventSourceId <- IO EventSource
freshEventSource
    socket <- core eventSourceId sink
    insertEventSource _componentInfoId eventSourceId 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 {..} <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  model
  Identity
  (ComponentInfo context props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    result <-
      atomicModifyIORef' eventSourceConnections $ \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 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, ToJSON model, ToJSON props,
 ToJSON action, FromJSON action) =>
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 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 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 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
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
bts (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Proxy context -> MTS -> IO ()
forall context jsval.
(Eq context, ToJSVal jsval) =>
Proxy context -> jsval -> IO ()
effectListener Proxy context
proxy (MTS -> IO ()) -> IO MTS -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO MTS
getMTSContext
          MTS -> IO ()
readyAckListener (MTS -> IO ()) -> IO MTS -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO MTS
getMTSContext
          IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (Maybe StaticKey -> IO ()
sendReadyUntilAcked Maybe StaticKey
sk)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
mts (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Proxy context -> BTS -> IO ()
forall context jsval.
(Eq context, ToJSVal jsval) =>
Proxy context -> jsval -> IO ()
effectListener Proxy context
proxy (BTS -> IO ()) -> IO BTS -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO BTS
getBTSContext
          Proxy context -> BTS -> IO ()
forall context. Eq context => Proxy context -> BTS -> IO ()
componentListener Proxy context
proxy (BTS -> IO ()) -> IO BTS -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO BTS
getBTSContext
          IO ()
registerMainThreadDispatch
#endif
        IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef Bool
liveMode Bool
live
        root <- MisoString -> IO JSVal
Diff.mountElement (Maybe MisoString -> MisoString
getMountPoint Maybe MisoString
mountPoint)
        when web (cleanup proxy live root)
        atomicWriteIORef globalContext initialContext
        -- dmj: top-level Component always responsive to Context changes
        let comp_' = Component context props model action
comp_ { useContext = True }
        void $ initialize events rootComponentId hydrate True props key sk comp_' (pure 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
        atomicWriteIORef schedulerThread =<< forkIO (scheduler proxy)
----------------------------------------------------------------------------
-- | Placeholder passed to a 'Props' constructor when only the resulting
-- '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 :: forall props. props
propsTypeOnly = String -> props
forall a. HasCallStack => String -> a
error String
"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 :: forall context jsval.
(Eq context, ToJSVal jsval) =>
Proxy context -> jsval -> IO ()
effectListener Proxy context
Proxy jsval
jsval = IO Function -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Function -> IO ()) -> IO Function -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  ctx <- jsval -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal jsval
jsval
  FFI.addEventListener ctx "Miso.effects" $ \JSVal
msgEvent ->
    (IO () -> (SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (\(SomeException
e :: SomeException) ->
        MisoString -> IO ()
FFI.consoleError (MisoString
"[effectListener]: exception in callback: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (SomeException -> String
forall a. Show a => a -> String
show SomeException
e))) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      msg <- JSVal -> Object
Object JSVal
msgEvent Object -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! MisoString
"data"
      EFFECT {..} <- fromJSValUnchecked msg :: IO EFFECT
      case effectStaticKey of
        Maybe StaticKey
Nothing -> MisoString -> IO ()
FFI.consoleError MisoString
"[effectListener]: must use 'static' keyword when mounting Component w/ native"
        Just StaticKey
key_ -> do
          StaticKey
-> IO
     (Maybe (StaticPtr (SomeStaticComponent (ZonkAny 45) context)))
forall a. StaticKey -> IO (Maybe (StaticPtr a))
unsafeLookupStaticPtr StaticKey
key_ IO (Maybe (StaticPtr (SomeStaticComponent (ZonkAny 45) context)))
-> (Maybe (StaticPtr (SomeStaticComponent (ZonkAny 45) context))
    -> 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 (StaticPtr (SomeStaticComponent (ZonkAny 45) context))
Nothing ->
              MisoString -> IO ()
FFI.consoleError MisoString
"[effectListener]: staticPtr NOT found for effectStaticKey"
            Just StaticPtr (SomeStaticComponent (ZonkAny 45) context)
ptr ->
              case StaticPtr (SomeStaticComponent (ZonkAny 45) context)
-> SomeStaticComponent (ZonkAny 45) context
forall a. StaticPtr a -> a
deRefStaticPtr StaticPtr (SomeStaticComponent (ZonkAny 45) context)
ptr of
               SomeStaticComponent ZonkAny 45 -> SomeComponent context
mk -> case ZonkAny 45 -> SomeComponent context
mk ZonkAny 45
forall props. props
propsTypeOnly of
                SomeComponent Maybe Key
_key props
_props (Component context props model action
_ :: Component context props model action) ->
                  case Value -> Result action
forall a. FromJSON a => Value -> Result a
fromJSON Value
effectAction :: Result action of
                    Success action
action -> do
                      comps <- IORef
  (IntMap
     (ComponentState
        (ZonkAny 46) (ZonkAny 47) (ZonkAny 48) (ZonkAny 49)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 46) (ZonkAny 47) (ZonkAny 48) (ZonkAny 49)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 46) (ZonkAny 47) (ZonkAny 48) (ZonkAny 49)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
                      case IM.lookup effectComponentId comps of
                        Maybe
  (ComponentState
     (ZonkAny 46) (ZonkAny 47) (ZonkAny 48) (ZonkAny 49))
Nothing ->
                          MisoString -> IO ()
FFI.consoleError (MisoString -> IO ()) -> MisoString -> IO ()
forall a b. (a -> b) -> a -> b
$ MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (MisoString -> MisoString) -> MisoString -> MisoString
forall a b. (a -> b) -> a -> b
$
                            MisoString
"[effectListener]: ComponentId NOT registered:" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> Int -> MisoString
forall str. ToMisoString str => str -> MisoString
ms Int
effectComponentId
                        Just ComponentState (ZonkAny 46) (ZonkAny 47) (ZonkAny 48) (ZonkAny 49)
_ -> do
                          MisoString -> IO ()
FFI.consoleLog MisoString
"[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.
                          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 -> (Queue action, ())) -> IO ())
-> (Queue action -> (Queue action, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Queue action
q ->
                            (Int -> action -> Queue action -> Queue action
forall action. Int -> action -> Queue action -> Queue action
enqueue Int
effectComponentId action
action Queue action
q, ())
                          Waiter -> IO ()
notify Waiter
globalWaiter
                    Error MisoString
e ->
                      MisoString -> IO ()
FFI.consoleError (MisoString
"[effectListener]: action decode error: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
ms MisoString
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 :: Maybe StaticKey -> IO ()
sendReadyUntilAcked Maybe StaticKey
sk = Int -> IO ()
go (Int
0 :: Int)
  where
    maxAttempts :: Int
maxAttempts = Int
20    -- ~1s of retrying at 50ms intervals
    intervalMicros :: Int
intervalMicros = Int
50000
    go :: Int -> IO ()
go Int
attempts = do
      ComponentType
-> Maybe StaticKey
-> Int
-> Int
-> Maybe Value
-> Maybe JSVal
-> IO ()
postComponent ComponentType
READY Maybe StaticKey
sk Int
topLevelComponentId Int
rootComponentId Maybe Value
forall a. Maybe a
Nothing Maybe JSVal
forall a. Maybe a
Nothing
      Int -> IO ()
threadDelay Int
intervalMicros
      acked <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
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 -> IO ()
readyAckListener (MTS JSVal
ctx) = IO Function -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Function -> IO ()) -> IO Function -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  JSVal -> MisoString -> (JSVal -> IO ()) -> IO Function
FFI.addEventListener JSVal
ctx MisoString
"Miso.components" ((JSVal -> IO ()) -> IO Function)
-> (JSVal -> IO ()) -> IO Function
forall a b. (a -> b) -> a -> b
$ \JSVal
msgEvent -> do
    msg <- JSVal -> Object
Object JSVal
msgEvent Object -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! MisoString
"data"
    COMPONENT {..} <- fromJSValUnchecked msg :: IO COMPONENT
    case componentComponentType of
      ComponentType
READY_ACK -> IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef Bool
readyAcked Bool
True
      ComponentType
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
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 :: JSVal -> IO JSVal
resolveNodeRef JSVal
domRef = do
  nodeId <- 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
=<< JSVal
domRef JSVal -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! MisoString
"nodeId" :: IO Int
  nodes  <- jsg "runtime" >>= (! "nodes")
  nodes ! ms nodeId
-----------------------------------------------------------------------------
componentListener :: forall context . Eq context => Proxy context -> BTS -> IO ()
componentListener :: forall context. Eq context => Proxy context -> BTS -> IO ()
componentListener Proxy context
Proxy (BTS JSVal
ctx) = IO Function -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Function -> IO ()) -> IO Function -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  JSVal -> MisoString -> (JSVal -> IO ()) -> IO Function
FFI.addEventListener JSVal
ctx MisoString
"Miso.components" ((JSVal -> IO ()) -> IO Function)
-> (JSVal -> IO ()) -> IO Function
forall a b. (a -> b) -> a -> b
$ \JSVal
msgEvent ->
    (IO () -> (SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (\(SomeException
e :: SomeException) ->
        MisoString -> IO ()
FFI.consoleError (MisoString
"[componentListener]: exception in callback: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (SomeException -> String
forall a. Show a => a -> String
show SomeException
e))) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    msg <- JSVal -> Object
Object JSVal
msgEvent Object -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! MisoString
"data"
    COMPONENT {..} <- fromJSValUnchecked msg :: IO COMPONENT
    case componentComponentStaticKey of
      Maybe StaticKey
Nothing -> MisoString -> IO ()
FFI.consoleError MisoString
"[COMPONENT]: must use 'static' keyword for Component mounting"
      Just StaticKey
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 ComponentType
componentComponentType of
          ComponentType
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 <- IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Bool
readyReceived (\Bool
r -> (Bool
True, Bool
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)
          ComponentType
_ ->
            StaticKey
-> IO
     (Maybe (StaticPtr (SomeStaticComponent (ZonkAny 118) context)))
forall a. StaticKey -> IO (Maybe (StaticPtr a))
unsafeLookupStaticPtr StaticKey
key_ IO (Maybe (StaticPtr (SomeStaticComponent (ZonkAny 118) context)))
-> (Maybe (StaticPtr (SomeStaticComponent (ZonkAny 118) context))
    -> 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 (StaticPtr (SomeStaticComponent (ZonkAny 118) context))
Nothing ->
                MisoString -> IO ()
FFI.consoleError MisoString
"[COMPONENT]: staticPtr NOT found for componentStaticKey"
              Just StaticPtr (SomeStaticComponent (ZonkAny 118) context)
ptr ->
                case StaticPtr (SomeStaticComponent (ZonkAny 118) context)
-> SomeStaticComponent (ZonkAny 118) context
forall a. StaticPtr a -> a
deRefStaticPtr StaticPtr (SomeStaticComponent (ZonkAny 118) context)
ptr of
                 SomeStaticComponent ZonkAny 118 -> SomeComponent context
mk -> case ZonkAny 118 -> SomeComponent context
mk ZonkAny 118
forall props. props
propsTypeOnly of
                  SomeComponent Maybe Key
_key props
_props (Component context props model action
comp_ :: Component context props model action) ->
                    case ComponentType
componentComponentType of
                      ComponentType
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.
                        Int
-> IntMap
     (ComponentState
        (ZonkAny 122) (ZonkAny 123) (ZonkAny 124) (ZonkAny 125))
-> Bool
forall a. Int -> IntMap a -> Bool
IM.member Int
componentComponentId (IntMap
   (ComponentState
      (ZonkAny 122) (ZonkAny 123) (ZonkAny 124) (ZonkAny 125))
 -> Bool)
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 122) (ZonkAny 123) (ZonkAny 124) (ZonkAny 125)))
-> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState
        (ZonkAny 122) (ZonkAny 123) (ZonkAny 124) (ZonkAny 125)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 122) (ZonkAny 123) (ZonkAny 124) (ZonkAny 125)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 122) (ZonkAny 123) (ZonkAny 124) (ZonkAny 125)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components IO Bool -> (Bool -> 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
                          Bool
True -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                          Bool
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 Maybe JSVal
componentComponentDOMRef of
                              Maybe JSVal
Nothing ->
                                MisoString -> IO ()
FFI.consoleError MisoString
"[COMPONENT]: MOUNT missing domRef payload"
                              Just JSVal
domRef -> do
                                -- Resolve the shipped 'DOMRef' to the real native element via
                                -- @globalThis.runtime.nodes[nodeId]@ so the MTS 'ComponentInfo'
                                -- Reader ('componentInfoDOMRef') holds a live ref.
                                parent_ <- JSVal -> IO JSVal
resolveNodeRef JSVal
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 Value
pv | Success props
initProps <- (Value -> Result props
forall a. FromJSON a => Value -> Result a
fromJSON Value
pv :: Result props) ->
                                    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, ToJSON model, ToJSON props,
 ToJSON action, FromJSON action) =>
Events
-> Int
-> Hydrate
-> Bool
-> props
-> Maybe Key
-> Maybe StaticKey
-> Component context props model action
-> IO JSVal
-> IO (ComponentState context props model action)
initialize Events
forall a. Monoid a => a
mempty Int
componentComponentId Hydrate
Draw Bool
False props
initProps
                                      Maybe Key
forall a. Maybe a
Nothing (StaticKey -> Maybe StaticKey
forall a. a -> Maybe a
Just (StaticPtr (SomeStaticComponent (ZonkAny 118) context) -> StaticKey
forall a. StaticPtr a -> StaticKey
staticKey StaticPtr (SomeStaticComponent (ZonkAny 118) context)
ptr)) Component context props model action
comp_ (JSVal -> IO JSVal
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSVal
parent_)
                                  Maybe Value
_ ->
                                    MisoString -> IO ()
FFI.consoleError MisoString
"[COMPONENT]: MOUNT missing/invalid props payload"
                      ComponentType
UNMOUNT ->
                        Int
-> IntMap
     (ComponentState context (ZonkAny 126) (ZonkAny 127) (ZonkAny 128))
-> Maybe
     (ComponentState context (ZonkAny 126) (ZonkAny 127) (ZonkAny 128))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
componentComponentId (IntMap
   (ComponentState context (ZonkAny 126) (ZonkAny 127) (ZonkAny 128))
 -> Maybe
      (ComponentState context (ZonkAny 126) (ZonkAny 127) (ZonkAny 128)))
-> IO
     (IntMap
        (ComponentState context (ZonkAny 126) (ZonkAny 127) (ZonkAny 128)))
-> IO
     (Maybe
        (ComponentState context (ZonkAny 126) (ZonkAny 127) (ZonkAny 128)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState context (ZonkAny 126) (ZonkAny 127) (ZonkAny 128)))
-> IO
     (IntMap
        (ComponentState context (ZonkAny 126) (ZonkAny 127) (ZonkAny 128)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState context (ZonkAny 126) (ZonkAny 127) (ZonkAny 128)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components IO
  (Maybe
     (ComponentState context (ZonkAny 126) (ZonkAny 127) (ZonkAny 128)))
-> (Maybe
      (ComponentState context (ZonkAny 126) (ZonkAny 127) (ZonkAny 128))
    -> 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 (ZonkAny 126) (ZonkAny 127) (ZonkAny 128))
Nothing ->
                            MisoString -> IO ()
FFI.consoleError (MisoString -> IO ()) -> MisoString -> IO ()
forall a b. (a -> b) -> a -> b
$ MisoString
"[COMPONENT]: Couldn't find Component to unmount " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<>
                              String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Int -> String
forall a. Show a => a -> String
show Int
componentComponentId)
                          Just ComponentState context (ZonkAny 126) (ZonkAny 127) (ZonkAny 128)
c -> forall context props model action.
Eq context =>
ComponentState context props model action -> IO ()
unmountComponent @context ComponentState context (ZonkAny 126) (ZonkAny 127) (ZonkAny 128)
c
                      ComponentType
MODEL_HYDRATE -> do
                        case Maybe Value
componentComponentPayload of
                          Maybe Value
Nothing ->
                            MisoString -> IO ()
FFI.consoleError MisoString
"[COMPONENT]: No model to hydrate"
                          Just Value
m ->
                            case Value -> Result model
forall a. FromJSON a => Value -> Result a
fromJSON Value
m :: Result model of
                              Success model
newModel ->
                                Int
-> State
     (ComponentState (ZonkAny 119) (ZonkAny 120) model (ZonkAny 121)) ()
-> IO ()
forall context props model action a.
Int -> State (ComponentState context props model action) a -> IO ()
modifyComponent Int
componentComponentId (State
   (ComponentState (ZonkAny 119) (ZonkAny 120) model (ZonkAny 121)) ()
 -> IO ())
-> State
     (ComponentState (ZonkAny 119) (ZonkAny 120) model (ZonkAny 121)) ()
-> IO ()
forall a b. (a -> b) -> a -> b
$ do
                                  Lens
  (ComponentState (ZonkAny 119) (ZonkAny 120) model (ZonkAny 121))
  model
forall context props model action.
Lens (ComponentState context props model action) model
componentModel Lens
  (ComponentState (ZonkAny 119) (ZonkAny 120) model (ZonkAny 121))
  model
-> model
-> State
     (ComponentState (ZonkAny 119) (ZonkAny 120) model (ZonkAny 121)) ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> field -> m ()
.= model
newModel
                              Error MisoString
e ->
                                MisoString -> IO ()
FFI.consoleError (MisoString
"[COMPONENT]: Could not decode model: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
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.
                      ComponentType
READY_ACK -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
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 :: JSVal -> IO ()
dispatchMainThreadEvent JSVal
arg =
  (IO () -> (SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (\(SomeException
e :: SomeException) ->
      MisoString -> IO ()
FFI.consoleError (MisoString
"[MTS dispatch] exception: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (SomeException -> String
forall a. Show a => a -> String
show SomeException
e))) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let o :: Object
o = JSVal -> Object
Object JSVal
arg
    compId    <- 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
o Object -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! MisoString
"componentId" :: IO ComponentId
    skHex     <- fromJSValUnchecked =<< o ! "staticKey"   :: IO MisoString
    eventVal  <- o ! "event"
    targetVal <- o ! "target"
    unsafeLookupStaticPtr (fromMisoString skHex) >>= \case
      Maybe (StaticPtr (EventHandler (ZonkAny 35) (ZonkAny 36)))
Nothing ->
        MisoString -> IO ()
FFI.consoleError (MisoString
"[MTS dispatch] no handler for staticKey " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
skHex)
      -- Fully-applied 'On' handlers resolve to a runnable '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 StaticPtr (EventHandler (ZonkAny 35) (ZonkAny 36))
ehPtr -> case StaticPtr (EventHandler (ZonkAny 35) (ZonkAny 36))
-> EventHandler (ZonkAny 35) (ZonkAny 36)
forall a. StaticPtr a -> a
deRefStaticPtr StaticPtr (EventHandler (ZonkAny 35) (ZonkAny 36))
ehPtr of
        EventHandler {Decoder result
result -> ZonkAny 35 -> JSVal -> ZonkAny 36
ZonkAny 35
-> Sink (ZonkAny 36) -> VTree -> LogLevel -> Events -> IO ()
eventHandlerConvert :: ()
eventHandlerDecoder :: ()
eventHandlerInstall :: forall model action.
EventHandler model action
-> model -> Sink action -> VTree -> LogLevel -> Events -> IO ()
eventHandlerInstall :: ZonkAny 35
-> Sink (ZonkAny 36) -> VTree -> LogLevel -> Events -> IO ()
eventHandlerDecoder :: Decoder result
eventHandlerConvert :: result -> ZonkAny 35 -> JSVal -> ZonkAny 36
..} -> do
          comps <- IORef
  (IntMap
     (ComponentState
        (ZonkAny 37) (ZonkAny 38) (ZonkAny 35) (ZonkAny 36)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 37) (ZonkAny 38) (ZonkAny 35) (ZonkAny 36)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 37) (ZonkAny 38) (ZonkAny 35) (ZonkAny 36)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
          case IM.lookup compId comps of
            Maybe
  (ComponentState
     (ZonkAny 37) (ZonkAny 38) (ZonkAny 35) (ZonkAny 36))
Nothing ->
              MisoString -> IO ()
FFI.consoleError (MisoString
"[MTS dispatch] no component " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Int -> String
forall a. Show a => a -> String
show Int
compId))
            Just ComponentState {Bool
Int
[JSVal]
Maybe StaticKey
Maybe Key
ZonkAny 35
ZonkAny 38
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
ZonkAny 35 -> IO ()
ZonkAny 35 -> ZonkAny 35 -> Bool
Sink (ZonkAny 36)
ZonkAny 38 -> ZonkAny 38 -> IO ()
Seq (ZonkAny 36)
-> ZonkAny 35
-> ZonkAny 38
-> ZonkAny 37
-> (ZonkAny 35, [Schedule (ZonkAny 37) (ZonkAny 36)])
Value -> Maybe (ZonkAny 36)
_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])
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> JSVal
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_componentId :: Int
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Int
_componentProps :: ZonkAny 38
_prevComponentProps :: ZonkAny 38
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: Sink (ZonkAny 36)
_componentPostEffect :: Sink (ZonkAny 36)
_componentModel :: ZonkAny 35
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe (ZonkAny 36)
_componentDraw :: ZonkAny 35 -> IO ()
_componentHydrate :: ZonkAny 35 -> IO ()
_componentPropsPhase :: ZonkAny 38 -> ZonkAny 38 -> IO ()
_componentModelDirty :: ZonkAny 35 -> ZonkAny 35 -> Bool
_componentApplyActions :: Seq (ZonkAny 36)
-> ZonkAny 35
-> ZonkAny 38
-> ZonkAny 37
-> (ZonkAny 35, [Schedule (ZonkAny 37) (ZonkAny 36)])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} -> do
              -- Decode + dispatch directly from the captured '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 <- DecodeTarget -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (Decoder result -> DecodeTarget
forall a. Decoder a -> DecodeTarget
decodeAt Decoder result
eventHandlerDecoder)
              mv <- fromJSVal =<< FFI.eventJSON decodeAtVal eventVal
              case mv of
                Maybe Value
Nothing ->
                  MisoString -> IO ()
FFI.consoleError MisoString
"[MTS dispatch] eventJSON returned no value"
                Just Value
v -> case (Value -> Parser result) -> Value -> Either MisoString result
forall a b. (a -> Parser b) -> a -> Either MisoString b
parseEither (Decoder result -> Value -> Parser result
forall a. Decoder a -> Value -> Parser a
decoder Decoder result
eventHandlerDecoder) Value
v of
                  Left MisoString
msg ->
                    MisoString -> IO ()
FFI.consoleError (MisoString
"[MTS dispatch] decode error: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
ms MisoString
msg)
                  Right result
result ->
                    Sink (ZonkAny 36)
_componentSink (result -> ZonkAny 35 -> JSVal -> ZonkAny 36
eventHandlerConvert result
result ZonkAny 35
_componentModel JSVal
targetVal)
-----------------------------------------------------------------------------
-- | Register 'dispatchMainThreadEvent' on @globalThis.runtime@ so the MTS
-- delegator can invoke it synchronously. MTS only.
registerMainThreadDispatch :: IO ()
registerMainThreadDispatch :: IO ()
registerMainThreadDispatch = do
  cb <- (JSVal -> IO ()) -> IO JSVal
FFI.syncCallback1 JSVal -> IO ()
dispatchMainThreadEvent
  runtimeObj <- jsg "runtime"
  FFI.set "dispatchMainThreadEvent" cb (Object runtimeObj)
#endif
----------------------------------------------------------------------------
-- | Dispatches a '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 :: ComponentType
-> Maybe StaticKey
-> Int
-> Int
-> Maybe Value
-> Maybe JSVal
-> IO ()
postComponent ComponentType
_ Maybe StaticKey
Nothing Int
_ Int
_ Maybe Value
_ Maybe JSVal
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
postComponent ComponentType
componentType_ sk :: Maybe StaticKey
sk@(Just StaticKey
_) Int
componentId_ Int
parentId_ Maybe Value
model_ Maybe JSVal
domRef_ = do
  ctx <- IO MTS
getMTSContext
  dispatchEvent ctx "Miso.components"
    (COMPONENT componentType_ sk componentId_ parentId_ model_ domRef_)
#endif
----------------------------------------------------------------------------
-- | Dispatches an '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 :: Maybe StaticKey -> Int -> Value -> IO ()
postEffect Maybe StaticKey
sk Int
componentId_ Value
action_ = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
mts (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ctx <- IO BTS
getBTSContext
    dispatchEvent ctx "Miso.effects" (EFFECT componentId_ action_ sk)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
bts (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ctx <- IO MTS
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 'initialize' \/ 'initComponent'.
--
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 '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
componentComponentDOMRef :: COMPONENT -> Maybe JSVal
componentComponentId :: COMPONENT -> Int
componentComponentParentId :: COMPONENT -> Int
componentComponentPayload :: COMPONENT -> Maybe Value
componentComponentStaticKey :: COMPONENT -> Maybe StaticKey
componentComponentType :: COMPONENT -> ComponentType
componentComponentType :: ComponentType
componentComponentStaticKey :: Maybe StaticKey
componentComponentId :: Int
componentComponentParentId :: Int
componentComponentPayload :: Maybe Value
componentComponentDOMRef :: Maybe JSVal
..} = do
    o <- IO Object
create
    setField o "componentType" componentComponentType
    setField o "staticKey" componentComponentStaticKey
    setField o "compId" componentComponentId
    setField o "compParentId" componentComponentParentId
    setField o "payload" componentComponentPayload
    setField o "domRef" componentComponentDOMRef
    toJSVal 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
    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
    msk  <- fromJSVal =<< getProp "staticKey" o
    let 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
    mcid <- fromJSVal =<< getProp "compId" o
    mcpid <- fromJSVal =<< getProp "compParentId" o
    mp   <- fromJSVal =<< getProp "payload" o
    mdr  <- fromJSVal =<< getProp "domRef" o
    pure (COMPONENT <$> mct <*> key <*> mcid <*> mcpid <*> mp <*> 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
effectAction :: EFFECT -> Value
effectComponentId :: EFFECT -> Int
effectStaticKey :: EFFECT -> Maybe StaticKey
effectComponentId :: Int
effectAction :: Value
effectStaticKey :: Maybe StaticKey
..} = do
    o <- IO Object
create
    setField o "componentId" effectComponentId
    setField o "action" effectAction
    setField o "staticKey" effectStaticKey
    toJSVal 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
    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
    maction <- fromJSVal =<< getProp "action" o
    mk <- fromJSVal =<< getProp "staticKey" o
    pure (EFFECT <$> mcid <*> maction <*> 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
  ctx_ <- ctx -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal ctx
ctx
  o <- create
  setField o "type" protocol
  setField o "data" =<< toJSVal payload
  _ <- Object ctx_ # "dispatchEvent" $ [o]
  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);
-- 'startApp' \/ '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
  action
-----------------------------------------------------------------------------