-----------------------------------------------------------------------------
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- |
-- 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
  , runView
  , renderStyles
  , renderScripts
  , Hydrate(..)
  -- * Subscription
  , startSub
  , stopSub
  -- * Pub / Sub
  , subscribe
  , unsubscribe
  , publish
  , Topic (..)
  , topic
  -- * Component
  , ComponentState
  -- ** Communication
  , mail
  , checkMail
  , broadcast
  , parent
  , mailParent
  -- ** WebSocket
  , websocketConnect
  , websocketSend
  , websocketClose
  , socketState
  , emptyWebSocket
  , WebSocket (..)
  , URL
  , SocketState (..)
  , CloseCode (..)
  , Closed (..)
  -- ** EventSource
  , eventSourceConnect
  , eventSourceClose
  , emptyEventSource
  , EventSource (..)
  ) where
-----------------------------------------------------------------------------
import           Control.Exception (SomeException)
import           Control.Monad (forM, forM_, when, void, forever, (<=<))
import           Control.Monad.Reader (ask, asks)
import           Control.Monad.IO.Class
import           Data.Aeson (FromJSON, ToJSON, Result(..), fromJSON, toJSON, Value(Null))
import           Data.Foldable (toList)
import           Data.IORef (IORef, newIORef, atomicModifyIORef', readIORef, atomicWriteIORef, modifyIORef')
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 qualified Data.Sequence as S
import           Data.Sequence (Seq)
import qualified JavaScript.Array as JSArray
#ifndef GHCJS_BOTH
import           Language.Javascript.JSaddle hiding (Sync, Result, Success)
#else
import           Language.Javascript.JSaddle
#endif
import           GHC.Conc (ThreadStatus(ThreadDied, ThreadFinished), ThreadId, killThread, threadStatus)
import           GHC.Generics (Generic)
import           Prelude hiding (null)
import           System.IO.Unsafe (unsafePerformIO)
import           System.Mem.StableName (makeStableName)
import           Text.HTML.TagSoup (Tag(..))
import           Text.HTML.TagSoup.Tree (parseTree, TagTree(..))
-----------------------------------------------------------------------------
import           Miso.Concurrent (Waiter(..), waiter, Mailbox, copyMailbox, readMail, sendMail, newMailbox)
import           Miso.Delegate (delegator, undelegator)
import           Miso.Diff (diff)
import qualified Miso.FFI.Internal as FFI
import           Miso.String hiding (reverse)
import           Miso.Types
import           Miso.Util
import           Miso.Style (renderStyleSheet)
import           Miso.Event (Events)
import           Miso.Property (textProp)
import           Miso.Effect (ComponentInfo(..), Sub, Sink, Effect, runEffect, io_, withSink)
-----------------------------------------------------------------------------
-- | Helper function to abstract out initialization of @Component@ between top-level API functions.
initialize
  :: Eq model
  => Component parent model action
  -> (Sink action -> JSM ([DOMRef], DOMRef, IORef VTree))
  -- ^ Callback function is used to perform the creation of VTree
  -> JSM (ComponentState model action)
initialize :: forall model parent action.
Eq model =>
Component parent model action
-> (Sink action -> JSM ([JSVal], JSVal, IORef VTree))
-> JSM (ComponentState model action)
initialize Component {model
[Binding parent model]
[JS]
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View model action
action -> Effect parent model action
Mail -> Maybe action
model :: model
update :: action -> Effect parent model action
view :: model -> View model action
subs :: [Sub action]
events :: Events
styles :: [CSS]
scripts :: [JS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
mailbox :: Mail -> Maybe action
bindings :: [Binding parent model]
bindings :: forall parent model action.
Component parent model action -> [Binding parent model]
mailbox :: forall parent model action.
Component parent model action -> Mail -> Maybe action
logLevel :: forall parent model action.
Component parent model action -> LogLevel
mountPoint :: forall parent model action.
Component parent model action -> Maybe MisoString
initialAction :: forall parent model action.
Component parent model action -> Maybe action
scripts :: forall parent model action. Component parent model action -> [JS]
styles :: forall parent model action. Component parent model action -> [CSS]
events :: forall parent model action. Component parent model action -> Events
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
model :: forall parent model action. Component parent model action -> model
..} Sink action -> JSM ([JSVal], JSVal, IORef VTree)
getView = do
  Waiter {..} <- IO Waiter -> JSM Waiter
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Waiter
waiter
  componentActions <- liftIO (newIORef S.empty)
  let
    componentSink = \action
action -> IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
      IORef (Seq action) -> (Seq action -> (Seq action, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Seq action)
componentActions ((Seq action -> (Seq action, ())) -> IO ())
-> (Seq action -> (Seq action, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Seq action
actions -> (Seq action
actions Seq action -> action -> Seq action
forall a. Seq a -> a -> Seq a
S.|> action
action, ())
      IO ()
serve
  componentId <- liftIO freshComponentId
  componentDiffs <- liftIO newMailbox
  (componentScripts, componentDOMRef, componentVTree) <- getView componentSink
  componentDOMRef <# ("componentId" :: MisoString) $ componentId
  componentSubThreads <- liftIO (newIORef M.empty)
  forM_ subs $ \Sub action
sub -> do
    threadId <- JSM () -> JSM ThreadId
FFI.forkJSM (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, ())
  componentModelCurrent <- liftIO (newIORef model)
  componentModelNew <- liftIO (newIORef model)
  let
    eventLoop = IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
wait JSM () -> JSM b -> JSM b
forall a b. JSM a -> JSM b -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> do
      currentModel <- IO model -> JSM model
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef model -> IO model
forall a. IORef a -> IO a
readIORef IORef model
componentModelCurrent)
      newModel <- liftIO (readIORef componentModelNew)
      let
        info = Int -> JSVal -> ComponentInfo parent
forall parent. Int -> JSVal -> ComponentInfo parent
ComponentInfo Int
componentId JSVal
componentDOMRef
      as <- liftIO $ atomicModifyIORef' componentActions $ \Seq action
actions -> (Seq action
forall a. Seq a
S.empty, Seq action
actions)
      updatedModel <- foldEffects update Async info componentSink (toList as) newModel
      currentName <- liftIO $ currentModel `seq` makeStableName currentModel
      updatedName <- liftIO $ updatedModel `seq` makeStableName updatedModel
      when (currentName /= updatedName && currentModel /= updatedModel) $ do
        newVTree <- runView Draw (view updatedModel) componentSink logLevel events
        oldVTree <- liftIO (readIORef componentVTree)
        void waitForAnimationFrame
        diff (Just oldVTree) (Just newVTree) componentDOMRef
        liftIO $ do
          atomicWriteIORef componentVTree newVTree
          atomicWriteIORef componentModelCurrent updatedModel
          atomicWriteIORef componentModelNew updatedModel
          sendMail componentDiffs Null
          -- dmj: child wake-up call for prop synch
      syncPoint
      eventLoop

  -- mailbox
  componentMailbox <- liftIO newMailbox
  componentMailboxThreadId <- do
    FFI.forkJSM . forever $ do
      message <- liftIO (readMail =<< copyMailbox componentMailbox)
      mapM_ componentSink (mailbox message)

  -- Bindings (aka. "reactive" mutable variable synchronization)
  -- Between immediate ancestor / descendant (and sibling if bidi via parent)
  let
    bidirectional = [ Binding parent model
b | b :: Binding parent model
b@Bidirectional {} <- [Binding parent model]
bindings ]
    parentToChild = [ Binding parent model
b | b :: Binding parent model
b@ParentToChild {} <- [Binding parent model]
bindings ] [Binding parent model]
-> [Binding parent model] -> [Binding parent model]
forall a. [a] -> [a] -> [a]
++ [Binding parent model]
bidirectional
    childToParent = [ Binding parent model
b | b :: Binding parent model
b@ChildToParent {} <- [Binding parent model]
bindings ] [Binding parent model]
-> [Binding parent model] -> [Binding parent model]
forall a. [a] -> [a] -> [a]
++ [Binding parent model]
bidirectional

  componentParentToChildThreadId <-
    synchronizeParentToChild
      componentDOMRef
      componentModelNew
      parentToChild
      serve

  componentChildToParentThreadId <-
    synchronizeChildToParent
      componentDOMRef
      componentModelNew
      componentDiffs
      childToParent

  let vcomp = ComponentState
        { componentServe :: IO ()
componentServe = IO ()
serve
        , Int
[JSVal]
Maybe ThreadId
ThreadId
IORef model
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Mailbox
Sink action
componentActions :: IORef (Seq action)
componentSink :: Sink action
componentId :: Int
componentDiffs :: Mailbox
componentScripts :: [JSVal]
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSubThreads :: IORef (Map MisoString ThreadId)
componentModelCurrent :: IORef model
componentModelNew :: IORef model
componentMailbox :: Mailbox
componentMailboxThreadId :: ThreadId
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
componentParentToChildThreadId :: Maybe ThreadId
componentDiffs :: Mailbox
componentMailboxThreadId :: ThreadId
componentScripts :: [JSVal]
componentMailbox :: Mailbox
componentActions :: IORef (Seq action)
componentModelNew :: IORef model
componentModelCurrent :: IORef model
componentSink :: Sink action
componentVTree :: IORef VTree
componentDOMRef :: JSVal
componentSubThreads :: IORef (Map MisoString ThreadId)
componentId :: Int
..
        }
  registerComponent vcomp
  delegator componentDOMRef componentVTree events (logLevel `elem` [DebugEvents, DebugAll])
  forM_ initialAction componentSink
  _ <- FFI.forkJSM eventLoop
  pure vcomp
-----------------------------------------------------------------------------
synchronizeChildToParent
  :: DOMRef
  -> IORef model
  -> Mailbox
  -> [ Binding parent model ]
  -> JSM (Maybe ThreadId)
synchronizeChildToParent :: forall model parent.
JSVal
-> IORef model
-> Mailbox
-> [Binding parent model]
-> JSM (Maybe ThreadId)
synchronizeChildToParent JSVal
_ IORef model
_ Mailbox
_ [] = Maybe ThreadId -> JSM (Maybe ThreadId)
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ThreadId
forall a. Maybe a
Nothing
synchronizeChildToParent JSVal
componentDOMRef IORef model
componentModelNew Mailbox
componentDiffs [Binding parent model]
bindings = do
  -- Get parent's componentNotify, subscribe to it, on notification
  -- update the current Component model using the user-specified lenses
  JSVal -> JSM (Maybe Int)
FFI.getParentComponentId JSVal
componentDOMRef JSM (Maybe Int)
-> (Maybe Int -> JSM (Maybe ThreadId)) -> JSM (Maybe ThreadId)
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Int
Nothing ->
      -- dmj: impossible case, parent always mounted
      Maybe ThreadId -> JSM (Maybe ThreadId)
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ThreadId
forall a. Maybe a
Nothing
    Just Int
parentId -> do
      Int
-> IntMap (ComponentState parent (ZonkAny 15))
-> Maybe (ComponentState parent (ZonkAny 15))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
parentId (IntMap (ComponentState parent (ZonkAny 15))
 -> Maybe (ComponentState parent (ZonkAny 15)))
-> JSM (IntMap (ComponentState parent (ZonkAny 15)))
-> JSM (Maybe (ComponentState parent (ZonkAny 15)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IntMap (ComponentState parent (ZonkAny 15)))
-> JSM (IntMap (ComponentState parent (ZonkAny 15)))
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (IntMap (ComponentState parent (ZonkAny 15)))
-> IO (IntMap (ComponentState parent (ZonkAny 15)))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState parent (ZonkAny 15)))
forall model action. IORef (IntMap (ComponentState model action))
components) JSM (Maybe (ComponentState parent (ZonkAny 15)))
-> (Maybe (ComponentState parent (ZonkAny 15))
    -> JSM (Maybe ThreadId))
-> JSM (Maybe ThreadId)
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (ComponentState parent (ZonkAny 15))
Nothing -> do
          -- dmj: another impossible case, parent always mounted in children
          Maybe ThreadId -> JSM (Maybe ThreadId)
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ThreadId
forall a. Maybe a
Nothing
        Just ComponentState parent (ZonkAny 15)
parentComponentState -> do
          ComponentState parent (ZonkAny 15) -> JSM ()
forall {action}. ComponentState parent action -> JSM ()
bindProperty ComponentState parent (ZonkAny 15)
parentComponentState
          -- dmj: ^ parent assumes child state on initialization
          (ThreadId -> Maybe ThreadId)
-> JSM ThreadId -> JSM (Maybe ThreadId)
forall a b. (a -> b) -> JSM a -> JSM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ThreadId -> Maybe ThreadId
forall a. a -> Maybe a
Just (JSM ThreadId -> JSM (Maybe ThreadId))
-> JSM ThreadId -> JSM (Maybe ThreadId)
forall a b. (a -> b) -> a -> b
$ JSM () -> JSM ThreadId
FFI.forkJSM (JSM () -> JSM ThreadId) -> JSM () -> JSM ThreadId
forall a b. (a -> b) -> a -> b
$ JSM () -> JSM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
            Mail -> JSM ()
Null <- IO Mail -> JSM Mail
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Mail -> JSM Mail) -> IO Mail -> JSM Mail
forall a b. (a -> b) -> a -> b
$ Mailbox -> IO Mail
readMail (Mailbox -> IO Mail) -> IO Mailbox -> IO Mail
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Mailbox -> IO Mailbox
copyMailbox Mailbox
componentDiffs
            -- dmj: ^ listen on child this time
            bindProperty parentComponentState
  where
    bindProperty :: ComponentState parent action -> JSM ()
bindProperty ComponentState parent action
parentComponentState = do
      [Binding parent model]
