-----------------------------------------------------------------------------
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE BlockArguments             #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE NumericUnderscores         #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -fno-warn-orphans       #-}
-----------------------------------------------------------------------------
-- |
-- 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
  , parent
  , mailParent
  , mailChildren
  , mailAncestors
  -- ** 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
  , componentIds
  , rootComponentId
  , componentId
  , modifyComponent
  , resetComponentState
  , componentModel
  -- ** Scheduler
  , scheduler
#ifdef WASM
  , evalFile
#endif
  , topLevelComponentId
  , initComponent
  , withJS
  ) where
-----------------------------------------------------------------------------
import qualified Data.IntSet as IS
import           Data.IntSet (IntSet)
import           Control.Category ((.))
import           Control.Concurrent
import           Control.Exception (SomeException, catch, evaluate)
import           Control.Monad (forM, forM_, when, void, (<=<), zipWithM_, forever, foldM)
import           Control.Monad.Reader (ask, asks)
import           Control.Monad.State hiding (state)
import           Miso.JSON (FromJSON, ToJSON, Result(..), fromJSON, toJSON)
import           Data.Foldable (toList)
import qualified Data.List as List
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)
#if __GLASGOW_HASKELL__ > 865
import           GHC.Conc (labelThread)
#endif
import           GHC.Conc (ThreadStatus(ThreadDied, ThreadFinished), threadStatus)
import           Prelude hiding ((.))
import           System.IO.Unsafe (unsafePerformIO)
import           System.Mem.StableName (makeStableName)
#ifdef BENCH
import           Text.Printf
#endif
import           Unsafe.Coerce (unsafeCoerce)
-----------------------------------------------------------------------------
import           Miso.Binding (Precedence(..))
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.JSON (encode, jsonStringify, Value)
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 parent, Eq model, Eq props)
  => Events
  -> ComponentId
  -> Hydrate
  -> Bool
  -- ^ Is the root node being rendered?
  -> props
  -- ^ Initial props for this component
  -> Component parent props model action
  -> IO DOMRef
  -- ^ Callback function is used for obtaining the t'Miso.Types.Component' 'DOMRef'.
  -> IO (ComponentState parent props model action)
initialize :: forall parent model props action.
(Eq parent, Eq model, Eq props) =>
Events
-> Int
-> Hydrate
-> Bool
-> props
-> Component parent props model action
-> IO JSVal
-> IO (ComponentState parent props model action)
initialize Events
events Int
_componentParentId Hydrate
hydrate Bool
isRoot props
initialProps comp :: Component parent props model action
comp@Component {model
Bool
[Binding parent model]
[JS]
[CSS]
[Sub action]
Maybe action
Maybe (IO model)
Maybe MisoString
LogLevel
props -> model -> View model action
action -> Effect parent props model action
Value -> Maybe action
model :: model
hydrateModel :: Maybe (IO model)
update :: action -> Effect parent props model action
view :: props -> model -> View model action
subs :: [Sub action]
styles :: [CSS]
scripts :: [JS]
mountPoint :: Maybe MisoString
logLevel :: LogLevel
mailbox :: Value -> Maybe action
bindings :: [Binding parent model]
eventPropagation :: Bool
mount :: Maybe action
unmount :: Maybe action
unmount :: forall parent props model action.
Component parent props model action -> Maybe action
mount :: forall parent props model action.
Component parent props model action -> Maybe action
eventPropagation :: forall parent props model action.
Component parent props model action -> Bool
bindings :: forall parent props model action.
Component parent props model action -> [Binding parent model]
mailbox :: forall parent props model action.
Component parent props model action -> Value -> Maybe action
logLevel :: forall parent props model action.
Component parent props model action -> LogLevel
mountPoint :: forall parent props model action.
Component parent props model action -> Maybe MisoString
scripts :: forall parent props model action.
Component parent props model action -> [JS]
styles :: forall parent props model action.
Component parent props model action -> [CSS]
subs :: forall parent props model action.
Component parent props model action -> [Sub action]
view :: forall parent props model action.
Component parent props model action
-> props -> model -> View model action
update :: forall parent props model action.
Component parent props model action
-> action -> Effect parent props model action
hydrateModel :: forall parent props model action.
Component parent props model action -> Maybe (IO model)
model :: forall parent props model action.
Component parent props model action -> model
..} IO JSVal
getComponentMountPoint = do
  _componentId <- IO Int
freshComponentId
  let _componentProps = props
initialProps
  let
    _componentSink = \action
action -> 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 (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
        Int
-> IntMap
     (ComponentState (ZonkAny 109) (ZonkAny 110) model (ZonkAny 111))
-> Maybe
     (ComponentState (ZonkAny 109) (ZonkAny 110) model (ZonkAny 111))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
_componentId (IntMap
   (ComponentState (ZonkAny 109) (ZonkAny 110) model (ZonkAny 111))
 -> Maybe
      (ComponentState (ZonkAny 109) (ZonkAny 110) model (ZonkAny 111)))
-> IO
     (IntMap
        (ComponentState (ZonkAny 109) (ZonkAny 110) model (ZonkAny 111)))
-> IO
     (Maybe
        (ComponentState (ZonkAny 109) (ZonkAny 110) model (ZonkAny 111)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState (ZonkAny 109) (ZonkAny 110) model (ZonkAny 111)))
-> IO
     (IntMap
        (ComponentState (ZonkAny 109) (ZonkAny 110) model (ZonkAny 111)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState (ZonkAny 109) (ZonkAny 110) model (ZonkAny 111)))
forall parent props model action.
IORef (IntMap (ComponentState parent props model action))
components IO
  (Maybe
     (ComponentState (ZonkAny 109) (ZonkAny 110) model (ZonkAny 111)))
-> (Maybe
      (ComponentState (ZonkAny 109) (ZonkAny 110) model (ZonkAny 111))
    -> IO model)
-> IO model
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe
  (ComponentState (ZonkAny 109) (ZonkAny 110) model (ZonkAny 111))
Nothing ->
            model -> IO model
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure model
model
          Just ComponentState (ZonkAny 109) (ZonkAny 110) model (ZonkAny 111)
cs ->
            -- hot reload scenario, let it flow
            model -> IO model
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentState (ZonkAny 109) (ZonkAny 110) model (ZonkAny 111)
cs ComponentState (ZonkAny 109) (ZonkAny 110) model (ZonkAny 111)
-> Lens
     (ComponentState (ZonkAny 109) (ZonkAny 110) model (ZonkAny 111))
     model
-> model
forall record field. record -> Lens record field -> field
^. Lens
  (ComponentState (ZonkAny 109) (ZonkAny 110) model (ZonkAny 111))
  model
forall parent props model action.
Lens (ComponentState parent props model action) model
componentModel)
      (Hydrate, Maybe (IO model))
_ -> model -> IO model
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure model
model
  _componentScripts <- (++) <$> renderScripts scripts <*> renderStyles styles
  _componentDOMRef <- getComponentMountPoint
  _componentIsDirty <- pure False
  _componentVTree <- liftIO $ newIORef (VTree (Object jsNull))
  _componentSubThreads <- liftIO (newIORef M.empty)

  frame <- newEmptyMVar :: IO (MVar Double)
  _componentMailbox <- pure 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
        props <- (ComponentState (ZonkAny 113) props (ZonkAny 114) (ZonkAny 115)
-> Lens
     (ComponentState (ZonkAny 113) props (ZonkAny 114) (ZonkAny 115))
     props
-> props
forall record field. record -> Lens record field -> field
^. Lens
  (ComponentState (ZonkAny 113) props (ZonkAny 114) (ZonkAny 115))
  props
forall parent props model action.
Lens (ComponentState parent props model action) props
componentProps) (ComponentState (ZonkAny 113) props (ZonkAny 114) (ZonkAny 115)
 -> props)
-> (IntMap
      (ComponentState (ZonkAny 113) props (ZonkAny 114) (ZonkAny 115))
    -> ComponentState (ZonkAny 113) props (ZonkAny 114) (ZonkAny 115))
-> IntMap
     (ComponentState (ZonkAny 113) props (ZonkAny 114) (ZonkAny 115))
-> 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 113) props (ZonkAny 114) (ZonkAny 115))
-> Int
-> ComponentState (ZonkAny 113) props (ZonkAny 114) (ZonkAny 115)
forall a. IntMap a -> Int -> a
IM.! Int
_componentId) (IntMap
   (ComponentState (ZonkAny 113) props (ZonkAny 114) (ZonkAny 115))
 -> props)
-> IO
     (IntMap
        (ComponentState (ZonkAny 113) props (ZonkAny 114) (ZonkAny 115)))
-> IO props
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState (ZonkAny 113) props (ZonkAny 114) (ZonkAny 115)))
-> IO
     (IntMap
        (ComponentState (ZonkAny 113) props (ZonkAny 114) (ZonkAny 115)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState (ZonkAny 113) props (ZonkAny 114) (ZonkAny 115)))
forall parent props model action.
IORef (IntMap (ComponentState parent props model action))
components
        newVTree <-
          buildVTree events _componentParentId _componentId Draw
            _componentSink logLevel (view props newModel)
        oldVTree <- liftIO (readIORef _componentVTree)
        _frame <- requestAnimationFrame rAFCallback
        _timestamp :: Double <- takeMVar frame
        Diff.diff (Just oldVTree) (Just newVTree) _componentDOMRef
        FFI.updateRef oldVTree newVTree
        liftIO (atomicWriteIORef _componentVTree newVTree)
        FFI.flush

  let _componentApplyActions = \([action]
actions :: [action]) model
model_ IntMap (ComponentState p props model a)
comps props
props -> do 
        let info :: ComponentInfo parent props
info = Int -> Int -> JSVal -> props -> ComponentInfo parent props
forall parent props.
Int -> Int -> JSVal -> props -> ComponentInfo parent props
ComponentInfo Int
_componentId Int
_componentParentId JSVal
_componentDOMRef props
props
        ((IntMap (ComponentState p props model a), model,
  [Schedule action], ComponentIds)
 -> action
 -> (IntMap (ComponentState p props model a), model,
     [Schedule action], ComponentIds))
-> (IntMap (ComponentState p props model a), model,
    [Schedule action], ComponentIds)
-> [action]
-> (IntMap (ComponentState p props model a), model,
    [Schedule action], ComponentIds)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\(IntMap (ComponentState p props model a)
vcomps, model
m, [Schedule action]
ss, ComponentIds
dirtySet) action
a ->
          case Effect parent props model action
-> ComponentInfo parent props
-> model
-> (model, [Schedule action])
forall parent props model action.
Effect parent props model action
-> ComponentInfo parent props
-> model
-> (model, [Schedule action])
runEffect (action -> Effect parent props model action
update action
a) ComponentInfo parent props
forall {parent}. ComponentInfo parent props
info model
m of
            (model
n, [Schedule action]
sss) ->
              let (IntMap (ComponentState p props model a)
newComps, ComponentIds
newDirty)
                    | model -> model -> Bool
forall model. Eq model => model -> model -> Bool
modelCheck model
m model
n =
                        let cs :: ComponentState p props model a
cs = IntMap (ComponentState p props model a)
vcomps IntMap (ComponentState p props model a)
-> Int -> ComponentState p props model a
forall a. IntMap a -> Int -> a
IM.! Int
_componentId
                        in Int
-> IntMap (ComponentState p props model a)
-> (IntMap (ComponentState p props model a), ComponentIds)
forall p props m a.
Int
-> IntMap (ComponentState p props m a)
-> (IntMap (ComponentState p props m a), ComponentIds)
propagate Int
_componentId
                          (Int
-> ComponentState p props model a
-> IntMap (ComponentState p props model a)
-> IntMap (ComponentState p props model a)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
_componentId (ComponentState p props model a
cs { _componentModel = n }) IntMap (ComponentState p props model a)
vcomps)
                    | Bool
otherwise = (IntMap (ComponentState p props model a)
vcomps, ComponentIds
forall a. Monoid a => a
mempty)
              in (IntMap (ComponentState p props model a)
newComps, model
n, [Schedule action]
ss [Schedule action] -> [Schedule action] -> [Schedule action]
forall a. Semigroup a => a -> a -> a
<> [Schedule action]
sss, ComponentIds
dirtySet ComponentIds -> ComponentIds -> ComponentIds
forall a. Semigroup a => a -> a -> a
<> ComponentIds
newDirty)
          ) (IntMap (ComponentState p props model a)
comps, model
model_, [], ComponentIds
forall a. Monoid a => a
mempty) [action]
actions

  let vcomponent = ComponentState
        { _componentEvents :: Events
_componentEvents = Events
events
        , _componentMailbox :: Value -> Maybe action
_componentMailbox = Value -> Maybe action
mailbox
        , _componentBindings :: [Binding parent model]
_componentBindings = [Binding parent model]
bindings
        , _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 model. Eq model => model -> model -> Bool
modelCheck
        , _componentChildren :: ComponentIds
_componentChildren = ComponentIds
forall a. Monoid a => a
mempty
        , _componentModel :: model
_componentModel = model
initializedModel
        , props
Bool
Int
[JSVal]
IORef (Map MisoString ThreadId)
IORef VTree
JSVal
model -> IO ()
Sink action
[action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
forall {action}. action -> IO ()
forall {p} {props} {a}.
[action]
-> model
-> IntMap (ComponentState p props model a)
-> props
-> (IntMap (ComponentState p props model a), model,
    [Schedule action], ComponentIds)
_componentParentId :: Int
_componentId :: Int
_componentProps :: props
_componentSink :: forall {action}. action -> IO ()
_componentScripts :: [JSVal]
_componentDOMRef :: JSVal
_componentIsDirty :: Bool
_componentVTree :: IORef VTree
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDraw :: model -> IO ()
_componentApplyActions :: forall {p} {props} {a}.
[action]
-> model
-> IntMap (ComponentState p props model a)
-> props
-> (IntMap (ComponentState p props model a), model,
    [Schedule action], ComponentIds)
_componentApplyActions :: [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: model -> IO ()
_componentScripts :: [JSVal]
_componentIsDirty :: Bool
_componentSink :: Sink action
_componentVTree :: IORef VTree
_componentDOMRef :: JSVal
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentProps :: props
_componentParentId :: Int
_componentId :: Int
..
        }

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

  -- Inherit bindings state (if applicable)
  _componentModel <- inheritParentBindings _componentParentId initializedModel bindings
  modifyComponent _componentId (componentModel .= _componentModel)

  initSubs subs _componentSubThreads _componentSink
  initialDraw _componentModel events hydrate isRoot comp vcomponent
  forM_ mount _componentSink
  FFI.mountComponent _componentId =<< toObject jsNull
  pure vcomponent
-----------------------------------------------------------------------------
inheritParentBindings
  :: ComponentId
  -- ^ ParentId
  -> child
  -- ^ Child model
  -> [ Binding parent child ]
  -> IO child
inheritParentBindings :: forall child parent.
Int -> child -> [Binding parent child] -> IO child
inheritParentBindings Int
compParentId child
childModel [Binding parent child]
bindings = do
  Int -> child -> [Binding parent child] -> IO ()
forall child parent.
Int -> child -> [Binding parent child] -> IO ()
inheritChildBindings Int
compParentId child
childModel [Binding parent child]
bindings
  (child -> Binding parent child -> IO child)
-> child -> [Binding parent child] -> IO child
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\child
m -> \case
            ParentToChild parent -> field
getParentField field -> child -> child
setChildField -> do
              ComponentState {..} <- (IntMap
  (ComponentState (ZonkAny 87) (ZonkAny 88) parent (ZonkAny 89))
-> Int
-> ComponentState (ZonkAny 87) (ZonkAny 88) parent (ZonkAny 89)
forall a. IntMap a -> Int -> a
IM.! Int
compParentId) (IntMap
   (ComponentState (ZonkAny 87) (ZonkAny 88) parent (ZonkAny 89))
 -> ComponentState (ZonkAny 87) (ZonkAny 88) parent (ZonkAny 89))
-> IO
     (IntMap
        (ComponentState (ZonkAny 87) (ZonkAny 88) parent (ZonkAny 89)))
-> IO
     (ComponentState (ZonkAny 87) (ZonkAny 88) parent (ZonkAny 89))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState (ZonkAny 87) (ZonkAny 88) parent (ZonkAny 89)))
-> IO
     (IntMap
        (ComponentState (ZonkAny 87) (ZonkAny 88) parent (ZonkAny 89)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState (ZonkAny 87) (ZonkAny 88) parent (ZonkAny 89)))
forall parent props model action.
IORef (IntMap (ComponentState parent props model action))
components
              pure (setChildField (getParentField _componentModel) m)
            Bidirectional Precedence
Parent parent -> field
getParentField field -> parent -> parent
_ child -> field
_ field -> child -> child
setChildField -> do
              ComponentState {..} <- (IntMap
  (ComponentState (ZonkAny 90) (ZonkAny 91) parent (ZonkAny 92))
-> Int
-> ComponentState (ZonkAny 90) (ZonkAny 91) parent (ZonkAny 92)
forall a. IntMap a -> Int -> a
IM.! Int
compParentId) (IntMap
   (ComponentState (ZonkAny 90) (ZonkAny 91) parent (ZonkAny 92))
 -> ComponentState (ZonkAny 90) (ZonkAny 91) parent (ZonkAny 92))
-> IO
     (IntMap
        (ComponentState (ZonkAny 90) (ZonkAny 91) parent (ZonkAny 92)))
-> IO
     (ComponentState (ZonkAny 90) (ZonkAny 91) parent (ZonkAny 92))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState (ZonkAny 90) (ZonkAny 91) parent (ZonkAny 92)))
-> IO
     (IntMap
        (ComponentState (ZonkAny 90) (ZonkAny 91) parent (ZonkAny 92)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState (ZonkAny 90) (ZonkAny 91) parent (ZonkAny 92)))
forall parent props model action.
IORef (IntMap (ComponentState parent props model action))
components
              pure (setChildField (getParentField _componentModel) m)
            Binding parent child
_ -> child -> IO child
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure child
m
        ) child
childModel [Binding parent child]
bindings
-----------------------------------------------------------------------------
inheritChildBindings
  :: ComponentId
  -- ^ ParentId
  -> child
  -- ^ Child component
  -> [ Binding parent child ]
  -> IO ()
inheritChildBindings :: forall child parent.
Int -> child -> [Binding parent child] -> IO ()
inheritChildBindings Int
compParentId child
childState [Binding parent child]
bindings = do
  [Binding parent child] -> (Binding parent child -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Binding parent child]
