-----------------------------------------------------------------------------
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE BlockArguments             #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# 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
  ) where
-----------------------------------------------------------------------------
import qualified Data.IntSet as IS
import           Data.IntSet (IntSet)
import           Data.Proxy (Proxy(Proxy))
import           Control.Category ((.))
import           Control.Concurrent
import           Control.Exception (SomeException, catch, evaluate)
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)

import           Data.Foldable (foldl')
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           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)
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.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(..))
import           Miso.Types
import           Miso.Util
-----------------------------------------------------------------------------
-- | Helper function to abstract out initialization of t'Miso.Types.Component' between top-level API functions.
initialize
  :: (Eq context, Eq model, Eq props)
  => 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
  -> Component context props model action
  -> IO DOMRef
  -- ^ Callback function is used for obtaining the t'Miso.Types.Component' 'DOMRef'.
  -> IO (ComponentState context props model action)
initialize :: forall context model props action.
(Eq context, Eq model, Eq props) =>
Events
-> Int
-> Hydrate
-> Bool
-> props
-> Maybe Key
-> 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 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 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 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 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
        vcomps <- IORef
  (IntMap
     (ComponentState (ZonkAny 99) (ZonkAny 100) model (ZonkAny 101)))
-> IO
     (IntMap
        (ComponentState (ZonkAny 99) (ZonkAny 100) model (ZonkAny 101)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState (ZonkAny 99) (ZonkAny 100) model (ZonkAny 101)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
        case maybeKey of
          Just Key
k  -> model -> IO model
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (model -> IO model) -> model -> IO model
forall a b. (a -> b) -> a -> b
$ model -> Maybe model -> model
forall a. a -> Maybe a -> a
fromMaybe model
model (Maybe model -> model) -> Maybe model -> model
forall a b. (a -> b) -> a -> b
$ [model] -> Maybe model
forall a. [a] -> Maybe a
listToMaybe
            [ ComponentState (ZonkAny 99) (ZonkAny 100) model (ZonkAny 101)
cs ComponentState (ZonkAny 99) (ZonkAny 100) model (ZonkAny 101)
-> Lens
     (ComponentState (ZonkAny 99) (ZonkAny 100) model (ZonkAny 101))
     model
-> model
forall record field. record -> Lens record field -> field
^. Lens
  (ComponentState (ZonkAny 99) (ZonkAny 100) model (ZonkAny 101))
  model
forall context props model action.
Lens (ComponentState context props model action) model
componentModel
            | ComponentState (ZonkAny 99) (ZonkAny 100) model (ZonkAny 101)
cs <- IntMap
  (ComponentState (ZonkAny 99) (ZonkAny 100) model (ZonkAny 101))
-> [ComponentState (ZonkAny 99) (ZonkAny 100) model (ZonkAny 101)]
forall a. IntMap a -> [a]
IM.elems IntMap
  (ComponentState (ZonkAny 99) (ZonkAny 100) model (ZonkAny 101))
vcomps
            , ComponentState (ZonkAny 99) (ZonkAny 100) model (ZonkAny 101)
cs ComponentState (ZonkAny 99) (ZonkAny 100) model (ZonkAny 101)
-> Lens
     (ComponentState (ZonkAny 99) (ZonkAny 100) model (ZonkAny 101))
     (Maybe Key)
-> Maybe Key
forall record field. record -> Lens record field -> field
^. Lens
  (ComponentState (ZonkAny 99) (ZonkAny 100) model (ZonkAny 101))
  (Maybe Key)
forall context props model action.
Lens (ComponentState context props model action) (Maybe Key)
componentKey Maybe Key -> Maybe Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key -> Maybe Key
forall a. a -> Maybe a
Just Key
k
            ]
          Maybe Key
Nothing -> 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 102) (ZonkAny 103) (ZonkAny 104) (ZonkAny 105))
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 102) (ZonkAny 103) (ZonkAny 104) (ZonkAny 105)
cs -> [JSVal] -> IO [JSVal]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentState
  (ZonkAny 102) (ZonkAny 103) (ZonkAny 104) (ZonkAny 105)
-> [JSVal]
forall context props model action.
ComponentState context props model action -> [JSVal]
_componentScripts ComponentState
  (ZonkAny 102) (ZonkAny 103) (ZonkAny 104) (ZonkAny 105)
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 106) props (ZonkAny 107) (ZonkAny 108)
-> Lens
     (ComponentState (ZonkAny 106) props (ZonkAny 107) (ZonkAny 108))
     props
-> props
forall record field. record -> Lens record field -> field
^. Lens
  (ComponentState (ZonkAny 106) props (ZonkAny 107) (ZonkAny 108))
  props
forall context props model action.
Lens (ComponentState context props model action) props
componentProps) (ComponentState (ZonkAny 106) props (ZonkAny 107) (ZonkAny 108)
 -> props)
-> (IntMap
      (ComponentState (ZonkAny 106) props (ZonkAny 107) (ZonkAny 108))
    -> ComponentState (ZonkAny 106) props (ZonkAny 107) (ZonkAny 108))