-> (Binding parent model -> JSM ()) -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Binding parent model]
bindings (ComponentState parent action
-> IORef model -> Binding parent model -> JSM ()
forall parent model action.
ComponentState parent action
-> IORef model -> Binding parent model -> JSM ()
bindChildToParent ComponentState parent action
parentComponentState IORef model
componentModelNew)
      IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ComponentState parent action -> IO ()
forall model action. ComponentState model action -> IO ()
componentServe ComponentState parent action
parentComponentState)
-----------------------------------------------------------------------------
bindChildToParent
  :: forall parent model action
   . ComponentState parent action
  -- ^ Parent model
  -> IORef model
  -- ^ Child new model
  -> Binding parent model
  -- ^ Binding
  -> JSM ()
bindChildToParent :: forall parent model action.
ComponentState parent action
-> IORef model -> Binding parent model -> JSM ()
bindChildToParent ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
ThreadId
IORef parent
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Mailbox
action -> JSM ()
componentServe :: forall model action. ComponentState model action -> IO ()
componentChildToParentThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentParentToChildThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentDiffs :: forall model action. ComponentState model action -> Mailbox
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentScripts :: forall model action. ComponentState model action -> [JSVal]
componentMailbox :: forall model action. ComponentState model action -> Mailbox
componentActions :: forall model action.
ComponentState model action -> IORef (Seq action)
componentModelNew :: forall model action. ComponentState model action -> IORef model
componentModelCurrent :: forall model action. ComponentState model action -> IORef model
componentSink :: forall model action.
ComponentState model action -> action -> JSM ()
componentVTree :: forall model action. ComponentState model action -> IORef VTree
componentDOMRef :: forall model action. ComponentState model action -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentId :: forall model action. ComponentState model action -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModelCurrent :: IORef parent
componentModelNew :: IORef parent
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentServe :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
..} IORef model
childRef = \case
  ChildToParent Setter parent field
setParent Getter model field
getChild ->
    Setter parent field -> Getter model field -> JSM ()
forall {m :: * -> *} {t}.
MonadIO m =>
(t -> parent -> parent) -> (model -> t) -> m ()
childToParent Setter parent field
setParent Getter model field
getChild
  Bidirectional Getter parent field
_ Setter parent field
setParent Getter model field
getChild Setter model field
_ ->
    Setter parent field -> Getter model field -> JSM ()
forall {m :: * -> *} {t}.
MonadIO m =>
(t -> parent -> parent) -> (model -> t) -> m ()
childToParent Setter parent field
setParent Getter model field
getChild
  Binding parent model
_ ->
    () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    childToParent :: (t -> parent -> parent) -> (model -> t) -> m ()
childToParent t -> parent -> parent
setParent model -> t
getChild = do
      childModel <- IO model -> m model
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef model -> IO model
forall a. IORef a -> IO a
readIORef IORef model
childRef)
      let newParent = t -> parent -> parent
setParent (model -> t
getChild model
childModel)
      liftIO $ atomicModifyIORef' componentModelNew $ \parent
m -> (parent -> parent
newParent parent
m, ())
-----------------------------------------------------------------------------
synchronizeParentToChild
  :: DOMRef
  -> IORef model
  -> [ Binding type_ model ]
  -> IO ()
  -> JSM (Maybe ThreadId)
synchronizeParentToChild :: forall model type_.
JSVal
-> IORef model
-> [Binding type_ model]
-> IO ()
-> JSM (Maybe ThreadId)
synchronizeParentToChild JSVal
_ IORef model
_ [] IO ()
_ = Maybe ThreadId -> JSM (Maybe ThreadId)
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ThreadId
forall a. Maybe a
Nothing
synchronizeParentToChild JSVal
componentDOMRef IORef model
componentModel_ [Binding type_ model]
bindings IO ()
serve = do
  -- Get parent's componentNotify, subscribe to it, on notification
  -- update the current Component model using the user-specified lenses
  JSVal -> JSM (Maybe Int)
FFI.getParentComponentId JSVal
componentDOMRef JSM (Maybe Int)
-> (Maybe Int -> JSM (Maybe ThreadId)) -> JSM (Maybe ThreadId)
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Int
Nothing ->
      -- dmj: impossible case, parent always mounted
      Maybe ThreadId -> JSM (Maybe ThreadId)
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ThreadId
forall a. Maybe a
Nothing
    Just Int
parentId -> do
      Int
-> IntMap (ComponentState type_ (ZonkAny 14))
-> Maybe (ComponentState type_ (ZonkAny 14))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
parentId (IntMap (ComponentState type_ (ZonkAny 14))
 -> Maybe (ComponentState type_ (ZonkAny 14)))
-> JSM (IntMap (ComponentState type_ (ZonkAny 14)))
-> JSM (Maybe (ComponentState type_ (ZonkAny 14)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IntMap (ComponentState type_ (ZonkAny 14)))
-> JSM (IntMap (ComponentState type_ (ZonkAny 14)))
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (IntMap (ComponentState type_ (ZonkAny 14)))
-> IO (IntMap (ComponentState type_ (ZonkAny 14)))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState type_ (ZonkAny 14)))
forall model action. IORef (IntMap (ComponentState model action))
components) JSM (Maybe (ComponentState type_ (ZonkAny 14)))
-> (Maybe (ComponentState type_ (ZonkAny 14))
    -> JSM (Maybe ThreadId))
-> JSM (Maybe ThreadId)
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (ComponentState type_ (ZonkAny 14))
Nothing -> do
          -- dmj: another impossible case, parent always mounted
          Maybe ThreadId -> JSM (Maybe ThreadId)
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ThreadId
forall a. Maybe a
Nothing
        Just ComponentState type_ (ZonkAny 14)
parentComponentState -> do
          ComponentState type_ (ZonkAny 14) -> JSM ()
forall {action}. ComponentState type_ action -> JSM ()
bindProperty ComponentState type_ (ZonkAny 14)
parentComponentState
          -- dmj: ^ assume parent state on initialization
          (ThreadId -> Maybe ThreadId)
-> JSM ThreadId -> JSM (Maybe ThreadId)
forall a b. (a -> b) -> JSM a -> JSM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ThreadId -> Maybe ThreadId
forall a. a -> Maybe a
Just (JSM ThreadId -> JSM (Maybe ThreadId))
-> JSM ThreadId -> JSM (Maybe ThreadId)
forall a b. (a -> b) -> a -> b
$ JSM () -> JSM ThreadId
FFI.forkJSM (JSM () -> JSM ThreadId) -> JSM () -> JSM ThreadId
forall a b. (a -> b) -> a -> b
$ JSM () -> JSM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
            Mail -> JSM ()
Null <- IO Mail -> JSM Mail
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Mail -> JSM Mail) -> IO Mail -> JSM Mail
forall a b. (a -> b) -> a -> b
$ Mailbox -> IO Mail
readMail (Mailbox -> IO Mail) -> IO Mailbox -> IO Mail
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Mailbox -> IO Mailbox
copyMailbox (ComponentState type_ (ZonkAny 14) -> Mailbox
forall model action. ComponentState model action -> Mailbox
componentDiffs ComponentState type_ (ZonkAny 14)
parentComponentState)
            bindProperty parentComponentState
  where
    bindProperty :: ComponentState type_ action -> JSM ()
bindProperty ComponentState type_ action
parentComponentState = do
      [Binding type_ model] -> (Binding type_ model -> JSM ()) -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Binding type_ model]
bindings (ComponentState type_ action
-> IORef model -> Binding type_ model -> JSM ()
forall parent model action.
ComponentState parent action
-> IORef model -> Binding parent model -> JSM ()
bindParentToChild ComponentState type_ action
parentComponentState IORef model
componentModel_)
      IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
serve
-----------------------------------------------------------------------------
bindParentToChild
  :: forall props model action
   . ComponentState props action
  -- ^ Parent model
  -> IORef model
  -- ^ Child new model
  -> Binding props model
  -- ^ binding
  -> JSM ()
bindParentToChild :: forall parent model action.
ComponentState parent action
-> IORef model -> Binding parent model -> JSM ()
bindParentToChild ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
ThreadId
IORef props
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Mailbox
action -> JSM ()
componentServe :: forall model action. ComponentState model action -> IO ()
componentChildToParentThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentParentToChildThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentDiffs :: forall model action. ComponentState model action -> Mailbox
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentScripts :: forall model action. ComponentState model action -> [JSVal]
componentMailbox :: forall model action. ComponentState model action -> Mailbox
componentActions :: forall model action.
ComponentState model action -> IORef (Seq action)
componentModelNew :: forall model action. ComponentState model action -> IORef model
componentModelCurrent :: forall model action. ComponentState model action -> IORef model
componentSink :: forall model action.
ComponentState model action -> action -> JSM ()
componentVTree :: forall model action. ComponentState model action -> IORef VTree
componentDOMRef :: forall model action. ComponentState model action -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentId :: forall model action. ComponentState model action -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModelCurrent :: IORef props
componentModelNew :: IORef props
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentServe :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
..} IORef model
modelRef = \case
  ParentToChild Getter props field
getParent Setter model field
setChild -> do
    Getter props field -> Setter model field -> JSM ()
forall {m :: * -> *} {t}.
MonadIO m =>
(props -> t) -> (t -> model -> model) -> m ()
parentToChild Getter props field
getParent Setter model field
setChild
  Bidirectional Getter props field
getParent Setter props field
_ Getter model field
_ Setter model field
setChild ->
    Getter props field -> Setter model field -> JSM ()
forall {m :: * -> *} {t}.
MonadIO m =>
(props -> t) -> (t -> model -> model) -> m ()
parentToChild Getter props field
getParent Setter model field
setChild
  Binding props model
_ ->
    () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    parentToChild :: (props -> t) -> (t -> model -> model) -> m ()
parentToChild props -> t
getParent t -> model -> model
setChild = do
      parentModel <- IO props -> m props
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef props -> IO props
forall a. IORef a -> IO a
readIORef IORef props
componentModelNew)
      let newChild = t -> model -> model
setChild (props -> t
getParent props
parentModel)
      liftIO $ atomicModifyIORef' modelRef $ \model
m -> (model -> model
newChild model
m, ())
-----------------------------------------------------------------------------
-- | 'Hydrate' avoids calling @diff@, and instead calls @hydrate@
-- 'Draw' invokes '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)
-----------------------------------------------------------------------------
-- | @Component@ state, data associated with the lifetime of a @Component@
data ComponentState model action
  = ComponentState
  { forall model action. ComponentState model action -> Int
componentId              :: ComponentId
  , forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentSubThreads      :: IORef (Map MisoString ThreadId)
  , forall model action. ComponentState model action -> JSVal
componentDOMRef          :: DOMRef
  , forall model action. ComponentState model action -> IORef VTree
componentVTree           :: IORef VTree
  , forall model action.
ComponentState model action -> action -> JSM ()
componentSink            :: action -> JSM ()
  , forall model action. ComponentState model action -> IORef model
componentModelCurrent    :: IORef model
  , forall model action. ComponentState model action -> IORef model
componentModelNew        :: IORef model
  , forall model action.
ComponentState model action -> IORef (Seq action)
componentActions         :: IORef (Seq action)
  , forall model action. ComponentState model action -> Mailbox
componentMailbox         :: Mailbox
  , forall model action. ComponentState model action -> [JSVal]
componentScripts         :: [DOMRef]
  , forall model action. ComponentState model action -> ThreadId
componentMailboxThreadId :: ThreadId
  , forall model action. ComponentState model action -> Mailbox
componentDiffs           :: Mailbox
  , forall model action. ComponentState model action -> IO ()
componentServe           :: IO ()
    -- ^ What the current component writes to, to notify anybody about its dirty model
  , forall model action. ComponentState model action -> Maybe ThreadId
componentParentToChildThreadId  :: Maybe ThreadId
  , forall model action. ComponentState model action -> Maybe ThreadId
componentChildToParentThreadId  :: Maybe ThreadId
    -- ^ What the current component listens on to invoke model synchronization
  }
-----------------------------------------------------------------------------
-- | A 'Topic' represents a place to send and receive messages. 'Topic' is used to facilitate
-- communication between 'Component'. 'Component' can 'subscribe' to or 'publish' to any 'Topic',
-- within the same 'Component' or across 'Component'.
--
-- This requires creating a custom 'ToJSON' / 'FromJSON'. Any other '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 '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
-----------------------------------------------------------------------------
mailboxes :: IORef (Map (Topic a) Mailbox)
{-# NOINLINE mailboxes #-}
mailboxes :: forall a. IORef (Map (Topic a) Mailbox)
mailboxes = IO (IORef (Map (Topic a) Mailbox)) -> IORef (Map (Topic a) Mailbox)
forall a. IO a -> a
unsafePerformIO (IO (IORef (Map (Topic a) Mailbox))
 -> IORef (Map (Topic a) Mailbox))
-> IO (IORef (Map (Topic a) Mailbox))
-> IORef (Map (Topic a) Mailbox)
forall a b. (a -> b) -> a -> b
$ IO (IORef (Map (Topic a) Mailbox))
-> IO (IORef (Map (Topic a) Mailbox))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Map (Topic a) Mailbox -> IO (IORef (Map (Topic a) Mailbox))
forall a. a -> IO (IORef a)
newIORef Map (Topic a) Mailbox
forall a. Monoid a => a
mempty)
-----------------------------------------------------------------------------
subscribers :: IORef (Map (ComponentId, Topic a) ThreadId)
{-# NOINLINE subscribers #-}
subscribers :: forall a. IORef (Map (Int, Topic a) ThreadId)
subscribers = IO (IORef (Map (Int, Topic a) ThreadId))
-> IORef (Map (Int, Topic a) ThreadId)
forall a. IO a -> a
unsafePerformIO (IO (IORef (Map (Int, Topic a) ThreadId))
 -> IORef (Map (Int, Topic a) ThreadId))
-> IO (IORef (Map (Int, Topic a) ThreadId))
-> IORef (Map (Int, Topic a) ThreadId)
forall a b. (a -> b) -> a -> b
$ IO (IORef (Map (Int, Topic a) ThreadId))
-> IO (IORef (Map (Int, Topic a) ThreadId))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Map (Int, Topic a) ThreadId
-> IO (IORef (Map (Int, Topic a) ThreadId))
forall a. a -> IO (IORef a)
newIORef Map (Int, Topic a) ThreadId
forall a. Monoid a => a
mempty)
-----------------------------------------------------------------------------
-- | Subscribes to a 'Topic', provides callback function that writes to '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 'Component'. As long as the underlying 'Value' are identical
-- '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 message
topicName message -> action
successful MisoString -> action
errorful = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Sink action -> JSM ()]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    let vcompId = Int
_componentId
    subscribersMap <- liftIO (readIORef subscribers)
    let key = (Int
vcompId, Topic message
topicName)
    case M.lookup key subscribersMap of
      Just ThreadId