bindings ((Binding parent child -> IO ()) -> IO ())
-> (Binding parent child -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
     ChildToParent field -> parent -> parent
setParentField child -> field
getChildField -> do
       Int
-> State
     (ComponentState (ZonkAny 81) (ZonkAny 82) parent (ZonkAny 83)) ()
-> IO ()
forall parent props model action a.
Int -> State (ComponentState parent props model action) a -> IO ()
modifyComponent Int
compParentId (State
   (ComponentState (ZonkAny 81) (ZonkAny 82) parent (ZonkAny 83)) ()
 -> IO ())
-> State
     (ComponentState (ZonkAny 81) (ZonkAny 82) parent (ZonkAny 83)) ()
-> IO ()
forall a b. (a -> b) -> a -> b
$ do
         Lens
  (ComponentState (ZonkAny 81) (ZonkAny 82) parent (ZonkAny 83))
  parent
forall parent props model action.
Lens (ComponentState parent props model action) model
componentModel Lens
  (ComponentState (ZonkAny 81) (ZonkAny 82) parent (ZonkAny 83))
  parent
-> (parent -> parent)
-> State
     (ComponentState (ZonkAny 81) (ZonkAny 82) parent (ZonkAny 83)) ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> (field -> field) -> m ()
%= field -> parent -> parent
setParentField (child -> field
getChildField child
childState)
         Lens
  (ComponentState (ZonkAny 81) (ZonkAny 82) parent (ZonkAny 83)) Bool
forall parent props model action.
Lens (ComponentState parent props model action) Bool
isDirty Lens
  (ComponentState (ZonkAny 81) (ZonkAny 82) parent (ZonkAny 83)) Bool
-> Bool
-> State
     (ComponentState (ZonkAny 81) (ZonkAny 82) parent (ZonkAny 83)) ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> field -> m ()
.= Bool
True
     Bidirectional Precedence
Child parent -> field
_ field -> parent -> parent
setParentField child -> field
getChildField field -> child -> child
_ -> do
       Int
-> State
     (ComponentState (ZonkAny 84) (ZonkAny 85) parent (ZonkAny 86)) ()
-> IO ()
forall parent props model action a.
Int -> State (ComponentState parent props model action) a -> IO ()
modifyComponent Int
compParentId (State
   (ComponentState (ZonkAny 84) (ZonkAny 85) parent (ZonkAny 86)) ()
 -> IO ())
-> State
     (ComponentState (ZonkAny 84) (ZonkAny 85) parent (ZonkAny 86)) ()
-> IO ()
forall a b. (a -> b) -> a -> b
$ do
         Lens
  (ComponentState (ZonkAny 84) (ZonkAny 85) parent (ZonkAny 86))
  parent
forall parent props model action.
Lens (ComponentState parent props model action) model
componentModel Lens
  (ComponentState (ZonkAny 84) (ZonkAny 85) parent (ZonkAny 86))
  parent
-> (parent -> parent)
-> State
     (ComponentState (ZonkAny 84) (ZonkAny 85) parent (ZonkAny 86)) ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> (field -> field) -> m ()
%= field -> parent -> parent
setParentField (child -> field
getChildField child
childState)
         Lens
  (ComponentState (ZonkAny 84) (ZonkAny 85) parent (ZonkAny 86)) Bool
forall parent props model action.
Lens (ComponentState parent props model action) Bool
isDirty Lens
  (ComponentState (ZonkAny 84) (ZonkAny 85) parent (ZonkAny 86)) Bool
-> Bool
-> State
     (ComponentState (ZonkAny 84) (ZonkAny 85) parent (ZonkAny 86)) ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> field -> m ()
.= Bool
True
     Binding parent child
_ -> do
       () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
-----------------------------------------------------------------------------
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 <- liftIO freshSubId
    liftIO $ atomicModifyIORef' _componentSubThreads $ \Map MisoString ThreadId
m ->
      (MisoString
-> ThreadId -> Map MisoString ThreadId -> Map MisoString ThreadId
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert MisoString
subKey ThreadId
threadId Map MisoString ThreadId
m, ())
-----------------------------------------------------------------------------
-- | Diffs two models, returning True if a redraw is necessary
modelCheck :: Eq model => model -> model -> Bool
modelCheck :: forall model. Eq model => model -> model -> 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 66) (ZonkAny 67) (ZonkAny 68) (ZonkAny 69))
-> Bool
forall a. Maybe a -> Bool
isJust (Maybe
   (ComponentState
      (ZonkAny 66) (ZonkAny 67) (ZonkAny 68) (ZonkAny 69))
 -> Bool)
-> (IntMap
      (ComponentState
         (ZonkAny 66) (ZonkAny 67) (ZonkAny 68) (ZonkAny 69))
    -> Maybe
         (ComponentState
            (ZonkAny 66) (ZonkAny 67) (ZonkAny 68) (ZonkAny 69)))
-> IntMap
     (ComponentState
        (ZonkAny 66) (ZonkAny 67) (ZonkAny 68) (ZonkAny 69))
-> 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 66) (ZonkAny 67) (ZonkAny 68) (ZonkAny 69))
-> Maybe
     (ComponentState
        (ZonkAny 66) (ZonkAny 67) (ZonkAny 68) (ZonkAny 69))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap
   (ComponentState
      (ZonkAny 66) (ZonkAny 67) (ZonkAny 68) (ZonkAny 69))
 -> Bool)
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 66) (ZonkAny 67) (ZonkAny 68) (ZonkAny 69)))
-> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState
        (ZonkAny 66) (ZonkAny 67) (ZonkAny 68) (ZonkAny 69)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 66) (ZonkAny 67) (ZonkAny 68) (ZonkAny 69)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 66) (ZonkAny 67) (ZonkAny 68) (ZonkAny 69)))
forall parent props model action.
IORef (IntMap (ComponentState parent 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 (via 'Binding'). It also is responsible for
-- top-down rendering of the UI Component tree.
scheduler :: IO ()
scheduler :: IO ()
scheduler =
  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, [ZonkAny 76]))
forall action. IO (Maybe (Int, [action]))
getBatch IO (Maybe (Int, [ZonkAny 76]))
-> (Maybe (Int, [ZonkAny 76]) -> 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, [ZonkAny 76])
Nothing -> Waiter -> IO ()
wait Waiter
globalWaiter
      Just (Int
vcompId, [])
        | Int
vcompId Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 -> do
            -- props propagation, negated 'ComponentId' indicates render-phase only.
            vcomps <- IO
  (IntMap
     (ComponentState
        (ZonkAny 77) (ZonkAny 78) (ZonkAny 79) (ZonkAny 80)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 77) (ZonkAny 78) (ZonkAny 79) (ZonkAny 80)))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef
  (IntMap
     (ComponentState
        (ZonkAny 77) (ZonkAny 78) (ZonkAny 79) (ZonkAny 80)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 77) (ZonkAny 78) (ZonkAny 79) (ZonkAny 80)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 77) (ZonkAny 78) (ZonkAny 79) (ZonkAny 80)))