-> IntMap
     (ComponentState (ZonkAny 106) props (ZonkAny 107) (ZonkAny 108))
-> 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 106) props (ZonkAny 107) (ZonkAny 108))
-> Int
-> ComponentState (ZonkAny 106) props (ZonkAny 107) (ZonkAny 108)
forall a. IntMap a -> Int -> a
IM.! Int
_componentId) (IntMap
   (ComponentState (ZonkAny 106) props (ZonkAny 107) (ZonkAny 108))
 -> props)
-> IO
     (IntMap
        (ComponentState (ZonkAny 106) props (ZonkAny 107) (ZonkAny 108)))
-> IO props
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState (ZonkAny 106) props (ZonkAny 107) (ZonkAny 108)))
-> IO
     (IntMap
        (ComponentState (ZonkAny 106) props (ZonkAny 107) (ZonkAny 108)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState (ZonkAny 106) props (ZonkAny 107) (ZonkAny 108)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
        currentContext <- readIORef globalContext
        newVTree <-
          buildVTree events _componentParentId _componentId Draw
            _componentSink logLevel (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

  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
a ->
              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
a) 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]
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
_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 ()
_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 ()
_componentId :: Int
_componentParentId :: Int
_componentProps :: props
_componentSink :: Sink action
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentVTree :: IORef VTree
..
        }

  when isRoot (delegator _componentDOMRef _componentVTree events (logLevel `elem` [DebugEvents, DebugAll]))
  registerComponent vcomponent

  initSubs subs _componentSubThreads _componentSink
  initialDraw initializedModel events hydrate isRoot comp vcomponent
  forM_ mount _componentSink
  when bts (FFI.mountComponent _componentId =<< toObject jsNull)
  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 69) (ZonkAny 70) (ZonkAny 71) (ZonkAny 72))
-> Bool
forall a. Maybe a -> Bool
isJust (Maybe
   (ComponentState
      (ZonkAny 69) (ZonkAny 70) (ZonkAny 71) (ZonkAny 72))
 -> Bool)
-> (IntMap
      (ComponentState
         (ZonkAny 69) (ZonkAny 70) (ZonkAny 71) (ZonkAny 72))
    -> Maybe
         (ComponentState
            (ZonkAny 69) (ZonkAny 70) (ZonkAny 71) (ZonkAny 72)))
-> IntMap
     (ComponentState
        (ZonkAny 69) (ZonkAny 70) (ZonkAny 71) (ZonkAny 72))
-> 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 69) (ZonkAny 70) (ZonkAny 71) (ZonkAny 72))
-> Maybe
     (ComponentState
        (ZonkAny 69) (ZonkAny 70) (ZonkAny 71) (ZonkAny 72))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap
   (ComponentState
      (ZonkAny 69) (ZonkAny 70) (ZonkAny 71) (ZonkAny 72))
 -> Bool)
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 69) (ZonkAny 70) (ZonkAny 71) (ZonkAny 72)))
-> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState
        (ZonkAny 69) (ZonkAny 70) (ZonkAny 71) (ZonkAny 72)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 69) (ZonkAny 70) (ZonkAny 71) (ZonkAny 72)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 69) (ZonkAny 70) (ZonkAny 71) (ZonkAny 72)))
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
    IO (Maybe (Int, Seq (ZonkAny 78)))