_ ->
        MisoString -> JSM ()
FFI.consoleWarn (MisoString
"Already subscribed to: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> Topic message -> MisoString
forall str. ToMisoString str => str -> MisoString
ms Topic message
topicName)
      Maybe ThreadId
Nothing -> do
        Topic message -> Map (Topic message) Mailbox -> Maybe Mailbox
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Topic message
topicName (Map (Topic message) Mailbox -> Maybe Mailbox)
-> JSM (Map (Topic message) Mailbox) -> JSM (Maybe Mailbox)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map (Topic message) Mailbox)
-> JSM (Map (Topic message) Mailbox)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Map (Topic message) Mailbox)
-> IO (Map (Topic message) Mailbox)
forall a. IORef a -> IO a
readIORef IORef (Map (Topic message) Mailbox)
forall a. IORef (Map (Topic a) Mailbox)
mailboxes) JSM (Maybe Mailbox) -> (Maybe Mailbox -> JSM ()) -> JSM ()
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe Mailbox
Nothing -> do
            -- no mailbox exists, create a new one, register it and subscribe
            mailbox <- IO Mailbox -> JSM Mailbox
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Mailbox -> JSM Mailbox) -> IO Mailbox -> JSM Mailbox
forall a b. (a -> b) -> a -> b
$ do
              mailbox <- IO Mailbox
newMailbox
              atomicModifyIORef' mailboxes $ \Map (Topic message) Mailbox
m -> (Topic message
-> Mailbox
-> Map (Topic message) Mailbox
-> Map (Topic message) Mailbox
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Topic message
topicName Mailbox
mailbox Map (Topic message) Mailbox
m, ())
              pure mailbox
            subscribeToMailbox key mailbox vcompId
          Just Mailbox
mailbox -> do
            (Int, Topic message) -> Mailbox -> Int -> JSM ()
forall {a}. (Int, Topic a) -> Mailbox -> Int -> JSM ()
subscribeToMailbox (Int, Topic message)
key Mailbox
mailbox Int
vcompId
  where
    subscribeToMailbox :: (Int, Topic a) -> Mailbox -> Int -> JSM ()
subscribeToMailbox (Int, Topic a)
key Mailbox
mailbox Int
vcompId = do
      threadId <- JSM () -> JSM ThreadId
FFI.forkJSM (JSM () -> JSM ThreadId) -> JSM () -> JSM ThreadId
forall a b. (a -> b) -> a -> b
$ do
        clonedMailbox <- IO Mailbox -> JSM Mailbox
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Mailbox -> IO Mailbox
copyMailbox Mailbox
mailbox)
        ComponentState {..} <- (IM.! vcompId) <$> liftIO (readIORef components)
        forever $ do
          fromJSON <$> liftIO (readMail clonedMailbox) >>= \case
            Success message
msg ->
              Sink action
componentSink (message -> action
successful message
msg)
            Error String
msg ->
              Sink action
componentSink (MisoString -> action
errorful (String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms String
msg))
      liftIO $ atomicModifyIORef' subscribers $ \Map (Int, Topic a) ThreadId
m ->
        ((Int, Topic a)
-> ThreadId
-> Map (Int, Topic a) ThreadId
-> Map (Int, Topic a) ThreadId
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Int, Topic a)
key ThreadId
threadId Map (Int, Topic a) ThreadId
m, ())
-----------------------------------------------------------------------------
-- 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 to a 'Topic'
--
-- Unsubscribes a 'Component' from receiving messages from @Topic message@
--
-- 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 message
topicName = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Sink action -> JSM ()]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ (unsubscribe_ topicName _componentId)
-----------------------------------------------------------------------------
-- | Internal unsubscribe used in component unmounting and in 'unsubscribe'
unsubscribe_ :: Topic message -> ComponentId -> JSM ()
unsubscribe_ :: forall message. Topic message -> Int -> JSM ()
unsubscribe_ Topic message
topicName Int
vcompId = do
  let key :: (Int, Topic message)
key = (Int
vcompId, Topic message
topicName)
  subscribersMap <- IO (Map (Int, Topic message) ThreadId)
-> JSM (Map (Int, Topic message) ThreadId)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Map (Int, Topic message) ThreadId)
-> IO (Map (Int, Topic message) ThreadId)
forall a. IORef a -> IO a
readIORef IORef (Map (Int, Topic message) ThreadId)
forall a. IORef (Map (Int, Topic a) ThreadId)
subscribers)
  case M.lookup key subscribersMap of
    Just ThreadId
threadId -> do
      IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
        ThreadId -> IO ()
killThread ThreadId
threadId
        IORef (Map (Int, Topic message) ThreadId)
-> (Map (Int, Topic message) ThreadId
    -> (Map (Int, Topic message) ThreadId, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map (Int, Topic message) ThreadId)
forall a. IORef (Map (Int, Topic a) ThreadId)
subscribers ((Map (Int, Topic message) ThreadId
  -> (Map (Int, Topic message) ThreadId, ()))
 -> IO ())
-> (Map (Int, Topic message) ThreadId
    -> (Map (Int, Topic message) ThreadId, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map (Int, Topic message) ThreadId
m ->
          ((Int, Topic message)
-> Map (Int, Topic message) ThreadId
-> Map (Int, Topic message) ThreadId
forall k a. Ord k => k -> Map k a -> Map k a
M.delete (Int, Topic message)
key Map (Int, Topic message) ThreadId
m, ())
    Maybe ThreadId
Nothing ->
      () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
-----------------------------------------------------------------------------
-- | Publish to a @Topic message@
--
-- @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 '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 () Action
--       update_ = \case
--         AddOne ->
--           publish arithmetic Increment
--         SubtractOne ->
--           publish arithemtic Decrement
--
-- @
--
-- @since 1.9.0.0
publish
  :: ToJSON message
  => Topic message
  -> message
  -> Effect parent model action
publish :: forall message parent model action.
ToJSON message =>
Topic message -> message -> Effect parent model action
publish Topic message
topicName message
value = JSM () -> Effect parent model action
forall parent model action. JSM () -> Effect parent model action
io_ (JSM () -> Effect parent model action)
-> JSM () -> Effect parent model action
forall a b. (a -> b) -> a -> b
$ do
  result <- Topic message -> Map (Topic message) Mailbox -> Maybe Mailbox
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Topic message
topicName (Map (Topic message) Mailbox -> Maybe Mailbox)
-> JSM (Map (Topic message) Mailbox) -> JSM (Maybe Mailbox)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map (Topic message) Mailbox)
-> JSM (Map (Topic message) Mailbox)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Map (Topic message) Mailbox)
-> IO (Map (Topic message) Mailbox)
forall a. IORef a -> IO a
readIORef IORef (Map (Topic message) Mailbox)
forall a. IORef (Map (Topic a) Mailbox)
mailboxes)
  case result of
    Just Mailbox
mailbox ->
      IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ Mailbox -> Mail -> IO ()
sendMail Mailbox
mailbox (message -> Mail
forall a. ToJSON a => a -> Mail
toJSON message
value)
    Maybe Mailbox
Nothing -> IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
      mailbox <- IO Mailbox
newMailbox
      void $ atomicModifyIORef' mailboxes $ \Map (Topic message) Mailbox
m -> (Topic message
-> Mailbox
-> Map (Topic message) Mailbox
-> Map (Topic message) Mailbox
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Topic message
topicName Mailbox
mailbox Map (Topic message) Mailbox
m, ())
-----------------------------------------------------------------------------
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
$ IO (IORef Int) -> IO (IORef Int)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (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)
-----------------------------------------------------------------------------
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
$ IO (IORef Int) -> IO (IORef Int)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0)
-----------------------------------------------------------------------------
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 @Component@ @Map@ that holds the state of all currently
-- mounted @Component@s
components :: IORef (IntMap (ComponentState model action))
{-# NOINLINE components #-}
components :: forall model action. IORef (IntMap (ComponentState model action))
components = IO (IORef (IntMap (ComponentState model action)))
-> IORef (IntMap (ComponentState model action))
forall a. IO a -> a
unsafePerformIO (IntMap (ComponentState model action)
-> IO (IORef (IntMap (ComponentState model action)))
forall a. a -> IO (IORef a)
newIORef IntMap (ComponentState model action)
forall a. Monoid a => a
mempty)
-----------------------------------------------------------------------------
-- | Data type to indicate if effects should be handled asynchronously
-- or synchronously.
--
data Synchronicity
  = Async
  | Sync
  deriving (Int -> Synchronicity -> ShowS
[Synchronicity] -> ShowS
Synchronicity -> String
(Int -> Synchronicity -> ShowS)
-> (Synchronicity -> String)
-> ([Synchronicity] -> ShowS)
-> Show Synchronicity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Synchronicity -> ShowS
showsPrec :: Int -> Synchronicity -> ShowS
$cshow :: Synchronicity -> String
show :: Synchronicity -> String
$cshowList :: [Synchronicity] -> ShowS
showList :: [Synchronicity] -> ShowS
Show, Synchronicity -> Synchronicity -> Bool
(Synchronicity -> Synchronicity -> Bool)
-> (Synchronicity -> Synchronicity -> Bool) -> Eq Synchronicity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Synchronicity -> Synchronicity -> Bool
== :: Synchronicity -> Synchronicity -> Bool
$c/= :: Synchronicity -> Synchronicity -> Bool
/= :: Synchronicity -> Synchronicity -> Bool
Eq)
-----------------------------------------------------------------------------
syncWith :: Synchronicity -> JSM () -> JSM ()
syncWith :: Synchronicity -> JSM () -> JSM ()
syncWith Synchronicity
Sync  JSM ()
x = JSM ()
x
syncWith Synchronicity
Async JSM ()
x = JSM ThreadId -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM () -> JSM ThreadId
FFI.forkJSM JSM ()
x)
-----------------------------------------------------------------------------
-- | Helper for processing effects in the event loop.
foldEffects
  :: (action -> Effect parent model action)
  -> Synchronicity
  -> ComponentInfo parent
  -> Sink action
  -> [action]
  -> model
  -> JSM model
foldEffects :: forall action parent model.
(action -> Effect parent model action)
-> Synchronicity
-> ComponentInfo parent
-> Sink action
-> [action]
-> model
-> JSM model
foldEffects action -> Effect parent model action
_ Synchronicity
_ ComponentInfo parent
_ Sink action
_ [] model
m = model -> JSM model
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure model
m
foldEffects action -> Effect parent model action
update Synchronicity
synchronicity ComponentInfo parent
info Sink action
snk (action
e:[action]
es) model
o =
  case Effect parent model action
-> ComponentInfo parent
-> model
-> (model, [Sink action -> JSM ()])
forall parent model action.
Effect parent model action
-> ComponentInfo parent
-> model
-> (model, [Sink action -> JSM ()])
runEffect (action -> Effect parent model action
update action
e) ComponentInfo parent
info model
o of
    (model
n, [Sink action -> JSM ()]
subs) -> do
      [Sink action -> JSM ()]
-> ((Sink action -> JSM ()) -> JSM ()) -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Sink action -> JSM ()]
subs (((Sink action -> JSM ()) -> JSM ()) -> JSM ())
-> ((Sink action -> JSM ()) -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \Sink action -> JSM ()
sub -> do
        Synchronicity -> JSM () -> JSM ()
syncWith Synchronicity
synchronicity (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$
          Sink action -> JSM ()
sub Sink action
snk JSM () -> (SomeException -> JSM ()) -> JSM ()
forall e a.
(HasCallStack, Exception e) =>
JSM a -> (e -> JSM a) -> JSM a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (JSM () -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM () -> JSM ())
-> (SomeException -> JSM ()) -> SomeException -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> JSM ()
exception)
      (action -> Effect parent model action)
-> Synchronicity
-> ComponentInfo parent
-> Sink action
-> [action]
-> model
-> JSM model
forall action parent model.
(action -> Effect parent model action)
-> Synchronicity
-> ComponentInfo parent
-> Sink action
-> [action]
-> model
-> JSM model
foldEffects action -> Effect parent model action
update Synchronicity
synchronicity ComponentInfo parent
info Sink action
snk [action]
es model
n
  where
    exception :: SomeException -> JSM ()
    exception :: SomeException -> JSM ()
exception SomeException
ex = MisoString -> JSM ()
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)
--------------------------------------------------
-- | Internally used for runView parent and startComponent
-- Initial draw helper
-- If hydrateing, bypass diff and continue copying
drawComponent
  :: Hydrate
  -> DOMRef
  -> Component parent model action
  -> Sink action
  -> JSM ([DOMRef], JSVal, IORef VTree)