forall parent props model action.
IORef (IntMap (ComponentState parent props model action))
components)
            forM_ (IM.lookup (negate vcompId) vcomps) $ \ComponentState {Bool
Int
[JSVal]
[Binding (ZonkAny 77) (ZonkAny 79)]
ZonkAny 78
ZonkAny 79
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
[ZonkAny 80]
-> ZonkAny 79
-> IntMap
     (ComponentState
        (ZonkAny 77) (ZonkAny 78) (ZonkAny 79) (ZonkAny 80))
-> ZonkAny 78
-> (IntMap
      (ComponentState
         (ZonkAny 77) (ZonkAny 78) (ZonkAny 79) (ZonkAny 80)),
    ZonkAny 79, [Schedule (ZonkAny 80)], ComponentIds)
ZonkAny 79 -> IO ()
ZonkAny 79 -> ZonkAny 79 -> Bool
ZonkAny 80 -> IO ()
Value -> Maybe (ZonkAny 80)
_componentModel :: forall parent props model action.
ComponentState parent props model action -> model
_componentEvents :: forall parent props model action.
ComponentState parent props model action -> Events
_componentMailbox :: forall parent props model action.
ComponentState parent props model action -> Value -> Maybe action
_componentBindings :: forall parent props model action.
ComponentState parent props model action -> [Binding parent model]
_componentTopics :: forall parent props model action.
ComponentState parent props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent props model action.
ComponentState parent props model action -> model -> model -> Bool
_componentChildren :: forall parent props model action.
ComponentState parent props model action -> ComponentIds
_componentApplyActions :: forall parent props model action.
ComponentState parent props model action
-> [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent props model action.
ComponentState parent props model action -> model -> IO ()
_componentScripts :: forall parent props model action.
ComponentState parent props model action -> [JSVal]
_componentIsDirty :: forall parent props model action.
ComponentState parent props model action -> Bool
_componentSink :: forall parent props model action.
ComponentState parent props model action -> action -> IO ()
_componentVTree :: forall parent props model action.
ComponentState parent props model action -> IORef VTree
_componentDOMRef :: forall parent props model action.
ComponentState parent props model action -> JSVal
_componentSubThreads :: forall parent props model action.
ComponentState parent props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall parent props model action.
ComponentState parent props model action -> props
_componentParentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentProps :: ZonkAny 78
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: ZonkAny 80 -> IO ()
_componentModel :: ZonkAny 79
_componentIsDirty :: Bool
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentBindings :: [Binding (ZonkAny 77) (ZonkAny 79)]
_componentMailbox :: Value -> Maybe (ZonkAny 80)
_componentDraw :: ZonkAny 79 -> IO ()
_componentModelDirty :: ZonkAny 79 -> ZonkAny 79 -> Bool
_componentApplyActions :: [ZonkAny 80]
-> ZonkAny 79
-> IntMap
     (ComponentState
        (ZonkAny 77) (ZonkAny 78) (ZonkAny 79) (ZonkAny 80))
-> ZonkAny 78
-> (IntMap
      (ComponentState
         (ZonkAny 77) (ZonkAny 78) (ZonkAny 79) (ZonkAny 80)),
    ZonkAny 79, [Schedule (ZonkAny 80)], ComponentIds)
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} ->
              ZonkAny 79 -> IO ()
_componentDraw ZonkAny 79
_componentModel
                             
      Just (Int
vcompId, [ZonkAny 76]
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 -> [action] -> IO ()
    run :: forall action. Int -> [action] -> IO ()
run Int
vcompId = ComponentIds -> IO ()
renderComponents (ComponentIds -> IO ())
-> ([action] -> IO ComponentIds) -> [action] -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Int -> [action] -> IO ComponentIds
forall action. Int -> [action] -> IO ComponentIds
commit Int
vcompId
    -----------------------------------------------------------------------------
    -- | Apply the actions across the model, evaluate async and sync IO.
    commit :: ComponentId -> [action] -> IO ComponentIds
    commit :: forall action. Int -> [action] -> IO ComponentIds
commit Int
vcompId [action]
events = do
      (updatedModel, schedules, dirtySet, ComponentState{..}) <- do
        IORef
  (IntMap
     (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action))
-> (IntMap
      (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action)
    -> (IntMap
          (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action),
        (ZonkAny 72, [Schedule action], ComponentIds,
         ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action)))
-> IO
     (ZonkAny 72, [Schedule action], ComponentIds,
      ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef
  (IntMap
     (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action))
forall parent props model action.
IORef (IntMap (ComponentState parent props model action))
components ((IntMap
    (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action)
  -> (IntMap
        (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action),
      (ZonkAny 72, [Schedule action], ComponentIds,
       ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action)))
 -> IO
      (ZonkAny 72, [Schedule action], ComponentIds,
       ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action))
-> (IntMap
      (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action)
    -> (IntMap
          (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action),
        (ZonkAny 72, [Schedule action], ComponentIds,
         ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action)))
-> IO
     (ZonkAny 72, [Schedule action], ComponentIds,
      ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action)
forall a b. (a -> b) -> a -> b
$ \IntMap
  (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action)
vcomps -> do
          let cs :: ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action
cs@ComponentState {Bool
Int
[JSVal]
[Binding (ZonkAny 74) (ZonkAny 72)]
ZonkAny 72
ZonkAny 75
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
action -> IO ()
[action]
-> ZonkAny 72
-> IntMap
     (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action)
-> ZonkAny 75
-> (IntMap
      (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action),
    ZonkAny 72, [Schedule action], ComponentIds)
ZonkAny 72 -> IO ()
ZonkAny 72 -> ZonkAny 72 -> Bool
Value -> Maybe action
_componentModel :: forall parent props model action.
ComponentState parent props model action -> model
_componentEvents :: forall parent props model action.
ComponentState parent props model action -> Events
_componentMailbox :: forall parent props model action.
ComponentState parent props model action -> Value -> Maybe action
_componentBindings :: forall parent props model action.
ComponentState parent props model action -> [Binding parent model]
_componentTopics :: forall parent props model action.
ComponentState parent props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent props model action.
ComponentState parent props model action -> model -> model -> Bool
_componentChildren :: forall parent props model action.
ComponentState parent props model action -> ComponentIds
_componentApplyActions :: forall parent props model action.
ComponentState parent props model action
-> [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent props model action.
ComponentState parent props model action -> model -> IO ()
_componentScripts :: forall parent props model action.
ComponentState parent props model action -> [JSVal]
_componentIsDirty :: forall parent props model action.
ComponentState parent props model action -> Bool
_componentSink :: forall parent props model action.
ComponentState parent props model action -> action -> IO ()
_componentVTree :: forall parent props model action.
ComponentState parent props model action -> IORef VTree
_componentDOMRef :: forall parent props model action.
ComponentState parent props model action -> JSVal
_componentSubThreads :: forall parent props model action.
ComponentState parent props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall parent props model action.
ComponentState parent props model action -> props
_componentParentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentProps :: ZonkAny 75
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: ZonkAny 72
_componentIsDirty :: Bool
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentBindings :: [Binding (ZonkAny 74) (ZonkAny 72)]
_componentMailbox :: Value -> Maybe action
_componentDraw :: ZonkAny 72 -> IO ()
_componentModelDirty :: ZonkAny 72 -> ZonkAny 72 -> Bool
_componentApplyActions :: [action]
-> ZonkAny 72
-> IntMap
     (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action)
-> ZonkAny 75
-> (IntMap
      (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action),
    ZonkAny 72, [Schedule action], ComponentIds)
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} = IntMap
  (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action)
vcomps IntMap
  (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action)
-> Int
-> ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action
forall a. IntMap a -> Int -> a
IM.! Int
vcompId
          case [action]
-> ZonkAny 72
-> IntMap
     (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action)
-> ZonkAny 75
-> (IntMap
      (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action),
    ZonkAny 72, [Schedule action], ComponentIds)
_componentApplyActions [action]
events ZonkAny 72
_componentModel IntMap
  (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action)
vcomps ZonkAny 75
_componentProps of
            (IntMap
  (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action)
x, ZonkAny 72
updatedModel, [Schedule action]
schedules, ComponentIds
dirtySet) ->
              (IntMap
  (ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action)
x, (ZonkAny 72
updatedModel, [Schedule action]
schedules, ComponentIds
dirtySet, ComponentState (ZonkAny 74) (ZonkAny 75) (ZonkAny 72) action
cs))
      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)
      if _componentModelDirty _componentModel updatedModel
        then do
          modifyComponent _componentId $ do
            isDirty .= True
            componentModel .= updatedModel
          pure dirtySet
        else
          pure mempty
-----------------------------------------------------------------------------
-- | Perform a top-down rendering of the 'Component' tree.
--
-- We lookup the components each time to account for unmounting.
-- Reset the dirty bit if a render occurs
--
renderComponents :: ComponentIds -> IO ()
renderComponents :: ComponentIds -> IO ()
renderComponents ComponentIds
dirtySet = do
  [Int] -> (Int -> IO (Maybe ())) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ComponentIds -> [Int]
IS.toAscList ComponentIds
dirtySet) ((Int -> IO (Maybe ())) -> IO ())
-> (Int -> IO (Maybe ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
vcompId ->
    Int
-> IntMap
     (ComponentState
        (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65))
-> Maybe
     (ComponentState
        (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap
   (ComponentState
      (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65))
 -> Maybe
      (ComponentState
         (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65)))
-> IO
     (Maybe
        (ComponentState
           (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO
  (IntMap
     (ComponentState
        (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65)))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef
  (IntMap
     (ComponentState
        (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65)))
forall parent props model action.
IORef (IntMap (ComponentState parent props model action))
components) IO
  (Maybe
     (ComponentState
        (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65)))
-> (Maybe
      (ComponentState
         (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65))
    -> IO (Maybe ()))
-> IO (Maybe ())
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 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65)
 -> IO ())
-> Maybe
     (ComponentState
        (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65))
-> IO (Maybe ())
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM \ComponentState {Bool
Int
[JSVal]
[Binding (ZonkAny 62) (ZonkAny 64)]
ZonkAny 63
ZonkAny 64
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
[ZonkAny 65]
-> ZonkAny 64
-> IntMap
     (ComponentState
        (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65))
-> ZonkAny 63
-> (IntMap
      (ComponentState
         (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65)),
    ZonkAny 64, [Schedule (ZonkAny 65)], ComponentIds)
ZonkAny 64 -> IO ()
ZonkAny 64 -> ZonkAny 64 -> Bool
ZonkAny 65 -> IO ()
Value -> Maybe (ZonkAny 65)
_componentModel :: forall parent props model action.
ComponentState parent props model action -> model
_componentEvents :: forall parent props model action.
ComponentState parent props model action -> Events
_componentMailbox :: forall parent props model action.
ComponentState parent props model action -> Value -> Maybe action
_componentBindings :: forall parent props model action.
ComponentState parent props model action -> [Binding parent model]
_componentTopics :: forall parent props model action.
ComponentState parent props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent props model action.
ComponentState parent props model action -> model -> model -> Bool
_componentChildren :: forall parent props model action.
ComponentState parent props model action -> ComponentIds
_componentApplyActions :: forall parent props model action.
ComponentState parent props model action
-> [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent props model action.
ComponentState parent props model action -> model -> IO ()
_componentScripts :: forall parent props model action.
ComponentState parent props model action -> [JSVal]
_componentIsDirty :: forall parent props model action.
ComponentState parent props model action -> Bool
_componentSink :: forall parent props model action.
ComponentState parent props model action -> action -> IO ()
_componentVTree :: forall parent props model action.
ComponentState parent props model action -> IORef VTree
_componentDOMRef :: forall parent props model action.
ComponentState parent props model action -> JSVal
_componentSubThreads :: forall parent props model action.
ComponentState parent props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall parent props model action.
ComponentState parent props model action -> props
_componentParentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentProps :: ZonkAny 63
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: ZonkAny 65 -> IO ()
_componentModel :: ZonkAny 64
_componentIsDirty :: Bool
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentBindings :: [Binding (ZonkAny 62) (ZonkAny 64)]
_componentMailbox :: Value -> Maybe (ZonkAny 65)
_componentDraw :: ZonkAny 64 -> IO ()
_componentModelDirty :: ZonkAny 64 -> ZonkAny 64 -> Bool
_componentApplyActions :: [ZonkAny 65]
-> ZonkAny 64
-> IntMap
     (ComponentState
        (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65))
-> ZonkAny 63
-> (IntMap
      (ComponentState
         (ZonkAny 62) (ZonkAny 63) (ZonkAny 64) (ZonkAny 65)),
    ZonkAny 64, [Schedule (ZonkAny 65)], ComponentIds)
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
_componentIsDirty (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        ZonkAny 64 -> IO ()
_componentDraw ZonkAny 64
_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
      Int
-> State
     (ComponentState (ZonkAny 5) (ZonkAny 6) (ZonkAny 7) (ZonkAny 8)) ()
-> IO ()
forall parent props model action a.
Int -> State (ComponentState parent props model action) a -> IO ()
modifyComponent Int
_componentId (Lens
  (ComponentState (ZonkAny 5) (ZonkAny 6) (ZonkAny 7) (ZonkAny 8))
  Bool
forall parent props model action.
Lens (ComponentState parent props model action) Bool
isDirty Lens
  (ComponentState (ZonkAny 5) (ZonkAny 6) (ZonkAny 7) (ZonkAny 8))
  Bool
-> Bool
-> State
     (ComponentState (ZonkAny 5) (ZonkAny 6) (ZonkAny 7) (ZonkAny 8)) ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> field -> m ()
.= Bool
False)
-----------------------------------------------------------------------------
-- | Modify a single t'Component p m a' at a t'ComponentId'.
--
-- Auxiliary function
modifyComponent
  :: ComponentId
  -> State (ComponentState parent props model action) a
  -> IO ()
modifyComponent :: forall parent props model action a.
Int -> State (ComponentState parent props model action) a -> IO ()
modifyComponent Int
vcompId State (ComponentState parent props model action) a
go = 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
$
  IORef (IntMap (ComponentState parent props model action))
-> (IntMap (ComponentState parent props model action)
    -> (IntMap (ComponentState parent props model action), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (IntMap (ComponentState parent props model action))
forall parent props model action.
IORef (IntMap (ComponentState parent props model action))
components ((IntMap (ComponentState parent props model action)
  -> (IntMap (ComponentState parent props model action), ()))
 -> IO ())
-> (IntMap (ComponentState parent props model action)
    -> (IntMap (ComponentState parent props model action), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \IntMap (ComponentState parent props model action)
vcomps ->
    ((ComponentState parent props model action
 -> ComponentState parent props model action)
-> Int
-> IntMap (ComponentState parent props model action)
-> IntMap (ComponentState parent props model action)
forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IM.adjust (State (ComponentState parent props model action) a
-> ComponentState parent props model action
-> ComponentState parent props model action
forall s a. State s a -> s -> s
execState State (ComponentState parent props model action) a
go) Int
vcompId IntMap (ComponentState parent props model action)
vcomps, ())
----------------------------------------------------------------------------
propagate
  :: ComponentId
  -> IntMap (ComponentState p props m a)
  -> (IntMap (ComponentState p props m a), ComponentIds)
propagate :: forall p props m a.
Int
-> IntMap (ComponentState p props m a)
-> (IntMap (ComponentState p props m a), ComponentIds)
propagate Int
vcompId IntMap (ComponentState p props m a)
vcomps =
  let dfsState :: DFS p props m a
dfsState = State (DFS p props m a) () -> DFS p props m a -> DFS p props m a
forall s a. State s a -> s -> s
execState State (DFS p props m a) ()
forall p props m a. Synch p props m a ()
synch (IntMap (ComponentState p props m a) -> Int -> DFS p props m a
forall p props m a.
IntMap (ComponentState p props m a) -> Int -> DFS p props m a
dfs IntMap (ComponentState p props m a)
vcomps Int
vcompId)
  in (DFS p props m a -> IntMap (ComponentState p props m a)
forall p props m a.
DFS p props m a -> IntMap (ComponentState p props m a)
_state DFS p props m a
dfsState, DFS p props m a -> ComponentIds
forall p props m a. DFS p props m a -> ComponentIds
_visited DFS p props m a
dfsState)
-----------------------------------------------------------------------------
-- | Create an empty DFS state
dfs :: IntMap (ComponentState p props m a) -> ComponentId -> DFS p props m a
dfs :: forall p props m a.
IntMap (ComponentState p props m a) -> Int -> DFS p props m a
dfs IntMap (ComponentState p props m a)
cs Int
vcompId = IntMap (ComponentState p props m a)
-> ComponentIds -> [Int] -> DFS p props m a
forall p props m a.
IntMap (ComponentState p props m a)
-> ComponentIds -> [Int] -> DFS p props m a
DFS IntMap (ComponentState p props m a)
cs ComponentIds
forall a. Monoid a => a
mempty (Int -> [Int]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
vcompId)
-----------------------------------------------------------------------------
type ComponentIds = IntSet
-----------------------------------------------------------------------------
data DFS p props m a
  = DFS
  { forall p props m a.
DFS p props m a -> IntMap (ComponentState p props m a)
_state :: IntMap (ComponentState p props m a)
    -- ^ global component state to alter
  , forall p props m a. DFS p props m a -> ComponentIds
_visited :: ComponentIds
    -- ^ visited set
  , forall p props m a. DFS p props m a -> [Int]
_stack :: [ComponentId]
    -- ^ neighbors queue
  }
-----------------------------------------------------------------------------
type Synch p props m a x = State (DFS p props m a) x
-----------------------------------------------------------------------------
visited :: Lens (DFS p props m a) (ComponentIds)
visited :: forall p props m a. Lens (DFS p props m a) ComponentIds
visited = (DFS p props m a -> ComponentIds)
-> (DFS p props m a -> ComponentIds -> DFS p props m a)
-> Lens (DFS p props m a) ComponentIds
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens DFS p props m a -> ComponentIds
forall p props m a. DFS p props m a -> ComponentIds
_visited ((DFS p props m a -> ComponentIds -> DFS p props m a)
 -> Lens (DFS p props m a) ComponentIds)
-> (DFS p props m a -> ComponentIds -> DFS p props m a)
-> Lens (DFS p props m a) ComponentIds
forall a b. (a -> b) -> a -> b
$ \DFS p props m a
r ComponentIds
x -> DFS p props m a
r { _visited = x }
-----------------------------------------------------------------------------
state :: Lens (DFS p props m a) (IntMap (ComponentState p props m a))
state :: forall p props m a.
Lens (DFS p props m a) (IntMap (ComponentState p props m a))
state = (DFS p props m a -> IntMap (ComponentState p props m a))
-> (DFS p props m a
    -> IntMap (ComponentState p props m a) -> DFS p props m a)
-> Lens (DFS p props m a) (IntMap (ComponentState p props m a))
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens DFS p props m a -> IntMap (ComponentState p props m a)
forall p props m a.
DFS p props m a -> IntMap (ComponentState p props m a)
_state ((DFS p props m a
  -> IntMap (ComponentState p props m a) -> DFS p props m a)
 -> Lens (DFS p props m a) (IntMap (ComponentState p props m a)))
-> (DFS p props m a
    -> IntMap (ComponentState p props m a) -> DFS p props m a)
-> Lens (DFS p props m a) (IntMap (ComponentState p props m a))
forall a b. (a -> b) -> a -> b
$ \DFS p props m a
r IntMap (ComponentState p props m a)
x -> DFS p props m a
r { _state = x }
-----------------------------------------------------------------------------
stack :: Lens (DFS p props m a) [ComponentId]
stack :: forall p props m a. Lens (DFS p props m a) [Int]
stack = (DFS p props m a -> [Int])
-> (DFS p props m a -> [Int] -> DFS p props m a)
-> Lens (DFS p props m a) [Int]
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens DFS p props m a -> [Int]
forall p props m a. DFS p props m a -> [Int]
_stack ((DFS p props m a -> [Int] -> DFS p props m a)
 -> Lens (DFS p props m a) [Int])
-> (DFS p props m a -> [Int] -> DFS p props m a)
-> Lens (DFS p props m a) [Int]
forall a b. (a -> b) -> a -> b
$ \DFS p props m a
r [Int]
x -> DFS p props m a
r { _stack = x }
-----------------------------------------------------------------------------
synch :: Synch p props m a ()
synch :: forall p props m a. Synch p props m a ()
synch = (ComponentState p props m a
 -> StateT (DFS p props m a) Identity ())
-> Maybe (ComponentState p props m a)
-> StateT (DFS p props m a) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ComponentState p props m a -> StateT (DFS p props m a) Identity ()
forall p props m a.
ComponentState p props m a -> Synch p props m a ()
go (Maybe (ComponentState p props m a)
 -> StateT (DFS p props m a) Identity ())
-> StateT
     (DFS p props m a) Identity (Maybe (ComponentState p props m a))
-> StateT (DFS p props m a) Identity ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT
  (DFS p props m a) Identity (Maybe (ComponentState p props m a))
forall p props m a.
Synch p props m a (Maybe (ComponentState p props m a))
pop
  where
    go :: ComponentState p props m a -> Synch p props m a ()
    go :: forall p props m a.
ComponentState p props m a -> Synch p props m a ()
go ComponentState p props m a
cs = do
      seen <- Int -> ComponentIds -> Bool
IS.member (ComponentState p props m a
cs ComponentState p props m a
-> Lens (ComponentState p props m a) Int -> Int
forall record field. record -> Lens record field -> field
^. Lens (ComponentState p props m a) Int
forall parent props model action.
Lens (ComponentState parent props model action) Int
componentId) (ComponentIds -> Bool)
-> StateT (DFS p props m a) Identity ComponentIds
-> StateT (DFS p props m a) Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens (DFS p props m a) ComponentIds
-> StateT (DFS p props m a) Identity ComponentIds
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> m field
use Lens (DFS p props m a) ComponentIds
forall p props m a. Lens (DFS p props m a) ComponentIds
visited
      when (not seen) $ do
        propagateParent cs (cs ^. parentId)
        propagateChildren cs (cs ^. children)
        markVisited (cs ^. componentId)
        synch
-----------------------------------------------------------------------------
propagateChildren
  :: forall p props m a
   . ComponentState p props m a
  -> ComponentIds
  -> Synch p props m a ()
propagateChildren :: forall p props m a.
ComponentState p props m a -> ComponentIds -> Synch p props m a ()
propagateChildren ComponentState p props m a
currentState ComponentIds
childComponents = do
  [Int]
-> (Int -> StateT (DFS p props m a) Identity ())
-> StateT (DFS p props m a) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ComponentIds -> [Int]
IS.toList ComponentIds
childComponents) ((Int -> StateT (DFS p props m a) Identity ())
 -> StateT (DFS p props m a) Identity ())
-> (Int -> StateT (DFS p props m a) Identity ())
-> StateT (DFS p props m a) Identity ()
forall a b. (a -> b) -> a -> b
$ \Int
childId -> do
    childState <- (IntMap (ZonkAny 44) -> ZonkAny 44)
-> IntMap (ComponentState p props m a)
-> ComponentState m props m a
forall a b. a -> b
unsafeCoerce (IntMap (ZonkAny 44) -> Int -> ZonkAny 44
forall a. IntMap a -> Int -> a
IM.! Int
childId) (IntMap (ComponentState p props m a) -> ComponentState m props m a)
-> StateT
     (DFS p props m a) Identity (IntMap (ComponentState p props m a))
-> StateT (DFS p props m a) Identity (ComponentState m props m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens (DFS p props m a) (IntMap (ComponentState p props m a))
-> StateT
     (DFS p props m a) Identity (IntMap (ComponentState p props m a))
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> m field
use Lens (DFS p props m a) (IntMap (ComponentState p props m a))
forall p props m a.
Lens (DFS p props m a) (IntMap (ComponentState p props m a))
state
    updatedChild <- unsafeCoerce <$>
      foldM process childState (childState ^. componentBindings)
    let isChildDirty =
          (ComponentState m props m a -> m -> m -> Bool
forall parent props model action.
ComponentState parent props model action -> model -> model -> Bool
_componentModelDirty ComponentState m props m a
childState)
          (ComponentState m props m a -> m
forall parent props model action.
ComponentState parent props model action -> model
_componentModel ComponentState m props m a
childState)
          (ComponentState p props m a -> m
forall parent props model action.
ComponentState parent props model action -> model
_componentModel ComponentState p props m a
updatedChild)
    when isChildDirty $ do
      state.at childId ?= updatedChild { _componentIsDirty = True }
      visit childId
    where
      process
        :: ComponentState m props child a
        -> Binding m child
        -> Synch p props m a (ComponentState m props child a)
      process :: forall child.
ComponentState m props child a
-> Binding m child
-> Synch p props m a (ComponentState m props child a)
process ComponentState m props child a
childState = \case
        ParentToChild m -> field
getCurrentField field -> child -> child
setChildField -> do
          let currentChildModel :: child
currentChildModel = ComponentState m props child a
childState ComponentState m props child a
-> Lens (ComponentState m props child a) child -> child
forall record field. record -> Lens record field -> field
^. Lens (ComponentState m props child a) child
forall parent props model action.
Lens (ComponentState parent props model action) model
componentModel
              currentFieldValue :: field
currentFieldValue = m -> field
getCurrentField (ComponentState p props m a
currentState ComponentState p props m a
-> Lens (ComponentState p props m a) m -> m
forall record field. record -> Lens record field -> field
^. Lens (ComponentState p props m a) m
forall parent props model action.
Lens (ComponentState parent props model action) model
componentModel)
              updatedChildModel :: child
updatedChildModel = field -> child -> child
setChildField field
currentFieldValue child
currentChildModel
          ComponentState m props child a
-> Synch p props m a (ComponentState m props child a)
forall a. a -> StateT (DFS p props m a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentState m props child a
childState ComponentState m props child a
-> (ComponentState m props child a
    -> ComponentState m props child a)
-> ComponentState m props child a
forall a b. a -> (a -> b) -> b
& Lens (ComponentState m props child a) child
forall parent props model action.
Lens (ComponentState parent props model action) model
componentModel Lens (ComponentState m props child a) child
-> child
-> ComponentState m props child a
-> ComponentState m props child a
forall record field. Lens record field -> field -> record -> record
.~ child
updatedChildModel)
        Bidirectional Precedence
_ m -> field
getCurrentField field -> m -> m
_ child -> field
_ field -> child -> child
setChildField -> do
          let currentChildModel :: child
currentChildModel = ComponentState m props child a -> child
forall parent props model action.
ComponentState parent props model action -> model
_componentModel ComponentState m props child a
childState
              currentFieldValue :: field
currentFieldValue = m -> field
getCurrentField (ComponentState p props m a
currentState ComponentState p props m a
-> Lens (ComponentState p props m a) m -> m
forall record field. record -> Lens record field -> field
^. Lens (ComponentState p props m a) m
forall parent props model action.
Lens (ComponentState parent props model action) model
componentModel)
              updatedChildModel :: child
updatedChildModel = field -> child -> child
setChildField field
currentFieldValue child
currentChildModel
          ComponentState m props child a
-> Synch p props m a (ComponentState m props child a)
forall a. a -> StateT (DFS p props m a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentState m props child a
childState ComponentState m props child a
-> (ComponentState m props child a
    -> ComponentState m props child a)
-> ComponentState m props child a
forall a b. a -> (a -> b) -> b
& Lens (ComponentState m props child a) child
forall parent props model action.
Lens (ComponentState parent props model action) model
componentModel Lens (ComponentState m props child a) child
-> child
-> ComponentState m props child a
-> ComponentState m props child a
forall record field. Lens record field -> field -> record -> record
.~ child
updatedChildModel)
        Binding m child
_ ->
          ComponentState m props child a
-> Synch p props m a (ComponentState m props child a)
forall a. a -> StateT (DFS p props m a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ComponentState m props child a
childState
-----------------------------------------------------------------------------
propagateParent
  :: forall p props m a
   . ComponentState p props m a
  -> ComponentId
  -> Synch p props m a ()
propagateParent :: forall p props m a.
ComponentState p props m a -> Int -> Synch p props m a ()
propagateParent ComponentState p props m a
currentState Int
parentId_ =
  Int
-> IntMap (ComponentState p props m a)
-> Maybe (ComponentState p props m a)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
parentId_ (IntMap (ComponentState p props m a)
 -> Maybe (ComponentState p props m a))
-> StateT
     (DFS p props m a) Identity (IntMap (ComponentState p props m a))
-> StateT
     (DFS p props m a) Identity (Maybe (ComponentState p props m a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens (DFS p props m a) (IntMap (ComponentState p props m a))
-> StateT
     (DFS p props m a) Identity (IntMap (ComponentState p props m a))
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> m field
use Lens (DFS p props m a) (IntMap (ComponentState p props m a))
forall p props m a.
Lens (DFS p props m a) (IntMap (ComponentState p props m a))
state StateT
  (DFS p props m a) Identity (Maybe (ComponentState p props m a))
-> (Maybe (ComponentState p props m a)
    -> StateT (DFS p props m a) Identity ())
-> StateT (DFS p props m a) Identity ()
forall a b.
StateT (DFS p props m a) Identity a
-> (a -> StateT (DFS p props m a) Identity b)
-> StateT (DFS p props m a) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ComponentState p props m a
 -> StateT (DFS p props m a) Identity ())
-> Maybe (ComponentState p props m a)
-> StateT (DFS p props m a) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ \case
    ComponentState p props m a
parentState -> do
      updatedParent <- ComponentState (ZonkAny 45) props p a -> ComponentState p props m a
forall a b. a -> b
unsafeCoerce (ComponentState (ZonkAny 45) props p a
 -> ComponentState p props m a)
-> StateT
     (DFS p props m a) Identity (ComponentState (ZonkAny 45) props p a)
-> StateT (DFS p props m a) Identity (ComponentState p props m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (ComponentState (ZonkAny 45) props p a
 -> Binding p m
 -> StateT
      (DFS p props m a) Identity (ComponentState (ZonkAny 45) props p a))
-> ComponentState (ZonkAny 45) props p a
-> [Binding p m]
-> StateT
     (DFS p props m a) Identity (ComponentState (ZonkAny 45) props p a)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ComponentState (ZonkAny 45) props p a
-> Binding p m
-> StateT
     (DFS p props m a) Identity (ComponentState (ZonkAny 45) props p a)
forall x.
ComponentState x props p a
-> Binding p m -> Synch p props m a (ComponentState x props p a)
process (ComponentState p props m a -> ComponentState (ZonkAny 45) props p a
forall a b. a -> b
unsafeCoerce ComponentState p props m a
parentState) (ComponentState p props m a
currentState ComponentState p props m a
-> Lens (ComponentState p props m a) [Binding p m] -> [Binding p m]
forall record field. record -> Lens record field -> field
^. Lens (ComponentState p props m a) [Binding p m]
forall p props m a. Lens (ComponentState p props m a) [Binding p m]
componentBindings)
      let isParentDirty =
            (ComponentState p props m a -> m -> m -> Bool
forall parent props model action.
ComponentState parent props model action -> model -> model -> Bool
_componentModelDirty ComponentState p props m a
parentState)
            (ComponentState p props m a -> m
forall parent props model action.
ComponentState parent props model action -> model
_componentModel ComponentState p props m a
parentState)
            (ComponentState p props m a -> m
forall parent props model action.
ComponentState parent props model action -> model
_componentModel ComponentState p props m a
updatedParent)
      when isParentDirty $ do
        state.at parentId_ ?= updatedParent { _componentIsDirty = True }
        visit parentId_
  where
    process
      :: ComponentState x props p a
      -> Binding p m
      -> Synch p props m a (ComponentState x props p a)
    process :: forall x.
ComponentState x props p a
-> Binding p m -> Synch p props m a (ComponentState x props p a)
process ComponentState x props p a
parentState = \case
      ChildToParent field -> p -> p
setParentField m -> field
getCurrentField -> do
        let currentParentModel :: p
currentParentModel = ComponentState x props p a
parentState ComponentState x props p a
-> Lens (ComponentState x props p a) p -> p
forall record field. record -> Lens record field -> field
^. Lens (ComponentState x props p a) p
forall parent props model action.
Lens (ComponentState parent props model action) model
componentModel
            currentFieldValue :: field
currentFieldValue = m -> field
getCurrentField (ComponentState p props m a
currentState ComponentState p props m a
-> Lens (ComponentState p props m a) m -> m
forall record field. record -> Lens record field -> field
^. Lens (ComponentState p props m a) m
forall parent props model action.
Lens (ComponentState parent props model action) model
componentModel)
            updatedParentModel :: p
updatedParentModel = field -> p -> p
setParentField field
currentFieldValue p
currentParentModel
        ComponentState x props p a
-> Synch p props m a (ComponentState x props p a)
forall a. a -> StateT (DFS p props m a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentState x props p a
parentState ComponentState x props p a
-> (ComponentState x props p a -> ComponentState x props p a)
-> ComponentState x props p a
forall a b. a -> (a -> b) -> b
& Lens (ComponentState x props p a) p
forall parent props model action.
Lens (ComponentState parent props model action) model
componentModel Lens (ComponentState x props p a) p
-> p -> ComponentState x props p a -> ComponentState x props p a
forall record field. Lens record field -> field -> record -> record
.~ p
updatedParentModel)
      Bidirectional Precedence
_ p -> field
_ field -> p -> p
setParentField m -> field
getCurrentField field -> m -> m
_ -> do
        let currentParentModel :: p
currentParentModel = ComponentState x props p a
parentState ComponentState x props p a
-> Lens (ComponentState x props p a) p -> p
forall record field. record -> Lens record field -> field
^. Lens (ComponentState x props p a) p
forall parent props model action.
Lens (ComponentState parent props model action) model
componentModel
            currentFieldValue :: field
currentFieldValue = m -> field
getCurrentField (ComponentState p props m a
currentState ComponentState p props m a
-> Lens (ComponentState p props m a) m -> m
forall record field. record -> Lens record field -> field
^. Lens (ComponentState p props m a) m
forall parent props model action.
Lens (ComponentState parent props model action) model
componentModel)
            updatedParentModel :: p
updatedParentModel = field -> p -> p
setParentField field
currentFieldValue p
currentParentModel
        ComponentState x props p a
-> Synch p props m a (ComponentState x props p a)
forall a. a -> StateT (DFS p props m a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentState x props p a
parentState ComponentState x props p a
-> (ComponentState x props p a -> ComponentState x props p a)
-> ComponentState x props p a
forall a b. a -> (a -> b) -> b
& Lens (ComponentState x props p a) p
forall parent props model action.
Lens (ComponentState parent props model action) model
componentModel Lens (ComponentState x props p a) p
-> p -> ComponentState x props p a -> ComponentState x props p a
forall record field. Lens record field -> field -> record -> record
.~ p
updatedParentModel)
      Binding p m
_ ->
        ComponentState x props p a
-> Synch p props m a (ComponentState x props p a)
forall a. a -> StateT (DFS p props m a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ComponentState x props p a
parentState
-----------------------------------------------------------------------------
markVisited :: ComponentId -> Synch p props m a ()
markVisited :: forall p props m a. Int -> Synch p props m a ()
markVisited Int
vcompId = Lens (DFS p props m a) ComponentIds
forall p props m a. Lens (DFS p props m a) ComponentIds
visitedLens (DFS p props m a) ComponentIds
-> LensCore (Maybe ()) ComponentIds
-> LensCore (Maybe ()) (DFS p props m a)
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
vcompId LensCore (Maybe ()) (DFS p props m a)
-> () -> StateT (DFS p props m a) Identity ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record (Maybe field) -> field -> m ()
?= ()
-----------------------------------------------------------------------------
visit :: ComponentId -> Synch p props m a ()
visit :: forall p props m a. Int -> Synch p props m a ()
visit Int
vcompId = Lens (DFS p props m a) [Int]
forall p props m a. Lens (DFS p props m a) [Int]
stack Lens (DFS p props m a) [Int]
-> ([Int] -> [Int]) -> StateT (DFS p props m a) Identity ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> (field -> field) -> m ()
%= (Int
vcompIdInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:)
-----------------------------------------------------------------------------
pop :: Synch p props m a (Maybe (ComponentState p props m a))
pop :: forall p props m a.
Synch p props m a (Maybe (ComponentState p props m a))
pop = Lens (DFS p props m a) [Int]
-> StateT (DFS p props m a) Identity [Int]
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> m field
use Lens (DFS p props m a) [Int]
forall p props m a. Lens (DFS p props m a) [Int]
stack StateT (DFS p props m a) Identity [Int]
-> ([Int]
    -> StateT
         (DFS p props m a) Identity (Maybe (ComponentState p props m a)))
-> StateT
     (DFS p props m a) Identity (Maybe (ComponentState p props m a))
forall a b.
StateT (DFS p props m a) Identity a
-> (a -> StateT (DFS p props m a) Identity b)
-> StateT (DFS p props m a) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  [] ->
    Maybe (ComponentState p props m a)
-> StateT
     (DFS p props m a) Identity (Maybe (ComponentState p props m a))
forall a. a -> StateT (DFS p props m a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ComponentState p props m a)
forall a. Maybe a
Nothing
  Int
x : [Int]
xs -> do
    Lens (DFS p props m a) [Int]
forall p props m a. Lens (DFS p props m a) [Int]
stack Lens (DFS p props m a) [Int]
-> [Int] -> StateT (DFS p props m a) Identity ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> field -> m ()
.= [Int]
xs
    Lens (DFS p props m a) (Maybe (ComponentState p props m a))
-> StateT
     (DFS p props m a) Identity (Maybe (ComponentState p props m a))
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> m field
use (Lens (DFS p props m a) (IntMap (ComponentState p props m a))
forall p props m a.
Lens (DFS p props m a) (IntMap (ComponentState p props m a))
state Lens (DFS p props m a) (IntMap (ComponentState p props m a))
-> LensCore
     (Maybe (ComponentState p props m a))
     (IntMap (ComponentState p props m a))
-> Lens (DFS p props m a) (Maybe (ComponentState p props m a))
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 (ComponentState p props m a))
-> Lens
     (IntMap (ComponentState p props m a))
     (Maybe (IxValue (IntMap (ComponentState p props m a))))
forall at. At at => Index at -> Lens at (Maybe (IxValue at))
at Int
Index (IntMap (ComponentState p props m a))
x)
-----------------------------------------------------------------------------
initialDraw
  :: (Eq m, Eq props)
  => m
  -> Events
  -> Hydrate
  -> Bool
  -> Component p props m a
  -> ComponentState p props m a
  -> IO ()
initialDraw :: forall m props p a.
(Eq m, Eq props) =>
m
-> Events
-> Hydrate
-> Bool
-> Component p props m a
-> ComponentState p props m a
-> IO ()
initialDraw m
initializedModel Events
events Hydrate
hydrate Bool
isRoot Component {m
Bool
[Binding p m]
[JS]
[CSS]
[Sub a]
Maybe a
Maybe (IO m)
Maybe MisoString
LogLevel
props -> m -> View m a
a -> Effect p props m a
Value -> Maybe a
unmount :: forall parent props model action.
Component parent props model action -> Maybe action
mount :: forall parent props model action.
Component parent props model action -> Maybe action
eventPropagation :: forall parent props model action.
Component parent props model action -> Bool
bindings :: forall parent props model action.
Component parent props model action -> [Binding parent model]
mailbox :: forall parent props model action.
Component parent props model action -> Value -> Maybe action
logLevel :: forall parent props model action.
Component parent props model action -> LogLevel
mountPoint :: forall parent props model action.
Component parent props model action -> Maybe MisoString
scripts :: forall parent props model action.
Component parent props model action -> [JS]
styles :: forall parent props model action.
Component parent props model action -> [CSS]
subs :: forall parent props model action.
Component parent props model action -> [Sub action]
view :: forall parent props model action.
Component parent props model action
-> props -> model -> View model action
update :: forall parent props model action.
Component parent props model action
-> action -> Effect parent props model action
hydrateModel :: forall parent props model action.
Component parent props model action -> Maybe (IO model)
model :: forall parent props model action.
Component parent props model action -> model
model :: m
hydrateModel :: Maybe (IO m)
update :: a -> Effect p props m a
view :: props -> m -> View m a
subs :: [Sub a]
styles :: [CSS]
scripts :: [JS]
mountPoint :: Maybe MisoString
logLevel :: LogLevel
mailbox :: Value -> Maybe a
bindings :: [Binding p m]
eventPropagation :: Bool
mount :: Maybe a
unmount :: Maybe a
..} ComponentState {m
props
Bool
Int
[JSVal]
[Binding p m]
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
m -> IO ()
m -> m -> Bool
a -> IO ()
[a]
-> m
-> IntMap (ComponentState p props m a)
-> props
-> (IntMap (ComponentState p props m a), m, [Schedule a],
    ComponentIds)
Value -> Maybe a
_componentModel :: forall parent props model action.
ComponentState parent props model action -> model
_componentEvents :: forall parent props model action.
ComponentState parent props model action -> Events
_componentMailbox :: forall parent props model action.
ComponentState parent props model action -> Value -> Maybe action
_componentBindings :: forall parent props model action.
ComponentState parent props model action -> [Binding parent model]
_componentTopics :: forall parent props model action.
ComponentState parent props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent props model action.
ComponentState parent props model action -> model -> model -> Bool
_componentChildren :: forall parent props model action.
ComponentState parent props model action -> ComponentIds
_componentApplyActions :: forall parent props model action.
ComponentState parent props model action
-> [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent props model action.
ComponentState parent props model action -> model -> IO ()
_componentScripts :: forall parent props model action.
ComponentState parent props model action -> [JSVal]
_componentIsDirty :: forall parent props model action.
ComponentState parent props model action -> Bool
_componentSink :: forall parent props model action.
ComponentState parent props model action -> action -> IO ()
_componentVTree :: forall parent props model action.
ComponentState parent props model action -> IORef VTree
_componentDOMRef :: forall parent props model action.
ComponentState parent props model action -> JSVal
_componentSubThreads :: forall parent props model action.
ComponentState parent props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall parent props model action.
ComponentState parent props model action -> props
_componentParentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: a -> IO ()
_componentModel :: m
_componentIsDirty :: Bool
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentBindings :: [Binding p m]
_componentMailbox :: Value -> Maybe a
_componentDraw :: m -> IO ()
_componentModelDirty :: m -> m -> Bool
_componentApplyActions :: [a]
-> m
-> IntMap (ComponentState p props m a)
-> props
-> (IntMap (ComponentState p props m a), m, [Schedule a],
    ComponentIds)
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} = do
#ifdef BENCH
  start <- FFI.now
#endif
  vtree <- Events
-> Int
-> Int
-> Hydrate
-> (a -> IO ())
-> LogLevel
-> View m a
-> IO VTree
forall model action.
Eq model =>
Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> View model action
-> IO VTree
buildVTree Events
events Int
_componentParentId Int
_componentId Hydrate
hydrate a -> IO ()
_componentSink LogLevel
logLevel
    (props -> m -> View m a
view props
_componentProps m
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 _componentProps initializedModel)
              Diff.diff Nothing (Just newTree) _componentDOMRef
              liftIO (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, [action]))
getBatch :: forall action. IO (Maybe (Int, [action]))
getBatch = do
  IO (Maybe (Int, [action])) -> IO (Maybe (Int, [action]))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Int, [action])) -> IO (Maybe (Int, [action])))
-> IO (Maybe (Int, [action])) -> IO (Maybe (Int, [action]))
forall a b. (a -> b) -> a -> b
$ IORef (Queue action)
-> (Queue action -> (Queue action, Maybe (Int, [action])))
-> IO (Maybe (Int, [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, [action])))
 -> IO (Maybe (Int, [action])))
-> (Queue action -> (Queue action, Maybe (Int, [action])))
-> IO (Maybe (Int, [action]))
forall a b. (a -> b) -> a -> b
$ \Queue action
q ->
    case Queue action -> Maybe (Int, [action], Queue action)
forall action. Queue action -> Maybe (Int, [action], Queue action)
dequeue Queue action
q of
      Maybe (Int, [action], Queue action)
Nothing -> (Queue action
q, Maybe (Int, [action])
forall a. Maybe a
Nothing)
      Just (Int
vcompId, [action]
actions, Queue action
newQueue) ->
        (Queue action
newQueue, (Int, [action]) -> Maybe (Int, [action])
forall a. a -> Maybe a
Just (Int
vcompId, [action]
actions))
-----------------------------------------------------------------------------
-- | Helper for event extraction at a specific 'ComponentId'
drainQueueAt :: ComponentId -> IO [a]
drainQueueAt :: forall a. Int -> IO [a]
drainQueueAt Int
vcompId = IO [a] -> IO [a]
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [a] -> IO [a]) -> IO [a] -> IO [a]
forall a b. (a -> b) -> a -> b
$ IORef (Queue a) -> (Queue a -> (Queue a, [a])) -> IO [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, [a])
forall action. Int -> Queue action -> (Queue action, [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 43))
-> (Queue (ZonkAny 43) -> (Queue (ZonkAny 43), ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Queue (ZonkAny 43))
forall action. IORef (Queue action)
globalQueue ((Queue (ZonkAny 43) -> (Queue (ZonkAny 43), ())) -> IO ())
-> (Queue (ZonkAny 43) -> (Queue (ZonkAny 43), ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Queue (ZonkAny 43)
q ->
     (Queue (ZonkAny 43)
q Queue (ZonkAny 43)
-> (Queue (ZonkAny 43) -> Queue (ZonkAny 43)) -> Queue (ZonkAny 43)
forall a b. a -> (a -> b) -> b
& Lens (Queue (ZonkAny 43)) (Seq Int)
forall action. Lens (Queue action) (Seq Int)
queueSchedule Lens (Queue (ZonkAny 43)) (Seq Int)
-> (Seq Int -> Seq Int) -> Queue (ZonkAny 43) -> Queue (ZonkAny 43)
forall record field.
Lens record field -> (field -> field) -> record -> record
%~ (Seq Int -> Int -> Seq Int
forall a. Seq a -> a -> Seq a
S.|> Int -> Int
forall a. Num a => a -> a
negate Int
vcompId), ())
-----------------------------------------------------------------------------
-- | 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, [action], Queue action)
dequeue :: forall action. Queue action -> Maybe (Int, [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, [action], Queue action)
forall a. Maybe a
Nothing
    sched :: Seq Int
sched@(Int
vcompId S.:<| Seq Int
leftover) ->
      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 model. Eq model => model -> model -> Bool
== Int
vcompId) Seq Int
sched
          in (Int, [action], Queue action)
-> Maybe (Int, [action], Queue action)
forall a. a -> Maybe a
Just (Int
vcompId, [], 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 model. Eq model => model -> model -> 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, [action], Queue action)
-> Maybe (Int, [action], Queue action)
forall a. a -> Maybe a
Just (Int
vcompId, Seq action -> [action]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList 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, [action])
dequeueAt :: forall action. Int -> Queue action -> (Queue action, [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, [])
    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 model. Eq model => model -> model -> 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 -> [action]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList 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)
-----------------------------------------------------------------------------
componentId :: Lens (ComponentState parent props model action) ComponentId
componentId :: forall parent props model action.
Lens (ComponentState parent props model action) Int
componentId = (ComponentState parent props model action -> Int)
-> (ComponentState parent props model action
    -> Int -> ComponentState parent props model action)
-> Lens (ComponentState parent props model action) Int
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState parent props model action -> Int
forall parent props model action.
ComponentState parent props model action -> Int
_componentId ((ComponentState parent props model action
  -> Int -> ComponentState parent props model action)
 -> Lens (ComponentState parent props model action) Int)
-> (ComponentState parent props model action
    -> Int -> ComponentState parent props model action)
-> Lens (ComponentState parent props model action) Int
forall a b. (a -> b) -> a -> b
$ \ComponentState parent props model action
record Int
field -> ComponentState parent props model action
record { _componentId = field }
-----------------------------------------------------------------------------
parentId :: Lens (ComponentState parent props model action) ComponentId
parentId :: forall parent props model action.
Lens (ComponentState parent props model action) Int
parentId = (ComponentState parent props model action -> Int)
-> (ComponentState parent props model action
    -> Int -> ComponentState parent props model action)
-> Lens (ComponentState parent props model action) Int
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState parent props model action -> Int
forall parent props model action.
ComponentState parent props model action -> Int
_componentParentId ((ComponentState parent props model action
  -> Int -> ComponentState parent props model action)
 -> Lens (ComponentState parent props model action) Int)
-> (ComponentState parent props model action
    -> Int -> ComponentState parent props model action)
-> Lens (ComponentState parent props model action) Int
forall a b. (a -> b) -> a -> b
$ \ComponentState parent props model action
record Int
field -> ComponentState parent props model action
record { _componentParentId = field }
-----------------------------------------------------------------------------
children :: Lens (ComponentState parent props model action) (ComponentIds)
children :: forall parent props model action.
Lens (ComponentState parent props model action) ComponentIds
children = (ComponentState parent props model action -> ComponentIds)
-> (ComponentState parent props model action
    -> ComponentIds -> ComponentState parent props model action)
-> Lens (ComponentState parent props model action) ComponentIds
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState parent props model action -> ComponentIds
forall parent props model action.
ComponentState parent props model action -> ComponentIds
_componentChildren ((ComponentState parent props model action
  -> ComponentIds -> ComponentState parent props model action)
 -> Lens (ComponentState parent props model action) ComponentIds)
-> (ComponentState parent props model action
    -> ComponentIds -> ComponentState parent props model action)
-> Lens (ComponentState parent props model action) ComponentIds
forall a b. (a -> b) -> a -> b
$ \ComponentState parent props model action
record ComponentIds
field -> ComponentState parent props model action
record { _componentChildren = field }
-----------------------------------------------------------------------------
componentTopics :: Lens (ComponentState parent props model action) (Map MisoString (Value -> IO ()))
componentTopics :: forall parent props model action.
Lens
  (ComponentState parent props model action)
  (Map MisoString (Value -> IO ()))
componentTopics = (ComponentState parent props model action
 -> Map MisoString (Value -> IO ()))
-> (ComponentState parent props model action
    -> Map MisoString (Value -> IO ())
    -> ComponentState parent props model action)
-> Lens
     (ComponentState parent props model action)
     (Map MisoString (Value -> IO ()))
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState parent props model action
-> Map MisoString (Value -> IO ())
forall parent props model action.
ComponentState parent props model action
-> Map MisoString (Value -> IO ())
_componentTopics ((ComponentState parent props model action
  -> Map MisoString (Value -> IO ())
  -> ComponentState parent props model action)
 -> Lens
      (ComponentState parent props model action)
      (Map MisoString (Value -> IO ())))
-> (ComponentState parent props model action
    -> Map MisoString (Value -> IO ())
    -> ComponentState parent props model action)
-> Lens
     (ComponentState parent props model action)
     (Map MisoString (Value -> IO ()))
forall a b. (a -> b) -> a -> b
$ \ComponentState parent props model action
record Map MisoString (Value -> IO ())
field -> ComponentState parent props model action
record { _componentTopics = field }
-----------------------------------------------------------------------------
isDirty :: Lens (ComponentState parent props model action) Bool
isDirty :: forall parent props model action.
Lens (ComponentState parent props model action) Bool
isDirty = (ComponentState parent props model action -> Bool)
-> (ComponentState parent props model action
    -> Bool -> ComponentState parent props model action)
-> Lens (ComponentState parent props model action) Bool
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState parent props model action -> Bool
forall parent props model action.
ComponentState parent props model action -> Bool
_componentIsDirty ((ComponentState parent props model action
  -> Bool -> ComponentState parent props model action)
 -> Lens (ComponentState parent props model action) Bool)
-> (ComponentState parent props model action
    -> Bool -> ComponentState parent props model action)
-> Lens (ComponentState parent props model action) Bool
forall a b. (a -> b) -> a -> b
$ \ComponentState parent props model action
record Bool
field -> ComponentState parent props model action
record { _componentIsDirty = field }
-----------------------------------------------------------------------------
componentModel :: Lens (ComponentState parent props model action) model
componentModel :: forall parent props model action.
Lens (ComponentState parent props model action) model
componentModel = (ComponentState parent props model action -> model)
-> (ComponentState parent props model action
    -> model -> ComponentState parent props model action)
-> Lens (ComponentState parent props model action) model
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState parent props model action -> model
forall parent props model action.
ComponentState parent props model action -> model
_componentModel ((ComponentState parent props model action
  -> model -> ComponentState parent props model action)
 -> Lens (ComponentState parent props model action) model)
-> (ComponentState parent props model action
    -> model -> ComponentState parent props model action)
-> Lens (ComponentState parent props model action) model
forall a b. (a -> b) -> a -> b
$ \ComponentState parent props model action
record model
field -> ComponentState parent props model action
record { _componentModel = field }
-----------------------------------------------------------------------------
componentBindings :: Lens (ComponentState p props m a) [Binding p m]
componentBindings :: forall p props m a. Lens (ComponentState p props m a) [Binding p m]
componentBindings = (ComponentState p props m a -> [Binding p m])
-> (ComponentState p props m a
    -> [Binding p m] -> ComponentState p props m a)
-> Lens (ComponentState p props m a) [Binding p m]
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState p props m a -> [Binding p m]
forall parent props model action.
ComponentState parent props model action -> [Binding parent model]
_componentBindings ((ComponentState p props m a
  -> [Binding p m] -> ComponentState p props m a)
 -> Lens (ComponentState p props m a) [Binding p m])
-> (ComponentState p props m a
    -> [Binding p m] -> ComponentState p props m a)
-> Lens (ComponentState p props m a) [Binding p m]
forall a b. (a -> b) -> a -> b
$ \ComponentState p props m a
record [Binding p m]
field -> ComponentState p props m a
record { _componentBindings = field }
-----------------------------------------------------------------------------
componentProps :: Lens (ComponentState parent props model action) props
componentProps :: forall parent props model action.
Lens (ComponentState parent props model action) props
componentProps = (ComponentState parent props model action -> props)
-> (ComponentState parent props model action
    -> props -> ComponentState parent props model action)
-> Lens (ComponentState parent props model action) props
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState parent props model action -> props
forall parent props model action.
ComponentState parent props model action -> props
_componentProps ((ComponentState parent props model action
  -> props -> ComponentState parent props model action)
 -> Lens (ComponentState parent props model action) props)
-> (ComponentState parent props model action
    -> props -> ComponentState parent props model action)
-> Lens (ComponentState parent props model action) props
forall a b. (a -> b) -> a -> b
$ \ComponentState parent props model action
record props
field -> ComponentState parent props model action
record { _componentProps = 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 parent props model action
  = ComponentState
  { forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: ComponentId
  -- ^ The ID of the current t'Miso.Types.Component'
  , forall parent props model action.
ComponentState parent props model action -> Int
_componentParentId :: ComponentId
  -- ^ The ID of the t'Miso.Types.Component''s parent
  , forall parent props model action.
ComponentState parent props model action -> props
_componentProps :: props
  -- ^ The current props passed to this t'Miso.Types.Component'
  , forall parent props model action.
ComponentState parent props model action
-> IORef (Map MisoString ThreadId)
_componentSubThreads :: IORef (Map MisoString ThreadId)
  -- ^ Mapping of all 'Sub' in use by t'Miso.Types.Component'
  , forall parent props model action.
ComponentState parent props model action -> JSVal
_componentDOMRef :: DOMRef
  -- ^ The DOM reference the t'Miso.Types.Component' is mounted on
  , forall parent props model action.
ComponentState parent props model action -> IORef VTree
_componentVTree :: IORef VTree
  -- ^ A reference to the current virtual DOM (i.e. t'VTree')
  , forall parent props model action.
ComponentState parent props model action -> action -> IO ()
_componentSink :: action -> IO ()
  -- ^ t'Miso.Types.Component' t'Sink' used to enter events into the system
  , forall parent props model action.
ComponentState parent props model action -> model
_componentModel :: model
  -- ^ t'Miso.Types.Component' state
  , forall parent props model action.
ComponentState parent props model action -> Bool
_componentIsDirty :: Bool
  -- ^ Indicator if t'Miso.Types.Component' needs to be drawn
  , forall parent props model action.
ComponentState parent props model action -> [JSVal]
_componentScripts :: [DOMRef]
  -- ^ DOM references for \<script\> and \<style\> appended to \<head\>
  , forall parent props model action.
ComponentState parent props model action -> Events
_componentEvents :: Events
  -- ^ List of events a t'Miso.Types.Component' listens on
  , forall parent props model action.
ComponentState parent props model action -> [Binding parent model]
_componentBindings :: [Binding parent model]
  -- ^ Declarative bindings between t'Miso.Types.Component' 'model'.
  , forall parent props model action.
ComponentState parent props model action -> Value -> Maybe action
_componentMailbox :: Value -> Maybe action
  -- ^ Mailbox for asynchronous t'Miso.Types.Component' communication
  , forall parent props model action.
ComponentState parent props model action -> model -> IO ()
_componentDraw :: model -> IO ()
  -- ^ Helper function for t'Miso.Types.Component' rendering
  , forall parent props model action.
ComponentState parent props model action -> model -> model -> Bool
_componentModelDirty :: model -> model -> Bool
  -- ^ Model diffing
  , forall parent props model action.
ComponentState parent props model action
-> [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentApplyActions
      :: [action]
      -> model
      -> IntMap (ComponentState parent props model action)
      -> props
      -> (IntMap (ComponentState parent props model action), model, [Schedule action], ComponentIds)
  -- ^ t'Miso.Types.Component' actions application
  , forall parent props model action.
ComponentState parent props model action
-> Map MisoString (Value -> IO ())
_componentTopics :: Map MisoString (Value -> IO ())
  -- ^ t'Miso.Types.Component' topics using for Pub Sub async communication.
  , forall parent props model action.
ComponentState parent 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 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 to a @Topic@, provides callback function that writes to t'Miso.Types.Component' 'Sink'
--
-- If a @Topic message@ does not exist when calling 'subscribe' it is generated dynamically.
-- Each subscriber decodes the received 'Value' using it's own 'FromJSON' instance. This provides
-- for loose-coupling between t'Miso.Types.Component'. As long as the underlying 'Value' are identical
-- t'Miso.Types.Component' can use their own types without serialization issues. @Topic message@ should
-- have their own JSON API specification when being distributed.
--
-- @
--
-- arithmetic :: Topic Message
-- arithmetic = topic "arithmetic"
--
-- clientComponent :: MisoString -> Component Int Action
-- clientComponent name = component 0 update_ $ \m ->
--   div_
--   []
--   [ br_ []
--   , text (name <> " : " <> ms (m ^. _id))
--   , button_ [ onClick Unsubscribe ] [ "unsubscribe" ]
--   , button_ [ onClick Subscribe ] [ "subscribe" ]
--   ] where
--       update_ :: Action -> Effect Int Action
--       update_ = \case
--         AddOne -> do
--           _id += 1
--         SubtractOne ->
--           _id -= 1
--         Unsubscribe ->
--           unsubscribe arithmetic
--         Subscribe ->
--           subscribe arithmetic Notification
--         Notification (Success Increment) -> do
--           update_ AddOne
--         Notification (Success Decrement) -> do
--           update_ SubtractOne
--         Notification (Error msg) ->
--           io_ $ consoleError ("Decode failure: " <> ms msg)
--         _ -> pure ()
--
-- @
--
-- @since 1.9.0.0
subscribe
  :: FromJSON message
  => Topic message
  -> (message -> action)
  -> (MisoString -> action)
  -> Effect parent props model action
subscribe :: forall message action parent props model.
FromJSON message =>
Topic message
-> (message -> action)
-> (MisoString -> action)
-> Effect parent props model action
subscribe (Topic MisoString
topicName) message -> action
successful MisoString -> action
errorful = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent props)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink ->
    Int
-> State
     (ComponentState
        (ZonkAny 46) (ZonkAny 47) (ZonkAny 48) (ZonkAny 49))
     ()
-> IO ()
forall parent props model action a.
Int -> State (ComponentState parent props model action) a -> IO ()
modifyComponent Int
_componentInfoId (State
   (ComponentState
      (ZonkAny 46) (ZonkAny 47) (ZonkAny 48) (ZonkAny 49))
   ()
 -> IO ())
-> State
     (ComponentState
        (ZonkAny 46) (ZonkAny 47) (ZonkAny 48) (ZonkAny 49))
     ()
-> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Lens
  (ComponentState
     (ZonkAny 46) (ZonkAny 47) (ZonkAny 48) (ZonkAny 49))
  (Map MisoString (Value -> IO ()))
forall parent props model action.
Lens
  (ComponentState parent props model action)
  (Map MisoString (Value -> IO ()))
componentTopics Lens
  (ComponentState
     (ZonkAny 46) (ZonkAny 47) (ZonkAny 48) (ZonkAny 49))
  (Map MisoString (Value -> IO ()))
-> (Map MisoString (Value -> IO ())
    -> Map MisoString (Value -> IO ()))
-> State
     (ComponentState
        (ZonkAny 46) (ZonkAny 47) (ZonkAny 48) (ZonkAny 49))
     ()
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)
-----------------------------------------------------------------------------
-- Pub / Sub implementation
--
-- (Subscribe)
--
-- Check if you're already subscribed to this topic.
--
--  [true]  - If you're already subscribed, then it's a no-op (warn)
--
--  [false] - If you're not subscribed then fork a new thread that holds the duplicated topic
--            and blocks on the read end of the duplicated topic, sink messages into component sink
--
-- (Unsubscribe)
--
-- Check if you're already subscribed to this topic
--
--  [true] - Kill the thread, delete the subscriber entry
--
--  [false] - If you're not subscribed, then it's a no-op (warn)
--
-- (Publish)
--
-- Check if the Topic exists
--
--  [true] - If it exists then write the message to the topic
--
--  [false] - If it doesn't exist, create it.
--
-- N.B. Components can be both publishers and subscribers to their own topics.
-----------------------------------------------------------------------------
-- | Unsubscribe from a t'Topic'
--
-- Unsubscribes a t'Miso.Types.Component' from receiving messages from t'Topic'
--
-- See 'subscribe' for more use.
--
-- @since 1.9.0.0
unsubscribe :: Topic message -> Effect parent props model action
unsubscribe :: forall message parent props model action.
Topic message -> Effect parent props model action
unsubscribe (Topic MisoString
topicName) = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent props)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent 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 () 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 parent () Action
--       update_ = \case
--         AddOne ->
--           publish arithmetic Increment
--         SubtractOne ->
--           publish arithemtic Decrement
--
-- @
--
-- @since 1.9.0.0
publish
  :: ToJSON message
  => Topic message
  -> message
  -> IO ()
publish :: forall message. ToJSON message => Topic message -> message -> IO ()
publish (Topic MisoString
topicName) message
message = (ComponentState (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)
 -> IO ())
-> [ComponentState
      (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)]
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ComponentState (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)
-> IO ()
forall (m :: * -> *) parent props model action.
MonadIO m =>
ComponentState parent props model action -> m ()
go ([ComponentState
    (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)]
 -> IO ())
-> IO
     [ComponentState
        (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)]
-> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IntMap
  (ComponentState
     (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42))
-> [ComponentState
      (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)]
forall a. IntMap a -> [a]
IM.elems (IntMap
   (ComponentState
      (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42))
 -> [ComponentState
       (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)])
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)))
-> IO
     [ComponentState
        (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState
        (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 39) (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)))
forall parent props model action.
IORef (IntMap (ComponentState parent props model action))
components
  where
    go :: ComponentState parent props model action -> f ()
go ComponentState {props
model
Bool
Int
[JSVal]
[Binding parent model]
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
model -> IO ()
model -> model -> Bool
action -> IO ()
[action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
Value -> Maybe action
_componentModel :: forall parent props model action.
ComponentState parent props model action -> model
_componentEvents :: forall parent props model action.
ComponentState parent props model action -> Events
_componentMailbox :: forall parent props model action.
ComponentState parent props model action -> Value -> Maybe action
_componentBindings :: forall parent props model action.
ComponentState parent props model action -> [Binding parent model]
_componentTopics :: forall parent props model action.
ComponentState parent props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent props model action.
ComponentState parent props model action -> model -> model -> Bool
_componentChildren :: forall parent props model action.
ComponentState parent props model action -> ComponentIds
_componentApplyActions :: forall parent props model action.
ComponentState parent props model action
-> [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent props model action.
ComponentState parent props model action -> model -> IO ()
_componentScripts :: forall parent props model action.
ComponentState parent props model action -> [JSVal]
_componentIsDirty :: forall parent props model action.
ComponentState parent props model action -> Bool
_componentSink :: forall parent props model action.
ComponentState parent props model action -> action -> IO ()
_componentVTree :: forall parent props model action.
ComponentState parent props model action -> IORef VTree
_componentDOMRef :: forall parent props model action.
ComponentState parent props model action -> JSVal
_componentSubThreads :: forall parent props model action.
ComponentState parent props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall parent props model action.
ComponentState parent props model action -> props
_componentParentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentIsDirty :: Bool
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentBindings :: [Binding parent model]
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} = do
      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 ->
          () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Value -> IO ()
f -> do
          IO () -> f ()
forall a. IO a -> f a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (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)
-----------------------------------------------------------------------------
-- | 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 parent props model action))
{-# NOINLINE components #-}
components :: forall parent props model action.
IORef (IntMap (ComponentState parent props model action))
components = IO (IORef (IntMap (ComponentState parent props model action)))
-> IORef (IntMap (ComponentState parent props model action))
forall a. IO a -> a
unsafePerformIO (IntMap (ComponentState parent props model action)
-> IO (IORef (IntMap (ComponentState parent props model action)))
forall a. a -> IO (IORef a)
newIORef IntMap (ComponentState parent 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
  :: ComponentState parent props model action
  -> IO ()
drain :: forall parent props model action.
ComponentState parent props model action -> IO ()
drain ComponentState {props
model
Bool
Int
[JSVal]
[Binding parent model]
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
model -> IO ()
model -> model -> Bool
action -> IO ()
[action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
Value -> Maybe action
_componentModel :: forall parent props model action.
ComponentState parent props model action -> model
_componentEvents :: forall parent props model action.
ComponentState parent props model action -> Events
_componentMailbox :: forall parent props model action.
ComponentState parent props model action -> Value -> Maybe action
_componentBindings :: forall parent props model action.
ComponentState parent props model action -> [Binding parent model]
_componentTopics :: forall parent props model action.
ComponentState parent props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent props model action.
ComponentState parent props model action -> model -> model -> Bool
_componentChildren :: forall parent props model action.
ComponentState parent props model action -> ComponentIds
_componentApplyActions :: forall parent props model action.
ComponentState parent props model action
-> [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent props model action.
ComponentState parent props model action -> model -> IO ()
_componentScripts :: forall parent props model action.
ComponentState parent props model action -> [JSVal]
_componentIsDirty :: forall parent props model action.
ComponentState parent props model action -> Bool
_componentSink :: forall parent props model action.
ComponentState parent props model action -> action -> IO ()
_componentVTree :: forall parent props model action.
ComponentState parent props model action -> IORef VTree
_componentDOMRef :: forall parent props model action.
ComponentState parent props model action -> JSVal
_componentSubThreads :: forall parent props model action.
ComponentState parent props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall parent props model action.
ComponentState parent props model action -> props
_componentParentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentIsDirty :: Bool
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentBindings :: [Binding parent model]
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} = do
  Int -> IO [action]
forall a. Int -> IO [a]
drainQueueAt Int
_componentId IO [action] -> ([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
    [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [action]
actions -> do
       vcomps <- IORef (IntMap (ComponentState parent props model action))
-> IO (IntMap (ComponentState parent props model action))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState parent props model action))
forall parent props model action.
IORef (IntMap (ComponentState parent props model action))
components
       case _componentApplyActions actions _componentModel vcomps _componentProps of
         (IntMap (ComponentState parent props model action)
newVComps, model
_, [Schedule action]
schedules, ComponentIds
_) -> do
           [Schedule action] -> (Schedule action -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Schedule action]
schedules ((Schedule action -> IO ()) -> IO ())
-> (Schedule 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))
             -- dmj: Don't recurse on drain, we only fire-off the last set
             -- of events for 'onBeforeUnmounted' hooks. The queue will
             -- ignore the rest of these.
           IORef (IntMap (ComponentState parent props model action))
-> IntMap (ComponentState parent props model action) -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef (IntMap (ComponentState parent props model action))
forall parent props model action.
IORef (IntMap (ComponentState parent props model action))
components IntMap (ComponentState parent props model action)
newVComps
-----------------------------------------------------------------------------
-- | Post unmount call to drop the <style> and <script> in <head>
unloadScripts :: ComponentState parent props model action -> IO ()
unloadScripts :: forall parent props model action.
ComponentState parent props model action -> IO ()
unloadScripts ComponentState {props
model
Bool
Int
[JSVal]
[Binding parent model]
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
model -> IO ()
model -> model -> Bool
action -> IO ()
[action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
Value -> Maybe action
_componentModel :: forall parent props model action.
ComponentState parent props model action -> model
_componentEvents :: forall parent props model action.
ComponentState parent props model action -> Events
_componentMailbox :: forall parent props model action.
ComponentState parent props model action -> Value -> Maybe action
_componentBindings :: forall parent props model action.
ComponentState parent props model action -> [Binding parent model]
_componentTopics :: forall parent props model action.
ComponentState parent props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent props model action.
ComponentState parent props model action -> model -> model -> Bool
_componentChildren :: forall parent props model action.
ComponentState parent props model action -> ComponentIds
_componentApplyActions :: forall parent props model action.
ComponentState parent props model action
-> [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent props model action.
ComponentState parent props model action -> model -> IO ()
_componentScripts :: forall parent props model action.
ComponentState parent props model action -> [JSVal]
_componentIsDirty :: forall parent props model action.
ComponentState parent props model action -> Bool
_componentSink :: forall parent props model action.
ComponentState parent props model action -> action -> IO ()
_componentVTree :: forall parent props model action.
ComponentState parent props model action -> IORef VTree
_componentDOMRef :: forall parent props model action.
ComponentState parent props model action -> JSVal
_componentSubThreads :: forall parent props model action.
ComponentState parent props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall parent props model action.
ComponentState parent props model action -> props
_componentParentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentIsDirty :: Bool
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentBindings :: [Binding parent model]
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} = do
  head_ <- IO JSVal
FFI.getHead
  forM_ _componentScripts (FFI.removeChild head_)
-----------------------------------------------------------------------------
-- | Helper to drop all lifecycle and mounting hooks if defined.
freeLifecycleHooks :: ComponentState parent props model action -> IO ()
freeLifecycleHooks :: forall parent props model action.
ComponentState parent props model action -> IO ()
freeLifecycleHooks ComponentState {props
model
Bool
Int
[JSVal]
[Binding parent model]
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
model -> IO ()
model -> model -> Bool
action -> IO ()
[action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
Value -> Maybe action
_componentModel :: forall parent props model action.
ComponentState parent props model action -> model
_componentEvents :: forall parent props model action.
ComponentState parent props model action -> Events
_componentMailbox :: forall parent props model action.
ComponentState parent props model action -> Value -> Maybe action
_componentBindings :: forall parent props model action.
ComponentState parent props model action -> [Binding parent model]
_componentTopics :: forall parent props model action.
ComponentState parent props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent props model action.
ComponentState parent props model action -> model -> model -> Bool
_componentChildren :: forall parent props model action.
ComponentState parent props model action -> ComponentIds
_componentApplyActions :: forall parent props model action.
ComponentState parent props model action
-> [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent props model action.
ComponentState parent props model action -> model -> IO ()
_componentScripts :: forall parent props model action.
ComponentState parent props model action -> [JSVal]
_componentIsDirty :: forall parent props model action.
ComponentState parent props model action -> Bool
_componentSink :: forall parent props model action.
ComponentState parent props model action -> action -> IO ()
_componentVTree :: forall parent props model action.
ComponentState parent props model action -> IORef VTree
_componentDOMRef :: forall parent props model action.
ComponentState parent props model action -> JSVal
_componentSubThreads :: forall parent props model action.
ComponentState parent props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall parent props model action.
ComponentState parent props model action -> props
_componentParentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentIsDirty :: Bool
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentBindings :: [Binding parent model]
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} = do
  VTree (Object comp) <- IO VTree -> IO VTree
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (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
  :: ComponentState parent props model action
  -> IO ()
unmountComponent :: forall parent props model action.
ComponentState parent props model action -> IO ()
unmountComponent cs :: ComponentState parent props model action
cs@ComponentState {props
model
Bool
Int
[JSVal]
[Binding parent model]
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
model -> IO ()
model -> model -> Bool
action -> IO ()
[action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
Value -> Maybe action
_componentModel :: forall parent props model action.
ComponentState parent props model action -> model
_componentEvents :: forall parent props model action.
ComponentState parent props model action -> Events
_componentMailbox :: forall parent props model action.
ComponentState parent props model action -> Value -> Maybe action
_componentBindings :: forall parent props model action.
ComponentState parent props model action -> [Binding parent model]
_componentTopics :: forall parent props model action.
ComponentState parent props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent props model action.
ComponentState parent props model action -> model -> model -> Bool
_componentChildren :: forall parent props model action.
ComponentState parent props model action -> ComponentIds
_componentApplyActions :: forall parent props model action.
ComponentState parent props model action
-> [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent props model action.
ComponentState parent props model action -> model -> IO ()
_componentScripts :: forall parent props model action.
ComponentState parent props model action -> [JSVal]
_componentIsDirty :: forall parent props model action.
ComponentState parent props model action -> Bool
_componentSink :: forall parent props model action.
ComponentState parent props model action -> action -> IO ()
_componentVTree :: forall parent props model action.
ComponentState parent props model action -> IORef VTree
_componentDOMRef :: forall parent props model action.
ComponentState parent props model action -> JSVal
_componentSubThreads :: forall parent props model action.
ComponentState parent props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall parent props model action.
ComponentState parent props model action -> props
_componentParentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentIsDirty :: Bool
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentBindings :: [Binding parent model]
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} = do
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((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 parent props model action -> IO ()
forall parent props model action.
ComponentState parent props model action -> IO ()
drain ComponentState parent props model action
cs
  Int -> IO ()
finalizeWebSockets Int
_componentId
  Int -> IO ()
finalizeEventSources Int
_componentId
  ComponentState parent props model action -> IO ()
forall parent props model action.
ComponentState parent props model action -> IO ()
unloadScripts ComponentState parent props model action
cs
  ComponentState parent props model action -> IO ()
forall parent props model action.
ComponentState parent props model action -> IO ()
freeLifecycleHooks ComponentState parent props model action
cs
  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
    Int
-> State
     (ComponentState
        (ZonkAny 54) (ZonkAny 55) (ZonkAny 56) (ZonkAny 57))
     ()
-> IO ()
forall parent props model action a.
Int -> State (ComponentState parent props model action) a -> IO ()
modifyComponent Int
_componentParentId (State
   (ComponentState
      (ZonkAny 54) (ZonkAny 55) (ZonkAny 56) (ZonkAny 57))
   ()
 -> IO ())
-> State
     (ComponentState
        (ZonkAny 54) (ZonkAny 55) (ZonkAny 56) (ZonkAny 57))
     ()
-> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Lens
  (ComponentState
     (ZonkAny 54) (ZonkAny 55) (ZonkAny 56) (ZonkAny 57))
  ComponentIds
forall parent props model action.
Lens (ComponentState parent props model action) ComponentIds
childrenLens
  (ComponentState
     (ZonkAny 54) (ZonkAny 55) (ZonkAny 56) (ZonkAny 57))
  ComponentIds
-> LensCore (Maybe ()) ComponentIds
-> LensCore
     (Maybe ())
     (ComponentState
        (ZonkAny 54) (ZonkAny 55) (ZonkAny 56) (ZonkAny 57))
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 54) (ZonkAny 55) (ZonkAny 56) (ZonkAny 57))
-> Maybe ()
-> State
     (ComponentState
        (ZonkAny 54) (ZonkAny 55) (ZonkAny 56) (ZonkAny 57))
     ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> field -> m ()
.= Maybe ()
forall a. Maybe a
Nothing
    IORef
  (IntMap
     (ComponentState
        (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61)))
-> (IntMap
      (ComponentState
         (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61))
    -> (IntMap
          (ComponentState
             (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61)),
        ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef
  (IntMap
     (ComponentState
        (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61)))
forall parent props model action.
IORef (IntMap (ComponentState parent props model action))
components ((IntMap
    (ComponentState
       (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61))
  -> (IntMap
        (ComponentState
           (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61)),
      ()))
 -> IO ())
-> (IntMap
      (ComponentState
         (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61))
    -> (IntMap
          (ComponentState
             (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61)),
        ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \IntMap
  (ComponentState
     (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61))
m -> (Int
-> IntMap
     (ComponentState
        (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61))
-> IntMap
     (ComponentState
        (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61))
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
_componentId IntMap
  (ComponentState
     (ZonkAny 58) (ZonkAny 59) (ZonkAny 60) (ZonkAny 61))
m, ())
  Int -> IO ()
FFI.unmountComponent Int
_componentId
-----------------------------------------------------------------------------
resetComponentState :: IO () -> IO ()
resetComponentState :: IO () -> IO ()
resetComponentState IO ()
clear = do
  cs <- IORef
  (IntMap
     (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) (ZonkAny 3)))
-> (IntMap
      (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) (ZonkAny 3))
    -> (IntMap
          (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) (ZonkAny 3)),
        IntMap
          (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) (ZonkAny 3))))
-> IO
     (IntMap
        (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) (ZonkAny 3)))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef
  (IntMap
     (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) (ZonkAny 3)))
forall parent props model action.
IORef (IntMap (ComponentState parent props model action))
components ((IntMap
    (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) (ZonkAny 3))
  -> (IntMap
        (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) (ZonkAny 3)),
      IntMap
        (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) (ZonkAny 3))))
 -> IO
      (IntMap
         (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) (ZonkAny 3))))
-> (IntMap
      (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) (ZonkAny 3))
    -> (IntMap
          (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) (ZonkAny 3)),
        IntMap
          (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) (ZonkAny 3))))
-> IO
     (IntMap
        (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) (ZonkAny 3)))
forall a b. (a -> b) -> a -> b
$ \IntMap
  (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) (ZonkAny 3))
vcomps -> (IntMap
  (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) (ZonkAny 3))
forall a. Monoid a => a
mempty, IntMap
  (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2) (ZonkAny 3))
vcomps)
  atomicWriteIORef globalQueue mempty
  atomicWriteIORef componentIds topLevelComponentId
  atomicWriteIORef subIds 0
  forM_ cs unmountComponent
  clear
-----------------------------------------------------------------------------
-- | 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
  :: Eq model
  => Events
  -> ComponentId
  -> ComponentId
  -> Hydrate
  -> Sink action
  -> LogLevel
  -> View model action
  -> IO VTree
buildVTree :: forall model action.
Eq model =>
Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> View model 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 model props model action
app) -> do
    vcomp_ <- IO Object
create

    mountCallback <- do
      syncCallback1' $ \JSVal
parent_ -> do
        ComponentState {..} <- Events
-> Int
-> Hydrate
-> Bool
-> props
-> Component model props model action
-> IO JSVal
-> IO (ComponentState model props model action)
forall parent model props action.
(Eq parent, Eq model, Eq props) =>
Events
-> Int
-> Hydrate
-> Bool
-> props
-> Component parent props model action
-> IO JSVal
-> IO (ComponentState parent props model action)
initialize Events
events_ Int
vcompId Hydrate
hydrate Bool
False props
newProps Component model 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 (ZonkAny 100) (ZonkAny 101) (ZonkAny 102) action)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just ComponentState (ZonkAny 100) (ZonkAny 101) (ZonkAny 102) 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 model props model action -> Maybe action
forall parent props model action.
Component parent props model action -> Maybe action
unmount Component model props model action
app) (ComponentState (ZonkAny 100) (ZonkAny 101) (ZonkAny 102) action
-> action -> IO ()
forall parent props model action.
ComponentState parent props model action -> action -> IO ()
_componentSink ComponentState (ZonkAny 100) (ZonkAny 101) (ZonkAny 102) action
componentState)
            ComponentState (ZonkAny 100) (ZonkAny 101) (ZonkAny 102) action
-> IO ()
forall parent props model action.
ComponentState parent props model action -> IO ()
unmountComponent ComponentState (ZonkAny 100) (ZonkAny 101) (ZonkAny 102) 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_ (componentProps .= newProps)
          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 model 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_
    flip (FFI.set "children") vnode_ vchildren
    flip (FFI.set "type") vnode_ =<< toJSVal VNodeType
    pure (VTree vnode_)
      where
        procreate :: v -> IO [Object]
procreate v
parentVTree = do
          kidsViews <- ([Object] -> View model action -> IO [Object])
-> [Object] -> [View model action] -> IO [Object]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (v -> [Object] -> View model action -> IO [Object]
forall {model} {v}.
(Eq model, ToJSVal v) =>
v -> [Object] -> View model action -> IO [Object]
buildKid v
parentVTree) [] [View model action]
kids
          let ordered = [Object] -> [Object]
forall a. [a] -> [a]
reverse [Object]
kidsViews
          setNextSibling ordered
          pure ordered
            where
              setNextSibling :: [b] -> IO ()
setNextSibling [b]
xs =
                (b -> b -> IO ()) -> [b] -> [b] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ ((b -> MisoString -> b -> IO ()) -> MisoString -> b -> b -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> MisoString -> b -> IO ()
forall o v.
(ToObject o, ToJSVal v) =>
o -> MisoString -> v -> IO ()
setField MisoString
"nextSibling")
                  [b]
xs (Int -> [b] -> [b]
forall a. Int -> [a] -> [a]
drop Int
1 [b]
xs)
              buildKid :: v -> [Object] -> View model action -> IO [Object]
buildKid v
_ [Object]
acc (VFrag Maybe Key
_ []) = [Object] -> IO [Object]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Object]
acc
              buildKid v
p [Object]
acc View model action
kid = do
                VTree child <- Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> View model action
-> IO VTree
forall model action.
Eq model =>
Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> View model action
-> IO VTree
buildVTree Events
events_ Int
parentId_ Int
vcompId Hydrate
hydrate Sink action
snk LogLevel
logLevel_ View model action
kid
                FFI.set "parent" p child
                pure (child : acc)
  VText Maybe Key
key MisoString
t -> do
    vtree <- IO Object
create
    flip (FFI.set "type") vtree =<< toJSVal VTextType
    forM_ key $ \Key
k -> MisoString -> MisoString -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"key" (Key -> MisoString
forall str. ToMisoString str => str -> MisoString
ms Key
k) Object
vtree
    FFI.set "ns" ("text" :: MisoString) vtree
    FFI.set "text" t vtree
    pure (VTree vtree)
  VFrag Maybe Key
maybeKey [View model action]
kids -> do
    frag <- IO Object
create
    FFI.set "type" VFragType frag
    forM_ maybeKey $ \(Key MisoString
k) -> MisoString -> MisoString -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"key" MisoString
k Object
frag
    vchildren <- toJSVal =<< procreateFragChildren frag
    FFI.set "children" vchildren frag
    pure (VTree frag)
      where
        procreateFragChildren :: p -> IO [Object]
procreateFragChildren p
parentVTree = do
          kidsViews <- ([Object] -> View model action -> IO [Object])
-> [Object] -> [View model action] -> IO [Object]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [Object] -> View model action -> IO [Object]
forall {model}.
Eq model =>
[Object] -> View model action -> IO [Object]
buildKid [] [View model action]
kids
          let ordered = [Object] -> [Object]
forall a. [a] -> [a]
reverse [Object]
kidsViews
          zipWithM_ (flip setField "nextSibling") ordered (drop 1 ordered)
          pure ordered
            where
              buildKid :: [Object] -> View model action -> IO [Object]
buildKid [Object]
acc (VFrag Maybe Key
_ []) = [Object] -> IO [Object]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Object]
acc
              buildKid [Object]
acc View model action
kid = do
                VTree child <- Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> View model action
-> IO VTree
forall model action.
Eq model =>
Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> View model action
-> IO VTree
buildVTree Events
events_ Int
parentId_ Int
vcompId Hydrate
hydrate Sink action
snk LogLevel
logLevel_ View model 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 parent props model action -> m ()
registerComponent :: forall (m :: * -> *) parent props model action.
MonadIO m =>
ComponentState parent props model action -> m ()
registerComponent ComponentState parent 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 parent props model action))
-> (IntMap (ComponentState parent props model action)
    -> (IntMap (ComponentState parent props model action), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (IntMap (ComponentState parent props model action))
forall parent props model action.
IORef (IntMap (ComponentState parent props model action))
components ((IntMap (ComponentState parent props model action)
  -> (IntMap (ComponentState parent props model action), ()))
 -> IO ())
-> (IntMap (ComponentState parent props model action)
    -> (IntMap (ComponentState parent props model action), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \IntMap (ComponentState parent props model action)
cs ->
    (Int
-> ComponentState parent props model action
-> IntMap (ComponentState parent props model action)
-> IntMap (ComponentState parent props model action)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (ComponentState parent props model action -> Int
forall parent props model action.
ComponentState parent props model action -> Int
_componentId ComponentState parent props model action
componentState) ComponentState parent props model action
componentState IntMap (ComponentState parent props model action)
cs, ())
-----------------------------------------------------------------------------
-- | 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 parent props model action
startSub :: forall subKey action parent props model.
ToMisoString subKey =>
subKey -> Sub action -> Effect parent props model action
startSub subKey
subKey Sub action
sub = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent props)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    IM.lookup _componentInfoId <$> liftIO (readIORef components) >>= \case
      Maybe (ComponentState (ZonkAny 9) (ZonkAny 10) (ZonkAny 11) action)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just compState :: ComponentState (ZonkAny 9) (ZonkAny 10) (ZonkAny 11) action
compState@ComponentState {Bool
Int
[JSVal]
[Binding (ZonkAny 9) (ZonkAny 11)]
ZonkAny 10
ZonkAny 11
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
action -> IO ()
[action]
-> ZonkAny 11
-> IntMap
     (ComponentState (ZonkAny 9) (ZonkAny 10) (ZonkAny 11) action)
-> ZonkAny 10
-> (IntMap
      (ComponentState (ZonkAny 9) (ZonkAny 10) (ZonkAny 11) action),
    ZonkAny 11, [Schedule action], ComponentIds)
ZonkAny 11 -> IO ()
ZonkAny 11 -> ZonkAny 11 -> Bool
Value -> Maybe action
_componentModel :: forall parent props model action.
ComponentState parent props model action -> model
_componentEvents :: forall parent props model action.
ComponentState parent props model action -> Events
_componentMailbox :: forall parent props model action.
ComponentState parent props model action -> Value -> Maybe action
_componentBindings :: forall parent props model action.
ComponentState parent props model action -> [Binding parent model]
_componentTopics :: forall parent props model action.
ComponentState parent props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent props model action.
ComponentState parent props model action -> model -> model -> Bool
_componentChildren :: forall parent props model action.
ComponentState parent props model action -> ComponentIds
_componentApplyActions :: forall parent props model action.
ComponentState parent props model action
-> [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent props model action.
ComponentState parent props model action -> model -> IO ()
_componentScripts :: forall parent props model action.
ComponentState parent props model action -> [JSVal]
_componentIsDirty :: forall parent props model action.
ComponentState parent props model action -> Bool
_componentSink :: forall parent props model action.
ComponentState parent props model action -> action -> IO ()
_componentVTree :: forall parent props model action.
ComponentState parent props model action -> IORef VTree
_componentDOMRef :: forall parent props model action.
ComponentState parent props model action -> JSVal
_componentSubThreads :: forall parent props model action.
ComponentState parent props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall parent props model action.
ComponentState parent props model action -> props
_componentParentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentProps :: ZonkAny 10
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: ZonkAny 11
_componentIsDirty :: Bool
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentBindings :: [Binding (ZonkAny 9) (ZonkAny 11)]
_componentMailbox :: Value -> Maybe action
_componentDraw :: ZonkAny 11 -> IO ()
_componentModelDirty :: ZonkAny 11 -> ZonkAny 11 -> Bool
_componentApplyActions :: [action]
-> ZonkAny 11
-> IntMap
     (ComponentState (ZonkAny 9) (ZonkAny 10) (ZonkAny 11) action)
-> ZonkAny 10
-> (IntMap
      (ComponentState (ZonkAny 9) (ZonkAny 10) (ZonkAny 11) action),
    ZonkAny 11, [Schedule action], ComponentIds)
_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 9) (ZonkAny 10) (ZonkAny 11) action
-> IO ()
forall {parent} {props} {model}.
ComponentState parent props model action -> IO ()
startThread ComponentState (ZonkAny 9) (ZonkAny 10) (ZonkAny 11) action
compState
          Just ThreadId
tid -> do
            status <- ThreadId -> IO ThreadStatus
threadStatus ThreadId
tid
            case status of
              ThreadStatus
ThreadFinished -> ComponentState (ZonkAny 9) (ZonkAny 10) (ZonkAny 11) action
-> IO ()
forall {parent} {props} {model}.
ComponentState parent props model action -> IO ()
startThread ComponentState (ZonkAny 9) (ZonkAny 10) (ZonkAny 11) action
compState
              ThreadStatus
ThreadDied -> ComponentState (ZonkAny 9) (ZonkAny 10) (ZonkAny 11) action
-> IO ()
forall {parent} {props} {model}.
ComponentState parent props model action -> IO ()
startThread ComponentState (ZonkAny 9) (ZonkAny 10) (ZonkAny 11) action
compState
              ThreadStatus
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    startThread :: ComponentState parent props model action -> IO ()
startThread ComponentState {props
model
Bool
Int
[JSVal]
[Binding parent model]
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
action -> IO ()
model -> IO ()
model -> model -> Bool
[action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
Value -> Maybe action
_componentModel :: forall parent props model action.
ComponentState parent props model action -> model
_componentEvents :: forall parent props model action.
ComponentState parent props model action -> Events
_componentMailbox :: forall parent props model action.
ComponentState parent props model action -> Value -> Maybe action
_componentBindings :: forall parent props model action.
ComponentState parent props model action -> [Binding parent model]
_componentTopics :: forall parent props model action.
ComponentState parent props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent props model action.
ComponentState parent props model action -> model -> model -> Bool
_componentChildren :: forall parent props model action.
ComponentState parent props model action -> ComponentIds
_componentApplyActions :: forall parent props model action.
ComponentState parent props model action
-> [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent props model action.
ComponentState parent props model action -> model -> IO ()
_componentScripts :: forall parent props model action.
ComponentState parent props model action -> [JSVal]
_componentIsDirty :: forall parent props model action.
ComponentState parent props model action -> Bool
_componentSink :: forall parent props model action.
ComponentState parent props model action -> action -> IO ()
_componentVTree :: forall parent props model action.
ComponentState parent props model action -> IORef VTree
_componentDOMRef :: forall parent props model action.
ComponentState parent props model action -> JSVal
_componentSubThreads :: forall parent props model action.
ComponentState parent props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall parent props model action.
ComponentState parent props model action -> props
_componentParentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentProps :: props
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentIsDirty :: Bool
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentBindings :: [Binding parent model]
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_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 parent props model action
stopSub :: forall subKey parent props model action.
ToMisoString subKey =>
subKey -> Effect parent props model action
stopSub subKey
subKey = do
  vcompId <- (ComponentInfo parent props -> Int)
-> RWST
     (ComponentInfo parent props) [Schedule action] model Identity Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ComponentInfo parent props -> Int
forall parent props. ComponentInfo parent props -> Int
_componentInfoId
  io_ $ do
    IM.lookup vcompId <$> readIORef components >>= \case
      Maybe
  (ComponentState
     (ZonkAny 12) (ZonkAny 13) (ZonkAny 14) (ZonkAny 15))
Nothing -> do
        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just ComponentState {Bool
Int
[JSVal]
[Binding (ZonkAny 12) (ZonkAny 14)]
ZonkAny 13
ZonkAny 14
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
[ZonkAny 15]
-> ZonkAny 14
-> IntMap
     (ComponentState
        (ZonkAny 12) (ZonkAny 13) (ZonkAny 14) (ZonkAny 15))
-> ZonkAny 13
-> (IntMap
      (ComponentState
         (ZonkAny 12) (ZonkAny 13) (ZonkAny 14) (ZonkAny 15)),
    ZonkAny 14, [Schedule (ZonkAny 15)], ComponentIds)
ZonkAny 14 -> IO ()
ZonkAny 14 -> ZonkAny 14 -> Bool
ZonkAny 15 -> IO ()
Value -> Maybe (ZonkAny 15)
_componentModel :: forall parent props model action.
ComponentState parent props model action -> model
_componentEvents :: forall parent props model action.
ComponentState parent props model action -> Events
_componentMailbox :: forall parent props model action.
ComponentState parent props model action -> Value -> Maybe action
_componentBindings :: forall parent props model action.
ComponentState parent props model action -> [Binding parent model]
_componentTopics :: forall parent props model action.
ComponentState parent props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent props model action.
ComponentState parent props model action -> model -> model -> Bool
_componentChildren :: forall parent props model action.
ComponentState parent props model action -> ComponentIds
_componentApplyActions :: forall parent props model action.
ComponentState parent props model action
-> [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent props model action.
ComponentState parent props model action -> model -> IO ()
_componentScripts :: forall parent props model action.
ComponentState parent props model action -> [JSVal]
_componentIsDirty :: forall parent props model action.
ComponentState parent props model action -> Bool
_componentSink :: forall parent props model action.
ComponentState parent props model action -> action -> IO ()
_componentVTree :: forall parent props model action.
ComponentState parent props model action -> IORef VTree
_componentDOMRef :: forall parent props model action.
ComponentState parent props model action -> JSVal
_componentSubThreads :: forall parent props model action.
ComponentState parent props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall parent props model action.
ComponentState parent props model action -> props
_componentParentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentProps :: ZonkAny 13
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: ZonkAny 15 -> IO ()
_componentModel :: ZonkAny 14
_componentIsDirty :: Bool
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentBindings :: [Binding (ZonkAny 12) (ZonkAny 14)]
_componentMailbox :: Value -> Maybe (ZonkAny 15)
_componentDraw :: ZonkAny 14 -> IO ()
_componentModelDirty :: ZonkAny 14 -> ZonkAny 14 -> Bool
_componentApplyActions :: [ZonkAny 15]
-> ZonkAny 14
-> IntMap
     (ComponentState
        (ZonkAny 12) (ZonkAny 13) (ZonkAny 14) (ZonkAny 15))
-> ZonkAny 13
-> (IntMap
      (ComponentState
         (ZonkAny 12) (ZonkAny 13) (ZonkAny 14) (ZonkAny 15)),
    ZonkAny 14, [Schedule (ZonkAny 15)], ComponentIds)
_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 parent 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 16) (ZonkAny 17) (ZonkAny 18) (ZonkAny 19))
-> Maybe
     (ComponentState
        (ZonkAny 16) (ZonkAny 17) (ZonkAny 18) (ZonkAny 19))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap
   (ComponentState
      (ZonkAny 16) (ZonkAny 17) (ZonkAny 18) (ZonkAny 19))
 -> Maybe
      (ComponentState
         (ZonkAny 16) (ZonkAny 17) (ZonkAny 18) (ZonkAny 19)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 16) (ZonkAny 17) (ZonkAny 18) (ZonkAny 19)))
-> IO
     (Maybe
        (ComponentState
           (ZonkAny 16) (ZonkAny 17) (ZonkAny 18) (ZonkAny 19)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState
        (ZonkAny 16) (ZonkAny 17) (ZonkAny 18) (ZonkAny 19)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 16) (ZonkAny 17) (ZonkAny 18) (ZonkAny 19)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 16) (ZonkAny 17) (ZonkAny 18) (ZonkAny 19)))
forall parent props model action.
IORef (IntMap (ComponentState parent props model action))
components IO
  (Maybe
     (ComponentState
        (ZonkAny 16) (ZonkAny 17) (ZonkAny 18) (ZonkAny 19)))
-> (Maybe
      (ComponentState
         (ZonkAny 16) (ZonkAny 17) (ZonkAny 18) (ZonkAny 19))
    -> 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 16) (ZonkAny 17) (ZonkAny 18) (ZonkAny 19))
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just ComponentState{Bool
Int
[JSVal]
[Binding (ZonkAny 16) (ZonkAny 18)]
ZonkAny 17
ZonkAny 18
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
[ZonkAny 19]
-> ZonkAny 18
-> IntMap
     (ComponentState
        (ZonkAny 16) (ZonkAny 17) (ZonkAny 18) (ZonkAny 19))
-> ZonkAny 17
-> (IntMap
      (ComponentState
         (ZonkAny 16) (ZonkAny 17) (ZonkAny 18) (ZonkAny 19)),
    ZonkAny 18, [Schedule (ZonkAny 19)], ComponentIds)
ZonkAny 18 -> IO ()
ZonkAny 18 -> ZonkAny 18 -> Bool
ZonkAny 19 -> IO ()
Value -> Maybe (ZonkAny 19)
_componentModel :: forall parent props model action.
ComponentState parent props model action -> model
_componentEvents :: forall parent props model action.
ComponentState parent props model action -> Events
_componentMailbox :: forall parent props model action.
ComponentState parent props model action -> Value -> Maybe action
_componentBindings :: forall parent props model action.
ComponentState parent props model action -> [Binding parent model]
_componentTopics :: forall parent props model action.
ComponentState parent props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent props model action.
ComponentState parent props model action -> model -> model -> Bool
_componentChildren :: forall parent props model action.
ComponentState parent props model action -> ComponentIds
_componentApplyActions :: forall parent props model action.
ComponentState parent props model action
-> [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent props model action.
ComponentState parent props model action -> model -> IO ()
_componentScripts :: forall parent props model action.
ComponentState parent props model action -> [JSVal]
_componentIsDirty :: forall parent props model action.
ComponentState parent props model action -> Bool
_componentSink :: forall parent props model action.
ComponentState parent props model action -> action -> IO ()
_componentVTree :: forall parent props model action.
ComponentState parent props model action -> IORef VTree
_componentDOMRef :: forall parent props model action.
ComponentState parent props model action -> JSVal
_componentSubThreads :: forall parent props model action.
ComponentState parent props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall parent props model action.
ComponentState parent props model action -> props
_componentParentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentProps :: ZonkAny 17
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: ZonkAny 19 -> IO ()
_componentModel :: ZonkAny 18
_componentIsDirty :: Bool
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentBindings :: [Binding (ZonkAny 16) (ZonkAny 18)]
_componentMailbox :: Value -> Maybe (ZonkAny 19)
_componentDraw :: ZonkAny 18 -> IO ()
_componentModelDirty :: ZonkAny 18 -> ZonkAny 18 -> Bool
_componentApplyActions :: [ZonkAny 19]
-> ZonkAny 18
-> IntMap
     (ComponentState
        (ZonkAny 16) (ZonkAny 17) (ZonkAny 18) (ZonkAny 19))
-> ZonkAny 17
-> (IntMap
      (ComponentState
         (ZonkAny 16) (ZonkAny 17) (ZonkAny 18) (ZonkAny 19)),
    ZonkAny 18, [Schedule (ZonkAny 19)], ComponentIds)
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} ->
      case Value -> Maybe (ZonkAny 19)
_componentMailbox (message -> Value
forall a. ToJSON a => a -> Value
toJSON message
msg) of
        Maybe (ZonkAny 19)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just ZonkAny 19
action ->
          ZonkAny 19 -> IO ()
_componentSink ZonkAny 19
action
-----------------------------------------------------------------------------
-- | Send any @ToJSON message => message@ to the parent's t'Miso.Types.Component' mailbox
--
-- @
-- mailParent ("test message" :: MisoString) :: Effect parent props model action
-- @
--
-- @since 1.9.0.0
mailParent
  :: ToJSON message
  => message
  -- ^ Message to send
  -> Effect parent props model action
mailParent :: forall message parent props model action.
ToJSON message =>
message -> Effect parent props model action
mailParent message
msg = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent props)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent 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 parent props model action
-- @
--
-- @since 1.11.0.0
mailAncestors
  :: ToJSON message
  => message
  -- ^ Message to send
  -> Effect parent props model action
mailAncestors :: forall message parent props model action.
ToJSON message =>
message -> Effect parent props model action
mailAncestors message
msg = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent props)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent 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 20) (ZonkAny 21) (ZonkAny 22) (ZonkAny 23))
-> Maybe
     (ComponentState
        (ZonkAny 20) (ZonkAny 21) (ZonkAny 22) (ZonkAny 23))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap
   (ComponentState
      (ZonkAny 20) (ZonkAny 21) (ZonkAny 22) (ZonkAny 23))
 -> Maybe
      (ComponentState
         (ZonkAny 20) (ZonkAny 21) (ZonkAny 22) (ZonkAny 23)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 20) (ZonkAny 21) (ZonkAny 22) (ZonkAny 23)))