forall action. IO (Maybe (Int, Seq action))
getBatch IO (Maybe (Int, Seq (ZonkAny 78)))
-> (Maybe (Int, Seq (ZonkAny 78)) -> 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 78))
Nothing -> Waiter -> IO ()
wait Waiter
globalWaiter
      Just (Int
vcompId, Seq (ZonkAny 78)
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 79) (ZonkAny 80) (ZonkAny 81) (ZonkAny 82)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 79) (ZonkAny 80) (ZonkAny 81) (ZonkAny 82)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 79) (ZonkAny 80) (ZonkAny 81) (ZonkAny 82)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
            forM_ (IM.elems vcomps) $ \ComponentState {Bool
Int
[JSVal]
Maybe Key
ZonkAny 80
ZonkAny 81
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
ZonkAny 80 -> ZonkAny 80 -> IO ()
ZonkAny 81 -> IO ()
ZonkAny 81 -> ZonkAny 81 -> Bool
ZonkAny 82 -> IO ()
Seq (ZonkAny 82)
-> ZonkAny 81
-> ZonkAny 80
-> ZonkAny 79
-> (ZonkAny 81, [Schedule (ZonkAny 79) (ZonkAny 82)])
Value -> Maybe (ZonkAny 82)
_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 ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> action -> IO ()
_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
_componentParentId :: Int
_componentProps :: ZonkAny 80
_prevComponentProps :: ZonkAny 80
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: ZonkAny 82 -> IO ()
_componentModel :: ZonkAny 81
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe (ZonkAny 82)
_componentDraw :: ZonkAny 81 -> IO ()
_componentPropsPhase :: ZonkAny 80 -> ZonkAny 80 -> IO ()
_componentModelDirty :: ZonkAny 81 -> ZonkAny 81 -> Bool
_componentApplyActions :: Seq (ZonkAny 82)
-> ZonkAny 81
-> ZonkAny 80
-> ZonkAny 79
-> (ZonkAny 81, [Schedule (ZonkAny 79) (ZonkAny 82)])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} ->
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
_componentUseContext (ZonkAny 81 -> IO ()
_componentDraw ZonkAny 81
_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 83) (ZonkAny 84) (ZonkAny 85) (ZonkAny 86)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 83) (ZonkAny 84) (ZonkAny 85) (ZonkAny 86)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 83) (ZonkAny 84) (ZonkAny 85) (ZonkAny 86)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components
            forM_ (IM.lookup (negate vcompId) vcomps) $ \ComponentState {Bool
Int
[JSVal]
Maybe Key
ZonkAny 84
ZonkAny 85
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
ZonkAny 84 -> ZonkAny 84 -> IO ()
ZonkAny 85 -> IO ()
ZonkAny 85 -> ZonkAny 85 -> Bool
ZonkAny 86 -> IO ()
Seq (ZonkAny 86)
-> ZonkAny 85
-> ZonkAny 84
-> ZonkAny 83
-> (ZonkAny 85, [Schedule (ZonkAny 83) (ZonkAny 86)])
Value -> Maybe (ZonkAny 86)
_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 ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> action -> IO ()
_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
_componentParentId :: Int
_componentProps :: ZonkAny 84
_prevComponentProps :: ZonkAny 84
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: ZonkAny 86 -> IO ()
_componentModel :: ZonkAny 85
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe (ZonkAny 86)
_componentDraw :: ZonkAny 85 -> IO ()
_componentPropsPhase :: ZonkAny 84 -> ZonkAny 84 -> IO ()
_componentModelDirty :: ZonkAny 85 -> ZonkAny 85 -> Bool
_componentApplyActions :: Seq (ZonkAny 86)
-> ZonkAny 85
-> ZonkAny 84
-> ZonkAny 83
-> (ZonkAny 85, [Schedule (ZonkAny 83) (ZonkAny 86)])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} -> do
              ZonkAny 85 -> IO ()
_componentDraw ZonkAny 85
_componentModel
              ZonkAny 84 -> ZonkAny 84 -> IO ()
_componentPropsPhase ZonkAny 84
_prevComponentProps ZonkAny 84
_componentProps

      Just (Int
vcompId, Seq (ZonkAny 78)
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.
    run :: ComponentId -> Seq action -> IO ()
    run :: forall action. Int -> Seq action -> IO ()
run Int
vcompId = (Int -> IO ()) -> Maybe Int -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> IO ()
renderComponent (Maybe Int -> IO ())
-> (Seq action -> IO (Maybe Int)) -> Seq action -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Int -> Seq action -> IO (Maybe Int)
forall action. Int -> Seq action -> IO (Maybe Int)
commit Int
vcompId
    -----------------------------------------------------------------------------
    -- | 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
      forM_ schedules $ \case
        Schedule Synchronicity
Async (action -> IO ()) -> IO ()
action ->
          Synchronicity -> IO () -> IO ()
evalScheduled Synchronicity
Async ((action -> IO ()) -> IO ()
action action -> IO ()
_componentSink)
        Schedule Synchronicity
Sync (action -> IO ()) -> IO ()
action ->
          Synchronicity -> IO () -> IO ()
evalScheduled Synchronicity
Sync ((action -> IO ()) -> IO ()
action action -> IO ()
_componentSink)
        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, ())
      updatedContext <- readIORef globalContext
      when (currentContext /= updatedContext) enqueueContextPropagation
      if _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 65) (ZonkAny 66) (ZonkAny 67) (ZonkAny 68))
-> Maybe
     (ComponentState
        (ZonkAny 65) (ZonkAny 66) (ZonkAny 67) (ZonkAny 68))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap
   (ComponentState
      (ZonkAny 65) (ZonkAny 66) (ZonkAny 67) (ZonkAny 68))
 -> Maybe
      (ComponentState
         (ZonkAny 65) (ZonkAny 66) (ZonkAny 67) (ZonkAny 68)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 65) (ZonkAny 66) (ZonkAny 67) (ZonkAny 68)))
-> IO
     (Maybe
        (ComponentState
           (ZonkAny 65) (ZonkAny 66) (ZonkAny 67) (ZonkAny 68)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState
        (ZonkAny 65) (ZonkAny 66) (ZonkAny 67) (ZonkAny 68)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 65) (ZonkAny 66) (ZonkAny 67) (ZonkAny 68)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 65) (ZonkAny 66) (ZonkAny 67) (ZonkAny 68)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components IO
  (Maybe
     (ComponentState
        (ZonkAny 65) (ZonkAny 66) (ZonkAny 67) (ZonkAny 68)))
-> (Maybe
      (ComponentState
         (ZonkAny 65) (ZonkAny 66) (ZonkAny 67) (ZonkAny 68))
    -> 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 65) (ZonkAny 66) (ZonkAny 67) (ZonkAny 68)
 -> IO ())