drawComponent :: forall parent model action.
Hydrate
-> JSVal
-> Component parent model action
-> Sink action
-> JSM ([JSVal], JSVal, IORef VTree)
drawComponent Hydrate
hydrate JSVal
mountElement Component {model
[Binding parent model]
[JS]
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View model action
action -> Effect parent model action
Mail -> Maybe action
bindings :: forall parent model action.
Component parent model action -> [Binding parent model]
mailbox :: forall parent model action.
Component parent model action -> Mail -> Maybe action
logLevel :: forall parent model action.
Component parent model action -> LogLevel
mountPoint :: forall parent model action.
Component parent model action -> Maybe MisoString
initialAction :: forall parent model action.
Component parent model action -> Maybe action
scripts :: forall parent model action. Component parent model action -> [JS]
styles :: forall parent model action. Component parent model action -> [CSS]
events :: forall parent model action. Component parent model action -> Events
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
model :: forall parent model action. Component parent model action -> model
model :: model
update :: action -> Effect parent model action
view :: model -> View model action
subs :: [Sub action]
events :: Events
styles :: [CSS]
scripts :: [JS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
mailbox :: Mail -> Maybe action
bindings :: [Binding parent model]
..} Sink action
snk = do
  refs <- [JSVal] -> [JSVal] -> [JSVal]
forall a. [a] -> [a] -> [a]
(++) ([JSVal] -> [JSVal] -> [JSVal])
-> JSM [JSVal] -> JSM ([JSVal] -> [JSVal])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [JS] -> JSM [JSVal]
renderScripts [JS]
scripts JSM ([JSVal] -> [JSVal]) -> JSM [JSVal] -> JSM [JSVal]
forall a b. JSM (a -> b) -> JSM a -> JSM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [CSS] -> JSM [JSVal]
renderStyles [CSS]
styles
  vtree <- runView hydrate (view model) snk logLevel events
  when (hydrate == Draw) (diff Nothing (Just vtree) mountElement)
  ref <- liftIO (newIORef vtree)
  pure (refs, mountElement, ref)
-----------------------------------------------------------------------------
-- | Drains the event queue before unmounting, executed synchronously
drain
  :: Component parent model action
  -> ComponentState model action
  -> JSM ()
drain :: forall parent model action.
Component parent model action
-> ComponentState model action -> JSM ()
drain app :: Component parent model action
app@Component{model
[Binding parent model]
[JS]
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View model action
action -> Effect parent model action
Mail -> Maybe action
bindings :: forall parent model action.
Component parent model action -> [Binding parent model]
mailbox :: forall parent model action.
Component parent model action -> Mail -> Maybe action
logLevel :: forall parent model action.
Component parent model action -> LogLevel
mountPoint :: forall parent model action.
Component parent model action -> Maybe MisoString
initialAction :: forall parent model action.
Component parent model action -> Maybe action
scripts :: forall parent model action. Component parent model action -> [JS]
styles :: forall parent model action. Component parent model action -> [CSS]
events :: forall parent model action. Component parent model action -> Events
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
model :: forall parent model action. Component parent model action -> model
model :: model
update :: action -> Effect parent model action
view :: model -> View model action
subs :: [Sub action]
events :: Events
styles :: [CSS]
scripts :: [JS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
mailbox :: Mail -> Maybe action
bindings :: [Binding parent model]
..} cs :: ComponentState model action
cs@ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
ThreadId
IORef model
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Mailbox
action -> JSM ()
componentServe :: forall model action. ComponentState model action -> IO ()
componentChildToParentThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentParentToChildThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentDiffs :: forall model action. ComponentState model action -> Mailbox
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentScripts :: forall model action. ComponentState model action -> [JSVal]
componentMailbox :: forall model action. ComponentState model action -> Mailbox
componentActions :: forall model action.
ComponentState model action -> IORef (Seq action)
componentModelNew :: forall model action. ComponentState model action -> IORef model
componentModelCurrent :: forall model action. ComponentState model action -> IORef model
componentSink :: forall model action.
ComponentState model action -> action -> JSM ()
componentVTree :: forall model action. ComponentState model action -> IORef VTree
componentDOMRef :: forall model action. ComponentState model action -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentId :: forall model action. ComponentState model action -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModelCurrent :: IORef model
componentModelNew :: IORef model
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentServe :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
..} = do
  actions <- IO (Seq action) -> JSM (Seq action)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Seq action) -> JSM (Seq action))
-> IO (Seq action) -> JSM (Seq action)
forall a b. (a -> b) -> a -> b
$ IORef (Seq action)
-> (Seq action -> (Seq action, Seq action)) -> IO (Seq action)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Seq action)
componentActions ((Seq action -> (Seq action, Seq action)) -> IO (Seq action))
-> (Seq action -> (Seq action, Seq action)) -> IO (Seq action)
forall a b. (a -> b) -> a -> b
$ \Seq action
actions -> (Seq action
forall a. Seq a
S.empty, Seq action
actions)
  let info = Int -> JSVal -> ComponentInfo parent
forall parent. Int -> JSVal -> ComponentInfo parent
ComponentInfo Int
componentId JSVal
componentDOMRef
  if S.null actions then pure () else go info actions
  unloadScripts cs
      where
        go :: ComponentInfo parent -> t action -> JSM ()
go ComponentInfo parent
info t action
actions = do
          x <- IO model -> JSM model
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef model -> IO model
forall a. IORef a -> IO a
readIORef IORef model
componentModelCurrent)
          y <- foldEffects update Sync info componentSink (toList actions) x
          liftIO (atomicWriteIORef componentModelCurrent y)
          drain app cs
-----------------------------------------------------------------------------
-- | Post unmount call to drop the <style> and <script> in <head>
unloadScripts :: ComponentState model action -> JSM ()
unloadScripts :: forall model action. ComponentState model action -> JSM ()
unloadScripts ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
ThreadId
IORef model
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Mailbox
action -> JSM ()
componentServe :: forall model action. ComponentState model action -> IO ()
componentChildToParentThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentParentToChildThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentDiffs :: forall model action. ComponentState model action -> Mailbox
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentScripts :: forall model action. ComponentState model action -> [JSVal]
componentMailbox :: forall model action. ComponentState model action -> Mailbox
componentActions :: forall model action.
ComponentState model action -> IORef (Seq action)
componentModelNew :: forall model action. ComponentState model action -> IORef model
componentModelCurrent :: forall model action. ComponentState model action -> IORef model
componentSink :: forall model action.
ComponentState model action -> action -> JSM ()
componentVTree :: forall model action. ComponentState model action -> IORef VTree
componentDOMRef :: forall model action. ComponentState model action -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentId :: forall model action. ComponentState model action -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModelCurrent :: IORef model
componentModelNew :: IORef model
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentServe :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
..} = do
  [JSVal] -> (JSVal -> JSM JSVal) -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [JSVal]
componentScripts ((JSVal -> JSM JSVal) -> JSM ()) -> (JSVal -> JSM JSVal) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \JSVal
domRef ->
    -- dmj: abstract this out into context
    forall a. ToJSString a => a -> JSM JSVal
jsg @MisoString MisoString
"document"
      JSM JSVal -> MisoString -> JSM JSVal
forall this name.
(MakeObject this, ToJSString name) =>
this -> name -> JSM JSVal
! (MisoString
"head" :: MisoString)
      # ("removeChild" :: MisoString)
      ([JSVal] -> JSM JSVal) -> [JSVal] -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ [JSVal
domRef]
-----------------------------------------------------------------------------
-- | Helper function for cleanly destroying a @Component@
unmount
  :: Function
  -> Component parent model action
  -> ComponentState model action
  -> JSM ()
unmount :: forall parent model action.
Function
-> Component parent model action
-> ComponentState model action
-> JSM ()
unmount Function
mountCallback app :: Component parent model action
app@Component {model
[Binding parent model]
[JS]
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Events
LogLevel
model -> View model action
action -> Effect parent model action
Mail -> Maybe action
bindings :: forall parent model action.
Component parent model action -> [Binding parent model]
mailbox :: forall parent model action.
Component parent model action -> Mail -> Maybe action
logLevel :: forall parent model action.
Component parent model action -> LogLevel
mountPoint :: forall parent model action.
Component parent model action -> Maybe MisoString
initialAction :: forall parent model action.
Component parent model action -> Maybe action
scripts :: forall parent model action. Component parent model action -> [JS]
styles :: forall parent model action. Component parent model action -> [CSS]
events :: forall parent model action. Component parent model action -> Events
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
model :: forall parent model action. Component parent model action -> model
model :: model
update :: action -> Effect parent model action
view :: model -> View model action
subs :: [Sub action]
events :: Events
styles :: [CSS]
scripts :: [JS]
initialAction :: Maybe action
mountPoint :: Maybe MisoString
logLevel :: LogLevel
mailbox :: Mail -> Maybe action
bindings :: [Binding parent model]
..} cs :: ComponentState model action
cs@ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
ThreadId
IORef model
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Mailbox
action -> JSM ()
componentServe :: forall model action. ComponentState model action -> IO ()
componentChildToParentThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentParentToChildThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentDiffs :: forall model action. ComponentState model action -> Mailbox
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentScripts :: forall model action. ComponentState model action -> [JSVal]
componentMailbox :: forall model action. ComponentState model action -> Mailbox
componentActions :: forall model action.
ComponentState model action -> IORef (Seq action)
componentModelNew :: forall model action. ComponentState model action -> IORef model
componentModelCurrent :: forall model action. ComponentState model action -> IORef model
componentSink :: forall model action.
ComponentState model action -> action -> JSM ()
componentVTree :: forall model action. ComponentState model action -> IORef VTree
componentDOMRef :: forall model action. ComponentState model action -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentId :: forall model action. ComponentState model action -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModelCurrent :: IORef model
componentModelNew :: IORef model
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentServe :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
..} = do
  JSVal -> IORef VTree -> Events -> Bool -> JSM ()
undelegator JSVal
componentDOMRef IORef VTree
componentVTree Events
events (LogLevel
logLevel LogLevel -> [LogLevel] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [LogLevel
DebugEvents, LogLevel
DebugAll])
  Function -> JSM ()
freeFunction Function
mountCallback
  IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ThreadId -> IO ()
killThread ThreadId
componentMailboxThreadId)
  IO () -> JSM ()
forall a. IO a -> JSM 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)
  IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((ThreadId -> IO ()) -> Maybe ThreadId -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread Maybe ThreadId
componentParentToChildThreadId)
  IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((ThreadId -> IO ()) -> Maybe ThreadId -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread Maybe ThreadId
componentChildToParentThreadId)
  Int -> JSM ()
killSubscribers Int
componentId
  Component parent model action
-> ComponentState model action -> JSM ()
forall parent model action.
Component parent model action
-> ComponentState model action -> JSM ()
drain Component parent model action
app ComponentState model action
cs
  IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ IORef (IntMap (ComponentState (ZonkAny 12) (ZonkAny 13)))
-> (IntMap (ComponentState (ZonkAny 12) (ZonkAny 13))
    -> (IntMap (ComponentState (ZonkAny 12) (ZonkAny 13)), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (IntMap (ComponentState (ZonkAny 12) (ZonkAny 13)))
forall model action. IORef (IntMap (ComponentState model action))
components ((IntMap (ComponentState (ZonkAny 12) (ZonkAny 13))
  -> (IntMap (ComponentState (ZonkAny 12) (ZonkAny 13)), ()))
 -> IO ())
-> (IntMap (ComponentState (ZonkAny 12) (ZonkAny 13))
    -> (IntMap (ComponentState (ZonkAny 12) (ZonkAny 13)), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \IntMap (ComponentState (ZonkAny 12) (ZonkAny 13))
m -> (Int
-> IntMap (ComponentState (ZonkAny 12) (ZonkAny 13))
-> IntMap (ComponentState (ZonkAny 12) (ZonkAny 13))
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
componentId IntMap (ComponentState (ZonkAny 12) (ZonkAny 13))
m, ())
  Int -> JSM ()
finalizeWebSockets Int
componentId
  Int -> JSM ()
finalizeEventSources Int
componentId
  ComponentState model action -> JSM ()
forall model action. ComponentState model action -> JSM ()
unloadScripts ComponentState model action
cs
-----------------------------------------------------------------------------
killSubscribers :: ComponentId -> JSM ()
killSubscribers :: Int -> JSM ()
killSubscribers Int
componentId =
  (Topic (ZonkAny 11) -> JSM ()) -> [Topic (ZonkAny 11)] -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Topic (ZonkAny 11) -> Int -> JSM ())
-> Int -> Topic (ZonkAny 11) -> JSM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Topic (ZonkAny 11) -> Int -> JSM ()
forall message. Topic message -> Int -> JSM ()
unsubscribe_ Int
componentId) ([Topic (ZonkAny 11)] -> JSM ())
-> JSM [Topic (ZonkAny 11)] -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Map (Topic (ZonkAny 11)) Mailbox -> [Topic (ZonkAny 11)]
forall k a. Map k a -> [k]
M.keys (Map (Topic (ZonkAny 11)) Mailbox -> [Topic (ZonkAny 11)])
-> JSM (Map (Topic (ZonkAny 11)) Mailbox)
-> JSM [Topic (ZonkAny 11)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map (Topic (ZonkAny 11)) Mailbox)
-> JSM (Map (Topic (ZonkAny 11)) Mailbox)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Map (Topic (ZonkAny 11)) Mailbox)
-> IO (Map (Topic (ZonkAny 11)) Mailbox)
forall a. IORef a -> IO a
readIORef IORef (Map (Topic (ZonkAny 11)) Mailbox)
forall a. IORef (Map (Topic a) Mailbox)
mailboxes)
-----------------------------------------------------------------------------
-- | 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.
runView
  :: Hydrate
  -> View model action
  -> Sink action
  -> LogLevel
  -> Events
  -> JSM VTree