-> IO
     (Maybe
        (ComponentState
           (ZonkAny 20) (ZonkAny 21) (ZonkAny 22) (ZonkAny 23)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap
     (ComponentState
        (ZonkAny 20) (ZonkAny 21) (ZonkAny 22) (ZonkAny 23)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 20) (ZonkAny 21) (ZonkAny 22) (ZonkAny 23)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState
        (ZonkAny 20) (ZonkAny 21) (ZonkAny 22) (ZonkAny 23)))
forall parent props model action.
IORef (IntMap (ComponentState parent props model action))
components IO
  (Maybe
     (ComponentState
        (ZonkAny 20) (ZonkAny 21) (ZonkAny 22) (ZonkAny 23)))
-> (Maybe
      (ComponentState
         (ZonkAny 20) (ZonkAny 21) (ZonkAny 22) (ZonkAny 23))
    -> 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 20) (ZonkAny 21) (ZonkAny 22) (ZonkAny 23))
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just ComponentState (ZonkAny 20) (ZonkAny 21) (ZonkAny 22) (ZonkAny 23)
cs -> Int -> IO ()
climb (ComponentState (ZonkAny 20) (ZonkAny 21) (ZonkAny 22) (ZonkAny 23)
-> Int
forall parent props model action.
ComponentState parent props model action -> Int
_componentParentId ComponentState (ZonkAny 20) (ZonkAny 21) (ZonkAny 22) (ZonkAny 23)
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 parent props model action
-- @
--
-- @since 1.9.0.0
mailChildren
  :: ToJSON message
  => message
  -- ^ Message to send
  -> Effect parent props model action
mailChildren :: forall message parent props model action.
ToJSON message =>
message -> Effect parent props model action
mailChildren message
msg = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent props)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    ComponentState {..} <- (IM.! _componentInfoId) <$> readIORef components
    forM_ (IS.toList _componentChildren) (flip mail msg)
