-----------------------------------------------------------------------------
{-# 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-2025 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
  -- ** 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
  -- ** Scheduler
  , scheduler
#ifdef WASM
  , evalFile
#endif
  ) where
-----------------------------------------------------------------------------
import qualified Data.IntSet as IS
import           Data.IntSet (IntSet)
import           Control.Category ((.))
import           Control.Concurrent
import           Control.Exception (SomeException, catch)
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)
import           GHC.Conc (ThreadStatus(ThreadDied, ThreadFinished), threadStatus)
#ifdef WASM
import qualified Language.Haskell.TH as TH
#endif
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.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
#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)
  => Events
  -> ComponentId
  -> Hydrate
  -> Bool
  -- ^ Is the root node being rendered?
  -> Component parent model action
  -> IO DOMRef
  -- ^ Callback function is used for obtaining the t'Miso.Types.Component' 'DOMRef'.
  -> IO (ComponentState parent model action)
initialize :: forall parent model action.
(Eq parent, Eq model) =>
Events
-> Int
-> Hydrate
-> Bool
-> Component parent model action
-> IO DOMRef
-> IO (ComponentState parent model action)
initialize Events
events Int
_componentParentId Hydrate
hydrate Bool
isRoot comp :: Component parent model action
comp@Component {model
Bool
[Binding parent model]
[JS]
[CSS]
[Sub action]
Maybe action
Maybe (IO model)
Maybe MisoString
LogLevel
model -> View model action
action -> Effect parent model action
Value -> Maybe action
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
unmount :: forall parent model action.
Component parent model action -> Maybe action
mount :: forall parent model action.
Component parent model action -> Maybe action
eventPropagation :: forall parent model action. Component parent model action -> Bool
bindings :: forall parent model action.
Component parent model action -> [Binding parent model]
mailbox :: forall parent model action.
Component parent model action -> Value -> Maybe action
logLevel :: forall parent model action.
Component parent model action -> LogLevel
mountPoint :: forall parent model action.
Component parent model action -> Maybe MisoString
scripts :: forall parent model action. Component parent model action -> [JS]
styles :: forall parent model action. Component parent model action -> [CSS]
subs :: forall parent model action.
Component parent model action -> [Sub action]
view :: forall parent model action.
Component parent model action -> model -> View model action
update :: forall parent model action.
Component parent model action
-> action -> Effect parent model action
hydrateModel :: forall parent model action.
Component parent model action -> Maybe (IO model)
model :: forall parent model action. Component parent model action -> model
..} IO DOMRef
getComponentMountPoint = do
  _componentId <- IO Int
freshComponentId
  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
action) -> IO model
action
      (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)
  _componentModel <- liftIO (pure initializedModel)
  _componentMailbox <- pure S.empty

  rAFCallback <-
    asyncCallback1 $ \DOMRef
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
=<< DOMRef -> IO Double
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked DOMRef
jsval

  let _componentDraw = \model
newModel -> do
        newVTree <- 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
_componentParentId Int
_componentId Hydrate
Draw Sink action
forall {action}. action -> IO ()
_componentSink LogLevel
logLevel (model -> View model action
view model
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)

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

  let vcomp = 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
        , model
Bool
Int
[DOMRef]
IORef (Map MisoString ThreadId)
IORef VTree
DOMRef
model -> IO ()
Sink action
[action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
forall {action}. action -> IO ()
forall {p} {a}.
[action]
-> model
-> IntMap (ComponentState p model a)
-> (IntMap (ComponentState p model a), model, [Schedule action],
    ComponentIds)
_componentParentId :: Int
_componentId :: Int
_componentSink :: forall {action}. action -> IO ()
_componentScripts :: [DOMRef]
_componentDOMRef :: DOMRef
_componentIsDirty :: Bool
_componentVTree :: IORef VTree
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentModel :: model
_componentDraw :: model -> IO ()
_componentApplyActions :: forall {p} {a}.
[action]
-> model
-> IntMap (ComponentState p model a)
-> (IntMap (ComponentState p model a), model, [Schedule action],
    ComponentIds)
_componentModel :: model
_componentApplyActions :: [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: model -> IO ()
_componentScripts :: [DOMRef]
_componentIsDirty :: Bool
_componentSink :: Sink action
_componentVTree :: IORef VTree
_componentDOMRef :: DOMRef
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentParentId :: Int
_componentId :: Int
..
        }

  registerComponent vcomp
  initSubs subs _componentSubThreads _componentSink
  when isRoot (delegator _componentDOMRef _componentVTree events (logLevel `elem` [DebugEvents, DebugAll]))
  initialDraw initializedModel events hydrate isRoot comp vcomp
  forM_ mount _componentSink
  when isRoot $ void (forkIO scheduler)
  pure vcomp
-----------------------------------------------------------------------------
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 40) (ZonkAny 41) (ZonkAny 42))
-> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ComponentState (ZonkAny 40) (ZonkAny 41) (ZonkAny 42))
 -> Bool)
-> (IntMap (ComponentState (ZonkAny 40) (ZonkAny 41) (ZonkAny 42))
    -> Maybe (ComponentState (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)))
-> IntMap (ComponentState (ZonkAny 40) (ZonkAny 41) (ZonkAny 42))
-> 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 40) (ZonkAny 41) (ZonkAny 42))
-> Maybe (ComponentState (ZonkAny 40) (ZonkAny 41) (ZonkAny 42))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap (ComponentState (ZonkAny 40) (ZonkAny 41) (ZonkAny 42))
 -> Bool)
-> IO
     (IntMap (ComponentState (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)))
-> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap (ComponentState (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)))
-> IO
     (IntMap (ComponentState (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap (ComponentState (ZonkAny 40) (ZonkAny 41) (ZonkAny 42)))
forall parent model action.
IORef (IntMap (ComponentState parent 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 50]))
forall action. IO (Maybe (Int, [action]))
getBatch IO (Maybe (Int, [ZonkAny 50]))
-> (Maybe (Int, [ZonkAny 50]) -> 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 50])
Nothing -> Waiter -> IO ()
wait Waiter
globalWaiter
      Just (Int
vcompId, [ZonkAny 50]
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 49) (ZonkAny 47) action))
-> (IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action)
    -> (IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action),
        (ZonkAny 47, [Schedule action], ComponentIds,
         ComponentState (ZonkAny 49) (ZonkAny 47) action)))
-> IO
     (ZonkAny 47, [Schedule action], ComponentIds,
      ComponentState (ZonkAny 49) (ZonkAny 47) action)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action))
forall parent model action.
IORef (IntMap (ComponentState parent model action))
components ((IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action)
  -> (IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action),
      (ZonkAny 47, [Schedule action], ComponentIds,
       ComponentState (ZonkAny 49) (ZonkAny 47) action)))
 -> IO
      (ZonkAny 47, [Schedule action], ComponentIds,
       ComponentState (ZonkAny 49) (ZonkAny 47) action))
-> (IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action)
    -> (IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action),
        (ZonkAny 47, [Schedule action], ComponentIds,
         ComponentState (ZonkAny 49) (ZonkAny 47) action)))
-> IO
     (ZonkAny 47, [Schedule action], ComponentIds,
      ComponentState (ZonkAny 49) (ZonkAny 47) action)
forall a b. (a -> b) -> a -> b
$ \IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action)
vcomps -> do
          let cs :: ComponentState (ZonkAny 49) (ZonkAny 47) action
cs@ComponentState {Bool
Int
[DOMRef]
[Binding (ZonkAny 49) (ZonkAny 47)]
ZonkAny 47
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
DOMRef
action -> IO ()
[action]
-> ZonkAny 47
-> IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action)
-> (IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action),
    ZonkAny 47, [Schedule action], ComponentIds)
ZonkAny 47 -> IO ()
ZonkAny 47 -> ZonkAny 47 -> Bool
Value -> Maybe action
_componentModel :: forall parent model action.
ComponentState parent model action -> model
_componentEvents :: forall parent model action.
ComponentState parent model action -> Events
_componentMailbox :: forall parent model action.
ComponentState parent model action -> Value -> Maybe action
_componentBindings :: forall parent model action.
ComponentState parent model action -> [Binding parent model]
_componentTopics :: forall parent model action.
ComponentState parent model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent model action.
ComponentState parent model action -> model -> model -> Bool
_componentChildren :: forall parent model action.
ComponentState parent model action -> ComponentIds
_componentApplyActions :: forall parent model action.
ComponentState parent model action
-> [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent model action.
ComponentState parent model action -> model -> IO ()
_componentScripts :: forall parent model action.
ComponentState parent model action -> [DOMRef]
_componentIsDirty :: forall parent model action.
ComponentState parent model action -> Bool
_componentSink :: forall parent model action.
ComponentState parent model action -> action -> IO ()
_componentVTree :: forall parent model action.
ComponentState parent model action -> IORef VTree
_componentDOMRef :: forall parent model action.
ComponentState parent model action -> DOMRef
_componentSubThreads :: forall parent model action.
ComponentState parent model action
-> IORef (Map MisoString ThreadId)
_componentParentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: DOMRef
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: ZonkAny 47
_componentIsDirty :: Bool
_componentScripts :: [DOMRef]
_componentEvents :: Events
_componentBindings :: [Binding (ZonkAny 49) (ZonkAny 47)]
_componentMailbox :: Value -> Maybe action
_componentDraw :: ZonkAny 47 -> IO ()
_componentModelDirty :: ZonkAny 47 -> ZonkAny 47 -> Bool
_componentApplyActions :: [action]
-> ZonkAny 47
-> IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action)
-> (IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action),
    ZonkAny 47, [Schedule action], ComponentIds)
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} = IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action)
vcomps IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action)
-> Int -> ComponentState (ZonkAny 49) (ZonkAny 47) action
forall a. IntMap a -> Int -> a
IM.! Int
vcompId
          case [action]
-> ZonkAny 47
-> IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action)
-> (IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action),
    ZonkAny 47, [Schedule action], ComponentIds)
_componentApplyActions [action]
events ZonkAny 47
_componentModel IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action)
vcomps of
            (IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action)
x, ZonkAny 47
updatedModel, [Schedule action]
schedules, ComponentIds
dirtySet) ->
              (IntMap (ComponentState (ZonkAny 49) (ZonkAny 47) action)
x, (ZonkAny 47
updatedModel, [Schedule action]
schedules, ComponentIds
dirtySet, ComponentState (ZonkAny 49) (ZonkAny 47) 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 43) (ZonkAny 44) (ZonkAny 45))
-> Maybe (ComponentState (ZonkAny 43) (ZonkAny 44) (ZonkAny 45))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap (ComponentState (ZonkAny 43) (ZonkAny 44) (ZonkAny 45))
 -> Maybe (ComponentState (ZonkAny 43) (ZonkAny 44) (ZonkAny 45)))
-> IO
     (IntMap (ComponentState (ZonkAny 43) (ZonkAny 44) (ZonkAny 45)))
-> IO
     (Maybe (ComponentState (ZonkAny 43) (ZonkAny 44) (ZonkAny 45)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IntMap (ComponentState (ZonkAny 43) (ZonkAny 44) (ZonkAny 45)))
-> IO
     (IntMap (ComponentState (ZonkAny 43) (ZonkAny 44) (ZonkAny 45)))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef
  (IntMap (ComponentState (ZonkAny 43) (ZonkAny 44) (ZonkAny 45)))
-> IO
     (IntMap (ComponentState (ZonkAny 43) (ZonkAny 44) (ZonkAny 45)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap (ComponentState (ZonkAny 43) (ZonkAny 44) (ZonkAny 45)))
forall parent model action.
IORef (IntMap (ComponentState parent model action))
components) IO (Maybe (ComponentState (ZonkAny 43) (ZonkAny 44) (ZonkAny 45)))
-> (Maybe (ComponentState (ZonkAny 43) (ZonkAny 44) (ZonkAny 45))
    -> 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 43) (ZonkAny 44) (ZonkAny 45) -> IO ())
-> Maybe (ComponentState (ZonkAny 43) (ZonkAny 44) (ZonkAny 45))
-> 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
[DOMRef]
[Binding (ZonkAny 43) (ZonkAny 44)]
ZonkAny 44
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
DOMRef
[ZonkAny 45]
-> ZonkAny 44
-> IntMap (ComponentState (ZonkAny 43) (ZonkAny 44) (ZonkAny 45))
-> (IntMap (ComponentState (ZonkAny 43) (ZonkAny 44) (ZonkAny 45)),
    ZonkAny 44, [Schedule (ZonkAny 45)], ComponentIds)