runView :: forall model action.
Hydrate
-> View model action
-> Sink action
-> LogLevel
-> Events
-> JSM VTree
runView Hydrate
hydrate (VComp NS
ns MisoString
tag [Attribute action]
attrs (SomeComponent Component model model action
app)) Sink action
snk LogLevel
_ Events
_ = do
  mountCallback <- do
    (JSVal -> JSVal -> JSM ()) -> JSM Function
FFI.syncCallback2 ((JSVal -> JSVal -> JSM ()) -> JSM Function)
-> (JSVal -> JSVal -> JSM ()) -> JSM Function
forall a b. (a -> b) -> a -> b
$ \JSVal
domRef JSVal
continuation -> do
      ComponentState {..} <- Component model model action
-> ((action -> JSM ()) -> JSM ([JSVal], JSVal, IORef VTree))
-> JSM (ComponentState model action)
forall model parent action.
Eq model =>
Component parent model action
-> (Sink action -> JSM ([JSVal], JSVal, IORef VTree))
-> JSM (ComponentState model action)
initialize Component model model action
app (Hydrate
-> JSVal
-> Component model model action
-> (action -> JSM ())
-> JSM ([JSVal], JSVal, IORef VTree)
forall parent model action.
Hydrate
-> JSVal
-> Component parent model action
-> Sink action
-> JSM ([JSVal], JSVal, IORef VTree)
drawComponent Hydrate
hydrate JSVal
domRef Component model model action
app)
      vtree <- toJSVal =<< liftIO (readIORef componentVTree)
      vcompId <- toJSVal componentId
      FFI.set "componentId" vcompId (Object domRef)
      void $ call continuation global [vcompId, vtree]
  unmountCallback <- toJSVal =<< do
    FFI.syncCallback1 $ \JSVal
domRef -> do
      componentId <- JSM Int -> JSM Int
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSVal -> JSM Int
FFI.getComponentId JSVal
domRef)
      IM.lookup componentId <$> liftIO (readIORef components) >>= \case
        Maybe (ComponentState model action)
Nothing -> () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just ComponentState model action
componentState ->
          Function
-> Component model model action
-> ComponentState model action
-> JSM ()
forall parent model action.
Function
-> Component parent model action
-> ComponentState model action
-> JSM ()
unmount Function
mountCallback Component model model action
app ComponentState model action
componentState
  vcomp <- createNode "vcomp" ns tag
  setAttrs vcomp attrs snk (logLevel app) (events app)
  flip (FFI.set "children") vcomp =<< toJSVal ([] :: [MisoString])
  flip (FFI.set "mount") vcomp =<< toJSVal mountCallback
  FFI.set "unmount" unmountCallback vcomp
  pure (VTree vcomp)
runView Hydrate
hydrate (VNode NS
ns MisoString
tag [Attribute action]
attrs [View model action]
kids) Sink action
snk LogLevel
logLevel Events
events = do
  vnode <- MisoString -> NS -> MisoString -> JSM Object
createNode MisoString
"vnode" NS
ns MisoString
tag
  setAttrs vnode attrs snk logLevel events
  vchildren <- ghcjsPure . jsval =<< procreate
  FFI.set "children" vchildren vnode
  sync <- FFI.shouldSync =<< toJSVal vnode
  FFI.set "shouldSync" sync vnode
  pure $ VTree vnode
    where
      procreate :: JSM (SomeJSArray m)
procreate = do
        kidsViews <- [View model action]
-> (View model action -> JSM JSVal) -> JSM [JSVal]
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 -> JSM JSVal) -> JSM [JSVal])
-> (View model action -> JSM JSVal) -> JSM [JSVal]
forall a b. (a -> b) -> a -> b
$ \View model action
kid -> do
          VTree (Object vtree) <- Hydrate
-> View model action
-> Sink action
-> LogLevel
-> Events
-> JSM VTree
forall model action.
Hydrate
-> View model action
-> Sink action
-> LogLevel
-> Events
-> JSM VTree
runView Hydrate
hydrate View model action
kid Sink action
snk LogLevel
logLevel Events
events
          pure vtree
        ghcjsPure (JSArray.fromList kidsViews)
runView Hydrate
_ (VText MisoString
t) Sink action
_ LogLevel
_ Events
_ = do
  vtree <- JSM Object
create
  FFI.set "type" ("vtext" :: JSString) vtree
  FFI.set "ns" ("text" :: JSString) vtree
  FFI.set "text" t vtree
  pure $ VTree vtree
runView Hydrate
hydrate (VTextRaw MisoString
str) Sink action
snk LogLevel
logLevel Events
events =
  case MisoString -> [View (ZonkAny 17) action]
forall model action. MisoString -> [View model action]
parseView MisoString
str of
    [] ->
      Hydrate
-> View (ZonkAny 18) action
-> Sink action
-> LogLevel
-> Events
-> JSM VTree
forall model action.
Hydrate
-> View model action
-> Sink action
-> LogLevel
-> Events
-> JSM VTree
runView Hydrate
hydrate (MisoString -> View (ZonkAny 18) action
forall model action. MisoString -> View model action
VText (MisoString
" " :: MisoString)) Sink action
snk LogLevel
logLevel Events
events
    [View (ZonkAny 17) action
parent_] ->
      Hydrate
-> View (ZonkAny 17) action
-> Sink action
-> LogLevel
-> Events
-> JSM VTree
forall model action.
Hydrate
-> View model action
-> Sink action
-> LogLevel
-> Events
-> JSM VTree
runView Hydrate
hydrate View (ZonkAny 17) action
parent_ Sink action
snk LogLevel
logLevel Events
events
    [View (ZonkAny 17) action]
kids -> do
      Hydrate
-> View (ZonkAny 17) action
-> Sink action
-> LogLevel
-> Events
-> JSM VTree
forall model action.
Hydrate
-> View model action
-> Sink action
-> LogLevel
-> Events
-> JSM VTree
runView Hydrate
hydrate (NS
-> MisoString
-> [Attribute action]
-> [View (ZonkAny 17) action]
-> View (ZonkAny 17) action
forall model action.
NS
-> MisoString
-> [Attribute action]
-> [View model action]
-> View model action
VNode NS
HTML MisoString
"div" [Attribute action]
forall a. Monoid a => a
mempty [View (ZonkAny 17) action]
kids) Sink action
snk LogLevel
logLevel Events
events
-----------------------------------------------------------------------------
-- | @createNode@
-- A helper function for constructing a vtree (used for 'vcomp' and 'vnode')
-- Doesn't handle children
createNode :: MisoString -> NS -> MisoString -> JSM Object
createNode :: MisoString -> NS -> MisoString -> JSM Object
createNode MisoString
typ NS
ns MisoString
tag = do
  vnode <- JSM Object
create
  cssObj <- create
  propsObj <- create
  eventsObj <- create
  FFI.set "css" cssObj vnode
  FFI.set "type" typ vnode
  FFI.set "props" propsObj vnode
  FFI.set "events" eventsObj vnode
  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
  -> JSM ()
setAttrs :: forall action.
Object
-> [Attribute action]
-> Sink action
-> LogLevel
-> Events
-> JSM ()
setAttrs Object
vnode [Attribute action]
attrs Sink action
snk LogLevel
logLevel Events
events =
  [Attribute action] -> (Attribute action -> JSM ()) -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Attribute action]
attrs ((Attribute action -> JSM ()) -> JSM ())
-> (Attribute action -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \case
    Property MisoString
"key" Mail
v -> do
      value <- Mail -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal Mail
v
      FFI.set "key" value vnode
    Property MisoString
k Mail
v -> do
      value <- Mail -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal Mail
v
      o <- getProp "props" vnode
      FFI.set k value (Object o)
    Event Sink action -> VTree -> LogLevel -> Events -> JSM ()
callback ->
      Sink action -> VTree -> LogLevel -> Events -> JSM ()
callback Sink action
snk (Object -> VTree
VTree Object
vnode) LogLevel
logLevel Events
events
    Styles Map MisoString MisoString
styles -> do
      cssObj <- JSString -> Object -> JSM JSVal
getProp JSString
"css" Object
vnode
      forM_ (M.toList styles) $ \(MisoString
k,MisoString
v) -> do
        MisoString -> MisoString -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
FFI.set MisoString
k MisoString
v (JSVal -> Object
Object JSVal
cssObj)
-----------------------------------------------------------------------------
-- | Used to support RawText, inlining of HTML.
-- Filters tree to only branches and leaves w/ Text tags.
-- converts to `View m a`. Note: if HTML is malformed,
-- (e.g. closing tags and opening tags are present) they will
-- be removed.
parseView :: MisoString -> [View model action]
parseView :: forall model action. MisoString -> [View model action]
parseView MisoString
html = [View model action] -> [View model action]
forall a. [a] -> [a]
reverse ([TagTree MisoString] -> [View model action] -> [View model action]
forall {model} {action}.
[TagTree MisoString] -> [View model action] -> [View model action]
go (MisoString -> [TagTree MisoString]
forall str. StringLike str => str -> [TagTree str]
parseTree MisoString
html) [])
  where
    go :: [TagTree MisoString] -> [View model action] -> [View model action]
go [] [View model action]
xs = [View model action]
xs
    go (TagLeaf (TagText MisoString
s) : [TagTree MisoString]
next) [View model action]
views =
      [TagTree MisoString] -> [View model action] -> [View model action]
go [TagTree MisoString]
next (MisoString -> View model action
forall model action. MisoString -> View model action
VText MisoString
s View model action -> [View model action] -> [View model action]
forall a. a -> [a] -> [a]
: [View model action]
views)
    go (TagLeaf (TagOpen MisoString
name [(MisoString, MisoString)]
attrs) : [TagTree MisoString]
next) [View model action]
views =
      [TagTree MisoString] -> [View model action] -> [View model action]
go (MisoString
-> [(MisoString, MisoString)]
-> [TagTree MisoString]
-> TagTree MisoString
forall str. str -> [Attribute str] -> [TagTree str] -> TagTree str
TagBranch MisoString
name [(MisoString, MisoString)]
attrs [] TagTree MisoString -> [TagTree MisoString] -> [TagTree MisoString]
forall a. a -> [a] -> [a]
: [TagTree MisoString]
next) [View model action]
views
    go (TagBranch MisoString
name [(MisoString, MisoString)]
attrs [TagTree MisoString]
kids : [TagTree MisoString]
next) [View model action]
views =
      let
        attrs' :: [Attribute action]
attrs' = [ MisoString -> MisoString -> Attribute action
forall action. MisoString -> MisoString -> Attribute action
textProp MisoString
key MisoString
value
                 | (MisoString
key, MisoString
value) <- [(MisoString, MisoString)]
attrs
                 ]
        newNode :: View model action
newNode =
          NS
-> MisoString
-> [Attribute action]
-> [View model action]
-> View model action
forall model action.
NS
-> MisoString
-> [Attribute action]
-> [View model action]
-> View model action
VNode NS
HTML MisoString
name [Attribute action]
forall {action}. [Attribute action]
attrs' ([View model action] -> [View model action]
forall a. [a] -> [a]
reverse ([TagTree MisoString] -> [View model action] -> [View model action]
go [TagTree MisoString]
kids []))
      in
        [TagTree MisoString] -> [View model action] -> [View model action]
go [TagTree MisoString]
next (View model action
newNodeView model action -> [View model action] -> [View model action]
forall a. a -> [a] -> [a]
:[View model action]
views)
    go (TagLeaf Tag MisoString
_ : [TagTree MisoString]
next) [View model action]
views =
      [TagTree MisoString] -> [View model action] -> [View model action]
go [TagTree MisoString]
next [View model action]
views
-----------------------------------------------------------------------------
-- | Registers components in the global state
registerComponent :: MonadIO m => ComponentState model action -> m ()
registerComponent :: forall (m :: * -> *) model action.
MonadIO m =>
ComponentState model action -> m ()
registerComponent ComponentState 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 model action))
-> (IntMap (ComponentState model action)
    -> IntMap (ComponentState model action))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (IntMap (ComponentState model action))
forall model action. IORef (IntMap (ComponentState model action))
components
  ((IntMap (ComponentState model action)
  -> IntMap (ComponentState model action))
 -> IO ())
-> (IntMap (ComponentState model action)
    -> IntMap (ComponentState model action))
-> IO ()
forall a b. (a -> b) -> a -> b
$ Int
-> ComponentState model action
-> IntMap (ComponentState model action)
-> IntMap (ComponentState model action)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (ComponentState model action -> Int
forall model action. ComponentState model action -> Int
componentId ComponentState model action
componentState) ComponentState model action
componentState
-----------------------------------------------------------------------------
-- | Renders styles
--
-- Meant for development purposes
-- Appends CSS to <head>
--
renderStyles :: [CSS] -> JSM [JSVal]
renderStyles :: [CSS] -> JSM [JSVal]
renderStyles [CSS]
styles =
  [CSS] -> (CSS -> JSM JSVal) -> JSM [JSVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CSS]
styles ((CSS -> JSM JSVal) -> JSM [JSVal])
-> (CSS -> JSM JSVal) -> JSM [JSVal]
forall a b. (a -> b) -> a -> b
$ \case
    Href MisoString
url -> MisoString -> JSM JSVal
FFI.addStyleSheet MisoString
url
    Style MisoString
css -> MisoString -> JSM JSVal
FFI.addStyle MisoString
css
    Sheet StyleSheet