----------------------------------------------------------------------------
-- | 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)
-----------------------------------------------------------------------------
-- | Fetches the parent `model` from the child (if @parent@ exists).
--
-- N.B. this is a no-op for 'ROOT'.
--
-- @since 1.9.0.0
parent
  :: (parent -> action)
  -- ^ Successful callback
  -> action
  -- ^ Errorful callback
  -> Effect parent props model action
parent :: forall parent action props model.
(parent -> action) -> action -> Effect parent props model action
parent parent -> action
successful action
errorful = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent props)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent props)
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink -> do
    Int
-> IntMap
     (ComponentState (ZonkAny 28) (ZonkAny 29) parent (ZonkAny 30))
-> Maybe
     (ComponentState (ZonkAny 28) (ZonkAny 29) parent (ZonkAny 30))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
_componentInfoParentId (IntMap
   (ComponentState (ZonkAny 28) (ZonkAny 29) parent (ZonkAny 30))
 -> Maybe
      (ComponentState (ZonkAny 28) (ZonkAny 29) parent (ZonkAny 30)))
-> IO
     (IntMap
        (ComponentState (ZonkAny 28) (ZonkAny 29) parent (ZonkAny 30)))
-> IO
     (Maybe
        (ComponentState (ZonkAny 28) (ZonkAny 29) parent (ZonkAny 30)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO
  (IntMap
     (ComponentState (ZonkAny 28) (ZonkAny 29) parent (ZonkAny 30)))
-> IO
     (IntMap
        (ComponentState (ZonkAny 28) (ZonkAny 29) parent (ZonkAny 30)))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef
  (IntMap
     (ComponentState (ZonkAny 28) (ZonkAny 29) parent (ZonkAny 30)))
-> IO
     (IntMap
        (ComponentState (ZonkAny 28) (ZonkAny 29) parent (ZonkAny 30)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap
     (ComponentState (ZonkAny 28) (ZonkAny 29) parent (ZonkAny 30)))
forall parent props model action.
IORef (IntMap (ComponentState parent props model action))
components) IO
  (Maybe
     (ComponentState (ZonkAny 28) (ZonkAny 29) parent (ZonkAny 30)))
-> (Maybe
      (ComponentState (ZonkAny 28) (ZonkAny 29) parent (ZonkAny 30))
    -> 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 28) (ZonkAny 29) parent (ZonkAny 30))
Nothing -> Sink action
sink action
errorful
      Just ComponentState {parent
Bool
Int
[JSVal]
[Binding (ZonkAny 28) parent]
ZonkAny 29
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
parent -> IO ()
parent -> parent -> Bool
[ZonkAny 30]
-> parent
-> IntMap
     (ComponentState (ZonkAny 28) (ZonkAny 29) parent (ZonkAny 30))
-> ZonkAny 29
-> (IntMap
      (ComponentState (ZonkAny 28) (ZonkAny 29) parent (ZonkAny 30)),
    parent, [Schedule (ZonkAny 30)], ComponentIds)
ZonkAny 30 -> IO ()
Value -> Maybe (ZonkAny 30)
_componentModel :: forall parent props model action.
ComponentState parent props model action -> model
_componentEvents :: forall parent props model action.
ComponentState parent props model action -> Events
_componentMailbox :: forall parent props model action.
ComponentState parent props model action -> Value -> Maybe action
_componentBindings :: forall parent props model action.
ComponentState parent props model action -> [Binding parent model]
_componentTopics :: forall parent props model action.
ComponentState parent props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent props model action.
ComponentState parent props model action -> model -> model -> Bool
_componentChildren :: forall parent props model action.
ComponentState parent props model action -> ComponentIds
_componentApplyActions :: forall parent props model action.
ComponentState parent props model action
-> [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent props model action.
ComponentState parent props model action -> model -> IO ()
_componentScripts :: forall parent props model action.
ComponentState parent props model action -> [JSVal]
_componentIsDirty :: forall parent props model action.
ComponentState parent props model action -> Bool
_componentSink :: forall parent props model action.
ComponentState parent props model action -> action -> IO ()
_componentVTree :: forall parent props model action.
ComponentState parent props model action -> IORef VTree
_componentDOMRef :: forall parent props model action.
ComponentState parent props model action -> JSVal
_componentSubThreads :: forall parent props model action.
ComponentState parent props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall parent props model action.
ComponentState parent props model action -> props
_componentParentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentProps :: ZonkAny 29
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: ZonkAny 30 -> IO ()
_componentModel :: parent
_componentIsDirty :: Bool
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentBindings :: [Binding (ZonkAny 28) parent]
_componentMailbox :: Value -> Maybe (ZonkAny 30)
_componentDraw :: parent -> IO ()
_componentModelDirty :: parent -> parent -> Bool
_componentApplyActions :: [ZonkAny 30]
-> parent
-> IntMap
     (ComponentState (ZonkAny 28) (ZonkAny 29) parent (ZonkAny 30))
-> ZonkAny 29
-> (IntMap
      (ComponentState (ZonkAny 28) (ZonkAny 29) parent (ZonkAny 30)),
    parent, [Schedule (ZonkAny 30)], ComponentIds)
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} -> do
        Sink action
sink (parent -> action
successful parent
_componentModel)
-----------------------------------------------------------------------------
-- | Sends a message to all t'Miso.Types.Component' 'mailbox', excluding oneself.
--
-- @
--
-- update :: action -> Effect parent 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 parent props model action
broadcast :: forall model message parent props action.
(Eq model, ToJSON message) =>
message -> Effect parent props model action
broadcast message
msg = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent props)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent 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 model. Eq model => model -> model -> Bool
/= Int
vcompId) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Int
-> IntMap
     (ComponentState
        (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38))