-> Maybe
     (ComponentState
        (ZonkAny 65) (ZonkAny 66) (ZonkAny 67) (ZonkAny 68))
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ \ComponentState {Bool
Int
[JSVal]
Maybe Key
ZonkAny 66
ZonkAny 67
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
ZonkAny 66 -> ZonkAny 66 -> IO ()
ZonkAny 67 -> IO ()
ZonkAny 67 -> ZonkAny 67 -> Bool
ZonkAny 68 -> IO ()
Seq (ZonkAny 68)
-> ZonkAny 67
-> ZonkAny 66
-> ZonkAny 65
-> (ZonkAny 67, [Schedule (ZonkAny 65) (ZonkAny 68)])
Value -> Maybe (ZonkAny 68)
_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 ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> action -> IO ()
_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
_componentParentId :: Int
_componentProps :: ZonkAny 66
_prevComponentProps :: ZonkAny 66
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: ZonkAny 68 -> IO ()
_componentModel :: ZonkAny 67
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe (ZonkAny 68)
_componentDraw :: ZonkAny 67 -> IO ()
_componentPropsPhase :: ZonkAny 66 -> ZonkAny 66 -> IO ()
_componentModelDirty :: ZonkAny 67 -> ZonkAny 67 -> Bool
_componentApplyActions :: Seq (ZonkAny 68)
-> ZonkAny 67
-> ZonkAny 66
-> ZonkAny 65
-> (ZonkAny 67, [Schedule (ZonkAny 65) (ZonkAny 68)])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} -> do
  ZonkAny 67 -> IO ()
_componentDraw ZonkAny 67
_componentModel
  Int -> Object -> IO ()
FFI.modelHydration Int
_componentId (Object -> IO ()) -> IO Object -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal -> IO Object
forall a. ToObject a => a -> IO Object
toObject JSVal
jsNull
-----------------------------------------------------------------------------
-- | 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 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 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 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 Key
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
m -> IO ()
m -> m -> Bool
props -> props -> IO ()
a -> IO ()
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 ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> action -> IO ()
_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
_componentParentId :: Int
_componentProps :: props
_prevComponentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: a -> IO ()
_componentModel :: m
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe a
_componentDraw :: 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
    (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 (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
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 39))
-> (Queue (ZonkAny 39) -> (Queue (ZonkAny 39), ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Queue (ZonkAny 39))
forall action. IORef (Queue action)
globalQueue ((Queue (ZonkAny 39) -> (Queue (ZonkAny 39), ())) -> IO ())
-> (Queue (ZonkAny 39) -> (Queue (ZonkAny 39), ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Queue (ZonkAny 39)
q ->
     (Queue (ZonkAny 39)
q Queue (ZonkAny 39)
-> (Queue (ZonkAny 39) -> Queue (ZonkAny 39)) -> Queue (ZonkAny 39)
forall a b. a -> (a -> b) -> b
& Lens (Queue (ZonkAny 39)) (Seq Int)
forall action. Lens (Queue action) (Seq Int)
queueSchedule Lens (Queue (ZonkAny 39)) (Seq Int)
-> (Seq Int -> Seq Int) -> Queue (ZonkAny 39) -> Queue (ZonkAny 39)
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 40))
-> (Queue (ZonkAny 40) -> (Queue (ZonkAny 40), ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Queue (ZonkAny 40))
forall action. IORef (Queue action)
globalQueue ((Queue (ZonkAny 40) -> (Queue (ZonkAny 40), ())) -> IO ())
-> (Queue (ZonkAny 40) -> (Queue (ZonkAny 40), ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Queue (ZonkAny 40)
q ->
     (Queue (ZonkAny 40)
q Queue (ZonkAny 40)
-> (Queue (ZonkAny 40) -> Queue (ZonkAny 40)) -> Queue (ZonkAny 40)
forall a b. a -> (a -> b) -> b
& Lens (Queue (ZonkAny 40)) (Seq Int)
forall action. Lens (Queue action) (Seq Int)
queueSchedule Lens (Queue (ZonkAny 40)) (Seq Int)
-> (Seq Int -> Seq Int) -> Queue (ZonkAny 40) -> Queue (ZonkAny 40)
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
-----------------------------------------------------------------------------
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 }
-----------------------------------------------------------------------------
-- | Hydrate avoids calling @diff@, and instead calls @hydrate@
-- 'Draw' invokes 'Miso.Diff.diff'
data Hydrate
  = Draw
  | Hydrate
  deriving (Int -> Hydrate -> ShowS
[Hydrate] -> ShowS
Hydrate -> String
(Int -> Hydrate -> ShowS)
-> (Hydrate -> String) -> ([Hydrate] -> ShowS) -> Show Hydrate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Hydrate -> ShowS
showsPrec :: Int -> Hydrate -> ShowS
$cshow :: Hydrate -> String
show :: Hydrate -> String
$cshowList :: [Hydrate] -> ShowS
showList :: [Hydrate] -> ShowS
Show, Hydrate -> Hydrate -> Bool
(Hydrate -> Hydrate -> Bool)
-> (Hydrate -> Hydrate -> Bool) -> Eq Hydrate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Hydrate -> Hydrate -> Bool
== :: Hydrate -> Hydrate -> Bool
$c/= :: Hydrate -> Hydrate -> Bool
/= :: Hydrate -> Hydrate -> Bool
Eq)
-----------------------------------------------------------------------------
-- | 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 -> 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 -> action -> IO ()
_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 -> 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
-> 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 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 (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, Topic a -> MisoString
(Topic a -> MisoString) -> ToMisoString (Topic a)
forall a. Topic a -> MisoString
forall str. (str -> MisoString) -> ToMisoString str
$ctoMisoString :: forall a. Topic a -> MisoString
toMisoString :: Topic a -> MisoString
ToMisoString)
-----------------------------------------------------------------------------
-- | 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 41) (ZonkAny 42) (ZonkAny 43) (ZonkAny 44))
     ()
-> IO ()
forall context props model action a.
Int -> State (ComponentState context props model action) a -> IO ()
modifyComponent Int
_componentInfoId (State
   (ComponentState
      (ZonkAny 41) (ZonkAny 42) (ZonkAny 43) (ZonkAny 44))
   ()
 -> IO ())
-> State
     (ComponentState
        (ZonkAny 41) (ZonkAny 42) (ZonkAny 43) (ZonkAny 44))
     ()
-> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Lens
  (ComponentState
     (ZonkAny 41) (ZonkAny 42) (ZonkAny 43) (ZonkAny 44))
  (Map MisoString (Value -> IO ()))
forall context props model action.
Lens
  (ComponentState context props model action)
  (Map MisoString (Value -> IO ()))
componentTopics Lens
  (ComponentState
     (ZonkAny 41) (ZonkAny 42) (ZonkAny 43) (ZonkAny 44))
  (Map MisoString (Value -> IO ()))
-> (Map MisoString (Value -> IO ())
    -> Map MisoString (Value -> IO ()))
-> State
     (ComponentState
        (ZonkAny 41) (ZonkAny 42) (ZonkAny 43) (ZonkAny 44))
     ()
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 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38)
 -> IO ())
-> [ComponentState
      (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38)]
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ComponentState (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38)
-> IO ()
forall {context} {props} {model} {action}.
ComponentState context props model action -> IO ()
go ([ComponentState
    (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38)]
 -> IO ())
-> (IntMap
      (ComponentState
         (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38))
    -> [ComponentState
          (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38)])
-> IntMap
     (ComponentState
        (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38))
-> 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 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38))
-> [ComponentState
      (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38)]