sheet -> MisoString -> JSM JSVal
FFI.addStyle (StyleSheet -> MisoString
renderStyleSheet StyleSheet
sheet)
-----------------------------------------------------------------------------
-- | Renders scripts
--
-- Meant for development purposes
-- Appends JS to <head>
--
renderScripts :: [JS] -> JSM [JSVal]
renderScripts :: [JS] -> JSM [JSVal]
renderScripts [JS]
scripts =
  [JS] -> (JS -> JSM JSVal) -> JSM [JSVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [JS]
scripts ((JS -> JSM JSVal) -> JSM [JSVal])
-> (JS -> JSM JSVal) -> JSM [JSVal]
forall a b. (a -> b) -> a -> b
$ \case
    Src MisoString
src ->
      MisoString -> JSM JSVal
FFI.addSrc MisoString
src
    Script MisoString
script ->
      MisoString -> JSM JSVal
FFI.addScript MisoString
script
    ImportMap [(MisoString, MisoString)]
importMap -> do
      o <- JSM Object
create
      forM_ importMap $ \(MisoString
k,MisoString
v) ->
        MisoString -> MisoString -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
FFI.set MisoString
k MisoString
v Object
o
      FFI.addScriptImportMap
        =<< fromJSValUnchecked
        =<< (jsg @MisoString "JSON" # ("stringify" :: MisoString) $ [o])
-----------------------------------------------------------------------------
-- | Starts a named 'Sub' dynamically, during the life of a 'Component'.
-- The 'Sub' can be stopped by calling @Ord subKey => stop subKey@ from the 'update' function.
-- All 'Sub' started will be stopped if a '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 Sink action -> JSM ()
sub = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Sink action -> JSM ()]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    let vcompId = Int
_componentId
    IM.lookup vcompId <$> liftIO (readIORef components) >>= \case
      Maybe (ComponentState (ZonkAny 0) action)
Nothing -> () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just compState :: ComponentState (ZonkAny 0) action
compState@ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
ThreadId
IORef (ZonkAny 0)
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Mailbox
Sink action
componentServe :: forall model action. ComponentState model action -> IO ()
componentChildToParentThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentParentToChildThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentDiffs :: forall model action. ComponentState model action -> Mailbox
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentScripts :: forall model action. ComponentState model action -> [JSVal]
componentMailbox :: forall model action. ComponentState model action -> Mailbox
componentActions :: forall model action.
ComponentState model action -> IORef (Seq action)
componentModelNew :: forall model action. ComponentState model action -> IORef model
componentModelCurrent :: forall model action. ComponentState model action -> IORef model
componentSink :: forall model action.
ComponentState model action -> action -> JSM ()
componentVTree :: forall model action. ComponentState model action -> IORef VTree
componentDOMRef :: forall model action. ComponentState model action -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentId :: forall model action. ComponentState model action -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: Sink action
componentModelCurrent :: IORef (ZonkAny 0)
componentModelNew :: IORef (ZonkAny 0)
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentServe :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
..} -> do
        mtid <- IO (Maybe ThreadId) -> JSM (Maybe ThreadId)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MisoString -> Map MisoString ThreadId -> Maybe ThreadId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (subKey -> MisoString
forall str. ToMisoString str => str -> MisoString
ms subKey
subKey) (Map MisoString ThreadId -> Maybe ThreadId)
-> IO (Map MisoString ThreadId) -> IO (Maybe ThreadId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map MisoString ThreadId) -> IO (Map MisoString ThreadId)
forall a. IORef a -> IO a
readIORef IORef (Map MisoString ThreadId)
componentSubThreads)
        case mtid of
          Maybe ThreadId
Nothing ->
            ComponentState (ZonkAny 0) action -> JSM ()
forall {model}. ComponentState model action -> JSM ()
startThread ComponentState (ZonkAny 0) action
compState
          Just ThreadId
tid -> do
            status <- IO ThreadStatus -> JSM ThreadStatus
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ThreadId -> IO ThreadStatus
threadStatus ThreadId
tid)
            case status of
              ThreadStatus
ThreadFinished -> ComponentState (ZonkAny 0) action -> JSM ()
forall {model}. ComponentState model action -> JSM ()
startThread ComponentState (ZonkAny 0) action
compState
              ThreadStatus
ThreadDied -> ComponentState (ZonkAny 0) action -> JSM ()
forall {model}. ComponentState model action -> JSM ()
startThread ComponentState (ZonkAny 0) action
compState
              ThreadStatus
_ -> () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    startThread :: ComponentState model action -> JSM ()
startThread ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
ThreadId
IORef model
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Mailbox
Sink action
componentServe :: forall model action. ComponentState model action -> IO ()
componentChildToParentThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentParentToChildThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentDiffs :: forall model action. ComponentState model action -> Mailbox
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentScripts :: forall model action. ComponentState model action -> [JSVal]
componentMailbox :: forall model action. ComponentState model action -> Mailbox
componentActions :: forall model action.
ComponentState model action -> IORef (Seq action)
componentModelNew :: forall model action. ComponentState model action -> IORef model
componentModelCurrent :: forall model action. ComponentState model action -> IORef model
componentSink :: forall model action.
ComponentState model action -> action -> JSM ()
componentVTree :: forall model action. ComponentState model action -> IORef VTree
componentDOMRef :: forall model action. ComponentState model action -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentId :: forall model action. ComponentState model action -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: Sink action
componentModelCurrent :: IORef model
componentModelNew :: IORef model
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentServe :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
..} = do
      tid <- JSM () -> JSM ThreadId
FFI.forkJSM (Sink action -> JSM ()
sub Sink action
componentSink)
      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 (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 'Component'.
-- All 'Sub' started will be stopped automatically if a '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) [Sink action -> JSM ()] model Identity Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ComponentInfo parent -> Int
forall parent. ComponentInfo parent -> Int
_componentId
  io_ $ do
    IM.lookup vcompId <$> liftIO (readIORef components) >>= \case
      Maybe (ComponentState (ZonkAny 1) (ZonkAny 2))
Nothing -> do
        () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
ThreadId
IORef (ZonkAny 1)
IORef (Map MisoString ThreadId)
IORef (Seq (ZonkAny 2))
IORef VTree
JSVal
Mailbox
ZonkAny 2 -> JSM ()
componentServe :: forall model action. ComponentState model action -> IO ()
componentChildToParentThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentParentToChildThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentDiffs :: forall model action. ComponentState model action -> Mailbox
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentScripts :: forall model action. ComponentState model action -> [JSVal]
componentMailbox :: forall model action. ComponentState model action -> Mailbox
componentActions :: forall model action.
ComponentState model action -> IORef (Seq action)
componentModelNew :: forall model action. ComponentState model action -> IORef model
componentModelCurrent :: forall model action. ComponentState model action -> IORef model
componentSink :: forall model action.
ComponentState model action -> action -> JSM ()
componentVTree :: forall model action. ComponentState model action -> IORef VTree
componentDOMRef :: forall model action. ComponentState model action -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentId :: forall model action. ComponentState model action -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: ZonkAny 2 -> JSM ()
componentModelCurrent :: IORef (ZonkAny 1)
componentModelNew :: IORef (ZonkAny 1)
componentActions :: IORef (Seq (ZonkAny 2))
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentServe :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
..} -> do
        mtid <- IO (Maybe ThreadId) -> JSM (Maybe ThreadId)
forall a. IO a -> JSM 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 () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
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 'Component' mailbox, by 'ComponentId'
--
-- @
-- mail componentId ("test message" :: MisoString) :: Effect parent model action
-- @
--
-- @since 1.9.0.0
mail
  :: ToJSON message
  => ComponentId
  -> message
  -> Effect parent model action
mail :: forall message parent model action.
ToJSON message =>
Int -> message -> Effect parent model action
mail Int
vcompId message
message = JSM () -> Effect parent model action
forall parent model action. JSM () -> Effect parent model action
io_ (JSM () -> Effect parent model action)
-> JSM () -> Effect parent model action
forall a b. (a -> b) -> a -> b
$
  Int
-> IntMap (ComponentState (ZonkAny 3) (ZonkAny 4))
-> Maybe (ComponentState (ZonkAny 3) (ZonkAny 4))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap (ComponentState (ZonkAny 3) (ZonkAny 4))
 -> Maybe (ComponentState (ZonkAny 3) (ZonkAny 4)))
-> JSM (IntMap (ComponentState (ZonkAny 3) (ZonkAny 4)))
-> JSM (Maybe (ComponentState (ZonkAny 3) (ZonkAny 4)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IntMap (ComponentState (ZonkAny 3) (ZonkAny 4)))
-> JSM (IntMap (ComponentState (ZonkAny 3) (ZonkAny 4)))
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (IntMap (ComponentState (ZonkAny 3) (ZonkAny 4)))
-> IO (IntMap (ComponentState (ZonkAny 3) (ZonkAny 4)))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState (ZonkAny 3) (ZonkAny 4)))
forall model action. IORef (IntMap (ComponentState model action))
components) JSM (Maybe (ComponentState (ZonkAny 3) (ZonkAny 4)))
-> (Maybe (ComponentState (ZonkAny 3) (ZonkAny 4)) -> JSM ())
-> JSM ()
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (ComponentState (ZonkAny 3) (ZonkAny 4))
Nothing ->
      -- dmj: TODO add DebugMail here
      () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
ThreadId
IORef (ZonkAny 3)
IORef (Map MisoString ThreadId)
IORef (Seq (ZonkAny 4))
IORef VTree
JSVal
Mailbox
ZonkAny 4 -> JSM ()
componentServe :: forall model action. ComponentState model action -> IO ()
componentChildToParentThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentParentToChildThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentDiffs :: forall model action. ComponentState model action -> Mailbox
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentScripts :: forall model action. ComponentState model action -> [JSVal]
componentMailbox :: forall model action. ComponentState model action -> Mailbox
componentActions :: forall model action.
ComponentState model action -> IORef (Seq action)
componentModelNew :: forall model action. ComponentState model action -> IORef model
componentModelCurrent :: forall model action. ComponentState model action -> IORef model
componentSink :: forall model action.
ComponentState model action -> action -> JSM ()
componentVTree :: forall model action. ComponentState model action -> IORef VTree
componentDOMRef :: forall model action. ComponentState model action -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentId :: forall model action. ComponentState model action -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: ZonkAny 4 -> JSM ()
componentModelCurrent :: IORef (ZonkAny 3)
componentModelNew :: IORef (ZonkAny 3)
componentActions :: IORef (Seq (ZonkAny 4))
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentServe :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
..} ->
      IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ Mailbox -> Mail -> IO ()
sendMail Mailbox
componentMailbox (message -> Mail
forall a. ToJSON a => a -> Mail
toJSON message
message)
-----------------------------------------------------------------------------
-- | Send any @ToJSON message => message@ to the parent's @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
message = do
  domRef <- (ComponentInfo parent -> JSVal)
-> RWST
     (ComponentInfo parent) [Sink action -> JSM ()] model Identity JSVal
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ComponentInfo parent -> JSVal
forall parent. ComponentInfo parent -> JSVal
_componentDOMRef
  io_ $ do
    FFI.getParentComponentId domRef >>= \case
      Maybe Int
Nothing ->
        () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just Int
vcompId ->
        Int
-> IntMap (ComponentState (ZonkAny 5) (ZonkAny 6))
-> Maybe (ComponentState (ZonkAny 5) (ZonkAny 6))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (IntMap (ComponentState (ZonkAny 5) (ZonkAny 6))
 -> Maybe (ComponentState (ZonkAny 5) (ZonkAny 6)))
-> JSM (IntMap (ComponentState (ZonkAny 5) (ZonkAny 6)))
-> JSM (Maybe (ComponentState (ZonkAny 5) (ZonkAny 6)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IntMap (ComponentState (ZonkAny 5) (ZonkAny 6)))
-> JSM (IntMap (ComponentState (ZonkAny 5) (ZonkAny 6)))
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (IntMap (ComponentState (ZonkAny 5) (ZonkAny 6)))
-> IO (IntMap (ComponentState (ZonkAny 5) (ZonkAny 6)))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState (ZonkAny 5) (ZonkAny 6)))
forall model action. IORef (IntMap (ComponentState model action))
components) JSM (Maybe (ComponentState (ZonkAny 5) (ZonkAny 6)))
-> (Maybe (ComponentState (ZonkAny 5) (ZonkAny 6)) -> JSM ())
-> JSM ()
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe (ComponentState (ZonkAny 5) (ZonkAny 6))
Nothing ->
            -- dmj: TODO add DebugMail here
            () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
ThreadId
IORef (ZonkAny 5)
IORef (Map MisoString ThreadId)
IORef (Seq (ZonkAny 6))
IORef VTree
JSVal
Mailbox
ZonkAny 6 -> JSM ()
componentServe :: forall model action. ComponentState model action -> IO ()
componentChildToParentThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentParentToChildThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentDiffs :: forall model action. ComponentState model action -> Mailbox
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentScripts :: forall model action. ComponentState model action -> [JSVal]
componentMailbox :: forall model action. ComponentState model action -> Mailbox
componentActions :: forall model action.
ComponentState model action -> IORef (Seq action)
componentModelNew :: forall model action. ComponentState model action -> IORef model
componentModelCurrent :: forall model action. ComponentState model action -> IORef model
componentSink :: forall model action.
ComponentState model action -> action -> JSM ()
componentVTree :: forall model action. ComponentState model action -> IORef VTree
componentDOMRef :: forall model action. ComponentState model action -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentId :: forall model action. ComponentState model action -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: ZonkAny 6 -> JSM ()
componentModelCurrent :: IORef (ZonkAny 5)
componentModelNew :: IORef (ZonkAny 5)
componentActions :: IORef (Seq (ZonkAny 6))
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentServe :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
..} ->
            IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ Mailbox -> Mail -> IO ()