-> Maybe
     (ComponentState
        (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap
   (ComponentState
      (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38))
 -> Maybe
      (ComponentState
         (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38)))
-> IO
     (IntMap
        (ComponentState
           (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38)))
-> IO
     (Maybe
        (ComponentState
           (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 parent props model action.
IORef (IntMap (ComponentState parent props model action))
components IO
  (Maybe
     (ComponentState
        (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38)))
-> (Maybe
      (ComponentState
         (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38))
    -> 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 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38))
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just ComponentState{Bool
Int
[JSVal]
[Binding (ZonkAny 35) (ZonkAny 37)]
ZonkAny 36
ZonkAny 37
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
JSVal
[ZonkAny 38]
-> ZonkAny 37
-> IntMap
     (ComponentState
        (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38))
-> ZonkAny 36
-> (IntMap
      (ComponentState
         (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38)),
    ZonkAny 37, [Schedule (ZonkAny 38)], ComponentIds)
ZonkAny 37 -> IO ()
ZonkAny 37 -> ZonkAny 37 -> Bool
ZonkAny 38 -> IO ()
Value -> Maybe (ZonkAny 38)
_componentModel :: forall parent props model action.
ComponentState parent props model action -> model
_componentEvents :: forall parent props model action.
ComponentState parent props model action -> Events
_componentMailbox :: forall parent props model action.
ComponentState parent props model action -> Value -> Maybe action
_componentBindings :: forall parent props model action.
ComponentState parent props model action -> [Binding parent model]
_componentTopics :: forall parent props model action.
ComponentState parent props model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent props model action.
ComponentState parent props model action -> model -> model -> Bool
_componentChildren :: forall parent props model action.
ComponentState parent props model action -> ComponentIds
_componentApplyActions :: forall parent props model action.
ComponentState parent props model action
-> [action]
-> model
-> IntMap (ComponentState parent props model action)
-> props
-> (IntMap (ComponentState parent props model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent props model action.
ComponentState parent props model action -> model -> IO ()
_componentScripts :: forall parent props model action.
ComponentState parent props model action -> [JSVal]
_componentIsDirty :: forall parent props model action.
ComponentState parent props model action -> Bool
_componentSink :: forall parent props model action.
ComponentState parent props model action -> action -> IO ()
_componentVTree :: forall parent props model action.
ComponentState parent props model action -> IORef VTree
_componentDOMRef :: forall parent props model action.
ComponentState parent props model action -> JSVal
_componentSubThreads :: forall parent props model action.
ComponentState parent props model action
-> IORef (Map MisoString ThreadId)
_componentProps :: forall parent props model action.
ComponentState parent props model action -> props
_componentParentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: forall parent props model action.
ComponentState parent props model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentProps :: ZonkAny 36
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: JSVal
_componentVTree :: IORef VTree
_componentSink :: ZonkAny 38 -> IO ()
_componentModel :: ZonkAny 37
_componentIsDirty :: Bool
_componentScripts :: [JSVal]
_componentEvents :: Events
_componentBindings :: [Binding (ZonkAny 35) (ZonkAny 37)]
_componentMailbox :: Value -> Maybe (ZonkAny 38)
_componentDraw :: ZonkAny 37 -> IO ()
_componentModelDirty :: ZonkAny 37 -> ZonkAny 37 -> Bool
_componentApplyActions :: [ZonkAny 38]
-> ZonkAny 37
-> IntMap
     (ComponentState
        (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38))
-> ZonkAny 36
-> (IntMap
      (ComponentState
         (ZonkAny 35) (ZonkAny 36) (ZonkAny 37) (ZonkAny 38)),
    ZonkAny 37, [Schedule (ZonkAny 38)], ComponentIds)
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} ->
            case Value -> Maybe (ZonkAny 38)
_componentMailbox (message -> Value
forall a. ToJSON a => a -> Value
toJSON message
msg) of
              Maybe (ZonkAny 38)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Just ZonkAny 38
action -> ZonkAny 38 -> IO ()
_componentSink ZonkAny 38
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 parent props model action
websocketConnectText :: forall action parent props model.
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (MisoString -> action)
-> (MisoString -> action)
-> Effect parent props model action
websocketConnectText MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed MisoString -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> IO JSVal)
-> Effect parent props model action
forall action parent props model.
(WebSocket -> Sink action -> IO JSVal)
-> Effect parent props model action
websocketCore ((WebSocket -> Sink action -> IO JSVal)
 -> Effect parent props model action)
-> (WebSocket -> Sink action -> IO JSVal)
-> Effect parent 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 parent props model action
websocketConnectBLOB :: forall action parent props model.
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (Blob -> action)
-> (MisoString -> action)
-> Effect parent props model action
websocketConnectBLOB MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed Blob -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> IO JSVal)
-> Effect parent props model action
forall action parent props model.
(WebSocket -> Sink action -> IO JSVal)
-> Effect parent props model action
websocketCore ((WebSocket -> Sink action -> IO JSVal)
 -> Effect parent props model action)
-> (WebSocket -> Sink action -> IO JSVal)
-> Effect parent 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 parent props model action
websocketConnectArrayBuffer :: forall action parent props model.
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (ArrayBuffer -> action)
-> (MisoString -> action)
-> Effect parent props model action
websocketConnectArrayBuffer MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed ArrayBuffer -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> IO JSVal)
-> Effect parent props model action
forall action parent props model.
(WebSocket -> Sink action -> IO JSVal)
-> Effect parent props model action
websocketCore ((WebSocket -> Sink action -> IO JSVal)
 -> Effect parent props model action)
-> (WebSocket -> Sink action -> IO JSVal)
-> Effect parent 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 parent props model action
websocketConnectJSON :: forall json action parent props model.
FromJSON json =>
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (json -> action)
-> (MisoString -> action)
-> Effect parent props model action
websocketConnectJSON MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed json -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> IO JSVal)
-> Effect parent props model action
forall action parent props model.
(WebSocket -> Sink action -> IO JSVal)
-> Effect parent props model action
websocketCore ((WebSocket -> Sink action -> IO JSVal)
 -> Effect parent props model action)
-> (WebSocket -> Sink action -> IO JSVal)
-> Effect parent 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 parent props model action
websocketConnect :: forall json action parent props model.
FromJSON json =>
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (Payload json -> action)
-> (MisoString -> action)
-> Effect parent 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 parent props model action
forall action parent props model.
(WebSocket -> Sink action -> IO JSVal)
-> Effect parent props model action
websocketCore ((WebSocket -> Sink action -> IO JSVal)
 -> Effect parent props model action)
-> (WebSocket -> Sink action -> IO JSVal)
-> Effect parent 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 parent props model action
websocketCore :: forall action parent props model.
(WebSocket -> Sink action -> IO JSVal)
-> Effect parent props model action
websocketCore WebSocket -> Sink action -> IO JSVal
core = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent props)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent 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 ())
-> IO (Maybe (IntMap JSVal)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (WebSockets -> Maybe (IntMap JSVal))
-> IO WebSockets -> IO (Maybe (IntMap 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 ()
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 parent props model action
websocketClose :: forall parent props model action.
WebSocket -> Effect parent props model action
websocketClose WebSocket
socketId = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent props)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent 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 parent props model action
websocketSend :: forall value parent props model action.
ToJSON value =>
WebSocket -> Payload value -> Effect parent props model action
websocketSend WebSocket
socketId Payload value
msg = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent props)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent 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 parent props model action
socketState :: forall action parent props model.
WebSocket
-> (SocketState -> action) -> Effect parent props model action
socketState WebSocket
socketId SocketState -> action
callback = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent props)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent 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 parent props model action
eventSourceConnectText :: forall action parent props model.
MisoString
-> (EventSource -> action)
-> (MisoString -> action)
-> (MisoString -> action)
-> Effect parent props model action
eventSourceConnectText MisoString
url EventSource -> action
onOpen MisoString -> action
onMessage MisoString -> action
onError =
  (EventSource -> Sink action -> IO JSVal)