forall a. IntMap a -> [a]
IM.elems (IntMap
   (ComponentState
      (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38))
 -> IO ())
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38)))
-> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef
  (IntMap
     (ComponentState
        (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38)))
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 Key
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
props -> props -> IO ()
model -> IO ()
model -> model -> Bool
action -> IO ()
Seq action
-> model -> props -> context -> (model, [Schedule context action])
Value -> Maybe action
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_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 ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> action -> IO ()
_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
_componentParentId :: Int
_componentProps :: props
_prevComponentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe action
_componentDraw :: 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 62) (ZonkAny 63) (ZonkAny 64)))
-> IO
     (IntMap
        (ComponentState context (ZonkAny 62) (ZonkAny 63) (ZonkAny 64)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState context (ZonkAny 62) (ZonkAny 63) (ZonkAny 64)))
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 62) (ZonkAny 63) (ZonkAny 64)
cs@ComponentState{Bool
Int
[JSVal]
Maybe Key
ZonkAny 62
ZonkAny 63
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
ZonkAny 62 -> ZonkAny 62 -> IO ()
ZonkAny 63 -> IO ()
ZonkAny 63 -> ZonkAny 63 -> Bool
ZonkAny 64 -> IO ()
Seq (ZonkAny 64)
-> ZonkAny 63
-> ZonkAny 62
-> context
-> (ZonkAny 63, [Schedule context (ZonkAny 64)])
Value -> Maybe (ZonkAny 64)
_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 ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> action -> IO ()
_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
_componentParentId :: Int
_componentProps :: ZonkAny 62
_prevComponentProps :: ZonkAny 62
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: ZonkAny 64 -> IO ()
_componentModel :: ZonkAny 63
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe (ZonkAny 64)
_componentDraw :: ZonkAny 63 -> IO ()
_componentPropsPhase :: ZonkAny 62 -> ZonkAny 62 -> IO ()
_componentModelDirty :: ZonkAny 63 -> ZonkAny 63 -> Bool
_componentApplyActions :: Seq (ZonkAny 64)
-> ZonkAny 63
-> ZonkAny 62
-> context
-> (ZonkAny 63, [Schedule context (ZonkAny 64)])
_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 62) (ZonkAny 63) (ZonkAny 64)
-> IO ()
forall {context} {props} {model} {action}.
ComponentState context props model action -> IO ()
freeLifecycleHooks ComponentState context (ZonkAny 62) (ZonkAny 63) (ZonkAny 64)
cs
      else do
        -- We can do a full unmount if we're not doing hot reload
        forM_ (IM.toDescList vcomps) $ \(Int
_, ComponentState context (ZonkAny 62) (ZonkAny 63) (ZonkAny 64)
vcomp_) ->
          forall context props model action.