sendMail Mailbox
componentMailbox (message -> Mail
forall a. ToJSON a => a -> Mail
toJSON message
message)
----------------------------------------------------------------------------
-- | Helper function for processing 'Mail' from 'mail'.
--
-- @
--
-- data Action
--   = ParsedMail Message
--   | ErrorMail MisoString
--
-- 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) -> Mail -> Maybe action
checkMail value -> action
successful MisoString -> action
errorful Mail
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 Mail -> Result value
forall a. FromJSON a => Mail -> Result a
fromJSON Mail
value of
    Success value
x -> value -> action
successful value
x
    Error String
err -> MisoString -> action
errorful (String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms String
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)
  [Sink action -> JSM ()]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink -> do
    JSVal -> JSM (Maybe Int)
FFI.getParentComponentId JSVal
_componentDOMRef JSM (Maybe Int) -> (Maybe Int -> JSM ()) -> JSM ()
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Int
Nothing ->
        Sink action
sink action
errorful
      Just Int
parentId -> do
        Int
-> IntMap (ComponentState parent (ZonkAny 7))
-> Maybe (ComponentState parent (ZonkAny 7))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
parentId (IntMap (ComponentState parent (ZonkAny 7))
 -> Maybe (ComponentState parent (ZonkAny 7)))
-> JSM (IntMap (ComponentState parent (ZonkAny 7)))
-> JSM (Maybe (ComponentState parent (ZonkAny 7)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IntMap (ComponentState parent (ZonkAny 7)))
-> JSM (IntMap (ComponentState parent (ZonkAny 7)))
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (IntMap (ComponentState parent (ZonkAny 7)))
-> IO (IntMap (ComponentState parent (ZonkAny 7)))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState parent (ZonkAny 7)))
forall model action. IORef (IntMap (ComponentState model action))
components) JSM (Maybe (ComponentState parent (ZonkAny 7)))
-> (Maybe (ComponentState parent (ZonkAny 7)) -> JSM ()) -> JSM ()
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe (ComponentState parent (ZonkAny 7))
Nothing -> Sink action
sink action
errorful
          Just ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
ThreadId
IORef parent
IORef (Map MisoString ThreadId)
IORef (Seq (ZonkAny 7))
IORef VTree
JSVal
Mailbox
ZonkAny 7 -> JSM ()
componentServe :: forall model action. ComponentState model action -> IO ()
componentChildToParentThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentParentToChildThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentDiffs :: forall model action. ComponentState model action -> Mailbox
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentScripts :: forall model action. ComponentState model action -> [JSVal]
componentMailbox :: forall model action. ComponentState model action -> Mailbox
componentActions :: forall model action.
ComponentState model action -> IORef (Seq action)
componentModelNew :: forall model action. ComponentState model action -> IORef model
componentModelCurrent :: forall model action. ComponentState model action -> IORef model
componentSink :: forall model action.
ComponentState model action -> action -> JSM ()
componentVTree :: forall model action. ComponentState model action -> IORef VTree
componentDOMRef :: forall model action. ComponentState model action -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentId :: forall model action. ComponentState model action -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: ZonkAny 7 -> JSM ()
componentModelCurrent :: IORef parent
componentModelNew :: IORef parent
componentActions :: IORef (Seq (ZonkAny 7))
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentServe :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
..} -> do
            model <- IO parent -> JSM parent
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef parent -> IO parent
forall a. IORef a -> IO a
readIORef IORef parent
componentModelCurrent)
            sink (successful model)
-----------------------------------------------------------------------------
-- | Sends a message to all @Component@ 'mailbox', excluding oneself.
--
-- @
--
--   broadcast (String "public service announcement")
--
-- @
--
-- @since 1.9.0.0
broadcast
  :: ToJSON message
  => message
  -> Effect parent model action
broadcast :: forall message parent model action.
ToJSON message =>
message -> Effect parent model action
broadcast message
message = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Sink action -> JSM ()]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    vcomps <- liftIO (readIORef components)
    forM_ (IM.toList vcomps) $ \(Int
vcompId, ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
ThreadId
IORef (ZonkAny 8)
IORef (Map MisoString ThreadId)
IORef (Seq (ZonkAny 9))
IORef VTree
JSVal
Mailbox
ZonkAny 9 -> JSM ()
componentServe :: forall model action. ComponentState model action -> IO ()
componentChildToParentThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentParentToChildThreadId :: forall model action. ComponentState model action -> Maybe ThreadId
componentDiffs :: forall model action. ComponentState model action -> Mailbox
componentMailboxThreadId :: forall model action. ComponentState model action -> ThreadId
componentScripts :: forall model action. ComponentState model action -> [JSVal]
componentMailbox :: forall model action. ComponentState model action -> Mailbox
componentActions :: forall model action.
ComponentState model action -> IORef (Seq action)
componentModelNew :: forall model action. ComponentState model action -> IORef model
componentModelCurrent :: forall model action. ComponentState model action -> IORef model
componentSink :: forall model action.
ComponentState model action -> action -> JSM ()
componentVTree :: forall model action. ComponentState model action -> IORef VTree
componentDOMRef :: forall model action. ComponentState model action -> JSVal
componentSubThreads :: forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentId :: forall model action. ComponentState model action -> Int
componentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: ZonkAny 9 -> JSM ()
componentModelCurrent :: IORef (ZonkAny 8)
componentModelNew :: IORef (ZonkAny 8)
componentActions :: IORef (Seq (ZonkAny 9))
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentServe :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
..}) ->
      Bool -> JSM () -> JSM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
_componentId Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
vcompId) (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
        IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ Mailbox -> Mail -> IO ()
sendMail Mailbox
componentMailbox (message -> Mail
forall a. ToJSON a => a -> Mail
toJSON message
message)
-----------------------------------------------------------------------------
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))
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/WebSocket/WebSocket>
websocketConnect
  :: URL
  -- ^ WebSocket URL
  -> (WebSocket -> action)
  -- ^ onOpen
  -> (Closed -> action)
  -- ^ onClosed
  -> (JSVal -> action)
  -- ^ onMessage
  -> (JSVal -> action)
  -- ^ onError
  -> Effect parent model action
websocketConnect :: forall action parent model.
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (JSVal -> action)
-> (JSVal -> action)
-> Effect parent model action
websocketConnect MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed JSVal -> action
onError JSVal -> action
onMessage = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Sink action -> JSM ()]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink -> do
    webSocketId <- JSM WebSocket
freshWebSocket
    socket <- FFI.websocketConnect url
      (sink $ onOpen webSocketId)
      (sink . onClosed <=< fromJSValUnchecked)
      (sink . onMessage)
      (sink . onError)
    insertWebSocket _componentId webSocketId socket
  where
    insertWebSocket :: ComponentId -> WebSocket -> Socket -> JSM ()
    insertWebSocket :: Int -> WebSocket -> JSVal -> JSM ()
insertWebSocket Int
componentId (WebSocket Int
socketId) JSVal
socket =
      IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$
        IORef WebSockets -> (WebSockets -> (WebSockets, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef WebSockets
websocketConnections ((WebSockets -> (WebSockets, ())) -> IO ())
-> (WebSockets -> (WebSockets, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WebSockets
websockets ->
          (WebSockets -> WebSockets
update WebSockets
websockets, ())
      where
        update :: WebSockets -> WebSockets
update WebSockets
websockets =
          (IntMap JSVal -> IntMap JSVal -> IntMap JSVal)
-> WebSockets -> WebSockets -> WebSockets
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith IntMap JSVal -> IntMap JSVal -> IntMap JSVal
forall a. IntMap a -> IntMap a -> IntMap a
IM.union WebSockets
websockets
            (WebSockets -> WebSockets) -> WebSockets -> WebSockets
forall a b. (a -> b) -> a -> b
$ Int -> IntMap JSVal -> WebSockets
forall a. Int -> a -> IntMap a
IM.singleton Int
componentId
            (IntMap JSVal -> WebSockets) -> IntMap JSVal -> WebSockets
forall a b. (a -> b) -> a -> b
$ Int -> JSVal -> IntMap JSVal
forall a. Int -> a -> IntMap a
IM.singleton Int
socketId JSVal
socket
  
    freshWebSocket :: JSM WebSocket
    freshWebSocket :: JSM WebSocket
freshWebSocket = Int -> WebSocket
WebSocket (Int -> WebSocket) -> JSM Int -> JSM WebSocket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      IO Int -> JSM Int
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
websocketConnectionIds ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
x -> (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
x))
-----------------------------------------------------------------------------
getWebSocket :: ComponentId -> WebSocket -> WebSockets -> Maybe Socket
getWebSocket :: Int -> WebSocket -> WebSockets -> Maybe JSVal
getWebSocket Int
vcompId (WebSocket Int
websocketId) =
  Int -> IntMap JSVal -> Maybe JSVal
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
websocketId (IntMap JSVal -> Maybe JSVal)
-> (WebSockets -> Maybe (IntMap JSVal))
-> WebSockets
-> Maybe JSVal
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId
-----------------------------------------------------------------------------
finalizeWebSockets :: ComponentId -> JSM ()
finalizeWebSockets :: Int -> JSM ()
finalizeWebSockets Int
vcompId = do
  (IntMap JSVal -> JSM ()) -> Maybe (IntMap JSVal) -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((JSVal -> JSM ()) -> [JSVal] -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ JSVal -> JSM ()
FFI.websocketClose ([JSVal] -> JSM ())
-> (IntMap JSVal -> [JSVal]) -> IntMap JSVal -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap JSVal -> [JSVal]
forall a. IntMap a -> [a]
IM.elems) (Maybe (IntMap JSVal) -> JSM ())
-> JSM (Maybe (IntMap JSVal)) -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (WebSockets -> Maybe (IntMap JSVal))
-> JSM WebSockets -> JSM (Maybe (IntMap JSVal))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO WebSockets -> JSM WebSockets
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef WebSockets -> IO WebSockets
forall a. IORef a -> IO a
readIORef IORef WebSockets
websocketConnections)
  JSM ()
dropComponentWebSockets
    where
      dropComponentWebSockets :: JSM ()
      dropComponentWebSockets :: JSM ()
dropComponentWebSockets = IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$
        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)
  [Sink action -> JSM ()]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    result <- liftIO $
      atomicModifyIORef' websocketConnections $ \WebSockets
imap ->
        Int -> WebSocket -> WebSockets -> WebSockets
dropWebSocket Int
_componentId WebSocket
socketId WebSockets
imap WebSockets -> Maybe JSVal -> (WebSockets, Maybe JSVal)
forall k v. k -> v -> (k, v)
=:
          Int -> WebSocket -> WebSockets -> Maybe JSVal
getWebSocket Int
_componentId WebSocket
socketId WebSockets
imap
    case result of
      Maybe JSVal
Nothing ->
        () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just JSVal
socket ->
        JSVal -> JSM ()
FFI.websocketClose JSVal
socket
  where
    dropWebSocket :: ComponentId -> WebSocket -> WebSockets -> WebSockets
    dropWebSocket :: Int -> WebSocket -> WebSockets -> WebSockets
dropWebSocket Int
vcompId (WebSocket Int
websocketId) WebSockets
websockets = do
      case Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId WebSockets
websockets of
        Maybe (IntMap JSVal)
Nothing ->
          WebSockets
websockets
        Just IntMap JSVal
componentSockets ->
          Int -> IntMap JSVal -> WebSockets -> WebSockets
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
vcompId (Int -> IntMap JSVal -> IntMap JSVal
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
websocketId IntMap JSVal
componentSockets) WebSockets
websockets
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/WebSocket/send>
websocketSend :: WebSocket -> JSVal -> Effect parent model action
websocketSend :: forall parent model action.
WebSocket -> JSVal -> Effect parent model action
websocketSend WebSocket
socketId JSVal
msg = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Sink action -> JSM ()]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    getWebSocket _componentId socketId <$> liftIO (readIORef websocketConnections) >>= \case
      Maybe JSVal
Nothing -> () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just JSVal
socket -> JSVal -> JSVal -> JSM ()
FFI.websocketSend JSVal
socket JSVal
msg
-----------------------------------------------------------------------------
-- | Retrieves current status of `WebSocket`
--
-- If the '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)
  [Sink action -> JSM ()]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink -> do
     Int -> WebSocket -> WebSockets -> Maybe JSVal
getWebSocket Int
_componentId WebSocket
socketId (WebSockets -> Maybe JSVal) -> JSM WebSockets -> JSM (Maybe JSVal)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO WebSockets -> JSM WebSockets
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef WebSockets -> IO WebSockets
forall a. IORef a -> IO a
readIORef IORef WebSockets
websocketConnections) JSM (Maybe JSVal) -> (Maybe JSVal -> JSM ()) -> JSM ()
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just JSVal
socket -> do
        x <- JSVal
socket JSVal -> MisoString -> JSM JSVal
forall this name.
(MakeObject this, ToJSString name) =>
this -> name -> JSM JSVal
! (MisoString
"socketState" :: MisoString)
        socketstate <- toEnum <$> fromJSValUnchecked x
        sink (callback socketstate)
      Maybe JSVal
Nothing ->
        Sink action
sink (SocketState -> action
callback SocketState
CLOSED)
-----------------------------------------------------------------------------
codeToCloseCode :: Int -> CloseCode
codeToCloseCode :: Int -> CloseCode
codeToCloseCode = Int -> CloseCode
go
  where
    go :: Int -> CloseCode
go Int
1000 = CloseCode
CLOSE_NORMAL
    go Int
1001 = CloseCode
CLOSE_GOING_AWAY
    go Int
1002 = CloseCode
CLOSE_PROTOCOL_ERROR
    go Int
1003 = CloseCode
CLOSE_UNSUPPORTED
    go Int
1005 = CloseCode
CLOSE_NO_STATUS
    go Int