-> Effect parent props model action
forall action parent props model.
(EventSource -> Sink action -> IO JSVal)
-> Effect parent props model action
eventSourceCore ((EventSource -> Sink action -> IO JSVal)
 -> Effect parent props model action)
-> (EventSource -> Sink action -> IO JSVal)
-> Effect parent 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 parent props model action
eventSourceConnectJSON :: forall json action parent props model.
FromJSON json =>
MisoString
-> (EventSource -> action)
-> (json -> action)
-> (MisoString -> action)
-> Effect parent props model action
eventSourceConnectJSON MisoString
url EventSource -> action
onOpen json -> action
onMessage MisoString -> action
onError =
  (EventSource -> Sink action -> IO JSVal)
-> Effect parent props model action
forall action parent props model.
(EventSource -> Sink action -> IO JSVal)
-> Effect parent props model action
eventSourceCore ((EventSource -> Sink action -> IO JSVal)
 -> Effect parent props model action)
-> (EventSource -> Sink action -> IO JSVal)
-> Effect parent 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 parent props model action
eventSourceCore :: forall action parent props model.
(EventSource -> Sink action -> IO JSVal)
-> Effect parent props model action
eventSourceCore EventSource -> Sink action -> IO JSVal
core = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent props)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent 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 parent props model action
eventSourceClose :: forall parent props model action.
EventSource -> Effect parent props model action
eventSourceClose EventSource
socketId = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent props)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent 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 ())
-> IO (Maybe (IntMap JSVal)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (WebSockets -> Maybe (IntMap JSVal))
-> IO WebSockets -> IO (Maybe (IntMap 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
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
-----------------------------------------------------------------------------
initComponent
  :: (Eq parent, Eq model)
  => Events
  -> Hydrate
  -> Component parent () model action
  -> IO ()
initComponent :: forall parent model action.
(Eq parent, Eq model) =>
Events -> Hydrate -> Component parent () model action -> IO ()
initComponent Events
events Hydrate
hydrate vcomp_ :: Component parent () model action
vcomp_@Component {model
Bool
[Binding parent model]
[JS]
[CSS]
[Sub action]
Maybe action
Maybe (IO model)
Maybe MisoString
LogLevel
action -> Effect parent () model action
() -> model -> View model action
Value -> Maybe action
unmount :: forall parent props model action.
Component parent props model action -> Maybe action
mount :: forall parent props model action.
Component parent props model action -> Maybe action
eventPropagation :: forall parent props model action.
Component parent props model action -> Bool
bindings :: forall parent props model action.
Component parent props model action -> [Binding parent model]
mailbox :: forall parent props model action.
Component parent props model action -> Value -> Maybe action
logLevel :: forall parent props model action.
Component parent props model action -> LogLevel
mountPoint :: forall parent props model action.
Component parent props model action -> Maybe MisoString
scripts :: forall parent props model action.
Component parent props model action -> [JS]
styles :: forall parent props model action.
Component parent props model action -> [CSS]
subs :: forall parent props model action.
Component parent props model action -> [Sub action]
view :: forall parent props model action.
Component parent props model action
-> props -> model -> View model action
update :: forall parent props model action.
Component parent props model action
-> action -> Effect parent props model action
hydrateModel :: forall parent props model action.
Component parent props model action -> Maybe (IO model)
model :: forall parent props model action.
Component parent props model action -> model
model :: model
hydrateModel :: Maybe (IO model)
update :: action -> Effect parent () model action
view :: () -> model -> View model action
subs :: [Sub action]
styles :: [CSS]
scripts :: [JS]
mountPoint :: Maybe MisoString
logLevel :: LogLevel
mailbox :: Value -> Maybe action
bindings :: [Binding parent model]
eventPropagation :: Bool
mount :: Maybe action
unmount :: Maybe action
..} = 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)
  void $ initialize events rootComponentId hydrate True () vcomp_ (pure root)
#if __GLASGOW_HASKELL__ > 865
  flip labelThread "scheduler" =<< forkIO scheduler
#else
  void (forkIO scheduler)
#endif
----------------------------------------------------------------------------
-- | Load miso's javascript.
--
-- You don't need to use this function if you're compiling w/ WASM and using `miso` or `startApp`.
-- It's already invoked for you. This is a no-op w/ the JS backend.
--
-- If you need access to `Miso.FFI` to call functions from `miso.js`, but you're not
-- using `startApp` or `miso`, you'll need to call this function (w/ WASM only).
--
#ifdef PRODUCTION
#define MISO_JS_PATH "js/miso.prod.js"
#else
#define MISO_JS_PATH "js/miso.js"
#endif
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
  $(evalFile MISO_JS_PATH)
#endif
  action
-----------------------------------------------------------------------------