Eq context =>
ComponentState context props model action -> IO ()
unmountComponent @context ComponentState context (ZonkAny 62) (ZonkAny 63) (ZonkAny 64)
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)
-----------------------------------------------------------------------------
-- | 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 Key
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
props -> props -> IO ()
model -> IO ()
model -> model -> Bool
action -> IO ()
Seq action
-> model -> props -> context -> (model, [Schedule context action])
Value -> Maybe action
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_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 ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> action -> IO ()
_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
_componentParentId :: Int
_componentProps :: props
_prevComponentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe action
_componentDraw :: 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
             Schedule Synchronicity
_ (action -> IO ()) -> IO ()
action ->
               (action -> IO ()) -> IO ()
action action -> IO ()
_componentSink
                 IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(SomeException
e :: SomeException) -> IO SomeException -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (SomeException -> IO SomeException
forall a. a -> IO a
evaluate SomeException
e))
             ContextModify context -> context
f -> do
               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 (currentContext /= newContext) enqueueContextPropagation
           -- dmj: One last context propagation before aborting
-----------------------------------------------------------------------------
-- | 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 Key
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
props -> props -> IO ()
model -> IO ()
model -> model -> Bool
action -> IO ()
Seq action
-> model -> props -> context -> (model, [Schedule context action])
Value -> Maybe action
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_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 ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> action -> IO ()
_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
_componentParentId :: Int
_componentProps :: props
_prevComponentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe action
_componentDraw :: 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 Key
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
props -> props -> IO ()
model -> IO ()
model -> model -> Bool
action -> IO ()
Seq action
-> model -> props -> context -> (model, [Schedule context action])
Value -> Maybe action
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_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 ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> action -> IO ()
_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
_componentParentId :: Int
_componentProps :: props
_prevComponentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe action
_componentDraw :: 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 Key
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
props -> props -> IO ()
model -> IO ()
model -> model -> Bool
action -> IO ()
Seq action
-> model -> props -> context -> (model, [Schedule context action])
Value -> Maybe action
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_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 ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> action -> IO ()
_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
_componentParentId :: Int
_componentProps :: props
_prevComponentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe action
_componentDraw :: 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 49) (ZonkAny 50) (ZonkAny 51) (ZonkAny 52))
     ()
-> IO ()
forall context props model action a.
Int -> State (ComponentState context props model action) a -> IO ()
modifyComponent Int
_componentParentId (State
   (ComponentState
      (ZonkAny 49) (ZonkAny 50) (ZonkAny 51) (ZonkAny 52))
   ()
 -> IO ())
-> State
     (ComponentState
        (ZonkAny 49) (ZonkAny 50) (ZonkAny 51) (ZonkAny 52))
     ()
-> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Lens
  (ComponentState
     (ZonkAny 49) (ZonkAny 50) (ZonkAny 51) (ZonkAny 52))
  ComponentIds
forall context props model action.
Lens (ComponentState context props model action) ComponentIds
childrenLens
  (ComponentState
     (ZonkAny 49) (ZonkAny 50) (ZonkAny 51) (ZonkAny 52))
  ComponentIds
-> LensCore (Maybe ()) ComponentIds
-> LensCore
     (Maybe ())
     (ComponentState
        (ZonkAny 49) (ZonkAny 50) (ZonkAny 51) (ZonkAny 52))
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 49) (ZonkAny 50) (ZonkAny 51) (ZonkAny 52))
-> Maybe ()
-> State
     (ComponentState
        (ZonkAny 49) (ZonkAny 50) (ZonkAny 51) (ZonkAny 52))
     ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> field -> m ()
.= Maybe ()
forall a. Maybe a
Nothing
  IORef
  (IntMap
     (ComponentState
        (ZonkAny 53) (ZonkAny 54) (ZonkAny 55) (ZonkAny 56)))