ZonkAny 44 -> IO ()
ZonkAny 44 -> ZonkAny 44 -> Bool
ZonkAny 45 -> IO ()
Value -> Maybe (ZonkAny 45)
_componentModel :: forall parent model action.
ComponentState parent model action -> model
_componentEvents :: forall parent model action.
ComponentState parent model action -> Events
_componentMailbox :: forall parent model action.
ComponentState parent model action -> Value -> Maybe action
_componentBindings :: forall parent model action.
ComponentState parent model action -> [Binding parent model]
_componentTopics :: forall parent model action.
ComponentState parent model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent model action.
ComponentState parent model action -> model -> model -> Bool
_componentChildren :: forall parent model action.
ComponentState parent model action -> ComponentIds
_componentApplyActions :: forall parent model action.
ComponentState parent model action
-> [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent model action.
ComponentState parent model action -> model -> IO ()
_componentScripts :: forall parent model action.
ComponentState parent model action -> [DOMRef]
_componentIsDirty :: forall parent model action.
ComponentState parent model action -> Bool
_componentSink :: forall parent model action.
ComponentState parent model action -> action -> IO ()
_componentVTree :: forall parent model action.
ComponentState parent model action -> IORef VTree
_componentDOMRef :: forall parent model action.
ComponentState parent model action -> DOMRef
_componentSubThreads :: forall parent model action.
ComponentState parent model action
-> IORef (Map MisoString ThreadId)
_componentParentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: DOMRef
_componentVTree :: IORef VTree
_componentSink :: ZonkAny 45 -> IO ()
_componentModel :: ZonkAny 44
_componentIsDirty :: Bool
_componentScripts :: [DOMRef]
_componentEvents :: Events
_componentBindings :: [Binding (ZonkAny 43) (ZonkAny 44)]
_componentMailbox :: Value -> Maybe (ZonkAny 45)
_componentDraw :: ZonkAny 44 -> IO ()
_componentModelDirty :: ZonkAny 44 -> ZonkAny 44 -> Bool
_componentApplyActions :: [ZonkAny 45]
-> ZonkAny 44
-> IntMap (ComponentState (ZonkAny 43) (ZonkAny 44) (ZonkAny 45))
-> (IntMap (ComponentState (ZonkAny 43) (ZonkAny 44) (ZonkAny 45)),
    ZonkAny 44, [Schedule (ZonkAny 45)], ComponentIds)
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
_componentIsDirty (ZonkAny 44 -> IO ()
_componentDraw ZonkAny 44
_componentModel)
          Int
-> State (ComponentState (ZonkAny 4) (ZonkAny 5) (ZonkAny 6)) ()
-> IO ()
forall parent model action a.
Int -> State (ComponentState parent model action) a -> IO ()
modifyComponent Int
_componentId (Lens (ComponentState (ZonkAny 4) (ZonkAny 5) (ZonkAny 6)) Bool
forall parent model action.
Lens (ComponentState parent model action) Bool
isDirty Lens (ComponentState (ZonkAny 4) (ZonkAny 5) (ZonkAny 6)) Bool
-> Bool
-> State (ComponentState (ZonkAny 4) (ZonkAny 5) (ZonkAny 6)) ()
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 model action) a
  -> IO ()
modifyComponent :: forall parent model action a.
Int -> State (ComponentState parent model action) a -> IO ()
modifyComponent Int
vcompId State (ComponentState parent 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
$ do
  IORef (IntMap (ComponentState parent model action))
-> (IntMap (ComponentState parent model action)
    -> (IntMap (ComponentState parent model action), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (IntMap (ComponentState parent model action))
forall parent model action.
IORef (IntMap (ComponentState parent model action))
components ((IntMap (ComponentState parent model action)
  -> (IntMap (ComponentState parent model action), ()))
 -> IO ())
-> (IntMap (ComponentState parent model action)
    -> (IntMap (ComponentState parent model action), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \IntMap (ComponentState parent model action)
vcomps ->
    case Int
-> IntMap (ComponentState parent model action)
-> Maybe (ComponentState parent model action)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId IntMap (ComponentState parent model action)
vcomps of
      Maybe (ComponentState parent model action)
Nothing ->
        (IntMap (ComponentState parent model action)
vcomps, ())
      Just ComponentState parent model action
vcomp ->
        (Int
-> ComponentState parent model action
-> IntMap (ComponentState parent model action)
-> IntMap (ComponentState parent model action)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
vcompId (State (ComponentState parent model action) a
-> ComponentState parent model action
-> ComponentState parent model action
forall s a. State s a -> s -> s
execState State (ComponentState parent model action) a
go ComponentState parent model action
vcomp) IntMap (ComponentState parent model action)
vcomps, ())
----------------------------------------------------------------------------
propagate
  :: ComponentId
  -> IntMap (ComponentState p m a)
  -> (IntMap (ComponentState p m a), ComponentIds)
propagate :: forall p m a.
Int
-> IntMap (ComponentState p m a)
-> (IntMap (ComponentState p m a), ComponentIds)
propagate Int
vcompId IntMap (ComponentState p m a)
vcomps =
  let dfsState :: DFS p m a
dfsState = State (DFS p m a) () -> DFS p m a -> DFS p m a
forall s a. State s a -> s -> s
execState State (DFS p m a) ()
forall p m a. Synch p m a ()
synch (IntMap (ComponentState p m a) -> Int -> DFS p m a
forall p m a. IntMap (ComponentState p m a) -> Int -> DFS p m a
dfs IntMap (ComponentState p m a)
vcomps Int
vcompId)
  in (DFS p m a -> IntMap (ComponentState p m a)
forall p m a. DFS p m a -> IntMap (ComponentState p m a)
_state DFS p m a
dfsState, DFS p m a -> ComponentIds
forall p m a. DFS p m a -> ComponentIds
_visited DFS p m a
dfsState)
-----------------------------------------------------------------------------
-- | Create an empty DFS state
dfs :: IntMap (ComponentState p m a) -> ComponentId -> DFS p m a
dfs :: forall p m a. IntMap (ComponentState p m a) -> Int -> DFS p m a
dfs IntMap (ComponentState p m a)
cs Int
vcompId = IntMap (ComponentState p m a) -> ComponentIds -> [Int] -> DFS p m a
forall p m a.
IntMap (ComponentState p m a) -> ComponentIds -> [Int] -> DFS p m a
DFS IntMap (ComponentState p 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 m a
  = DFS
  { forall p m a. DFS p m a -> IntMap (ComponentState p m a)
_state :: IntMap (ComponentState p m a)
    -- ^ global component state to alter
  , forall p m a. DFS p m a -> ComponentIds
_visited :: ComponentIds
    -- ^ visited set
  , forall p m a. DFS p m a -> [Int]
_stack :: [ComponentId]
    -- ^ neighbors queue
  }
-----------------------------------------------------------------------------
type Synch p m a x = State (DFS p m a) x
-----------------------------------------------------------------------------
visited :: Lens (DFS p m a) (ComponentIds)
visited :: forall p m a. Lens (DFS p m a) ComponentIds
visited = (DFS p m a -> ComponentIds)
-> (DFS p m a -> ComponentIds -> DFS p m a)
-> Lens (DFS p m a) ComponentIds
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens DFS p m a -> ComponentIds
forall p m a. DFS p m a -> ComponentIds
_visited ((DFS p m a -> ComponentIds -> DFS p m a)
 -> Lens (DFS p m a) ComponentIds)
-> (DFS p m a -> ComponentIds -> DFS p m a)
-> Lens (DFS p m a) ComponentIds
forall a b. (a -> b) -> a -> b
$ \DFS p m a
r ComponentIds
x -> DFS p m a
r { _visited = x }
-----------------------------------------------------------------------------
state :: Lens (DFS p m a) (IntMap (ComponentState p m a))
state :: forall p m a. Lens (DFS p m a) (IntMap (ComponentState p m a))
state = (DFS p m a -> IntMap (ComponentState p m a))
-> (DFS p m a -> IntMap (ComponentState p m a) -> DFS p m a)
-> Lens (DFS p m a) (IntMap (ComponentState p m a))
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens DFS p m a -> IntMap (ComponentState p m a)
forall p m a. DFS p m a -> IntMap (ComponentState p m a)
_state ((DFS p m a -> IntMap (ComponentState p m a) -> DFS p m a)
 -> Lens (DFS p m a) (IntMap (ComponentState p m a)))
-> (DFS p m a -> IntMap (ComponentState p m a) -> DFS p m a)
-> Lens (DFS p m a) (IntMap (ComponentState p m a))
forall a b. (a -> b) -> a -> b
$ \DFS p m a
r IntMap (ComponentState p m a)
x -> DFS p m a
r { _state = x }
-----------------------------------------------------------------------------
stack :: Lens (DFS p m a) [ComponentId]
stack :: forall p m a. Lens (DFS p m a) [Int]
stack = (DFS p m a -> [Int])
-> (DFS p m a -> [Int] -> DFS p m a) -> Lens (DFS p m a) [Int]
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens DFS p m a -> [Int]
forall p m a. DFS p m a -> [Int]
_stack ((DFS p m a -> [Int] -> DFS p m a) -> Lens (DFS p m a) [Int])
-> (DFS p m a -> [Int] -> DFS p m a) -> Lens (DFS p m a) [Int]
forall a b. (a -> b) -> a -> b
$ \DFS p m a
r [Int]
x -> DFS p m a
r { _stack = x }
-----------------------------------------------------------------------------
synch :: Synch p m a ()
synch :: forall p m a. Synch p m a ()
synch = (ComponentState p m a -> StateT (DFS p m a) Identity ())
-> Maybe (ComponentState p m a) -> StateT (DFS p m a) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ComponentState p m a -> StateT (DFS p m a) Identity ()
forall p m a. ComponentState p m a -> Synch p m a ()
go (Maybe (ComponentState p m a) -> StateT (DFS p m a) Identity ())
-> StateT (DFS p m a) Identity (Maybe (ComponentState p m a))
-> StateT (DFS p m a) Identity ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT (DFS p m a) Identity (Maybe (ComponentState p m a))
forall p m a. Synch p m a (Maybe (ComponentState p m a))
pop
  where
    go :: ComponentState p m a -> Synch p m a ()
    go :: forall p m a. ComponentState p m a -> Synch p m a ()
go ComponentState p m a
cs = do
      seen <- Int -> ComponentIds -> Bool
IS.member (ComponentState p m a
cs ComponentState p m a -> Lens (ComponentState p m a) Int -> Int
forall record field. record -> Lens record field -> field
^. Lens (ComponentState p m a) Int
forall parent model action.
Lens (ComponentState parent model action) Int
componentId) (ComponentIds -> Bool)
-> StateT (DFS p m a) Identity ComponentIds
-> StateT (DFS p m a) Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens (DFS p m a) ComponentIds
-> StateT (DFS p m a) Identity ComponentIds
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> m field
use Lens (DFS p m a) ComponentIds
forall p m a. Lens (DFS p m a) ComponentIds
visited
      when (not seen) $ do
        propagateParent cs (cs ^. parentId)
        propagateChildren cs (cs ^. children)
        markVisited (cs ^. componentId)
        synch
-----------------------------------------------------------------------------
propagateChildren
  :: forall p m a
   . ComponentState p m a
  -> ComponentIds
  -> Synch p m a ()
propagateChildren :: forall p m a.
ComponentState p m a -> ComponentIds -> Synch p m a ()
propagateChildren ComponentState p m a
currentState ComponentIds
childComponents = do
  [Int]
-> (Int -> StateT (DFS p m a) Identity ())
-> StateT (DFS p 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 m a) Identity ())
 -> StateT (DFS p m a) Identity ())
-> (Int -> StateT (DFS p m a) Identity ())
-> StateT (DFS p m a) Identity ()
forall a b. (a -> b) -> a -> b
$ \Int
childId -> do
    childState <- (IntMap (ZonkAny 26) -> ZonkAny 26)
-> IntMap (ComponentState p m a) -> ComponentState m m a
forall a b. a -> b
unsafeCoerce (IntMap (ZonkAny 26) -> Int -> ZonkAny 26
forall a. IntMap a -> Int -> a
IM.! Int
childId) (IntMap (ComponentState p m a) -> ComponentState m m a)
-> StateT (DFS p m a) Identity (IntMap (ComponentState p m a))
-> StateT (DFS p m a) Identity (ComponentState m m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens (DFS p m a) (IntMap (ComponentState p m a))
-> StateT (DFS p m a) Identity (IntMap (ComponentState p m a))
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> m field
use Lens (DFS p m a) (IntMap (ComponentState p m a))
forall p m a. Lens (DFS p m a) (IntMap (ComponentState p m a))
state
    updatedChild <- unsafeCoerce <$>
      foldM process childState (childState ^. componentBindings)
    let isChildDirty =
          (ComponentState m m a -> m -> m -> Bool
forall parent model action.
ComponentState parent model action -> model -> model -> Bool
_componentModelDirty ComponentState m m a
childState)
          (ComponentState m m a -> m
forall parent model action.
ComponentState parent model action -> model
_componentModel ComponentState m m a
childState)
          (ComponentState p m a -> m
forall parent model action.
ComponentState parent model action -> model
_componentModel ComponentState p m a
updatedChild)
    when isChildDirty $ do
      state.at childId ?= updatedChild { _componentIsDirty = True }
      visit childId
    where
      process
        :: ComponentState m child a
        -> Binding m child
        -> Synch p m a (ComponentState m child a)
      process :: forall child.
ComponentState m child a
-> Binding m child -> Synch p m a (ComponentState m child a)
process ComponentState m child a
childState = \case
        ParentToChild m -> field
getCurrentField field -> child -> child
setChildField -> do
          let currentChildModel :: child
currentChildModel = ComponentState m child a
childState ComponentState m child a
-> Lens (ComponentState m child a) child -> child
forall record field. record -> Lens record field -> field
^. Lens (ComponentState m child a) child
forall parent model action.
Lens (ComponentState parent model action) model
componentModel
              currentFieldValue :: field
currentFieldValue = m -> field
getCurrentField (ComponentState p m a
currentState ComponentState p m a -> Lens (ComponentState p m a) m -> m
forall record field. record -> Lens record field -> field
^. Lens (ComponentState p m a) m
forall parent model action.
Lens (ComponentState parent model action) model
componentModel)
              updatedChildModel :: child
updatedChildModel = field -> child -> child
setChildField field
currentFieldValue child
currentChildModel
          ComponentState m child a -> Synch p m a (ComponentState m child a)
forall a. a -> StateT (DFS p m a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentState m child a
childState ComponentState m child a
-> (ComponentState m child a -> ComponentState m child a)
-> ComponentState m child a
forall a b. a -> (a -> b) -> b
& Lens (ComponentState m child a) child
forall parent model action.
Lens (ComponentState parent model action) model
componentModel Lens (ComponentState m child a) child
-> child -> ComponentState m child a -> ComponentState m child a
forall record field. Lens record field -> field -> record -> record
.~ child
updatedChildModel)
        Bidirectional m -> field
getCurrentField field -> m -> m
_ child -> field
_ field -> child -> child
setChildField -> do
          let currentChildModel :: child
currentChildModel = ComponentState m child a -> child
forall parent model action.
ComponentState parent model action -> model
_componentModel ComponentState m child a
childState
              currentFieldValue :: field
currentFieldValue = m -> field
getCurrentField (ComponentState p m a
currentState ComponentState p m a -> Lens (ComponentState p m a) m -> m
forall record field. record -> Lens record field -> field
^. Lens (ComponentState p m a) m
forall parent model action.
Lens (ComponentState parent model action) model
componentModel)
              updatedChildModel :: child
updatedChildModel = field -> child -> child
setChildField field
currentFieldValue child
currentChildModel
          ComponentState m child a -> Synch p m a (ComponentState m child a)
forall a. a -> StateT (DFS p m a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentState m child a
childState ComponentState m child a
-> (ComponentState m child a -> ComponentState m child a)
-> ComponentState m child a
forall a b. a -> (a -> b) -> b
& Lens (ComponentState m child a) child
forall parent model action.
Lens (ComponentState parent model action) model
componentModel Lens (ComponentState m child a) child
-> child -> ComponentState m child a -> ComponentState m child a
forall record field. Lens record field -> field -> record -> record
.~ child
updatedChildModel)
        Binding m child
_ ->
          ComponentState m child a -> Synch p m a (ComponentState m child a)
forall a. a -> StateT (DFS p m a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ComponentState m child a
childState
-----------------------------------------------------------------------------
propagateParent
  :: forall p m a
   . ComponentState p m a
  -> ComponentId
  -> Synch p m a ()
propagateParent :: forall p m a. ComponentState p m a -> Int -> Synch p m a ()
propagateParent ComponentState p m a
currentState Int
parentId_ =
  Int
-> IntMap (ComponentState p m a) -> Maybe (ComponentState p m a)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
parentId_ (IntMap (ComponentState p m a) -> Maybe (ComponentState p m a))
-> StateT (DFS p m a) Identity (IntMap (ComponentState p m a))
-> StateT (DFS p m a) Identity (Maybe (ComponentState p m a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens (DFS p m a) (IntMap (ComponentState p m a))
-> StateT (DFS p m a) Identity (IntMap (ComponentState p m a))
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> m field
use Lens (DFS p m a) (IntMap (ComponentState p m a))
forall p m a. Lens (DFS p m a) (IntMap (ComponentState p m a))
state StateT (DFS p m a) Identity (Maybe (ComponentState p m a))
-> (Maybe (ComponentState p m a) -> StateT (DFS p m a) Identity ())
-> StateT (DFS p m a) Identity ()
forall a b.
StateT (DFS p m a) Identity a
-> (a -> StateT (DFS p m a) Identity b)
-> StateT (DFS p m a) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ComponentState p m a -> StateT (DFS p m a) Identity ())
-> Maybe (ComponentState p m a) -> StateT (DFS p m a) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ \case
    ComponentState p m a
parentState -> do
      updatedParent <- ComponentState (ZonkAny 27) p a -> ComponentState p m a
forall a b. a -> b
unsafeCoerce (ComponentState (ZonkAny 27) p a -> ComponentState p m a)
-> StateT (DFS p m a) Identity (ComponentState (ZonkAny 27) p a)
-> StateT (DFS p m a) Identity (ComponentState p m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (ComponentState (ZonkAny 27) p a
 -> Binding p m
 -> StateT (DFS p m a) Identity (ComponentState (ZonkAny 27) p a))
-> ComponentState (ZonkAny 27) p a
-> [Binding p m]
-> StateT (DFS p m a) Identity (ComponentState (ZonkAny 27) p a)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ComponentState (ZonkAny 27) p a
-> Binding p m
-> StateT (DFS p m a) Identity (ComponentState (ZonkAny 27) p a)
forall x.
ComponentState x p a
-> Binding p m -> Synch p m a (ComponentState x p a)
process (ComponentState p m a -> ComponentState (ZonkAny 27) p a
forall a b. a -> b
unsafeCoerce ComponentState p m a
parentState) (ComponentState p m a
currentState ComponentState p m a
-> Lens (ComponentState p m a) [Binding p m] -> [Binding p m]
forall record field. record -> Lens record field -> field
^. Lens (ComponentState p m a) [Binding p m]
forall p m a. Lens (ComponentState p m a) [Binding p m]
componentBindings)
      let isParentDirty =
            (ComponentState p m a -> m -> m -> Bool
forall parent model action.
ComponentState parent model action -> model -> model -> Bool
_componentModelDirty ComponentState p m a
parentState)
            (ComponentState p m a -> m
forall parent model action.
ComponentState parent model action -> model
_componentModel ComponentState p m a
parentState)
            (ComponentState p m a -> m
forall parent model action.
ComponentState parent model action -> model
_componentModel ComponentState p m a
updatedParent)
      when isParentDirty $ do
        state.at parentId_ ?= updatedParent { _componentIsDirty = True }
        visit parentId_
  where
    process
      :: ComponentState x p a
      -> Binding p m
      -> Synch p m a (ComponentState x p a)
    process :: forall x.
ComponentState x p a
-> Binding p m -> Synch p m a (ComponentState x p a)
process ComponentState x p a
parentState = \case
      ChildToParent field -> p -> p
setParentField m -> field
getCurrentField -> do
        let currentParentModel :: p
currentParentModel = ComponentState x p a
parentState ComponentState x p a -> Lens (ComponentState x p a) p -> p
forall record field. record -> Lens record field -> field
^. Lens (ComponentState x p a) p
forall parent model action.
Lens (ComponentState parent model action) model
componentModel
            currentFieldValue :: field
currentFieldValue = m -> field
getCurrentField (ComponentState p m a
currentState ComponentState p m a -> Lens (ComponentState p m a) m -> m
forall record field. record -> Lens record field -> field
^. Lens (ComponentState p m a) m
forall parent model action.
Lens (ComponentState parent model action) model
componentModel)
            updatedParentModel :: p
updatedParentModel = field -> p -> p
setParentField field
currentFieldValue p
currentParentModel
        ComponentState x p a -> Synch p m a (ComponentState x p a)
forall a. a -> StateT (DFS p m a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentState x p a
parentState ComponentState x p a
-> (ComponentState x p a -> ComponentState x p a)
-> ComponentState x p a
forall a b. a -> (a -> b) -> b
& Lens (ComponentState x p a) p
forall parent model action.
Lens (ComponentState parent model action) model
componentModel Lens (ComponentState x p a) p
-> p -> ComponentState x p a -> ComponentState x p a
forall record field. Lens record field -> field -> record -> record
.~ p
updatedParentModel)
      Bidirectional p -> field
_ field -> p -> p
setParentField m -> field
getCurrentField field -> m -> m
_ -> do
        let currentParentModel :: p
currentParentModel = ComponentState x p a
parentState ComponentState x p a -> Lens (ComponentState x p a) p -> p
forall record field. record -> Lens record field -> field
^. Lens (ComponentState x p a) p
forall parent model action.
Lens (ComponentState parent model action) model
componentModel
            currentFieldValue :: field
currentFieldValue = m -> field
getCurrentField (ComponentState p m a
currentState ComponentState p m a -> Lens (ComponentState p m a) m -> m
forall record field. record -> Lens record field -> field
^. Lens (ComponentState p m a) m
forall parent model action.
Lens (ComponentState parent model action) model
componentModel)
            updatedParentModel :: p
updatedParentModel = field -> p -> p
setParentField field
currentFieldValue p
currentParentModel
        ComponentState x p a -> Synch p m a (ComponentState x p a)
forall a. a -> StateT (DFS p m a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentState x p a
parentState ComponentState x p a
-> (ComponentState x p a -> ComponentState x p a)
-> ComponentState x p a
forall a b. a -> (a -> b) -> b
& Lens (ComponentState x p a) p
forall parent model action.
Lens (ComponentState parent model action) model
componentModel Lens (ComponentState x p a) p
-> p -> ComponentState x p a -> ComponentState x p a
forall record field. Lens record field -> field -> record -> record
.~ p
updatedParentModel)
      Binding p m
_ ->
        ComponentState x p a -> Synch p m a (ComponentState x p a)
forall a. a -> StateT (DFS p m a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ComponentState x p a
parentState
-----------------------------------------------------------------------------
markVisited :: ComponentId -> Synch p m a ()
markVisited :: forall p m a. Int -> Synch p m a ()
markVisited Int
vcompId = Lens (DFS p m a) ComponentIds
forall p m a. Lens (DFS p m a) ComponentIds
visitedLens (DFS p m a) ComponentIds
-> LensCore (Maybe ()) ComponentIds
-> LensCore (Maybe ()) (DFS p 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 m a)
-> () -> StateT (DFS p m a) Identity ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record (Maybe field) -> field -> m ()
?= ()
-----------------------------------------------------------------------------
visit :: ComponentId -> Synch p m a ()
visit :: forall p m a. Int -> Synch p m a ()
visit Int
vcompId = Lens (DFS p m a) [Int]
forall p m a. Lens (DFS p m a) [Int]
stack Lens (DFS p m a) [Int]
-> ([Int] -> [Int]) -> StateT (DFS p 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 m a (Maybe (ComponentState p m a))
pop :: forall p m a. Synch p m a (Maybe (ComponentState p m a))
pop = Lens (DFS p m a) [Int] -> StateT (DFS p m a) Identity [Int]
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> m field
use Lens (DFS p m a) [Int]
forall p m a. Lens (DFS p m a) [Int]
stack StateT (DFS p m a) Identity [Int]
-> ([Int]
    -> StateT (DFS p m a) Identity (Maybe (ComponentState p m a)))
-> StateT (DFS p m a) Identity (Maybe (ComponentState p m a))
forall a b.
StateT (DFS p m a) Identity a
-> (a -> StateT (DFS p m a) Identity b)
-> StateT (DFS p m a) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  [] -> 
    Maybe (ComponentState p m a)
-> StateT (DFS p m a) Identity (Maybe (ComponentState p m a))
forall a. a -> StateT (DFS p m a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ComponentState p m a)
forall a. Maybe a
Nothing
  Int
x : [Int]
xs -> do
    Lens (DFS p m a) [Int]
forall p m a. Lens (DFS p m a) [Int]
stack Lens (DFS p m a) [Int] -> [Int] -> StateT (DFS p m a) Identity ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> field -> m ()
.= [Int]
xs
    Lens (DFS p m a) (Maybe (ComponentState p m a))
-> StateT (DFS p m a) Identity (Maybe (ComponentState p m a))
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> m field
use (Lens (DFS p m a) (IntMap (ComponentState p m a))
forall p m a. Lens (DFS p m a) (IntMap (ComponentState p m a))
state Lens (DFS p m a) (IntMap (ComponentState p m a))
-> LensCore
     (Maybe (ComponentState p m a)) (IntMap (ComponentState p m a))
-> Lens (DFS p m a) (Maybe (ComponentState p 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 m a))
-> Lens
     (IntMap (ComponentState p m a))
     (Maybe (IxValue (IntMap (ComponentState p m a))))
forall at. At at => Index at -> Lens at (Maybe (IxValue at))
at Int
Index (IntMap (ComponentState p m a))
x)
-----------------------------------------------------------------------------
initialDraw
  :: Eq m
  => m
  -> Events
  -> Hydrate
  -> Bool
  -> Component p m a
  -> ComponentState p m a
  -> IO ()
initialDraw :: forall m p a.
Eq m =>
m
-> Events
-> Hydrate
-> Bool
-> Component p m a
-> ComponentState p 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
m -> View m a
a -> Effect p m a
Value -> Maybe a
unmount :: forall parent model action.
Component parent model action -> Maybe action
mount :: forall parent model action.
Component parent model action -> Maybe action
eventPropagation :: forall parent model action. Component parent model action -> Bool
bindings :: forall parent model action.
Component parent model action -> [Binding parent model]
mailbox :: forall parent model action.
Component parent model action -> Value -> Maybe action
logLevel :: forall parent model action.
Component parent model action -> LogLevel
mountPoint :: forall parent model action.
Component parent model action -> Maybe MisoString
scripts :: forall parent model action. Component parent model action -> [JS]
styles :: forall parent model action. Component parent model action -> [CSS]
subs :: forall parent model action.
Component parent model action -> [Sub action]
view :: forall parent model action.
Component parent model action -> model -> View model action
update :: forall parent model action.
Component parent model action
-> action -> Effect parent model action
hydrateModel :: forall parent model action.
Component parent model action -> Maybe (IO model)
model :: forall parent model action. Component parent model action -> model
model :: m
hydrateModel :: Maybe (IO m)
update :: a -> Effect p m a
view :: 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
Bool
Int
[DOMRef]
[Binding p m]
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
DOMRef
m -> IO ()
m -> m -> Bool
a -> IO ()
[a]
-> m
-> IntMap (ComponentState p m a)
-> (IntMap (ComponentState p m a), m, [Schedule a], ComponentIds)
Value -> Maybe a
_componentModel :: forall parent model action.
ComponentState parent model action -> model
_componentEvents :: forall parent model action.
ComponentState parent model action -> Events
_componentMailbox :: forall parent model action.
ComponentState parent model action -> Value -> Maybe action
_componentBindings :: forall parent model action.
ComponentState parent model action -> [Binding parent model]
_componentTopics :: forall parent model action.
ComponentState parent model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent model action.
ComponentState parent model action -> model -> model -> Bool
_componentChildren :: forall parent model action.
ComponentState parent model action -> ComponentIds
_componentApplyActions :: forall parent model action.
ComponentState parent model action
-> [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent model action.
ComponentState parent model action -> model -> IO ()
_componentScripts :: forall parent model action.
ComponentState parent model action -> [DOMRef]
_componentIsDirty :: forall parent model action.
ComponentState parent model action -> Bool
_componentSink :: forall parent model action.
ComponentState parent model action -> action -> IO ()
_componentVTree :: forall parent model action.
ComponentState parent model action -> IORef VTree
_componentDOMRef :: forall parent model action.
ComponentState parent model action -> DOMRef
_componentSubThreads :: forall parent model action.
ComponentState parent model action
-> IORef (Map MisoString ThreadId)
_componentParentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: DOMRef
_componentVTree :: IORef VTree
_componentSink :: a -> IO ()
_componentModel :: m
_componentIsDirty :: Bool
_componentScripts :: [DOMRef]
_componentEvents :: Events
_componentBindings :: [Binding p m]
_componentMailbox :: Value -> Maybe a
_componentDraw :: m -> IO ()
_componentModelDirty :: m -> m -> Bool
_componentApplyActions :: [a]
-> m
-> IntMap (ComponentState p m a)
-> (IntMap (ComponentState p 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 (m -> View m a
view 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 -> DOMRef -> IO ()
Diff.diff Maybe VTree
forall a. Maybe a
Nothing (VTree -> Maybe VTree
forall a. a -> Maybe a
Just VTree
vtree) DOMRef
_componentDOMRef
      IORef VTree -> VTree -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef VTree
_componentVTree VTree
vtree
    Hydrate
Hydrate -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isRoot (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        hydrated <- LogLevel -> DOMRef -> VTree -> IO Bool
Hydrate.hydrate LogLevel
logLevel DOMRef
_componentDOMRef VTree
vtree
        if hydrated
          then atomicWriteIORef _componentVTree vtree
          else do
            newTree <-
              buildVTree events _componentParentId _componentId Draw
                _componentSink logLevel (view initializedModel)
            Diff.diff Nothing (Just newTree) _componentDOMRef
            liftIO (atomicWriteIORef _componentVTree newTree)
-----------------------------------------------------------------------------
-- | 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)
-----------------------------------------------------------------------------
-- | 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 -> -- dmj: if unmount occurred, just pop the schedule
          (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
leftover)
        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 model action) ComponentId
componentId :: forall parent model action.
Lens (ComponentState parent model action) Int
componentId = (ComponentState parent model action -> Int)
-> (ComponentState parent model action
    -> Int -> ComponentState parent model action)
-> Lens (ComponentState parent model action) Int
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState parent model action -> Int
forall parent model action.
ComponentState parent model action -> Int
_componentId ((ComponentState parent model action
  -> Int -> ComponentState parent model action)
 -> Lens (ComponentState parent model action) Int)
-> (ComponentState parent model action
    -> Int -> ComponentState parent model action)
-> Lens (ComponentState parent model action) Int
forall a b. (a -> b) -> a -> b
$ \ComponentState parent model action
record Int
field -> ComponentState parent model action
record { _componentId = field }
-----------------------------------------------------------------------------
parentId :: Lens (ComponentState parent model action) ComponentId
parentId :: forall parent model action.
Lens (ComponentState parent model action) Int
parentId = (ComponentState parent model action -> Int)
-> (ComponentState parent model action
    -> Int -> ComponentState parent model action)
-> Lens (ComponentState parent model action) Int
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState parent model action -> Int
forall parent model action.
ComponentState parent model action -> Int
_componentParentId ((ComponentState parent model action
  -> Int -> ComponentState parent model action)
 -> Lens (ComponentState parent model action) Int)
-> (ComponentState parent model action
    -> Int -> ComponentState parent model action)
-> Lens (ComponentState parent model action) Int
forall a b. (a -> b) -> a -> b
$ \ComponentState parent model action
record Int
field -> ComponentState parent model action
record { _componentParentId = field }
-----------------------------------------------------------------------------
children :: Lens (ComponentState parent model action) (ComponentIds)
children :: forall parent model action.
Lens (ComponentState parent model action) ComponentIds
children = (ComponentState parent model action -> ComponentIds)
-> (ComponentState parent model action
    -> ComponentIds -> ComponentState parent model action)
-> Lens (ComponentState parent model action) ComponentIds
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState parent model action -> ComponentIds
forall parent model action.
ComponentState parent model action -> ComponentIds
_componentChildren ((ComponentState parent model action
  -> ComponentIds -> ComponentState parent model action)
 -> Lens (ComponentState parent model action) ComponentIds)
-> (ComponentState parent model action
    -> ComponentIds -> ComponentState parent model action)
-> Lens (ComponentState parent model action) ComponentIds
forall a b. (a -> b) -> a -> b
$ \ComponentState parent model action
record ComponentIds
field -> ComponentState parent model action
record { _componentChildren = field }
-----------------------------------------------------------------------------
componentTopics :: Lens (ComponentState parent model action) (Map MisoString (Value -> IO ()))
componentTopics :: forall parent model action.
Lens
  (ComponentState parent model action)
  (Map MisoString (Value -> IO ()))
componentTopics = (ComponentState parent model action
 -> Map MisoString (Value -> IO ()))
-> (ComponentState parent model action
    -> Map MisoString (Value -> IO ())
    -> ComponentState parent model action)
-> Lens
     (ComponentState parent model action)
     (Map MisoString (Value -> IO ()))
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState parent model action
-> Map MisoString (Value -> IO ())
forall parent model action.
ComponentState parent model action
-> Map MisoString (Value -> IO ())
_componentTopics ((ComponentState parent model action
  -> Map MisoString (Value -> IO ())
  -> ComponentState parent model action)
 -> Lens
      (ComponentState parent model action)
      (Map MisoString (Value -> IO ())))
-> (ComponentState parent model action
    -> Map MisoString (Value -> IO ())
    -> ComponentState parent model action)
-> Lens
     (ComponentState parent model action)
     (Map MisoString (Value -> IO ()))
forall a b. (a -> b) -> a -> b
$ \ComponentState parent model action
record Map MisoString (Value -> IO ())
field -> ComponentState parent model action
record { _componentTopics = field }
-----------------------------------------------------------------------------
isDirty :: Lens (ComponentState parent model action) Bool
isDirty :: forall parent model action.
Lens (ComponentState parent model action) Bool
isDirty = (ComponentState parent model action -> Bool)
-> (ComponentState parent model action
    -> Bool -> ComponentState parent model action)
-> Lens (ComponentState parent model action) Bool
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState parent model action -> Bool
forall parent model action.
ComponentState parent model action -> Bool
_componentIsDirty ((ComponentState parent model action
  -> Bool -> ComponentState parent model action)
 -> Lens (ComponentState parent model action) Bool)
-> (ComponentState parent model action
    -> Bool -> ComponentState parent model action)
-> Lens (ComponentState parent model action) Bool
forall a b. (a -> b) -> a -> b
$ \ComponentState parent model action
record Bool
field -> ComponentState parent model action
record { _componentIsDirty = field }
-----------------------------------------------------------------------------
componentModel :: Lens (ComponentState parent model action) model
componentModel :: forall parent model action.
Lens (ComponentState parent model action) model
componentModel = (ComponentState parent model action -> model)
-> (ComponentState parent model action
    -> model -> ComponentState parent model action)
-> Lens (ComponentState parent model action) model
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState parent model action -> model
forall parent model action.
ComponentState parent model action -> model
_componentModel ((ComponentState parent model action
  -> model -> ComponentState parent model action)
 -> Lens (ComponentState parent model action) model)
-> (ComponentState parent model action
    -> model -> ComponentState parent model action)
-> Lens (ComponentState parent model action) model
forall a b. (a -> b) -> a -> b
$ \ComponentState parent model action
record model
field -> ComponentState parent model action
record { _componentModel = field }
-----------------------------------------------------------------------------
componentBindings :: Lens (ComponentState p m a) [Binding p m]
componentBindings :: forall p m a. Lens (ComponentState p m a) [Binding p m]
componentBindings = (ComponentState p m a -> [Binding p m])
-> (ComponentState p m a -> [Binding p m] -> ComponentState p m a)
-> Lens (ComponentState p m a) [Binding p m]
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens ComponentState p m a -> [Binding p m]
forall parent model action.
ComponentState parent model action -> [Binding parent model]
_componentBindings ((ComponentState p m a -> [Binding p m] -> ComponentState p m a)
 -> Lens (ComponentState p m a) [Binding p m])
-> (ComponentState p m a -> [Binding p m] -> ComponentState p m a)
-> Lens (ComponentState p m a) [Binding p m]
forall a b. (a -> b) -> a -> b
$ \ComponentState p m a
record [Binding p m]
field -> ComponentState p m a
record { _componentBindings = 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 model action
  = ComponentState
  { forall parent model action.
ComponentState parent model action -> Int
_componentId :: ComponentId
  -- ^ The ID of the current t'Miso.Types.Component'
  , forall parent model action.
ComponentState parent model action -> Int
_componentParentId :: ComponentId
  -- ^ The ID of the t'Miso.Types.Component''s parent
  , forall parent model action.
ComponentState parent model action
-> IORef (Map MisoString ThreadId)
_componentSubThreads :: IORef (Map MisoString ThreadId)
  -- ^ Mapping of all 'Sub' in use by t'Miso.Types.Component'
  , forall parent model action.
ComponentState parent model action -> DOMRef
_componentDOMRef :: DOMRef
  -- ^ The DOM reference the t'Miso.Types.Component' is mounted on
  , forall parent model action.
ComponentState parent model action -> IORef VTree
_componentVTree :: IORef VTree
  -- ^ A reference to the current virtual DOM (i.e. t'VTree')
  , forall parent model action.
ComponentState parent model action -> action -> IO ()
_componentSink :: action -> IO ()
  -- ^ t'Miso.Types.Component' t'Sink' used to enter events into the system
  , forall parent model action.
ComponentState parent model action -> model
_componentModel :: model
  -- ^ t'Miso.Types.Component' state
  , forall parent model action.
ComponentState parent model action -> Bool
_componentIsDirty :: Bool
  -- ^ Indicator if t'Miso.Types.Component' needs to be drawn
  , forall parent model action.
ComponentState parent model action -> [DOMRef]
_componentScripts :: [DOMRef]
  -- ^ DOM references for \<script\> and \<style\> appended to \<head\>
  , forall parent model action.
ComponentState parent model action -> Events
_componentEvents :: Events
  -- ^ List of events a t'Miso.Types.Component' listens on
  , forall parent model action.
ComponentState parent model action -> [Binding parent model]
_componentBindings :: [Binding parent model]
  -- ^ Declarative bindings between t'Miso.Types.Component' 'model'.
  , forall parent model action.
ComponentState parent model action -> Value -> Maybe action
_componentMailbox :: Value -> Maybe action
  -- ^ Mailbox for asynchronous t'Miso.Types.Component' communication
  , forall parent model action.
ComponentState parent model action -> model -> IO ()
_componentDraw :: model -> IO ()
  -- ^ Helper function for t'Miso.Types.Component' rendering
  , forall parent model action.
ComponentState parent model action -> model -> model -> Bool
_componentModelDirty :: model -> model -> Bool
  -- ^ Model diffing
  , forall parent model action.
ComponentState parent model action
-> [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
_componentApplyActions
      :: [action]
      -> model
      -> IntMap (ComponentState parent model action)
      -> (IntMap (ComponentState parent model action), model, [Schedule action], ComponentIds)
  -- ^ t'Miso.Types.Component' actions application
  , forall parent model action.
ComponentState parent model action
-> Map MisoString (Value -> IO ())
_componentTopics :: Map MisoString (Value -> IO ())
  -- ^ t'Miso.Types.Component' topics using for Pub Sub async communication.
  , forall parent model action.
ComponentState parent model action -> ComponentIds
_componentChildren :: ComponentIds
  }
-----------------------------------------------------------------------------
-- | 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 model action
subscribe :: forall message action parent model.
FromJSON message =>
Topic message
-> (message -> action)
-> (MisoString -> action)
-> Effect parent model action
subscribe (Topic MisoString
topicName) message -> action
successful MisoString -> action
errorful = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink ->
    Int
-> State (ComponentState (ZonkAny 28) (ZonkAny 29) (ZonkAny 30)) ()
-> IO ()
forall parent model action a.
Int -> State (ComponentState parent model action) a -> IO ()
modifyComponent Int
_componentInfoId (State (ComponentState (ZonkAny 28) (ZonkAny 29) (ZonkAny 30)) ()
 -> IO ())
-> State (ComponentState (ZonkAny 28) (ZonkAny 29) (ZonkAny 30)) ()
-> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Lens
  (ComponentState (ZonkAny 28) (ZonkAny 29) (ZonkAny 30))
  (Map MisoString (Value -> IO ()))
forall parent model action.
Lens
  (ComponentState parent model action)
  (Map MisoString (Value -> IO ()))
componentTopics Lens
  (ComponentState (ZonkAny 28) (ZonkAny 29) (ZonkAny 30))
  (Map MisoString (Value -> IO ()))
-> (Map MisoString (Value -> IO ())
    -> Map MisoString (Value -> IO ()))
-> State (ComponentState (ZonkAny 28) (ZonkAny 29) (ZonkAny 30)) ()
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 model action
unsubscribe :: forall message parent model action.
Topic message -> Effect parent model action
unsubscribe (Topic MisoString
topicName) = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
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")
--     [ onMountedWith Mount
--     ]
--   , component_ (client_ "client 2")
--     [ onMountedWith Mount
--     ]
--   ] 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 23) (ZonkAny 24) (ZonkAny 25) -> IO ())
-> [ComponentState (ZonkAny 23) (ZonkAny 24) (ZonkAny 25)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ComponentState (ZonkAny 23) (ZonkAny 24) (ZonkAny 25) -> IO ()
forall (m :: * -> *) parent model action.
MonadIO m =>
ComponentState parent model action -> m ()
go ([ComponentState (ZonkAny 23) (ZonkAny 24) (ZonkAny 25)] -> IO ())
-> IO [ComponentState (ZonkAny 23) (ZonkAny 24) (ZonkAny 25)]
-> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IntMap (ComponentState (ZonkAny 23) (ZonkAny 24) (ZonkAny 25))
-> [ComponentState (ZonkAny 23) (ZonkAny 24) (ZonkAny 25)]
forall a. IntMap a -> [a]
IM.elems (IntMap (ComponentState (ZonkAny 23) (ZonkAny 24) (ZonkAny 25))
 -> [ComponentState (ZonkAny 23) (ZonkAny 24) (ZonkAny 25)])
-> IO
     (IntMap (ComponentState (ZonkAny 23) (ZonkAny 24) (ZonkAny 25)))
-> IO [ComponentState (ZonkAny 23) (ZonkAny 24) (ZonkAny 25)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap (ComponentState (ZonkAny 23) (ZonkAny 24) (ZonkAny 25)))
-> IO
     (IntMap (ComponentState (ZonkAny 23) (ZonkAny 24) (ZonkAny 25)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap (ComponentState (ZonkAny 23) (ZonkAny 24) (ZonkAny 25)))
forall parent model action.
IORef (IntMap (ComponentState parent model action))
components
  where
    go :: ComponentState parent model action -> f ()
go ComponentState {model
Bool
Int
[DOMRef]
[Binding parent model]
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
DOMRef
model -> IO ()
model -> model -> Bool
action -> IO ()
[action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
Value -> Maybe action
_componentModel :: forall parent model action.
ComponentState parent model action -> model
_componentEvents :: forall parent model action.
ComponentState parent model action -> Events
_componentMailbox :: forall parent model action.
ComponentState parent model action -> Value -> Maybe action
_componentBindings :: forall parent model action.
ComponentState parent model action -> [Binding parent model]
_componentTopics :: forall parent model action.
ComponentState parent model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent model action.
ComponentState parent model action -> model -> model -> Bool
_componentChildren :: forall parent model action.
ComponentState parent model action -> ComponentIds
_componentApplyActions :: forall parent model action.
ComponentState parent model action
-> [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent model action.
ComponentState parent model action -> model -> IO ()
_componentScripts :: forall parent model action.
ComponentState parent model action -> [DOMRef]
_componentIsDirty :: forall parent model action.
ComponentState parent model action -> Bool
_componentSink :: forall parent model action.
ComponentState parent model action -> action -> IO ()
_componentVTree :: forall parent model action.
ComponentState parent model action -> IORef VTree
_componentDOMRef :: forall parent model action.
ComponentState parent model action -> DOMRef
_componentSubThreads :: forall parent model action.
ComponentState parent model action
-> IORef (Map MisoString ThreadId)
_componentParentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: DOMRef
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentIsDirty :: Bool
_componentScripts :: [DOMRef]
_componentEvents :: Events
_componentBindings :: [Binding parent model]
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent 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 model action))
{-# NOINLINE components #-}
components :: forall parent model action.
IORef (IntMap (ComponentState parent model action))
components = IO (IORef (IntMap (ComponentState parent model action)))
-> IORef (IntMap (ComponentState parent model action))
forall a. IO a -> a
unsafePerformIO (IntMap (ComponentState parent model action)
-> IO (IORef (IntMap (ComponentState parent model action)))
forall a. a -> IO (IORef a)
newIORef IntMap (ComponentState parent 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 model action
  -> IO ()
drain :: forall parent model action.
ComponentState parent model action -> IO ()
drain ComponentState {model
Bool
Int
[DOMRef]
[Binding parent model]
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
DOMRef
model -> IO ()
model -> model -> Bool
action -> IO ()
[action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
Value -> Maybe action
_componentModel :: forall parent model action.
ComponentState parent model action -> model
_componentEvents :: forall parent model action.
ComponentState parent model action -> Events
_componentMailbox :: forall parent model action.
ComponentState parent model action -> Value -> Maybe action
_componentBindings :: forall parent model action.
ComponentState parent model action -> [Binding parent model]
_componentTopics :: forall parent model action.
ComponentState parent model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent model action.
ComponentState parent model action -> model -> model -> Bool
_componentChildren :: forall parent model action.
ComponentState parent model action -> ComponentIds
_componentApplyActions :: forall parent model action.
ComponentState parent model action
-> [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent model action.
ComponentState parent model action -> model -> IO ()
_componentScripts :: forall parent model action.
ComponentState parent model action -> [DOMRef]
_componentIsDirty :: forall parent model action.
ComponentState parent model action -> Bool
_componentSink :: forall parent model action.
ComponentState parent model action -> action -> IO ()
_componentVTree :: forall parent model action.
ComponentState parent model action -> IORef VTree
_componentDOMRef :: forall parent model action.
ComponentState parent model action -> DOMRef
_componentSubThreads :: forall parent model action.
ComponentState parent model action
-> IORef (Map MisoString ThreadId)
_componentParentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: DOMRef
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentIsDirty :: Bool
_componentScripts :: [DOMRef]
_componentEvents :: Events
_componentBindings :: [Binding parent model]
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent 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 model action))
-> IO (IntMap (ComponentState parent model action))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState parent model action))
forall parent model action.
IORef (IntMap (ComponentState parent model action))
components
       case _componentApplyActions actions _componentModel vcomps of
         (IntMap (ComponentState parent 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
             -- 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 model action))
-> IntMap (ComponentState parent model action) -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef (IntMap (ComponentState parent model action))
forall parent model action.
IORef (IntMap (ComponentState parent model action))
components IntMap (ComponentState parent model action)
newVComps
-----------------------------------------------------------------------------
-- | Post unmount call to drop the <style> and <script> in <head>
unloadScripts :: ComponentState parent model action -> IO ()
unloadScripts :: forall parent model action.
ComponentState parent model action -> IO ()
unloadScripts ComponentState {model
Bool
Int
[DOMRef]
[Binding parent model]
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
DOMRef
model -> IO ()
model -> model -> Bool
action -> IO ()
[action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
Value -> Maybe action
_componentModel :: forall parent model action.
ComponentState parent model action -> model
_componentEvents :: forall parent model action.
ComponentState parent model action -> Events
_componentMailbox :: forall parent model action.
ComponentState parent model action -> Value -> Maybe action
_componentBindings :: forall parent model action.
ComponentState parent model action -> [Binding parent model]
_componentTopics :: forall parent model action.
ComponentState parent model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent model action.
ComponentState parent model action -> model -> model -> Bool
_componentChildren :: forall parent model action.
ComponentState parent model action -> ComponentIds
_componentApplyActions :: forall parent model action.
ComponentState parent model action
-> [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent model action.
ComponentState parent model action -> model -> IO ()
_componentScripts :: forall parent model action.
ComponentState parent model action -> [DOMRef]
_componentIsDirty :: forall parent model action.
ComponentState parent model action -> Bool
_componentSink :: forall parent model action.
ComponentState parent model action -> action -> IO ()
_componentVTree :: forall parent model action.
ComponentState parent model action -> IORef VTree
_componentDOMRef :: forall parent model action.
ComponentState parent model action -> DOMRef
_componentSubThreads :: forall parent model action.
ComponentState parent model action
-> IORef (Map MisoString ThreadId)
_componentParentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: DOMRef
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentIsDirty :: Bool
_componentScripts :: [DOMRef]
_componentEvents :: Events
_componentBindings :: [Binding parent model]
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} = do
  head_ <- IO DOMRef
FFI.getHead
  forM_ _componentScripts (FFI.removeChild head_)
-----------------------------------------------------------------------------
-- | Helper to drop all lifecycle and mounting hooks if defined.
freeLifecycleHooks :: ComponentState parent model action -> IO ()
freeLifecycleHooks :: forall parent model action.
ComponentState parent model action -> IO ()
freeLifecycleHooks ComponentState {model
Bool
Int
[DOMRef]
[Binding parent model]
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
DOMRef
model -> IO ()
model -> model -> Bool
action -> IO ()
[action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
Value -> Maybe action
_componentModel :: forall parent model action.
ComponentState parent model action -> model
_componentEvents :: forall parent model action.
ComponentState parent model action -> Events
_componentMailbox :: forall parent model action.
ComponentState parent model action -> Value -> Maybe action
_componentBindings :: forall parent model action.
ComponentState parent model action -> [Binding parent model]
_componentTopics :: forall parent model action.
ComponentState parent model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent model action.
ComponentState parent model action -> model -> model -> Bool
_componentChildren :: forall parent model action.
ComponentState parent model action -> ComponentIds
_componentApplyActions :: forall parent model action.
ComponentState parent model action
-> [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent model action.
ComponentState parent model action -> model -> IO ()
_componentScripts :: forall parent model action.
ComponentState parent model action -> [DOMRef]
_componentIsDirty :: forall parent model action.
ComponentState parent model action -> Bool
_componentSink :: forall parent model action.
ComponentState parent model action -> action -> IO ()
_componentVTree :: forall parent model action.
ComponentState parent model action -> IORef VTree
_componentDOMRef :: forall parent model action.
ComponentState parent model action -> DOMRef
_componentSubThreads :: forall parent model action.
ComponentState parent model action
-> IORef (Map MisoString ThreadId)
_componentParentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: DOMRef
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentIsDirty :: Bool
_componentScripts :: [DOMRef]
_componentEvents :: Events
_componentBindings :: [Binding parent model]
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} = do
  VTree (Object vcomp) <- 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 =<< vcomp ! ("mount" :: MisoString)
  mapM_ freeFunction =<< fromJSVal =<< vcomp ! ("unmount" :: MisoString)
-----------------------------------------------------------------------------
-- | Helper function for cleanly destroying a t'Miso.Types.Component'
unmountComponent
  :: ComponentState parent model action
  -> IO ()
unmountComponent :: forall parent model action.
ComponentState parent model action -> IO ()
unmountComponent cs :: ComponentState parent model action
cs@ComponentState {model
Bool
Int
[DOMRef]
[Binding parent model]
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
DOMRef
model -> IO ()
model -> model -> Bool
action -> IO ()
[action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
Value -> Maybe action
_componentModel :: forall parent model action.
ComponentState parent model action -> model
_componentEvents :: forall parent model action.
ComponentState parent model action -> Events
_componentMailbox :: forall parent model action.
ComponentState parent model action -> Value -> Maybe action
_componentBindings :: forall parent model action.
ComponentState parent model action -> [Binding parent model]
_componentTopics :: forall parent model action.
ComponentState parent model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent model action.
ComponentState parent model action -> model -> model -> Bool
_componentChildren :: forall parent model action.
ComponentState parent model action -> ComponentIds
_componentApplyActions :: forall parent model action.
ComponentState parent model action
-> [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent model action.
ComponentState parent model action -> model -> IO ()
_componentScripts :: forall parent model action.
ComponentState parent model action -> [DOMRef]
_componentIsDirty :: forall parent model action.
ComponentState parent model action -> Bool
_componentSink :: forall parent model action.
ComponentState parent model action -> action -> IO ()
_componentVTree :: forall parent model action.
ComponentState parent model action -> IORef VTree
_componentDOMRef :: forall parent model action.
ComponentState parent model action -> DOMRef
_componentSubThreads :: forall parent model action.
ComponentState parent model action
-> IORef (Map MisoString ThreadId)
_componentParentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: DOMRef
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentIsDirty :: Bool
_componentScripts :: [DOMRef]
_componentEvents :: Events
_componentBindings :: [Binding parent model]
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent 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 model action -> IO ()
forall parent model action.
ComponentState parent model action -> IO ()
drain ComponentState parent model action
cs
  Int -> IO ()
finalizeWebSockets Int
_componentId
  Int -> IO ()
finalizeEventSources Int
_componentId
  ComponentState parent model action -> IO ()
forall parent model action.
ComponentState parent model action -> IO ()
unloadScripts ComponentState parent model action
cs
  ComponentState parent model action -> IO ()
forall parent model action.
ComponentState parent model action -> IO ()
freeLifecycleHooks ComponentState parent 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
$ Int
-> State (ComponentState (ZonkAny 34) (ZonkAny 35) (ZonkAny 36)) ()
-> IO ()
forall parent model action a.
Int -> State (ComponentState parent model action) a -> IO ()
modifyComponent Int
_componentParentId (State (ComponentState (ZonkAny 34) (ZonkAny 35) (ZonkAny 36)) ()
 -> IO ())
-> State (ComponentState (ZonkAny 34) (ZonkAny 35) (ZonkAny 36)) ()
-> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Lens
  (ComponentState (ZonkAny 34) (ZonkAny 35) (ZonkAny 36))
  ComponentIds
forall parent model action.
Lens (ComponentState parent model action) ComponentIds
childrenLens
  (ComponentState (ZonkAny 34) (ZonkAny 35) (ZonkAny 36))
  ComponentIds
-> LensCore (Maybe ()) ComponentIds
-> LensCore
     (Maybe ()) (ComponentState (ZonkAny 34) (ZonkAny 35) (ZonkAny 36))
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 34) (ZonkAny 35) (ZonkAny 36))
-> Maybe ()
-> State (ComponentState (ZonkAny 34) (ZonkAny 35) (ZonkAny 36)) ()
forall record (m :: * -> *) field.
MonadState record m =>
Lens record field -> field -> m ()
.= Maybe ()
forall a. Maybe a
Nothing
  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 (ZonkAny 37) (ZonkAny 38) (ZonkAny 39)))
-> (IntMap (ComponentState (ZonkAny 37) (ZonkAny 38) (ZonkAny 39))
    -> (IntMap (ComponentState (ZonkAny 37) (ZonkAny 38) (ZonkAny 39)),
        ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef
  (IntMap (ComponentState (ZonkAny 37) (ZonkAny 38) (ZonkAny 39)))
forall parent model action.
IORef (IntMap (ComponentState parent model action))
components ((IntMap (ComponentState (ZonkAny 37) (ZonkAny 38) (ZonkAny 39))
  -> (IntMap (ComponentState (ZonkAny 37) (ZonkAny 38) (ZonkAny 39)),
      ()))
 -> IO ())
-> (IntMap (ComponentState (ZonkAny 37) (ZonkAny 38) (ZonkAny 39))
    -> (IntMap (ComponentState (ZonkAny 37) (ZonkAny 38) (ZonkAny 39)),
        ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \IntMap (ComponentState (ZonkAny 37) (ZonkAny 38) (ZonkAny 39))
m -> (Int
-> IntMap (ComponentState (ZonkAny 37) (ZonkAny 38) (ZonkAny 39))
-> IntMap (ComponentState (ZonkAny 37) (ZonkAny 38) (ZonkAny 39))
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
_componentId IntMap (ComponentState (ZonkAny 37) (ZonkAny 38) (ZonkAny 39))
m, ())
-----------------------------------------------------------------------------
resetComponentState :: IO () -> IO ()
resetComponentState :: IO () -> IO ()
resetComponentState IO ()
clear = do
  cs <- IORef (IntMap (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2)))
-> (IntMap (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2))
    -> (IntMap (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2)),
        IntMap (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2))))
-> IO (IntMap (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2)))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (IntMap (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2)))
forall parent model action.
IORef (IntMap (ComponentState parent model action))
components ((IntMap (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2))
  -> (IntMap (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2)),
      IntMap (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2))))
 -> IO
      (IntMap (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2))))
-> (IntMap (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2))
    -> (IntMap (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2)),
        IntMap (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2))))
-> IO (IntMap (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2)))
forall a b. (a -> b) -> a -> b
$ \IntMap (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2))
vcomps -> (IntMap (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2))
forall a. Monoid a => a
mempty, IntMap (ComponentState (ZonkAny 0) (ZonkAny 1) (ZonkAny 2))
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 [Attribute action]
attrs (SomeComponent Component model model action
app) -> do
    vcomp <- IO Object
create

    mountCallback <- do
      if hydrate == Hydrate
        then
          toJSVal jsNull
        else
          syncCallback1' $ \DOMRef
parent_ -> do
            ComponentState {..} <- Events
-> Int
-> Hydrate
-> Bool
-> Component model model action
-> IO DOMRef
-> IO (ComponentState model model action)
forall parent model action.
(Eq parent, Eq model) =>
Events
-> Int
-> Hydrate
-> Bool
-> Component parent model action
-> IO DOMRef
-> IO (ComponentState parent model action)
initialize Events
events_ Int
vcompId Hydrate
Draw Bool
False Component model model action
app (DOMRef -> IO DOMRef
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DOMRef
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 $ \DOMRef
vcompId_ -> do
        componentId_ <- DOMRef -> IO Int
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked DOMRef
vcompId_
        IM.lookup componentId_ <$> readIORef components >>= \case
          Maybe (ComponentState (ZonkAny 54) (ZonkAny 55) action)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just ComponentState (ZonkAny 54) (ZonkAny 55) 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 model action -> Maybe action
forall parent model action.
Component parent model action -> Maybe action
unmount Component model model action
app) (ComponentState (ZonkAny 54) (ZonkAny 55) action -> action -> IO ()
forall parent model action.
ComponentState parent model action -> action -> IO ()
_componentSink ComponentState (ZonkAny 54) (ZonkAny 55) action
componentState)
            ComponentState (ZonkAny 54) (ZonkAny 55) action -> IO ()
forall parent model action.
ComponentState parent model action -> IO ()
unmountComponent ComponentState (ZonkAny 54) (ZonkAny 55) action
componentState

    case hydrate of
      Hydrate
Hydrate -> do
        -- Mock .domRef for use during hydration
        domRef <- Object -> IO DOMRef
forall a. ToJSVal a => a -> IO DOMRef
toJSVal (Object -> IO DOMRef) -> IO Object -> IO DOMRef
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Object
create
        ComponentState {..} <- initialize events_ vcompId hydrate False app (pure domRef)
        vtree <- toJSVal =<< liftIO (readIORef _componentVTree)
        FFI.set "parent" vcomp (Object vtree)
        vcompId_ <- toJSVal _componentId
        FFI.set "componentId" vcompId_ vcomp
        FFI.set "child" vtree vcomp
      Hydrate
Draw -> do
        MisoString -> DOMRef -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"child" DOMRef
jsNull Object
vcomp

    setAttrs vcomp attrs snk (logLevel app) events_
    when (hydrate == Draw) (FFI.set "mount" mountCallback vcomp)
    FFI.set "unmount" unmountCallback vcomp
    FFI.set "eventPropagation" (eventPropagation app) vcomp
    flip (FFI.set "type") vcomp =<< toJSVal VCompType
    pure (VTree vcomp)
  VNode NS
ns MisoString
tag [Attribute action]
attrs [View model action]
kids -> do
    vnode <- MisoString -> NS -> MisoString -> IO Object
createNode MisoString
"vnode" NS
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 <- [View model action]
-> (View model action -> IO Object) -> IO [Object]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [View model action]
kids ((View model action -> IO Object) -> IO [Object])
-> (View model action -> IO Object) -> IO [Object]
forall a b. (a -> b) -> a -> b
$ \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
          setNextSibling kidsViews
          pure kidsViews
            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)
  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)
-----------------------------------------------------------------------------
-- | @createNode@
-- A helper function for constructing a vtree (used for @vcomp@ and @vnode@)
-- Doesn't handle children
createNode :: MisoString -> NS -> MisoString -> IO Object
createNode :: MisoString -> NS -> MisoString -> IO Object
createNode MisoString
typ NS
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 DOMRef
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 DOMRef
forall a. ToJSVal a => a -> IO DOMRef
toJSVal Value
v
      FFI.set "key" value vnode
    ClassList [MisoString]
classes ->
      DOMRef -> [MisoString] -> IO ()
FFI.populateClass DOMRef
jval [MisoString]
classes
    Property MisoString
k Value
v -> do
      value <- Value -> IO DOMRef
forall a. ToJSVal a => a -> IO DOMRef
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 DOMRef
forall o. ToObject o => MisoString -> o -> IO DOMRef
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 (DOMRef -> Object
Object DOMRef
cssObj)
-----------------------------------------------------------------------------
-- | Registers components in the global state
registerComponent :: MonadIO m => ComponentState parent model action -> m ()
registerComponent :: forall (m :: * -> *) parent model action.
MonadIO m =>
ComponentState parent model action -> m ()
registerComponent ComponentState parent 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 model action))
-> (IntMap (ComponentState parent model action)
    -> (IntMap (ComponentState parent model action), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (IntMap (ComponentState parent model action))
forall parent model action.
IORef (IntMap (ComponentState parent model action))
components ((IntMap (ComponentState parent model action)
  -> (IntMap (ComponentState parent model action), ()))
 -> IO ())
-> (IntMap (ComponentState parent model action)
    -> (IntMap (ComponentState parent model action), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \IntMap (ComponentState parent model action)
cs ->
    (Int
-> ComponentState parent model action
-> IntMap (ComponentState parent model action)
-> IntMap (ComponentState parent model action)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (ComponentState parent model action -> Int
forall parent model action.
ComponentState parent model action -> Int
_componentId ComponentState parent model action
componentState) ComponentState parent model action
componentState IntMap (ComponentState parent model action)
cs, ())
-----------------------------------------------------------------------------
-- | Renders styles
--
-- Meant for development purposes
-- Appends CSS to <head>
--
renderStyles :: [CSS] -> IO [DOMRef]
renderStyles :: [CSS] -> IO [DOMRef]
renderStyles [CSS]
styles =
  [CSS] -> (CSS -> IO DOMRef) -> IO [DOMRef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CSS]
styles ((CSS -> IO DOMRef) -> IO [DOMRef])
-> (CSS -> IO DOMRef) -> IO [DOMRef]
forall a b. (a -> b) -> a -> b
$ \case
    Href MisoString
url -> MisoString -> IO DOMRef
FFI.addStyleSheet MisoString
url
    Style MisoString
css -> MisoString -> IO DOMRef
FFI.addStyle MisoString
css
    Sheet StyleSheet
sheet -> MisoString -> IO DOMRef
FFI.addStyle (StyleSheet -> MisoString
renderStyleSheet StyleSheet
sheet)
-----------------------------------------------------------------------------
-- | Renders scripts
--
-- Meant for development purposes
-- Appends JS to <head>
--
renderScripts :: [JS] -> IO [DOMRef]
renderScripts :: [JS] -> IO [DOMRef]
renderScripts [JS]
scripts =
  [JS] -> (JS -> IO DOMRef) -> IO [DOMRef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [JS]
scripts ((JS -> IO DOMRef) -> IO [DOMRef])
-> (JS -> IO DOMRef) -> IO [DOMRef]
forall a b. (a -> b) -> a -> b
$ \case
    Src MisoString
src ->
      MisoString -> IO DOMRef
FFI.addSrc MisoString
src
    Script MisoString
script ->
      Bool -> MisoString -> IO DOMRef
FFI.addScript Bool
False MisoString
script
    Module MisoString
src ->
      Bool -> MisoString -> IO DOMRef
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
  -> Sub action
  -> Effect parent model action
startSub :: forall subKey action parent model.
ToMisoString subKey =>
subKey -> Sub action -> Effect parent model action
startSub subKey
subKey Sub action
sub = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    IM.lookup _componentInfoId <$> liftIO (readIORef components) >>= \case
      Maybe (ComponentState (ZonkAny 7) (ZonkAny 8) action)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just compState :: ComponentState (ZonkAny 7) (ZonkAny 8) action
compState@ComponentState {Bool
Int
[DOMRef]
[Binding (ZonkAny 7) (ZonkAny 8)]
ZonkAny 8
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
DOMRef
action -> IO ()
[action]
-> ZonkAny 8
-> IntMap (ComponentState (ZonkAny 7) (ZonkAny 8) action)
-> (IntMap (ComponentState (ZonkAny 7) (ZonkAny 8) action),
    ZonkAny 8, [Schedule action], ComponentIds)
ZonkAny 8 -> IO ()
ZonkAny 8 -> ZonkAny 8 -> Bool
Value -> Maybe action
_componentModel :: forall parent model action.
ComponentState parent model action -> model
_componentEvents :: forall parent model action.
ComponentState parent model action -> Events
_componentMailbox :: forall parent model action.
ComponentState parent model action -> Value -> Maybe action
_componentBindings :: forall parent model action.
ComponentState parent model action -> [Binding parent model]
_componentTopics :: forall parent model action.
ComponentState parent model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent model action.
ComponentState parent model action -> model -> model -> Bool
_componentChildren :: forall parent model action.
ComponentState parent model action -> ComponentIds
_componentApplyActions :: forall parent model action.
ComponentState parent model action
-> [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent model action.
ComponentState parent model action -> model -> IO ()
_componentScripts :: forall parent model action.
ComponentState parent model action -> [DOMRef]
_componentIsDirty :: forall parent model action.
ComponentState parent model action -> Bool
_componentSink :: forall parent model action.
ComponentState parent model action -> action -> IO ()
_componentVTree :: forall parent model action.
ComponentState parent model action -> IORef VTree
_componentDOMRef :: forall parent model action.
ComponentState parent model action -> DOMRef
_componentSubThreads :: forall parent model action.
ComponentState parent model action
-> IORef (Map MisoString ThreadId)
_componentParentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: DOMRef
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: ZonkAny 8
_componentIsDirty :: Bool
_componentScripts :: [DOMRef]
_componentEvents :: Events
_componentBindings :: [Binding (ZonkAny 7) (ZonkAny 8)]
_componentMailbox :: Value -> Maybe action
_componentDraw :: ZonkAny 8 -> IO ()
_componentModelDirty :: ZonkAny 8 -> ZonkAny 8 -> Bool
_componentApplyActions :: [action]
-> ZonkAny 8
-> IntMap (ComponentState (ZonkAny 7) (ZonkAny 8) action)
-> (IntMap (ComponentState (ZonkAny 7) (ZonkAny 8) action),
    ZonkAny 8, [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 7) (ZonkAny 8) action -> IO ()
forall {parent} {model}.
ComponentState parent model action -> IO ()
startThread ComponentState (ZonkAny 7) (ZonkAny 8) action
compState
          Just ThreadId
tid -> do
            status <- ThreadId -> IO ThreadStatus
threadStatus ThreadId
tid
            case status of
              ThreadStatus
ThreadFinished -> ComponentState (ZonkAny 7) (ZonkAny 8) action -> IO ()
forall {parent} {model}.
ComponentState parent model action -> IO ()
startThread ComponentState (ZonkAny 7) (ZonkAny 8) action
compState
              ThreadStatus
ThreadDied -> ComponentState (ZonkAny 7) (ZonkAny 8) action -> IO ()
forall {parent} {model}.
ComponentState parent model action -> IO ()
startThread ComponentState (ZonkAny 7) (ZonkAny 8) action
compState
              ThreadStatus
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    startThread :: ComponentState parent model action -> IO ()
startThread ComponentState {model
Bool
Int
[DOMRef]
[Binding parent model]
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
DOMRef
action -> IO ()
model -> IO ()
model -> model -> Bool
[action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
Value -> Maybe action
_componentModel :: forall parent model action.
ComponentState parent model action -> model
_componentEvents :: forall parent model action.
ComponentState parent model action -> Events
_componentMailbox :: forall parent model action.
ComponentState parent model action -> Value -> Maybe action
_componentBindings :: forall parent model action.
ComponentState parent model action -> [Binding parent model]
_componentTopics :: forall parent model action.
ComponentState parent model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent model action.
ComponentState parent model action -> model -> model -> Bool
_componentChildren :: forall parent model action.
ComponentState parent model action -> ComponentIds
_componentApplyActions :: forall parent model action.
ComponentState parent model action
-> [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent model action.
ComponentState parent model action -> model -> IO ()
_componentScripts :: forall parent model action.
ComponentState parent model action -> [DOMRef]
_componentIsDirty :: forall parent model action.
ComponentState parent model action -> Bool
_componentSink :: forall parent model action.
ComponentState parent model action -> action -> IO ()
_componentVTree :: forall parent model action.
ComponentState parent model action -> IORef VTree
_componentDOMRef :: forall parent model action.
ComponentState parent model action -> DOMRef
_componentSubThreads :: forall parent model action.
ComponentState parent model action
-> IORef (Map MisoString ThreadId)
_componentParentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: DOMRef
_componentVTree :: IORef VTree
_componentSink :: action -> IO ()
_componentModel :: model
_componentIsDirty :: Bool
_componentScripts :: [DOMRef]
_componentEvents :: Events
_componentBindings :: [Binding parent model]
_componentMailbox :: Value -> Maybe action
_componentDraw :: model -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent 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 -> Effect parent model action
stopSub :: forall subKey parent model action.
ToMisoString subKey =>
subKey -> Effect parent model action
stopSub subKey
subKey = do
  vcompId <- (ComponentInfo parent -> Int)
-> RWST (ComponentInfo parent) [Schedule action] model Identity Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ComponentInfo parent -> Int
forall parent. ComponentInfo parent -> Int
_componentInfoId
  io_ $ do
    IM.lookup vcompId <$> readIORef components >>= \case
      Maybe (ComponentState (ZonkAny 9) (ZonkAny 10) (ZonkAny 11))
Nothing -> do
        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just ComponentState {Bool
Int
[DOMRef]
[Binding (ZonkAny 9) (ZonkAny 10)]
ZonkAny 10
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
DOMRef
[ZonkAny 11]
-> ZonkAny 10
-> IntMap (ComponentState (ZonkAny 9) (ZonkAny 10) (ZonkAny 11))
-> (IntMap (ComponentState (ZonkAny 9) (ZonkAny 10) (ZonkAny 11)),
    ZonkAny 10, [Schedule (ZonkAny 11)], ComponentIds)
ZonkAny 10 -> IO ()
ZonkAny 10 -> ZonkAny 10 -> Bool
ZonkAny 11 -> IO ()
Value -> Maybe (ZonkAny 11)
_componentModel :: forall parent model action.
ComponentState parent model action -> model
_componentEvents :: forall parent model action.
ComponentState parent model action -> Events
_componentMailbox :: forall parent model action.
ComponentState parent model action -> Value -> Maybe action
_componentBindings :: forall parent model action.
ComponentState parent model action -> [Binding parent model]
_componentTopics :: forall parent model action.
ComponentState parent model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent model action.
ComponentState parent model action -> model -> model -> Bool
_componentChildren :: forall parent model action.
ComponentState parent model action -> ComponentIds
_componentApplyActions :: forall parent model action.
ComponentState parent model action
-> [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent model action.
ComponentState parent model action -> model -> IO ()
_componentScripts :: forall parent model action.
ComponentState parent model action -> [DOMRef]
_componentIsDirty :: forall parent model action.
ComponentState parent model action -> Bool
_componentSink :: forall parent model action.
ComponentState parent model action -> action -> IO ()
_componentVTree :: forall parent model action.
ComponentState parent model action -> IORef VTree
_componentDOMRef :: forall parent model action.
ComponentState parent model action -> DOMRef
_componentSubThreads :: forall parent model action.
ComponentState parent model action
-> IORef (Map MisoString ThreadId)
_componentParentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: DOMRef
_componentVTree :: IORef VTree
_componentSink :: ZonkAny 11 -> IO ()
_componentModel :: ZonkAny 10
_componentIsDirty :: Bool
_componentScripts :: [DOMRef]
_componentEvents :: Events
_componentBindings :: [Binding (ZonkAny 9) (ZonkAny 10)]
_componentMailbox :: Value -> Maybe (ZonkAny 11)
_componentDraw :: ZonkAny 10 -> IO ()
_componentModelDirty :: ZonkAny 10 -> ZonkAny 10 -> Bool
_componentApplyActions :: [ZonkAny 11]
-> ZonkAny 10
-> IntMap (ComponentState (ZonkAny 9) (ZonkAny 10) (ZonkAny 11))
-> (IntMap (ComponentState (ZonkAny 9) (ZonkAny 10) (ZonkAny 11)),
    ZonkAny 10, [Schedule (ZonkAny 11)], 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 model action
-- @
--
-- @since 1.9.0.0
mail
  :: ToJSON message
  => ComponentId
  -> message
  -> IO ()
mail :: forall message. ToJSON message => Int -> message -> IO ()
mail Int
vcompId message
msg =
  Int
-> IntMap (ComponentState (ZonkAny 12) (ZonkAny 13) (ZonkAny 14))
-> Maybe (ComponentState (ZonkAny 12) (ZonkAny 13) (ZonkAny 14))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap (ComponentState (ZonkAny 12) (ZonkAny 13) (ZonkAny 14))
 -> Maybe (ComponentState (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)))
-> IO
     (IntMap (ComponentState (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)))
-> IO
     (Maybe (ComponentState (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap (ComponentState (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)))
-> IO
     (IntMap (ComponentState (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap (ComponentState (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)))
forall parent model action.
IORef (IntMap (ComponentState parent model action))
components IO (Maybe (ComponentState (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)))
-> (Maybe (ComponentState (ZonkAny 12) (ZonkAny 13) (ZonkAny 14))
    -> IO ())
-> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (ComponentState (ZonkAny 12) (ZonkAny 13) (ZonkAny 14))
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just ComponentState{Bool
Int
[DOMRef]
[Binding (ZonkAny 12) (ZonkAny 13)]
ZonkAny 13
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
DOMRef
[ZonkAny 14]
-> ZonkAny 13
-> IntMap (ComponentState (ZonkAny 12) (ZonkAny 13) (ZonkAny 14))
-> (IntMap (ComponentState (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)),
    ZonkAny 13, [Schedule (ZonkAny 14)], ComponentIds)
ZonkAny 13 -> IO ()
ZonkAny 13 -> ZonkAny 13 -> Bool
ZonkAny 14 -> IO ()
Value -> Maybe (ZonkAny 14)
_componentModel :: forall parent model action.
ComponentState parent model action -> model
_componentEvents :: forall parent model action.
ComponentState parent model action -> Events
_componentMailbox :: forall parent model action.
ComponentState parent model action -> Value -> Maybe action
_componentBindings :: forall parent model action.
ComponentState parent model action -> [Binding parent model]
_componentTopics :: forall parent model action.
ComponentState parent model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent model action.
ComponentState parent model action -> model -> model -> Bool
_componentChildren :: forall parent model action.
ComponentState parent model action -> ComponentIds
_componentApplyActions :: forall parent model action.
ComponentState parent model action
-> [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent model action.
ComponentState parent model action -> model -> IO ()
_componentScripts :: forall parent model action.
ComponentState parent model action -> [DOMRef]
_componentIsDirty :: forall parent model action.
ComponentState parent model action -> Bool
_componentSink :: forall parent model action.
ComponentState parent model action -> action -> IO ()
_componentVTree :: forall parent model action.
ComponentState parent model action -> IORef VTree
_componentDOMRef :: forall parent model action.
ComponentState parent model action -> DOMRef
_componentSubThreads :: forall parent model action.
ComponentState parent model action
-> IORef (Map MisoString ThreadId)
_componentParentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: DOMRef
_componentVTree :: IORef VTree
_componentSink :: ZonkAny 14 -> IO ()
_componentModel :: ZonkAny 13
_componentIsDirty :: Bool
_componentScripts :: [DOMRef]
_componentEvents :: Events
_componentBindings :: [Binding (ZonkAny 12) (ZonkAny 13)]
_componentMailbox :: Value -> Maybe (ZonkAny 14)
_componentDraw :: ZonkAny 13 -> IO ()
_componentModelDirty :: ZonkAny 13 -> ZonkAny 13 -> Bool
_componentApplyActions :: [ZonkAny 14]
-> ZonkAny 13
-> IntMap (ComponentState (ZonkAny 12) (ZonkAny 13) (ZonkAny 14))
-> (IntMap (ComponentState (ZonkAny 12) (ZonkAny 13) (ZonkAny 14)),
    ZonkAny 13, [Schedule (ZonkAny 14)], ComponentIds)
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} ->
      case Value -> Maybe (ZonkAny 14)
_componentMailbox (message -> Value
forall a. ToJSON a => a -> Value
toJSON message
msg) of
        Maybe (ZonkAny 14)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just ZonkAny 14
action ->
          ZonkAny 14 -> IO ()
_componentSink ZonkAny 14
action
-----------------------------------------------------------------------------
-- | Send any @ToJSON message => message@ to the parent's t'Miso.Types.Component' mailbox
--
-- @
-- mailParent ("test message" :: MisoString) :: Effect parent model action
-- @
--
-- @since 1.9.0.0
mailParent
  :: ToJSON message
  => message
  -> Effect parent model action
mailParent :: forall message parent model action.
ToJSON message =>
message -> Effect parent model action
mailParent message
msg = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ (mail _componentInfoParentId 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)
  -> (MisoString -> action)
  -> Value
  -> 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.
--
-- @since 1.9.0.0
parent
  :: (parent -> action)
  -> action
  -> Effect parent model action
parent :: forall parent action model.
(parent -> action) -> action -> Effect parent model action
parent parent -> action
successful action
errorful = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink -> do
    Int
-> IntMap (ComponentState (ZonkAny 15) parent (ZonkAny 16))
-> Maybe (ComponentState (ZonkAny 15) parent (ZonkAny 16))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
_componentInfoParentId (IntMap (ComponentState (ZonkAny 15) parent (ZonkAny 16))
 -> Maybe (ComponentState (ZonkAny 15) parent (ZonkAny 16)))
-> IO (IntMap (ComponentState (ZonkAny 15) parent (ZonkAny 16)))
-> IO (Maybe (ComponentState (ZonkAny 15) parent (ZonkAny 16)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IntMap (ComponentState (ZonkAny 15) parent (ZonkAny 16)))
-> IO (IntMap (ComponentState (ZonkAny 15) parent (ZonkAny 16)))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (IntMap (ComponentState (ZonkAny 15) parent (ZonkAny 16)))
-> IO (IntMap (ComponentState (ZonkAny 15) parent (ZonkAny 16)))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState (ZonkAny 15) parent (ZonkAny 16)))
forall parent model action.
IORef (IntMap (ComponentState parent model action))
components) IO (Maybe (ComponentState (ZonkAny 15) parent (ZonkAny 16)))
-> (Maybe (ComponentState (ZonkAny 15) parent (ZonkAny 16))
    -> 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 15) parent (ZonkAny 16))
Nothing -> Sink action
sink action
errorful
      Just ComponentState {parent
Bool
Int
[DOMRef]
[Binding (ZonkAny 15) parent]
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
DOMRef
parent -> IO ()
parent -> parent -> Bool
[ZonkAny 16]
-> parent
-> IntMap (ComponentState (ZonkAny 15) parent (ZonkAny 16))
-> (IntMap (ComponentState (ZonkAny 15) parent (ZonkAny 16)),
    parent, [Schedule (ZonkAny 16)], ComponentIds)
ZonkAny 16 -> IO ()
Value -> Maybe (ZonkAny 16)
_componentModel :: forall parent model action.
ComponentState parent model action -> model
_componentEvents :: forall parent model action.
ComponentState parent model action -> Events
_componentMailbox :: forall parent model action.
ComponentState parent model action -> Value -> Maybe action
_componentBindings :: forall parent model action.
ComponentState parent model action -> [Binding parent model]
_componentTopics :: forall parent model action.
ComponentState parent model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent model action.
ComponentState parent model action -> model -> model -> Bool
_componentChildren :: forall parent model action.
ComponentState parent model action -> ComponentIds
_componentApplyActions :: forall parent model action.
ComponentState parent model action
-> [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent model action.
ComponentState parent model action -> model -> IO ()
_componentScripts :: forall parent model action.
ComponentState parent model action -> [DOMRef]
_componentIsDirty :: forall parent model action.
ComponentState parent model action -> Bool
_componentSink :: forall parent model action.
ComponentState parent model action -> action -> IO ()
_componentVTree :: forall parent model action.
ComponentState parent model action -> IORef VTree
_componentDOMRef :: forall parent model action.
ComponentState parent model action -> DOMRef
_componentSubThreads :: forall parent model action.
ComponentState parent model action
-> IORef (Map MisoString ThreadId)
_componentParentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: DOMRef
_componentVTree :: IORef VTree
_componentSink :: ZonkAny 16 -> IO ()
_componentModel :: parent
_componentIsDirty :: Bool
_componentScripts :: [DOMRef]
_componentEvents :: Events
_componentBindings :: [Binding (ZonkAny 15) parent]
_componentMailbox :: Value -> Maybe (ZonkAny 16)
_componentDraw :: parent -> IO ()
_componentModelDirty :: parent -> parent -> Bool
_componentApplyActions :: [ZonkAny 16]
-> parent
-> IntMap (ComponentState (ZonkAny 15) parent (ZonkAny 16))
-> (IntMap (ComponentState (ZonkAny 15) parent (ZonkAny 16)),
    parent, [Schedule (ZonkAny 16)], 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 model action
-- update _ = broadcast (String "public service announcement")
-- @
--
-- @since 1.9.0.0
broadcast
  :: Eq model
  => ToJSON message
  => message
  -> Effect parent model action
broadcast :: forall model message parent action.
(Eq model, ToJSON message) =>
message -> Effect parent model action
broadcast message
msg = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
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 20) (ZonkAny 21) (ZonkAny 22))
-> Maybe (ComponentState (ZonkAny 20) (ZonkAny 21) (ZonkAny 22))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap (ComponentState (ZonkAny 20) (ZonkAny 21) (ZonkAny 22))
 -> Maybe (ComponentState (ZonkAny 20) (ZonkAny 21) (ZonkAny 22)))
-> IO
     (IntMap (ComponentState (ZonkAny 20) (ZonkAny 21) (ZonkAny 22)))
-> IO
     (Maybe (ComponentState (ZonkAny 20) (ZonkAny 21) (ZonkAny 22)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (IntMap (ComponentState (ZonkAny 20) (ZonkAny 21) (ZonkAny 22)))
-> IO
     (IntMap (ComponentState (ZonkAny 20) (ZonkAny 21) (ZonkAny 22)))
forall a. IORef a -> IO a
readIORef IORef
  (IntMap (ComponentState (ZonkAny 20) (ZonkAny 21) (ZonkAny 22)))
forall parent model action.
IORef (IntMap (ComponentState parent model action))
components IO (Maybe (ComponentState (ZonkAny 20) (ZonkAny 21) (ZonkAny 22)))
-> (Maybe (ComponentState (ZonkAny 20) (ZonkAny 21) (ZonkAny 22))
    -> 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))
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just ComponentState{Bool
Int
[DOMRef]
[Binding (ZonkAny 20) (ZonkAny 21)]
ZonkAny 21
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
DOMRef
[ZonkAny 22]
-> ZonkAny 21
-> IntMap (ComponentState (ZonkAny 20) (ZonkAny 21) (ZonkAny 22))
-> (IntMap (ComponentState (ZonkAny 20) (ZonkAny 21) (ZonkAny 22)),
    ZonkAny 21, [Schedule (ZonkAny 22)], ComponentIds)
ZonkAny 21 -> IO ()
ZonkAny 21 -> ZonkAny 21 -> Bool
ZonkAny 22 -> IO ()
Value -> Maybe (ZonkAny 22)
_componentModel :: forall parent model action.
ComponentState parent model action -> model
_componentEvents :: forall parent model action.
ComponentState parent model action -> Events
_componentMailbox :: forall parent model action.
ComponentState parent model action -> Value -> Maybe action
_componentBindings :: forall parent model action.
ComponentState parent model action -> [Binding parent model]
_componentTopics :: forall parent model action.
ComponentState parent model action
-> Map MisoString (Value -> IO ())
_componentModelDirty :: forall parent model action.
ComponentState parent model action -> model -> model -> Bool
_componentChildren :: forall parent model action.
ComponentState parent model action -> ComponentIds
_componentApplyActions :: forall parent model action.
ComponentState parent model action
-> [action]
-> model
-> IntMap (ComponentState parent model action)
-> (IntMap (ComponentState parent model action), model,
    [Schedule action], ComponentIds)
_componentDraw :: forall parent model action.
ComponentState parent model action -> model -> IO ()
_componentScripts :: forall parent model action.
ComponentState parent model action -> [DOMRef]
_componentIsDirty :: forall parent model action.
ComponentState parent model action -> Bool
_componentSink :: forall parent model action.
ComponentState parent model action -> action -> IO ()
_componentVTree :: forall parent model action.
ComponentState parent model action -> IORef VTree
_componentDOMRef :: forall parent model action.
ComponentState parent model action -> DOMRef
_componentSubThreads :: forall parent model action.
ComponentState parent model action
-> IORef (Map MisoString ThreadId)
_componentParentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: forall parent model action.
ComponentState parent model action -> Int
_componentId :: Int
_componentParentId :: Int
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: DOMRef
_componentVTree :: IORef VTree
_componentSink :: ZonkAny 22 -> IO ()
_componentModel :: ZonkAny 21
_componentIsDirty :: Bool
_componentScripts :: [DOMRef]
_componentEvents :: Events
_componentBindings :: [Binding (ZonkAny 20) (ZonkAny 21)]
_componentMailbox :: Value -> Maybe (ZonkAny 22)
_componentDraw :: ZonkAny 21 -> IO ()
_componentModelDirty :: ZonkAny 21 -> ZonkAny 21 -> Bool
_componentApplyActions :: [ZonkAny 22]
-> ZonkAny 21
-> IntMap (ComponentState (ZonkAny 20) (ZonkAny 21) (ZonkAny 22))
-> (IntMap (ComponentState (ZonkAny 20) (ZonkAny 21) (ZonkAny 22)),
    ZonkAny 21, [Schedule (ZonkAny 22)], ComponentIds)
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
..} ->
            case Value -> Maybe (ZonkAny 22)
_componentMailbox (message -> Value
forall a. ToJSON a => a -> Value
toJSON message
msg) of
              Maybe (ZonkAny 22)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Just ZonkAny 22
action -> ZonkAny 22 -> IO ()
_componentSink ZonkAny 22
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 model action
websocketConnectText :: forall action parent model.
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (MisoString -> action)
-> (MisoString -> action)
-> Effect parent model action
websocketConnectText MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed MisoString -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> IO DOMRef)
-> Effect parent model action
forall action parent model.
(WebSocket -> Sink action -> IO DOMRef)
-> Effect parent model action
websocketCore ((WebSocket -> Sink action -> IO DOMRef)
 -> Effect parent model action)
-> (WebSocket -> Sink action -> IO DOMRef)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> IO ()
-> (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> (DOMRef -> IO ())
-> Bool
-> IO DOMRef
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 ()) -> (DOMRef -> IO Closed) -> DOMRef -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< DOMRef -> IO Closed
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked)
      ((DOMRef -> IO ()) -> Maybe (DOMRef -> 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 ())
-> (DOMRef -> IO MisoString) -> DOMRef -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< DOMRef -> IO MisoString
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked))
      Maybe (DOMRef -> IO ())
forall a. Maybe a
Nothing
      Maybe (DOMRef -> IO ())
forall a. Maybe a
Nothing
      Maybe (DOMRef -> 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 ())
-> (DOMRef -> IO MisoString) -> DOMRef -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< DOMRef -> IO MisoString
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked)
      Bool
True
-----------------------------------------------------------------------------
websocketConnectBLOB
  :: URL
  -- ^ t'WebSocket' 'URL'
  -> (WebSocket -> action)
  -- ^ onOpen
  -> (Closed -> action)
  -- ^ onClosed
  -> (Blob -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect parent model action
websocketConnectBLOB :: forall action parent model.
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (Blob -> action)
-> (MisoString -> action)
-> Effect parent model action
websocketConnectBLOB MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed Blob -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> IO DOMRef)
-> Effect parent model action
forall action parent model.
(WebSocket -> Sink action -> IO DOMRef)
-> Effect parent model action
websocketCore ((WebSocket -> Sink action -> IO DOMRef)
 -> Effect parent model action)
-> (WebSocket -> Sink action -> IO DOMRef)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> IO ()
-> (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> (DOMRef -> IO ())
-> Bool
-> IO DOMRef
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 ()) -> (DOMRef -> IO Closed) -> DOMRef -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< DOMRef -> IO Closed
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked)
      Maybe (DOMRef -> IO ())
forall a. Maybe a
Nothing
      Maybe (DOMRef -> IO ())
forall a. Maybe a
Nothing
      ((DOMRef -> IO ()) -> Maybe (DOMRef -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (DOMRef -> action) -> DOMRef -> 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) -> (DOMRef -> Blob) -> DOMRef -> 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
. DOMRef -> Blob
Blob))
      Maybe (DOMRef -> 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 ())
-> (DOMRef -> IO MisoString) -> DOMRef -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< DOMRef -> IO MisoString
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked)
      Bool
False
-----------------------------------------------------------------------------
websocketConnectArrayBuffer
  :: URL
  -- ^ t'WebSocket' 'URL'
  -> (WebSocket -> action)
  -- ^ onOpen
  -> (Closed -> action)
  -- ^ onClosed
  -> (ArrayBuffer -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect parent model action
websocketConnectArrayBuffer :: forall action parent model.
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (ArrayBuffer -> action)
-> (MisoString -> action)
-> Effect parent model action
websocketConnectArrayBuffer MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed ArrayBuffer -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> IO DOMRef)
-> Effect parent model action
forall action parent model.
(WebSocket -> Sink action -> IO DOMRef)
-> Effect parent model action
websocketCore ((WebSocket -> Sink action -> IO DOMRef)
 -> Effect parent model action)
-> (WebSocket -> Sink action -> IO DOMRef)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> IO ()
-> (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> (DOMRef -> IO ())
-> Bool
-> IO DOMRef
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 ()) -> (DOMRef -> IO Closed) -> DOMRef -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< DOMRef -> IO Closed
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked)
      Maybe (DOMRef -> IO ())
forall a. Maybe a
Nothing
      Maybe (DOMRef -> IO ())
forall a. Maybe a
Nothing
      Maybe (DOMRef -> IO ())
forall a. Maybe a
Nothing
      ((DOMRef -> IO ()) -> Maybe (DOMRef -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (DOMRef -> action) -> DOMRef -> 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)
-> (DOMRef -> ArrayBuffer) -> DOMRef -> 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
. DOMRef -> 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 ())
-> (DOMRef -> IO MisoString) -> DOMRef -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< DOMRef -> IO MisoString
forall a. FromJSVal a => DOMRef -> 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 model action
websocketConnectJSON :: forall json action parent model.
FromJSON json =>
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (json -> action)
-> (MisoString -> action)
-> Effect parent model action
websocketConnectJSON MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed json -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> IO DOMRef)
-> Effect parent model action
forall action parent model.
(WebSocket -> Sink action -> IO DOMRef)
-> Effect parent model action
websocketCore ((WebSocket -> Sink action -> IO DOMRef)
 -> Effect parent model action)
-> (WebSocket -> Sink action -> IO DOMRef)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> IO ()
-> (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> (DOMRef -> IO ())
-> Bool
-> IO DOMRef
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 ()) -> (DOMRef -> IO Closed) -> DOMRef -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< DOMRef -> IO Closed
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked)
      Maybe (DOMRef -> IO ())
forall a. Maybe a
Nothing
      ((DOMRef -> IO ()) -> Maybe (DOMRef -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\DOMRef
bytes -> do
          value :: Value <- DOMRef -> IO Value
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked DOMRef
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 (DOMRef -> IO ())
forall a. Maybe a
Nothing
      Maybe (DOMRef -> 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 ())
-> (DOMRef -> IO MisoString) -> DOMRef -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< DOMRef -> IO MisoString
forall a. FromJSVal a => DOMRef -> 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 model action
websocketConnect :: forall json action parent model.
FromJSON json =>
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (Payload json -> action)
-> (MisoString -> action)
-> Effect parent model action
websocketConnect MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed Payload json -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> IO DOMRef)
-> Effect parent model action
forall action parent model.
(WebSocket -> Sink action -> IO DOMRef)
-> Effect parent model action
websocketCore ((WebSocket -> Sink action -> IO DOMRef)
 -> Effect parent model action)
-> (WebSocket -> Sink action -> IO DOMRef)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> IO ()
-> (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> (DOMRef -> IO ())
-> Bool
-> IO DOMRef
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 ()) -> (DOMRef -> IO Closed) -> DOMRef -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< DOMRef -> IO Closed
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked)
      ((DOMRef -> IO ()) -> Maybe (DOMRef -> 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 ())
-> (DOMRef -> IO MisoString) -> DOMRef -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< DOMRef -> IO MisoString
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked))
      ((DOMRef -> IO ()) -> Maybe (DOMRef -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\DOMRef
bytes -> do
          value :: Value <- DOMRef -> IO Value
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked DOMRef
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)))
      ((DOMRef -> IO ()) -> Maybe (DOMRef -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (DOMRef -> action) -> DOMRef -> 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)
-> (DOMRef -> Payload json) -> DOMRef -> 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)
-> (DOMRef -> Blob) -> DOMRef -> 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
. DOMRef -> Blob
Blob))
      ((DOMRef -> IO ()) -> Maybe (DOMRef -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (DOMRef -> action) -> DOMRef -> 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)
-> (DOMRef -> Payload json) -> DOMRef -> 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)
-> (DOMRef -> ArrayBuffer) -> DOMRef -> 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
. DOMRef -> 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 ())
-> (DOMRef -> IO MisoString) -> DOMRef -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< DOMRef -> IO MisoString
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked)
      Bool
False
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/WebSocket/WebSocket>
websocketCore
  :: (WebSocket -> Sink action -> IO Socket)
  -> Effect parent model action
websocketCore :: forall action parent model.
(WebSocket -> Sink action -> IO DOMRef)
-> Effect parent model action
websocketCore WebSocket -> Sink action -> IO DOMRef
core = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
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 -> DOMRef -> IO ()
insertWebSocket Int
componentId_ (WebSocket Int
socketId) DOMRef
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 DOMRef -> IntMap DOMRef -> IntMap DOMRef)
-> WebSockets -> WebSockets -> WebSockets
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith IntMap DOMRef -> IntMap DOMRef -> IntMap DOMRef
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 DOMRef -> WebSockets
forall a. Int -> a -> IntMap a
IM.singleton Int
componentId_
            (IntMap DOMRef -> WebSockets) -> IntMap DOMRef -> WebSockets
forall a b. (a -> b) -> a -> b
$ Int -> DOMRef -> IntMap DOMRef
forall a. Int -> a -> IntMap a
IM.singleton Int
socketId DOMRef
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 DOMRef
getWebSocket Int
vcompId (WebSocket Int
websocketId) =
  Int -> IntMap DOMRef -> Maybe DOMRef
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
websocketId (IntMap DOMRef -> Maybe DOMRef)
-> (WebSockets -> Maybe (IntMap DOMRef))
-> WebSockets
-> Maybe DOMRef
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Int -> WebSockets -> Maybe (IntMap DOMRef)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId
-----------------------------------------------------------------------------
finalizeWebSockets :: ComponentId -> IO ()
finalizeWebSockets :: Int -> IO ()
finalizeWebSockets Int
vcompId = do
  (IntMap DOMRef -> IO ()) -> Maybe (IntMap DOMRef) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((DOMRef -> IO ()) -> [DOMRef] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DOMRef -> IO ()
FFI.websocketClose ([DOMRef] -> IO ())
-> (IntMap DOMRef -> [DOMRef]) -> IntMap DOMRef -> 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 DOMRef -> [DOMRef]
forall a. IntMap a -> [a]
IM.elems) (Maybe (IntMap DOMRef) -> IO ())
-> IO (Maybe (IntMap DOMRef)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Int -> WebSockets -> Maybe (IntMap DOMRef)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (WebSockets -> Maybe (IntMap DOMRef))
-> IO WebSockets -> IO (Maybe (IntMap DOMRef))
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 model action
websocketClose :: forall parent model action. WebSocket -> Effect parent model action
websocketClose WebSocket
socketId = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
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 DOMRef -> (WebSockets, Maybe DOMRef)
forall k v. k -> v -> (k, v)
=:
          Int -> WebSocket -> WebSockets -> Maybe DOMRef
getWebSocket Int
_componentInfoId WebSocket
socketId WebSockets
imap
    case result of
      Maybe DOMRef
Nothing ->
        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just DOMRef
socket ->
        DOMRef -> IO ()
FFI.websocketClose DOMRef
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 DOMRef)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId WebSockets
websockets of
        Maybe (IntMap DOMRef)
Nothing ->
          WebSockets
websockets
        Just IntMap DOMRef
componentSockets ->
          Int -> IntMap DOMRef -> WebSockets -> WebSockets
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
vcompId (Int -> IntMap DOMRef -> IntMap DOMRef
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
websocketId IntMap DOMRef
componentSockets) WebSockets
websockets
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/WebSocket/send>
websocketSend
  :: ToJSON value
  => WebSocket
  -> Payload value
  -> Effect parent model action
websocketSend :: forall value parent model action.
ToJSON value =>
WebSocket -> Payload value -> Effect parent model action
websocketSend WebSocket
socketId Payload value
msg = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    getWebSocket _componentInfoId socketId <$> readIORef websocketConnections >>= \case
      Maybe DOMRef
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just DOMRef
socket ->
        case Payload value
msg of
          JSON value
json_ ->
            DOMRef -> DOMRef -> IO ()
FFI.websocketSend DOMRef
socket (DOMRef -> IO ()) -> IO DOMRef -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> IO DOMRef
forall a. ToJSVal a => a -> IO DOMRef
toJSVal (value -> MisoString
forall a. ToJSON a => a -> MisoString
encode value
json_)
          BUFFER ArrayBuffer
arrayBuffer_ -> do
            DOMRef -> DOMRef -> IO ()
FFI.websocketSend DOMRef
socket (DOMRef -> IO ()) -> IO DOMRef -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ArrayBuffer -> IO DOMRef
forall a. ToJSVal a => a -> IO DOMRef
toJSVal ArrayBuffer
arrayBuffer_
          TEXT MisoString
txt ->
            DOMRef -> DOMRef -> IO ()
FFI.websocketSend DOMRef
socket (DOMRef -> IO ()) -> IO DOMRef -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> IO DOMRef
forall a. ToJSVal a => a -> IO DOMRef
toJSVal MisoString
txt
          BLOB Blob
blob_ ->
            DOMRef -> DOMRef -> IO ()
FFI.websocketSend DOMRef
socket (DOMRef -> IO ()) -> IO DOMRef -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Blob -> IO DOMRef
forall a. ToJSVal a => a -> IO DOMRef
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 model action
socketState :: forall action parent model.
WebSocket -> (SocketState -> action) -> Effect parent model action
socketState WebSocket
socketId SocketState -> action
callback = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink -> do
     Int -> WebSocket -> WebSockets -> Maybe DOMRef
getWebSocket Int
_componentInfoId WebSocket
socketId (WebSockets -> Maybe DOMRef) -> IO WebSockets -> IO (Maybe DOMRef)
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 DOMRef) -> (Maybe DOMRef -> 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 DOMRef
socket -> do
        x <- DOMRef
socket DOMRef -> MisoString -> IO DOMRef
forall o. ToObject o => o -> MisoString -> IO DOMRef
! (MisoString
"socketState" :: MisoString)
        socketstate <- toEnum <$> fromJSValUnchecked x
        sink (callback socketstate)
      Maybe DOMRef
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 :: DOMRef -> IO (Maybe Closed)
fromJSVal DOMRef
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 DOMRef -> IO (Maybe Int)
forall a. FromJSVal a => DOMRef -> IO (Maybe a)
fromJSVal (DOMRef -> IO (Maybe Int)) -> IO DOMRef -> IO (Maybe Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DOMRef
o DOMRef -> MisoString -> IO DOMRef
forall o. ToObject o => o -> MisoString -> IO DOMRef
! (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 DOMRef
(WebSocket -> IO DOMRef) -> ToJSVal WebSocket
forall a. (a -> IO DOMRef) -> ToJSVal a
$ctoJSVal :: WebSocket -> IO DOMRef
toJSVal :: WebSocket -> IO DOMRef
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 DOMRef
(EventSource -> IO DOMRef) -> ToJSVal EventSource
forall a. (a -> IO DOMRef) -> ToJSVal a
$ctoJSVal :: EventSource -> IO DOMRef
toJSVal :: EventSource -> IO DOMRef
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 model action
eventSourceConnectText :: forall action parent model.
MisoString
-> (EventSource -> action)
-> (MisoString -> action)
-> (MisoString -> action)
-> Effect parent model action
eventSourceConnectText MisoString
url EventSource -> action
onOpen MisoString -> action
onMessage MisoString -> action
onError =
  (EventSource -> Sink action -> IO DOMRef)
-> Effect parent model action
forall action parent model.
(EventSource -> Sink action -> IO DOMRef)
-> Effect parent model action
eventSourceCore ((EventSource -> Sink action -> IO DOMRef)
 -> Effect parent model action)
-> (EventSource -> Sink action -> IO DOMRef)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \EventSource
eventSourceId Sink action
sink -> do
    MisoString
-> IO ()
-> Maybe (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> (DOMRef -> IO ())
-> Bool
-> IO DOMRef
FFI.eventSourceConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ EventSource -> action
onOpen EventSource
eventSourceId)
      ((DOMRef -> IO ()) -> Maybe (DOMRef -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((DOMRef -> IO ()) -> Maybe (DOMRef -> IO ()))
-> (DOMRef -> IO ()) -> Maybe (DOMRef -> IO ())
forall a b. (a -> b) -> a -> b
$ \DOMRef
e -> do
          txt <- DOMRef -> IO MisoString
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked DOMRef
e
          sink (onMessage txt))
      Maybe (DOMRef -> 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 ())
-> (DOMRef -> IO MisoString) -> DOMRef -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< DOMRef -> IO MisoString
forall a. FromJSVal a => DOMRef -> 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 model action
eventSourceConnectJSON :: forall json action parent model.
FromJSON json =>
MisoString
-> (EventSource -> action)
-> (json -> action)
-> (MisoString -> action)
-> Effect parent model action
eventSourceConnectJSON MisoString
url EventSource -> action
onOpen json -> action
onMessage MisoString -> action
onError =
  (EventSource -> Sink action -> IO DOMRef)
-> Effect parent model action
forall action parent model.
(EventSource -> Sink action -> IO DOMRef)
-> Effect parent model action
eventSourceCore ((EventSource -> Sink action -> IO DOMRef)
 -> Effect parent model action)
-> (EventSource -> Sink action -> IO DOMRef)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \EventSource
eventSourceId Sink action
sink -> do
    MisoString
-> IO ()
-> Maybe (DOMRef -> IO ())
-> Maybe (DOMRef -> IO ())
-> (DOMRef -> IO ())
-> Bool
-> IO DOMRef
FFI.eventSourceConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ EventSource -> action
onOpen EventSource
eventSourceId)
      Maybe (DOMRef -> IO ())
forall a. Maybe a
Nothing
      ((DOMRef -> IO ()) -> Maybe (DOMRef -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((DOMRef -> IO ()) -> Maybe (DOMRef -> IO ()))
-> (DOMRef -> IO ()) -> Maybe (DOMRef -> IO ())
forall a b. (a -> b) -> a -> b
$ \DOMRef
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
<$> DOMRef -> IO Value
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked DOMRef
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 ())
-> (DOMRef -> IO MisoString) -> DOMRef -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< DOMRef -> IO MisoString
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked)
      Bool
False
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/EventSource/EventSource>
eventSourceCore
  :: (EventSource -> Sink action -> IO Socket)
  -> Effect parent model action
eventSourceCore :: forall action parent model.
(EventSource -> Sink action -> IO DOMRef)
-> Effect parent model action
eventSourceCore EventSource -> Sink action -> IO DOMRef
core = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
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 -> DOMRef -> IO ()
insertEventSource Int
componentId_ (EventSource Int
socketId) DOMRef
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 DOMRef -> IntMap DOMRef -> IntMap DOMRef)
-> WebSockets -> WebSockets -> WebSockets
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith IntMap DOMRef -> IntMap DOMRef -> IntMap DOMRef
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 DOMRef -> WebSockets
forall a. Int -> a -> IntMap a
IM.singleton Int
componentId_
            (IntMap DOMRef -> WebSockets) -> IntMap DOMRef -> WebSockets
forall a b. (a -> b) -> a -> b
$ Int -> DOMRef -> IntMap DOMRef
forall a. Int -> a -> IntMap a
IM.singleton Int
socketId DOMRef
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 model action
eventSourceClose :: forall parent model action.
EventSource -> Effect parent model action
eventSourceClose EventSource
socketId = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
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 DOMRef -> (WebSockets, Maybe DOMRef)
forall k v. k -> v -> (k, v)
=:
          Int -> EventSource -> WebSockets -> Maybe DOMRef
getEventSource Int
_componentInfoId EventSource
socketId WebSockets
imap
    case result of
      Maybe DOMRef
Nothing ->
        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just DOMRef
socket ->
        DOMRef -> IO ()
FFI.eventSourceClose DOMRef
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 DOMRef)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId WebSockets
eventSources of
        Maybe (IntMap DOMRef)
Nothing ->
          WebSockets
eventSources
        Just IntMap DOMRef
componentSockets ->
          Int -> IntMap DOMRef -> WebSockets -> WebSockets
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
vcompId (Int -> IntMap DOMRef -> IntMap DOMRef
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
eventSourceId IntMap DOMRef
componentSockets) WebSockets
eventSources

    getEventSource :: ComponentId -> EventSource -> EventSources -> Maybe Socket
    getEventSource :: Int -> EventSource -> WebSockets -> Maybe DOMRef
getEventSource Int
vcompId (EventSource Int
eventSourceId) =
      Int -> IntMap DOMRef -> Maybe DOMRef
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
eventSourceId (IntMap DOMRef -> Maybe DOMRef)
-> (WebSockets -> Maybe (IntMap DOMRef))
-> WebSockets
-> Maybe DOMRef
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Int -> WebSockets -> Maybe (IntMap DOMRef)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId
-----------------------------------------------------------------------------
finalizeEventSources :: ComponentId -> IO ()
finalizeEventSources :: Int -> IO ()
finalizeEventSources Int
vcompId = do
  (IntMap DOMRef -> IO ()) -> Maybe (IntMap DOMRef) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((DOMRef -> IO ()) -> [DOMRef] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DOMRef -> IO ()
FFI.eventSourceClose ([DOMRef] -> IO ())
-> (IntMap DOMRef -> [DOMRef]) -> IntMap DOMRef -> 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 DOMRef -> [DOMRef]
forall a. IntMap a -> [a]
IM.elems) (Maybe (IntMap DOMRef) -> IO ())
-> IO (Maybe (IntMap DOMRef)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Int -> WebSockets -> Maybe (IntMap DOMRef)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (WebSockets -> Maybe (IntMap DOMRef))
-> IO WebSockets -> IO (Maybe (IntMap DOMRef))
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
-----------------------------------------------------------------------------
#ifdef WASM
-----------------------------------------------------------------------------
-- | Like 'eval', but read the JS code to evaluate from a file.
evalFile :: FilePath -> TH.Q TH.Exp
evalFile path = eval_ =<< TH.runIO (readFile path)
  where
    eval_ :: String -> TH.Q TH.Exp
    eval_ chunk = [| $(Miso.DSL.TH.evalTH chunk []) :: IO () |]
-----------------------------------------------------------------------------
#endif
-----------------------------------------------------------------------------