1006 = CloseCode
CLOSE_ABNORMAL
    go Int
1007 = CloseCode
Unsupported_Data
    go Int
1008 = CloseCode
Policy_Violation
    go Int
1009 = CloseCode
CLOSE_TOO_LARGE
    go Int
1010 = CloseCode
Missing_Extension
    go Int
1011 = CloseCode
Internal_Error
    go Int
1012 = CloseCode
Service_Restart
    go Int
1013 = CloseCode
Try_Again_Later
    go Int
1015 = CloseCode
TLS_Handshake
    go Int
n    = Int -> CloseCode
OtherCode Int
n
-----------------------------------------------------------------------------
data Closed
  = Closed
  { Closed -> CloseCode
closedCode :: CloseCode
  , Closed -> Bool
wasClean :: Bool
  , Closed -> MisoString
reason :: MisoString
  } deriving (Closed -> Closed -> Bool
(Closed -> Closed -> Bool)
-> (Closed -> Closed -> Bool) -> Eq Closed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Closed -> Closed -> Bool
== :: Closed -> Closed -> Bool
$c/= :: Closed -> Closed -> Bool
/= :: Closed -> Closed -> Bool
Eq, Int -> Closed -> ShowS
[Closed] -> ShowS
Closed -> String
(Int -> Closed -> ShowS)
-> (Closed -> String) -> ([Closed] -> ShowS) -> Show Closed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Closed -> ShowS
showsPrec :: Int -> Closed -> ShowS
$cshow :: Closed -> String
show :: Closed -> String
$cshowList :: [Closed] -> ShowS
showList :: [Closed] -> ShowS
Show)
-----------------------------------------------------------------------------
instance FromJSVal Closed where
  fromJSVal :: JSVal -> JSM (Maybe Closed)
fromJSVal JSVal
o = do
    closed_ <- (Int -> CloseCode) -> Maybe Int -> Maybe CloseCode
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> CloseCode
codeToCloseCode (Maybe Int -> Maybe CloseCode)
-> JSM (Maybe Int) -> JSM (Maybe CloseCode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do JSVal -> JSM (Maybe Int)
forall a. FromJSVal a => JSVal -> JSM (Maybe a)
fromJSVal (JSVal -> JSM (Maybe Int)) -> JSM JSVal -> JSM (Maybe Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal
o JSVal -> MisoString -> JSM JSVal
forall this name.
(MakeObject this, ToJSString name) =>
this -> name -> JSM JSVal
! (MisoString
"code" :: MisoString)
    wasClean_ <- fromJSVal =<< o ! ("wasClean" :: MisoString)
    reason_ <- fromJSVal =<< o ! ("reason" :: MisoString)
    pure (Closed <$> closed_ <*> wasClean_ <*> reason_)
-----------------------------------------------------------------------------
-- | URL that the @Websocket@ will @connect@ to
type URL = MisoString
-----------------------------------------------------------------------------
-- | `SocketState` corresponding to current 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, (forall x. CloseCode -> Rep CloseCode x)
-> (forall x. Rep CloseCode x -> CloseCode) -> Generic CloseCode
forall x. Rep CloseCode x -> CloseCode
forall x. CloseCode -> Rep CloseCode x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CloseCode -> Rep CloseCode x
from :: forall x. CloseCode -> Rep CloseCode x
$cto :: forall x. Rep CloseCode x -> CloseCode
to :: forall x. Rep CloseCode x -> CloseCode
Generic)
-----------------------------------------------------------------------------
instance ToJSVal CloseCode
-----------------------------------------------------------------------------
instance FromJSVal CloseCode
-----------------------------------------------------------------------------
newtype WebSocket = WebSocket Int
  deriving ([WebSocket] -> JSM JSVal
WebSocket -> JSM JSVal
(WebSocket -> JSM JSVal)
-> ([WebSocket] -> JSM JSVal) -> ToJSVal WebSocket
forall a. (a -> JSM JSVal) -> ([a] -> JSM JSVal) -> ToJSVal a
$ctoJSVal :: WebSocket -> JSM JSVal
toJSVal :: WebSocket -> JSM JSVal
$ctoJSValListOf :: [WebSocket] -> JSM JSVal
toJSValListOf :: [WebSocket] -> JSM JSVal
ToJSVal, WebSocket -> WebSocket -> Bool
(WebSocket -> WebSocket -> Bool)
-> (WebSocket -> WebSocket -> Bool) -> Eq WebSocket
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WebSocket -> WebSocket -> Bool
== :: WebSocket -> WebSocket -> Bool
$c/= :: WebSocket -> WebSocket -> Bool
/= :: WebSocket -> WebSocket -> Bool
Eq, Integer -> WebSocket
WebSocket -> WebSocket
WebSocket -> WebSocket -> WebSocket
(WebSocket -> WebSocket -> WebSocket)
-> (WebSocket -> WebSocket -> WebSocket)
-> (WebSocket -> WebSocket -> WebSocket)
-> (WebSocket -> WebSocket)
-> (WebSocket -> WebSocket)
-> (WebSocket -> WebSocket)
-> (Integer -> WebSocket)
-> Num WebSocket
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: WebSocket -> WebSocket -> WebSocket
+ :: WebSocket -> WebSocket -> WebSocket
$c- :: WebSocket -> WebSocket -> WebSocket
- :: WebSocket -> WebSocket -> WebSocket
$c* :: WebSocket -> WebSocket -> WebSocket
* :: WebSocket -> WebSocket -> WebSocket
$cnegate :: WebSocket -> WebSocket
negate :: WebSocket -> WebSocket
$cabs :: WebSocket -> WebSocket
abs :: WebSocket -> WebSocket
$csignum :: WebSocket -> WebSocket
signum :: WebSocket -> WebSocket
$cfromInteger :: Integer -> WebSocket
fromInteger :: Integer -> WebSocket
Num)
-----------------------------------------------------------------------------
emptyWebSocket :: WebSocket
emptyWebSocket :: WebSocket
emptyWebSocket = (-WebSocket
1)
-----------------------------------------------------------------------------
newtype EventSource = EventSource Int
  deriving ([EventSource] -> JSM JSVal
EventSource -> JSM JSVal
(EventSource -> JSM JSVal)
-> ([EventSource] -> JSM JSVal) -> ToJSVal EventSource
forall a. (a -> JSM JSVal) -> ([a] -> JSM JSVal) -> ToJSVal a
$ctoJSVal :: EventSource -> JSM JSVal
toJSVal :: EventSource -> JSM JSVal
$ctoJSValListOf :: [EventSource] -> JSM JSVal
toJSValListOf :: [EventSource] -> JSM JSVal
ToJSVal, EventSource -> EventSource -> Bool
(EventSource -> EventSource -> Bool)
-> (EventSource -> EventSource -> Bool) -> Eq EventSource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EventSource -> EventSource -> Bool
== :: EventSource -> EventSource -> Bool
$c/= :: EventSource -> EventSource -> Bool
/= :: EventSource -> EventSource -> Bool
Eq, Integer -> EventSource
EventSource -> EventSource
EventSource -> EventSource -> EventSource
(EventSource -> EventSource -> EventSource)
-> (EventSource -> EventSource -> EventSource)
-> (EventSource -> EventSource -> EventSource)
-> (EventSource -> EventSource)
-> (EventSource -> EventSource)
-> (EventSource -> EventSource)
-> (Integer -> EventSource)
-> Num EventSource
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: EventSource -> EventSource -> EventSource
+ :: EventSource -> EventSource -> EventSource
$c- :: EventSource -> EventSource -> EventSource
- :: EventSource -> EventSource -> EventSource
$c* :: EventSource -> EventSource -> EventSource
* :: EventSource -> EventSource -> EventSource
$cnegate :: EventSource -> EventSource
negate :: EventSource -> EventSource
$cabs :: EventSource -> EventSource
abs :: EventSource -> EventSource
$csignum :: EventSource -> EventSource
signum :: EventSource -> EventSource
$cfromInteger :: Integer -> EventSource
fromInteger :: Integer -> EventSource
Num)
-----------------------------------------------------------------------------
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>
eventSourceConnect
  :: URL
  -- ^ EventSource URL
  -> (EventSource -> action)
  -- ^ onOpen
  -> (JSVal -> action)
  -- ^ onMessage
  -> (JSVal -> action)
  -- ^ onError
  -> Effect parent model action
eventSourceConnect :: forall action parent model.
MisoString
-> (EventSource -> action)
-> (JSVal -> action)
-> (JSVal -> action)
-> Effect parent model action
eventSourceConnect MisoString
url EventSource -> action
onOpen JSVal -> action
onMessage JSVal -> action
onError = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Sink action -> JSM ()]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink -> do
    eventSourceId <- JSM EventSource
freshEventSource
    socket <- FFI.eventSourceConnect url
      (sink $ onOpen eventSourceId)
      (sink . onMessage)
      (sink . onError)
    insertEventSource _componentId eventSourceId socket
  where
    insertEventSource :: ComponentId -> EventSource -> Socket -> JSM ()
    insertEventSource :: Int -> EventSource -> JSVal -> JSM ()
insertEventSource Int
componentId (EventSource Int
socketId) JSVal
socket =
      IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$
        IORef WebSockets -> (WebSockets -> (WebSockets, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef WebSockets
eventSourceConnections ((WebSockets -> (WebSockets, ())) -> IO ())
-> (WebSockets -> (WebSockets, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WebSockets
eventSources ->
          (WebSockets -> WebSockets
update WebSockets
eventSources, ())
      where
        update :: WebSockets -> WebSockets
update WebSockets
eventSources =
          (IntMap JSVal -> IntMap JSVal -> IntMap JSVal)
-> WebSockets -> WebSockets -> WebSockets
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith IntMap JSVal -> IntMap JSVal -> IntMap JSVal
forall a. IntMap a -> IntMap a -> IntMap a
IM.union WebSockets
eventSources
            (WebSockets -> WebSockets) -> WebSockets -> WebSockets
forall a b. (a -> b) -> a -> b
$ Int -> IntMap JSVal -> WebSockets
forall a. Int -> a -> IntMap a
IM.singleton Int
componentId
            (IntMap JSVal -> WebSockets) -> IntMap JSVal -> WebSockets
forall a b. (a -> b) -> a -> b
$ Int -> JSVal -> IntMap JSVal
forall a. Int -> a -> IntMap a
IM.singleton Int
socketId JSVal
socket
  
    freshEventSource :: JSM EventSource
    freshEventSource :: JSM EventSource
freshEventSource = Int -> EventSource
EventSource (Int -> EventSource) -> JSM Int -> JSM EventSource
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      IO Int -> JSM Int
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
eventSourceConnectionIds ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \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)
  [Sink action -> JSM ()]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    result <- liftIO $
      atomicModifyIORef' eventSourceConnections $ \WebSockets
imap ->
        Int -> EventSource -> WebSockets -> WebSockets
dropEventSource Int
_componentId EventSource
socketId WebSockets
imap WebSockets -> Maybe JSVal -> (WebSockets, Maybe JSVal)
forall k v. k -> v -> (k, v)
=:
          Int -> EventSource -> WebSockets -> Maybe JSVal
getEventSource Int
_componentId EventSource
socketId WebSockets
imap
    case result of
      Maybe JSVal
Nothing ->
        () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just JSVal
socket ->
        JSVal -> JSM ()
FFI.eventSourceClose JSVal
socket
  where
    dropEventSource :: ComponentId -> EventSource -> EventSources -> EventSources
    dropEventSource :: Int -> EventSource -> WebSockets -> WebSockets
dropEventSource Int
vcompId (EventSource Int
eventSourceId) WebSockets
eventSources = do
      case Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId WebSockets
eventSources of
        Maybe (IntMap JSVal)
Nothing ->
          WebSockets
eventSources
        Just IntMap JSVal
componentSockets ->
          Int -> IntMap JSVal -> WebSockets -> WebSockets
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
vcompId (Int -> IntMap JSVal -> IntMap JSVal
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
eventSourceId IntMap JSVal
componentSockets) WebSockets
eventSources
  
    getEventSource :: ComponentId -> EventSource -> EventSources -> Maybe Socket
    getEventSource :: Int -> EventSource -> WebSockets -> Maybe JSVal
getEventSource Int
vcompId (EventSource Int
eventSourceId) =
      Int -> IntMap JSVal -> Maybe JSVal
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
eventSourceId (IntMap JSVal -> Maybe JSVal)
-> (WebSockets -> Maybe (IntMap JSVal))
-> WebSockets
-> Maybe JSVal
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId
-----------------------------------------------------------------------------
finalizeEventSources :: ComponentId -> JSM ()
finalizeEventSources :: Int -> JSM ()
finalizeEventSources Int
vcompId = do
  (IntMap JSVal -> JSM ()) -> Maybe (IntMap JSVal) -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((JSVal -> JSM ()) -> [JSVal] -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ JSVal -> JSM ()
FFI.eventSourceClose ([JSVal] -> JSM ())
-> (IntMap JSVal -> [JSVal]) -> IntMap JSVal -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap JSVal -> [JSVal]
forall a. IntMap a -> [a]
IM.elems) (Maybe (IntMap JSVal) -> JSM ())
-> JSM (Maybe (IntMap JSVal)) -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (WebSockets -> Maybe (IntMap JSVal))
-> JSM WebSockets -> JSM (Maybe (IntMap JSVal))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO WebSockets -> JSM WebSockets
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef WebSockets -> IO WebSockets
forall a. IORef a -> IO a
readIORef IORef WebSockets
eventSourceConnections)
  JSM ()
dropComponentEventSources
    where
      dropComponentEventSources :: JSM ()
      dropComponentEventSources :: JSM ()
dropComponentEventSources = IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$
        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, ())
-----------------------------------------------------------------------------