-> (IntMap
      (ComponentState
         (ZonkAny 53) (ZonkAny 54) (ZonkAny 55) (ZonkAny 56))
    -> (IntMap
          (ComponentState
             (ZonkAny 53) (ZonkAny 54) (ZonkAny 55) (ZonkAny 56)),
        ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef
  (IntMap
     (ComponentState
        (ZonkAny 53) (ZonkAny 54) (ZonkAny 55) (ZonkAny 56)))
forall context props model action.
IORef (IntMap (ComponentState context props model action))
components ((IntMap
    (ComponentState
       (ZonkAny 53) (ZonkAny 54) (ZonkAny 55) (ZonkAny 56))
  -> (IntMap
        (ComponentState
           (ZonkAny 53) (ZonkAny 54) (ZonkAny 55) (ZonkAny 56)),
      ()))
 -> IO ())
-> (IntMap
      (ComponentState
         (ZonkAny 53) (ZonkAny 54) (ZonkAny 55) (ZonkAny 56))
    -> (IntMap
          (ComponentState
             (ZonkAny 53) (ZonkAny 54) (ZonkAny 55) (ZonkAny 56)),
        ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \IntMap
  (ComponentState
     (ZonkAny 53) (ZonkAny 54) (ZonkAny 55) (ZonkAny 56))
m -> (Int
-> IntMap
     (ComponentState
        (ZonkAny 53) (ZonkAny 54) (ZonkAny 55) (ZonkAny 56))
-> IntMap
     (ComponentState
        (ZonkAny 53) (ZonkAny 54) (ZonkAny 55) (ZonkAny 56))
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
_componentId IntMap
  (ComponentState
     (ZonkAny 53) (ZonkAny 54) (ZonkAny 55) (ZonkAny 56))
m, ())
  Int -> IO ()
FFI.unmountComponent Int
_componentId
-----------------------------------------------------------------------------
-- | 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 action . Eq context
  => Events
  -> ComponentId
  -> ComponentId
  -> Hydrate
  -> Sink action
  -> LogLevel
  -> View context action
  -> IO VTree
buildVTree :: forall context action.
Eq context =>
Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> View context action
-> IO VTree
buildVTree Events
events_ Int
parentId_ Int
vcompId Hydrate
hydrate Sink action
snk LogLevel
logLevel_ = \case
  VComp Maybe Key
maybeKey (SomeComponent props
newProps Component context props model action
app) -> do
    vcomp_ <- IO Object
create

    mountCallback <- do
      syncCallback1' $ \JSVal
parent_ -> do
        ComponentState {..} <- Events
-> Int
-> Hydrate
-> Bool
-> props
-> Maybe Key
-> Component context props model action
-> IO JSVal
-> IO (ComponentState context props model action)
forall context model props action.
(Eq context, Eq model, Eq props) =>
Events
-> Int
-> Hydrate
-> Bool
-> props
-> Maybe Key
-> 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 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" vcomp_ (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 94) (ZonkAny 95) action)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just ComponentState context (ZonkAny 94) (ZonkAny 95) action
componentState -> do
            Maybe action -> (action -> IO ()) -> 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 94) (ZonkAny 95) action
-> action -> IO ()
forall context props model action.
ComponentState context props model action -> action -> IO ()
_componentSink ComponentState context (ZonkAny 94) (ZonkAny 95) action
componentState)
            forall context props model action.
Eq context =>
ComponentState context props model action -> IO ()
unmountComponent @context ComponentState context (ZonkAny 94) (ZonkAny 95) 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 =<< vcomp_ ! ("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 vcomp_
    FFI.set "child" jsNull vcomp_
    forM_ maybeKey (\Key
key -> MisoString -> Key -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"key" Key
key Object
vcomp_)
    FFI.set "mount" mountCallback vcomp_
    FFI.set "unmount" unmountCallback vcomp_
    FFI.set "eventPropagation" (eventPropagation app) vcomp_
    FFI.set "type" VCompType vcomp_
    pure (VTree vcomp_)
  VNode Namespace
ns MisoString
tag [Attribute action]
attrs [View context action]
kids -> do
    vnode_ <- MisoString -> Namespace -> MisoString -> IO Object
createNode MisoString
"vnode" Namespace
ns MisoString
tag
    setAttrs vnode_ attrs snk logLevel_ events_
    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 action -> IO [Object])
-> [Object] -> [View context 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 action -> IO [Object]
forall {context} {v}.
(Eq context, ToJSVal v) =>
v -> [Object] -> View context action -> IO [Object]
buildKid v
parentVTree) [] [View context 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 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 action
kid = do
                VTree child <- Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> View context action
-> IO VTree
forall context action.
Eq context =>
Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> View context action
-> IO VTree
buildVTree Events
events_ Int
parentId_ Int
vcompId Hydrate
hydrate Sink action
snk LogLevel
logLevel_ View context 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 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 action -> IO [Object])
-> [Object] -> [View context 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 action -> IO [Object]
forall {context}.
Eq context =>
[Object] -> View context action -> IO [Object]
buildKid [] [View context 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 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 action
kid = do
                VTree child <- Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> View context action
-> IO VTree
forall context action.
Eq context =>
Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> View context action
-> IO VTree
buildVTree Events
events_ Int
parentId_ Int
vcompId Hydrate
hydrate Sink action
snk LogLevel
logLevel_ View context action
kid
                FFI.set "parent" parentVTree child
                pure (child : acc)
-----------------------------------------------------------------------------
-- | @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 action]
  -> Sink action
  -> LogLevel
  -> Events
  -> IO ()
setAttrs :: forall action.
Object
-> [Attribute action] -> Sink action -> LogLevel -> Events -> IO ()
setAttrs vnode_ :: Object
vnode_@(Object JSVal
jval) [Attribute action]
attrs Sink action
snk LogLevel
logLevel Events
events =
  [Attribute action] -> (Attribute action -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Attribute action]
attrs ((Attribute action -> IO ()) -> IO ())
-> (Attribute 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 Sink action -> VTree -> LogLevel -> Events -> IO ()
callback ->
      Sink action -> VTree -> LogLevel -> Events -> IO ()
callback 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 Key
ZonkAny 1
ZonkAny 2
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
action -> IO ()
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 ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> action -> IO ()
_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
_componentParentId :: Int
_componentProps :: ZonkAny 1
_prevComponentProps :: ZonkAny 1
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: ZonkAny 2
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe action
_componentDraw :: 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 Key
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
action -> IO ()
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 ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> action -> IO ()
_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
_componentParentId :: Int
_componentProps :: props
_prevComponentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe action
_componentDraw :: 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 action -> IO ()
_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 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
ZonkAny 6 -> IO ()
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 ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> action -> IO ()
_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
_componentParentId :: Int
_componentProps :: ZonkAny 4
_prevComponentProps :: ZonkAny 4
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: ZonkAny 6 -> IO ()
_componentModel :: ZonkAny 5
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe (ZonkAny 6)
_componentDraw :: 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 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
ZonkAny 10 -> IO ()
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 ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> action -> IO ()
_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
_componentParentId :: Int
_componentProps :: ZonkAny 8
_prevComponentProps :: ZonkAny 8
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: ZonkAny 10 -> IO ()
_componentModel :: ZonkAny 9
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe (ZonkAny 10)
_componentDraw :: 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 ->
          ZonkAny 10 -> IO ()
_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 Key
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
props -> props -> IO ()
model -> IO ()
model -> model -> Bool
action -> IO ()
Seq action
-> model -> props -> context -> (model, [Schedule context action])
Value -> Maybe action
_componentScripts :: forall context props model action.
ComponentState context props model action -> [JSVal]
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_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 ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> action -> IO ()
_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
_componentParentId :: Int
_componentProps :: props
_prevComponentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe action
_componentDraw :: 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 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
ZonkAny 34 -> IO ()
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 ()
_componentId :: forall context props model action.
ComponentState context props model action -> Int
_componentParentId :: forall context props model action.
ComponentState context props model action -> Int
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentSink :: forall context props model action.
ComponentState context props model action -> action -> IO ()
_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
_componentParentId :: Int
_componentProps :: ZonkAny 32
_prevComponentProps :: ZonkAny 32
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: ZonkAny 34 -> IO ()
_componentModel :: ZonkAny 33
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe (ZonkAny 34)
_componentDraw :: 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 -> ZonkAny 34 -> IO ()
_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 (WebSocket -> IO JSVal
(WebSocket -> IO JSVal) -> ToJSVal WebSocket
forall a. (a -> IO JSVal) -> ToJSVal a
$ctoJSVal :: WebSocket -> IO JSVal
toJSVal :: WebSocket -> IO JSVal
ToJSVal, 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, 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 (EventSource -> IO JSVal
(EventSource -> IO JSVal) -> ToJSVal EventSource
forall a. (a -> IO JSVal) -> ToJSVal a
$ctoJSVal :: EventSource -> IO JSVal
toJSVal :: EventSource -> IO JSVal
ToJSVal, 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, 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)
-----------------------------------------------------------------------------
-- | 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
  :: forall context model action . (Eq context, Eq model)
  => Events
  -> Hydrate
  -> Bool
  -> context
  -- ^ Initial global @context@
  -> Component context () model action
  -> IO ()
initComponent :: forall context model action.
(Eq context, Eq model) =>
Events
-> Hydrate
-> Bool
-> context
-> Component context () model action
-> IO ()
initComponent Events
events Hydrate
hydrate Bool
live context
initialContext vcomp_ :: Component context () model action
vcomp_@Component {model
Bool
[JS]
[CSS]
[Sub action]
Maybe action
Maybe (IO model)
Maybe MisoString
Maybe (() -> () -> action)
LogLevel
context -> () -> model -> View context action
action -> Effect context () 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 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 () model action
view :: context -> () -> model -> View context 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 (() -> () -> action)
..} = 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
    root <- MisoString -> IO JSVal
Diff.mountElement (Maybe MisoString -> MisoString
getMountPoint Maybe MisoString
mountPoint)
    let proxy = Proxy context
forall {k} (t :: k). Proxy t
Proxy :: Proxy context
    when web (cleanup proxy live root)
    atomicWriteIORef globalContext initialContext
    -- dmj: top-level Component always responsive to Context changes
    let vcomp_' = Component context () model action
vcomp_ { useContext = True }
    void $ initialize events rootComponentId hydrate True () Nothing vcomp_' (pure root)
    -- dmj: only the BTS (Lynx background) or plain web context drives the
    -- scheduler; the Lynx main thread (MTS) is render-only and must not fork one.
    when (bts || web) (atomicWriteIORef schedulerThread =<< forkIO (scheduler proxy))
----------------------------------------------------------------------------
-- | 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
----------------------------------------------------------------------------
-- | 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
-----------------------------------------------------------------------------