-----------------------------------------------------------------------------
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -fno-warn-orphans       #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Runtime
-- Copyright   :  (C) 2016-2025 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
-----------------------------------------------------------------------------
module Miso.Runtime
  ( -- * Internal functions
    initialize
  , freshComponentId
  , buildVTree
  , renderStyles
  , renderScripts
  , Hydrate(..)
  -- * Subscription
  , startSub
  , stopSub
  -- * Pub / Sub
  , subscribe
  , unsubscribe
  , publish
  , Topic (..)
  , topic
  -- * Component
  , ComponentState (..)
  -- ** Communication
  , mail
  , checkMail
  , broadcast
  , parent
  , mailParent
  -- ** WebSocket
  , websocketConnect
  , websocketConnectJSON
  , websocketConnectText
  , websocketConnectArrayBuffer
  , websocketConnectBLOB
  , websocketSend
  , websocketClose
  , socketState
  , emptyWebSocket
  , WebSocket (..)
  , URL
  , SocketState (..)
  , CloseCode (..)
  , Closed (..)
  -- ** EventSource
  , eventSourceConnectText
  , eventSourceConnectJSON
  , eventSourceClose
  , emptyEventSource
  , EventSource (..)
  -- ** Payload
  , Payload (..)
  , json
  , blob
  , arrayBuffer
  -- ** Internal Component state
  , components
  , componentIds
  , rootComponentId
  ) where
-----------------------------------------------------------------------------
import           Control.Concurrent.STM
import           Control.Exception (SomeException)
import           Control.Monad (forM, forM_, when, void, forever, (<=<), zipWithM_)
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)
#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           Prelude hiding (null)
import           System.IO.Unsafe (unsafePerformIO)
import           System.Mem.StableName (makeStableName)
#ifdef BENCH
import           Text.Printf
#endif
-----------------------------------------------------------------------------
import           Miso.Concurrent (Waiter(..), waiter, Mailbox, copyMailbox, readMail, sendMail, newMailbox)
import           Miso.Delegate (delegator)
import qualified Miso.Diff as Diff
import qualified Miso.Hydrate as Hydrate
import qualified Miso.FFI.Internal as FFI
import           Miso.FFI.Internal (Blob(..), ArrayBuffer(..))
import           Miso.String hiding (reverse, drop)
import           Miso.Types
import           Miso.Util
import           Miso.CSS (renderStyleSheet)
import           Miso.Effect ( ComponentInfo(..), Sub, Sink, Effect, Schedule(..), runEffect
                             , io_, withSink, Synchronicity(..)
                             )
-----------------------------------------------------------------------------
-- | Helper function to abstract out initialization of t'Miso.Types.Component' between top-level API functions.
initialize
  :: (Eq parent, Eq model)
  => ComponentId
  -> Hydrate
  -> Bool
  -- ^ Is the root node being rendered?
  -> Component parent model action
  -> JSM DOMRef
  -- ^ Callback function is used for obtaining the t'Miso.Types.Component' 'DOMRef'.
  -> JSM (ComponentState model action)
initialize :: forall parent model action.
(Eq parent, Eq model) =>
Int
-> Hydrate
-> Bool
-> Component parent model action
-> JSM JSVal
-> JSM (ComponentState model action)
initialize Int
componentParentId Hydrate
hydrate Bool
isRoot Component {model
Bool
[Binding parent model]
[JS]
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Maybe (JSM model)
Events
LogLevel
model -> View model action
action -> Effect parent model action
Mail -> Maybe action
model :: model
hydrateModel :: Maybe (JSM 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]
eventPropagation :: Bool
eventPropagation :: forall parent model action. Component parent model action -> Bool
bindings :: forall parent model action.
Component parent model action -> [Binding parent model]
mailbox :: forall parent model action.
Component parent model action -> 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
hydrateModel :: forall parent model action.
Component parent model action -> Maybe (JSM model)
model :: forall parent model action. Component parent model action -> model
..} JSM JSVal
getComponentMountPoint = 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 ()
notify
  componentId <- liftIO freshComponentId
  componentDiffs <- liftIO newMailbox
  initializedModel <-
    case (hydrate, hydrateModel) of
      (Hydrate
Hydrate, Just JSM model
action) ->
#ifdef SSR
         liftIO action
#else
         JSM model
action
#endif
      (Hydrate, Maybe (JSM model))
_ -> model -> JSM model
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure model
model
  componentScripts <- (++) <$> renderScripts scripts <*> renderStyles styles
  componentDOMRef <- getComponentMountPoint
  componentIsDirty <- liftIO (newTVarIO False)
  componentVTree <- do
#ifdef BENCH
    start <- if isRoot then FFI.now else pure 0
#endif
    vtree <- buildVTree componentParentId componentId hydrate componentSink logLevel events (view initializedModel)
#ifdef BENCH
    end <- if isRoot then FFI.now else pure 0
    when isRoot $ FFI.consoleLog $ ms (printf "buildVTree: %.3f ms" (end - start) :: String)
#endif
    ref <- liftIO (newIORef vtree)
    case hydrate of
      Hydrate
Draw -> do
        Maybe VTree -> Maybe VTree -> JSVal -> JSM ()
Diff.diff Maybe VTree
forall a. Maybe a
Nothing (VTree -> Maybe VTree
forall a. a -> Maybe a
Just VTree
vtree) JSVal
componentDOMRef
        IORef VTree -> JSM (IORef VTree)
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IORef VTree
ref
      Hydrate
Hydrate -> do
        Bool -> JSM () -> JSM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isRoot (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
          hydrated <- LogLevel -> JSVal -> VTree -> JSM Bool
Hydrate.hydrate LogLevel
logLevel JSVal
componentDOMRef VTree
vtree
          when (not hydrated) $ do
            liftIO $ do
              atomicWriteIORef components IM.empty
              atomicWriteIORef componentIds topLevelComponentId
              atomicWriteIORef subscribers mempty
              atomicWriteIORef mailboxes mempty
            newTree <- buildVTree componentParentId componentId Draw componentSink logLevel events (view initializedModel)
            liftIO (atomicWriteIORef ref newTree)
            Diff.diff Nothing (Just newTree) componentDOMRef
        IORef VTree -> JSM (IORef VTree)
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IORef VTree
ref
  componentSubThreads <- liftIO (newIORef M.empty)
  forM_ subs $ \Sub action
sub -> do
    threadId <- JSM () -> JSM ThreadId
FFI.forkJSM (Sub action
sub action -> JSM ()
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, ())
  componentModel <- liftIO (newTVarIO initializedModel)
  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 (TVar model -> IO model
forall a. TVar a -> IO a
readTVarIO TVar model
componentModel)
      let info = Int -> Int -> JSVal -> ComponentInfo parent
forall parent. Int -> Int -> JSVal -> ComponentInfo parent
ComponentInfo Int
componentId Int
componentParentId JSVal
componentDOMRef
      as <- liftIO $ atomicModifyIORef' componentActions $ \Seq action
actions -> (Seq action
forall a. Seq a
S.empty, Seq action
actions)
      updatedModel <- foldEffects update False info componentSink (toList as) currentModel
      currentName <- liftIO $ currentModel `seq` makeStableName currentModel
      updatedName <- liftIO $ updatedModel `seq` makeStableName updatedModel
      isDirty <- liftIO (readTVarIO componentIsDirty)
      when ((currentName /= updatedName && currentModel /= updatedModel) || isDirty) $ do
        newVTree <- buildVTree componentParentId componentId Draw componentSink logLevel events (view updatedModel)
        oldVTree <- liftIO (readIORef componentVTree)
        void waitForAnimationFrame
        Diff.diff (Just oldVTree) (Just newVTree) componentDOMRef
        FFI.updateRef oldVTree newVTree
        liftIO $ do
          atomicWriteIORef componentVTree newVTree
          mounted <- IM.size <$> readIORef components
          atomically $ do
            writeTVar componentModel updatedModel
            writeTVar componentIsDirty False
            -- dmj: reset the dirty bit
            when (mounted > 1) (writeTChan componentDiffs Null)
            -- dmj: child wake-up call for model 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
      componentParentId
      componentModel
      componentIsDirty
      parentToChild
      notify

  componentChildToParentThreadId <-
    synchronizeChildToParent
      componentParentId
      componentModel
      componentDiffs
      childToParent

  let vcomp = ComponentState
        { componentNotify :: IO ()
componentNotify = IO ()
notify
        , componentEvents :: Events
componentEvents = Events
events
        , componentParentId :: Int
componentParentId = Int
componentParentId
        , Int
[JSVal]
Maybe ThreadId
ThreadId
TVar model
TVar Bool
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Mailbox
action -> JSM ()
componentActions :: IORef (Seq action)
componentSink :: action -> JSM ()
componentId :: Int
componentDiffs :: Mailbox
componentScripts :: [JSVal]
componentDOMRef :: JSVal
componentIsDirty :: TVar Bool
componentVTree :: IORef VTree
componentSubThreads :: IORef (Map MisoString ThreadId)
componentModel :: TVar 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)
componentIsDirty :: TVar Bool
componentModel :: TVar model
componentSink :: action -> JSM ()
componentVTree :: IORef VTree
componentDOMRef :: JSVal
componentSubThreads :: IORef (Map MisoString ThreadId)
componentId :: Int
..
        }

  registerComponent vcomp
  if isRoot
    then
      delegator componentDOMRef componentVTree events (logLevel `elem` [DebugEvents, DebugAll])
    else
      addToDelegatedEvents logLevel events
  forM_ initialAction componentSink
  _ <- FFI.forkJSM eventLoop
  pure vcomp
-----------------------------------------------------------------------------
synchronizeChildToParent
  :: Eq parent
  => ComponentId
  -> TVar model
  -> Mailbox
  -> [ Binding parent model ]
  -> JSM (Maybe ThreadId)
synchronizeChildToParent :: forall parent model.
Eq parent =>
Int
-> TVar model
-> Mailbox
-> [Binding parent model]
-> JSM (Maybe ThreadId)
synchronizeChildToParent Int
_ TVar 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 Int
parentId TVar model
componentModel 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
  Int
-> IntMap (ComponentState parent (ZonkAny 19))
-> Maybe (ComponentState parent (ZonkAny 19))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
parentId (IntMap (ComponentState parent (ZonkAny 19))
 -> Maybe (ComponentState parent (ZonkAny 19)))
-> JSM (IntMap (ComponentState parent (ZonkAny 19)))
-> JSM (Maybe (ComponentState parent (ZonkAny 19)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IntMap (ComponentState parent (ZonkAny 19)))
-> JSM (IntMap (ComponentState parent (ZonkAny 19)))
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (IntMap (ComponentState parent (ZonkAny 19)))
-> IO (IntMap (ComponentState parent (ZonkAny 19)))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState parent (ZonkAny 19)))
forall model action. IORef (IntMap (ComponentState model action))
components) JSM (Maybe (ComponentState parent (ZonkAny 19)))
-> (Maybe (ComponentState parent (ZonkAny 19))
    -> 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 19))
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 19)
parentComponentState -> do
      ComponentState parent (ZonkAny 19) -> JSM ()
forall {action}. ComponentState parent action -> JSM ()
bindProperty ComponentState parent (ZonkAny 19)
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
$ do
        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
          _ <- IO Mail -> JSM Mail
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (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
      isDirty <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> JSM [Bool] -> JSM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding parent model]
-> (Binding parent model -> JSM Bool) -> JSM [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Binding parent model]
bindings (ComponentState parent action
-> TVar model -> Binding parent model -> JSM Bool
forall parent model action.
Eq parent =>
ComponentState parent action
-> TVar model -> Binding parent model -> JSM Bool
bindChildToParent ComponentState parent action
parentComponentState TVar model
componentModel)
      when isDirty $ do
        liftIO $ do
          atomically $ writeTVar (componentIsDirty parentComponentState) True
          componentNotify parentComponentState
-----------------------------------------------------------------------------
addToDelegatedEvents :: LogLevel -> Events -> JSM ()
addToDelegatedEvents :: LogLevel -> Events -> JSM ()
addToDelegatedEvents LogLevel
logLevel Events
events = do
  root <- (IntMap (ComponentState (ZonkAny 15) (ZonkAny 16))
-> Int -> ComponentState (ZonkAny 15) (ZonkAny 16)
forall a. IntMap a -> Int -> a
IM.! Int
topLevelComponentId) (IntMap (ComponentState (ZonkAny 15) (ZonkAny 16))
 -> ComponentState (ZonkAny 15) (ZonkAny 16))
-> JSM (IntMap (ComponentState (ZonkAny 15) (ZonkAny 16)))
-> JSM (ComponentState (ZonkAny 15) (ZonkAny 16))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IntMap (ComponentState (ZonkAny 15) (ZonkAny 16)))
-> JSM (IntMap (ComponentState (ZonkAny 15) (ZonkAny 16)))
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (IntMap (ComponentState (ZonkAny 15) (ZonkAny 16)))
-> IO (IntMap (ComponentState (ZonkAny 15) (ZonkAny 16)))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState (ZonkAny 15) (ZonkAny 16)))
forall model action. IORef (IntMap (ComponentState model action))
components)
  delegated <- M.unions . fmap componentEvents . IM.elems <$>
    liftIO (readIORef components)
  forM_ (M.assocs events) $ \(MisoString
eventName, Phase
capture) ->
    case MisoString -> Events -> Maybe Phase
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MisoString
eventName Events
delegated of
      Just Phase
delegatedCapture
        | Phase
delegatedCapture Phase -> Phase -> Bool
forall a. Eq a => a -> a -> Bool
== Phase
capture -> () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Maybe Phase
_ ->
        JSVal -> IORef VTree -> Events -> Bool -> JSM ()
delegator (ComponentState (ZonkAny 15) (ZonkAny 16) -> JSVal
forall model action. ComponentState model action -> JSVal
componentDOMRef ComponentState (ZonkAny 15) (ZonkAny 16)
root) (ComponentState (ZonkAny 15) (ZonkAny 16) -> IORef VTree
forall model action. ComponentState model action -> IORef VTree
componentVTree ComponentState (ZonkAny 15) (ZonkAny 16)
root)
          (MisoString -> Phase -> Events
forall k a. k -> a -> Map k a
M.singleton MisoString
eventName Phase
capture)
          (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])
-----------------------------------------------------------------------------
bindChildToParent
  :: forall parent model action
   . Eq parent
  => ComponentState parent action
  -- ^ Parent model
  -> TVar model
  -- ^ Child new model
  -> Binding parent model
  -- ^ Binding
  -> JSM Bool
bindChildToParent :: forall parent model action.
Eq parent =>
ComponentState parent action
-> TVar model -> Binding parent model -> JSM Bool
bindChildToParent ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
Events
ThreadId
TVar parent
TVar Bool
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Mailbox
action -> JSM ()
componentNotify :: forall model action. ComponentState model action -> IO ()
componentEvents :: forall model action. ComponentState model action -> Events
componentParentId :: forall model action. ComponentState model action -> Int
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)
componentIsDirty :: forall model action. ComponentState model action -> TVar Bool
componentModel :: forall model action. ComponentState model action -> TVar 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
componentParentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: TVar parent
componentIsDirty :: TVar Bool
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentNotify :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
componentEvents :: Events
..} TVar model
childRef = \case
  ChildToParent field -> parent -> parent
setParent model -> field
getChild ->
    (field -> parent -> parent) -> (model -> field) -> JSM Bool
forall {m :: * -> *} {t}.
MonadIO m =>
(t -> parent -> parent) -> (model -> t) -> m Bool
childToParent field -> parent -> parent
setParent model -> field
getChild
  Bidirectional parent -> field
_ field -> parent -> parent
setParent model -> field
getChild field -> model -> model
_ ->
    (field -> parent -> parent) -> (model -> field) -> JSM Bool
forall {m :: * -> *} {t}.
MonadIO m =>
(t -> parent -> parent) -> (model -> t) -> m Bool
childToParent field -> parent -> parent
setParent model -> field
getChild
  Binding parent model
_ ->
    Bool -> JSM Bool
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  where
    childToParent :: (t -> parent -> parent) -> (model -> t) -> m Bool
childToParent t -> parent -> parent
setParent model -> t
getChild = do
       IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
         childModel <- TVar model -> STM model
forall a. TVar a -> STM a
readTVar TVar model
childRef
         let f = t -> parent -> parent
setParent (model -> t
getChild model
childModel)
         currentParent <- readTVar componentModel
         modifyTVar' componentModel f
         newParent <- readTVar componentModel
         pure (currentParent /= newParent)
-----------------------------------------------------------------------------
synchronizeParentToChild
  :: Eq model
  => ComponentId
  -> TVar model
  -> TVar Bool
  -> [ Binding type_ model ]
  -> IO ()
  -> JSM (Maybe ThreadId)
synchronizeParentToChild :: forall model type_.
Eq model =>
Int
-> TVar model
-> TVar Bool
-> [Binding type_ model]
-> IO ()
-> JSM (Maybe ThreadId)
synchronizeParentToChild Int
_ TVar model
_ TVar Bool
_ [] 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 Int
parentId TVar model
componentModel_ TVar Bool
componentIsDirty [Binding type_ model]
bindings IO ()
notify= do
  -- Get parent's componentNotify, subscribe to it, on notification
  -- update the current Component model using the user-specified lenses
  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
      isDirty <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> JSM [Bool] -> JSM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding type_ model]
-> (Binding type_ model -> JSM Bool) -> JSM [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Binding type_ model]
bindings (ComponentState type_ action
-> TVar model -> Binding type_ model -> JSM Bool
forall props model action.
Eq model =>
ComponentState props action
-> TVar model -> Binding props model -> JSM Bool
bindParentToChild ComponentState type_ action
parentComponentState TVar model
componentModel_)
      when isDirty . liftIO $ do
        atomically (writeTVar componentIsDirty True)
        notify
-----------------------------------------------------------------------------
bindParentToChild
  :: forall props model action
   . Eq model
  => ComponentState props action
  -- ^ Parent model
  -> TVar model
  -- ^ Child new model
  -> Binding props model
  -- ^ binding
  -> JSM Bool
bindParentToChild :: forall props model action.
Eq model =>
ComponentState props action
-> TVar model -> Binding props model -> JSM Bool
bindParentToChild ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
Events
ThreadId
TVar props
TVar Bool
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Mailbox
action -> JSM ()
componentNotify :: forall model action. ComponentState model action -> IO ()
componentEvents :: forall model action. ComponentState model action -> Events
componentParentId :: forall model action. ComponentState model action -> Int
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)
componentIsDirty :: forall model action. ComponentState model action -> TVar Bool
componentModel :: forall model action. ComponentState model action -> TVar 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
componentParentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: TVar props
componentIsDirty :: TVar Bool
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentNotify :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
componentEvents :: Events
..} TVar model
modelRef = \case
  ParentToChild props -> field
getParent field -> model -> model
setChild -> do
    (props -> field) -> (field -> model -> model) -> JSM Bool
forall {m :: * -> *} {t}.
MonadIO m =>
(props -> t) -> (t -> model -> model) -> m Bool
parentToChild props -> field
getParent field -> model -> model
setChild
  Bidirectional props -> field
getParent field -> props -> props
_ model -> field
_ field -> model -> model
setChild ->
    (props -> field) -> (field -> model -> model) -> JSM Bool
forall {m :: * -> *} {t}.
MonadIO m =>
(props -> t) -> (t -> model -> model) -> m Bool
parentToChild props -> field
getParent field -> model -> model
setChild
  Binding props model
_ ->
    Bool -> JSM Bool
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  where
    parentToChild :: (props -> t) -> (t -> model -> model) -> m Bool
parentToChild props -> t
getParent t -> model -> model
setChild = IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
      parentModel <- TVar props -> STM props
forall a. TVar a -> STM a
readTVar TVar props
componentModel
      let f = t -> model -> model
setChild (props -> t
getParent props
parentModel)
      currentChild <- readTVar modelRef
      modifyTVar' modelRef f
      newChild <- readTVar modelRef
      pure (currentChild /= newChild)
-----------------------------------------------------------------------------
-- | Hydrate avoids calling @diff@, and instead calls @hydrate@
-- 'Draw' invokes 'Miso.Diff.diff'
data Hydrate
  = Draw
  | Hydrate
  deriving (Int -> Hydrate -> ShowS
[Hydrate] -> ShowS
Hydrate -> String
(Int -> Hydrate -> ShowS)
-> (Hydrate -> String) -> ([Hydrate] -> ShowS) -> Show Hydrate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Hydrate -> ShowS
showsPrec :: Int -> Hydrate -> ShowS
$cshow :: Hydrate -> String
show :: Hydrate -> String
$cshowList :: [Hydrate] -> ShowS
showList :: [Hydrate] -> ShowS
Show, Hydrate -> Hydrate -> Bool
(Hydrate -> Hydrate -> Bool)
-> (Hydrate -> Hydrate -> Bool) -> Eq Hydrate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Hydrate -> Hydrate -> Bool
== :: Hydrate -> Hydrate -> Bool
$c/= :: Hydrate -> Hydrate -> Bool
/= :: Hydrate -> Hydrate -> Bool
Eq)
-----------------------------------------------------------------------------
-- | t'Miso.Types.Component' state, data associated with the lifetime of a t'Miso.Types.Component'
data ComponentState model action
  = ComponentState
  { forall model action. ComponentState model action -> Int
componentId :: ComponentId
  -- ^ The ID of the current t'Miso.Types.Component'
  , forall model action. ComponentState model action -> Int
componentParentId :: ComponentId
  -- ^ The ID of the t'Miso.Types.Component''s parent
  , forall model action.
ComponentState model action -> IORef (Map MisoString ThreadId)
componentSubThreads :: IORef (Map MisoString ThreadId)
  -- ^ Mapping of all 'Sub' in use by Component
  , forall model action. ComponentState model action -> JSVal
componentDOMRef :: DOMRef
  -- ^ The DOM reference the t'Miso.Types.Component' is mounted on
  , forall model action. ComponentState model action -> IORef VTree
componentVTree :: IORef VTree
  -- ^ A reference to the current virtual DOM (i.e. t'VTree')
  , forall model action.
ComponentState model action -> action -> JSM ()
componentSink :: action -> JSM ()
  -- ^ t'Miso.Types.Component' t'Sink' used to enter events into the system
  , forall model action. ComponentState model action -> TVar model
componentModel :: TVar model
  -- ^ t'Miso.Types.Component' state
  , forall model action. ComponentState model action -> TVar Bool
componentIsDirty :: TVar Bool
  -- ^ Indicator if t'Miso.Types.Component' needs to be drawn
  , forall model action.
ComponentState model action -> IORef (Seq action)
componentActions :: IORef (Seq action)
  -- ^ Set of actions raised by the system
  , forall model action. ComponentState model action -> Mailbox
componentMailbox :: Mailbox
  -- ^ t'Mailbox' for receiving messages from other t'Miso.Types.Component'
  , forall model action. ComponentState model action -> [JSVal]
componentScripts :: [DOMRef]
  -- ^ DOM references for \<script\> and \<style\> appended to \<head\>
  , forall model action. ComponentState model action -> ThreadId
componentMailboxThreadId :: ThreadId
  -- ^ Thread responsible for taking actions from t'Mailbox' and
  -- putting them into 'componentActions'
  , forall model action. ComponentState model action -> Mailbox
componentDiffs :: Mailbox
  -- ^ Used with t'Binding' to synchronize other t'Miso.Types.Component' state
  -- at the granularity of a t'Miso.Lens.Lens'
  , forall model action. ComponentState model action -> IO ()
componentNotify :: IO ()
  -- ^ t'IO' action to unblock event loop thread
  , forall model action. ComponentState model action -> Maybe ThreadId
componentParentToChildThreadId :: Maybe ThreadId
  -- ^ Thread responsible for parent t'Binding' synchronization
  , forall model action. ComponentState model action -> Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
  -- ^ Thread responsible for child t'Binding' synchronization
  , forall model action. ComponentState model action -> Events
componentEvents :: Events
  -- ^ List of events a Component listens on
  }
-----------------------------------------------------------------------------
-- | A @Topic@ represents a place to send and receive messages. @Topic@ is used to facilitate
-- communication between t'Miso.Types.Component'. t'Miso.Types.Component' can 'subscribe' to or 'publish' to any @Topic@,
-- within the same t'Miso.Types.Component' or across t'Miso.Types.Component'.
--
-- This requires creating a custom 'ToJSON' / 'FromJSON'. Any other t'Miso.Types.Component'
-- can 'publish' or 'subscribe' to this @Topic message@. It is a way to provide
-- loosely-coupled communication between @Components@.
--
-- See 'publish', 'subscribe', 'unsubscribe' for more details.
--
-- When distributing t'Miso.Types.Component' for third-party use, it is recommended to export
-- the @Topic@, where message is the JSON protocol.
--
--
-- @since 1.9.0.0
newtype Topic a = Topic MisoString
  deriving (Eq (Topic a)
Eq (Topic a) =>
(Topic a -> Topic a -> Ordering)
-> (Topic a -> Topic a -> Bool)
-> (Topic a -> Topic a -> Bool)
-> (Topic a -> Topic a -> Bool)
-> (Topic a -> Topic a -> Bool)
-> (Topic a -> Topic a -> Topic a)
-> (Topic a -> Topic a -> Topic a)
-> Ord (Topic a)
Topic a -> Topic a -> Bool
Topic a -> Topic a -> Ordering
Topic a -> Topic a -> Topic a
forall a. Eq (Topic a)
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Topic a -> Topic a -> Bool
forall a. Topic a -> Topic a -> Ordering
forall a. Topic a -> Topic a -> Topic a
$ccompare :: forall a. Topic a -> Topic a -> Ordering
compare :: Topic a -> Topic a -> Ordering
$c< :: forall a. Topic a -> Topic a -> Bool
< :: Topic a -> Topic a -> Bool
$c<= :: forall a. Topic a -> Topic a -> Bool
<= :: Topic a -> Topic a -> Bool
$c> :: forall a. Topic a -> Topic a -> Bool
> :: Topic a -> Topic a -> Bool
$c>= :: forall a. Topic a -> Topic a -> Bool
>= :: Topic a -> Topic a -> Bool
$cmax :: forall a. Topic a -> Topic a -> Topic a
max :: Topic a -> Topic a -> Topic a
$cmin :: forall a. Topic a -> Topic a -> Topic a
min :: Topic a -> Topic a -> Topic a
Ord, Topic a -> Topic a -> Bool
(Topic a -> Topic a -> Bool)
-> (Topic a -> Topic a -> Bool) -> Eq (Topic a)
forall a. Topic a -> Topic a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Topic a -> Topic a -> Bool
== :: Topic a -> Topic a -> Bool
$c/= :: forall a. Topic a -> Topic a -> Bool
/= :: Topic a -> Topic a -> Bool
Eq, Int -> Topic a -> ShowS
[Topic a] -> ShowS
Topic a -> String
(Int -> Topic a -> ShowS)
-> (Topic a -> String) -> ([Topic a] -> ShowS) -> Show (Topic a)
forall a. Int -> Topic a -> ShowS
forall a. [Topic a] -> ShowS
forall a. Topic a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> Topic a -> ShowS
showsPrec :: Int -> Topic a -> ShowS
$cshow :: forall a. Topic a -> String
show :: Topic a -> String
$cshowList :: forall a. [Topic a] -> ShowS
showList :: [Topic a] -> ShowS
Show, Topic a -> MisoString
(Topic a -> MisoString) -> ToMisoString (Topic a)
forall a. Topic a -> MisoString
forall str. (str -> MisoString) -> ToMisoString str
$ctoMisoString :: forall a. Topic a -> MisoString
toMisoString :: Topic a -> MisoString
ToMisoString)
-----------------------------------------------------------------------------
-- | Smart constructor for creating a @Topic message@ to write to
--
-- @
--
-- data Message
--   = Increment
--   | Decrement
--   deriving (Show, Eq, Generic, ToJSON, FromJSON)
--
-- arithmetic :: Topic Message
-- arithmetic = topic "arithmetic"
--
-- data Action
--   = Notification (Result Message)
--   | Subscribe
--   | Unsubscribe
--
-- update_ :: Action -> Effect Int Action
-- update_ = \case
--   Unsubscribe ->
--     unsubscribe arithmetic
--   Subscribe ->
--     subscribe arithmetic Notification
--   Notification (Success Increment) ->
--     update_ AddOne
--   Notification (Success Decrement) ->
--     update_ SubtractOne
--   Notification (Error msg) ->
--     io_ $ consoleError ("Decode failure: " <> ms msg)
--
-- @
--
-- @since 1.9.0.0
topic :: MisoString -> Topic a
topic :: forall a. MisoString -> Topic a
topic = MisoString -> Topic a
forall a. MisoString -> Topic a
Topic
-----------------------------------------------------------------------------
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 t'Miso.Types.Component' 'Sink'
--
-- If a @Topic message@ does not exist when calling 'subscribe' it is generated dynamically.
-- Each subscriber decodes the received 'Value' using it's own 'FromJSON' instance. This provides
-- for loose-coupling between t'Miso.Types.Component'. As long as the underlying 'Value' are identical
-- t'Miso.Types.Component' can use their own types without serialization issues. @Topic message@ should
-- have their own JSON API specification when being distributed.
--
-- @
--
-- arithmetic :: Topic Message
-- arithmetic = topic "arithmetic"
--
-- clientComponent :: MisoString -> Component Int Action
-- clientComponent name = component 0 update_ $ \m ->
--   div_
--   []
--   [ br_ []
--   , text (name <> " : " <> ms (m ^. _id))
--   , button_ [ onClick Unsubscribe ] [ "unsubscribe" ]
--   , button_ [ onClick Subscribe ] [ "subscribe" ]
--   ] where
--       update_ :: Action -> Effect Int Action
--       update_ = \case
--         AddOne -> do
--           _id += 1
--         SubtractOne ->
--           _id -= 1
--         Unsubscribe ->
--           unsubscribe arithmetic
--         Subscribe ->
--           subscribe arithmetic Notification
--         Notification (Success Increment) -> do
--           update_ AddOne
--         Notification (Success Decrement) -> do
--           update_ SubtractOne
--         Notification (Error msg) ->
--           io_ $ consoleError ("Decode failure: " <> ms msg)
--         _ -> pure ()
--
-- @
--
-- @since 1.9.0.0
subscribe
  :: FromJSON message
  => Topic message
  -> (message -> action)
  -> (MisoString -> action)
  -> Effect parent model action
subscribe :: forall message action parent model.
FromJSON message =>
Topic message
-> (message -> action)
-> (MisoString -> action)
-> Effect parent model action
subscribe Topic message
topicName message -> action
successful MisoString -> action
errorful = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  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 ->
              action -> JSM ()
componentSink (message -> action
successful message
msg)
            Error String
msg ->
              action -> JSM ()
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 t'Topic'
--
-- Unsubscribes a t'Miso.Types.Component' from receiving messages from t'Topic'
--
-- See 'subscribe' for more use.
--
-- @since 1.9.0.0
unsubscribe :: Topic message -> Effect parent model action
unsubscribe :: forall message parent model action.
Topic message -> Effect parent model action
unsubscribe Topic message
topicName = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  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 t'Topic message'
--
-- t'Topic message' are generated dynamically if they do not exist. When using 'publish'
-- all subscribers are immediately notified of a new message. A message is distributed as a 'Value'
-- The underlying 'ToJSON' instance is used to construct this 'Value'.
--
-- We recommend documenting a public API for the JSON protocol message when distributing a t'Miso.Types.Component'
-- downstream to end users for consumption (be it inside a single cabal project or across multiple
-- cabal projects).
--
-- @
--
-- arithmetic :: Topic Message
-- arithmetic = topic "arithmetic"
--
-- server :: Component () Action
-- server = component () update_ $ \() ->
--   div_
--   []
--   [ "Server component"
--   , button_ [ onClick AddOne ] [ "+" ]
--   , button_ [ onClick SubtractOne ] [ "-" ]
--   , component_ (client_ "client 1")
--     [ onMountedWith Mount
--     ]
--   , component_ (client_ "client 2")
--     [ onMountedWith Mount
--     ]
--   ] where
--       update_ :: Action -> Transition () 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 a parent model action. JSM a -> 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)
-----------------------------------------------------------------------------
-- | This is used to demarcate the ROOT of a page. This ID will *never*
-- exist in the `components` map.
rootComponentId :: ComponentId
rootComponentId :: Int
rootComponentId = Int
0
-----------------------------------------------------------------------------
-- | This is the top-level ComponentId, hardcoded
topLevelComponentId :: ComponentId
topLevelComponentId :: Int
topLevelComponentId = Int
1
-----------------------------------------------------------------------------
-- | The global store of 'ComponentId', for internal-use only.
--
-- Used internally @freshComponentId@ to allocate new 'ComponentId' on
-- mount.
--
componentIds :: IORef Int
{-# NOINLINE componentIds #-}
componentIds :: IORef Int
componentIds = IO (IORef Int) -> IORef Int
forall a. IO a -> a
unsafePerformIO (IO (IORef Int) -> IORef Int) -> IO (IORef Int) -> IORef Int
forall a b. (a -> b) -> a -> b
$ 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
topLevelComponentId)
-----------------------------------------------------------------------------
freshComponentId :: IO ComponentId
freshComponentId :: IO Int
freshComponentId = IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
componentIds ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
y -> (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
y)
-----------------------------------------------------------------------------
-- | componentMap
--
-- This is a global t'Miso.Types.Component' @Map@ that holds the state of all currently
-- mounted t'Miso.Types.Component's
components :: IORef (IntMap (ComponentState 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)
-----------------------------------------------------------------------------
-- | This function evaluates effects according to 'Synchronicity'.
evalScheduled :: Synchronicity -> JSM () -> JSM ()
evalScheduled :: Synchronicity -> JSM () -> JSM ()
evalScheduled Synchronicity
Sync JSM ()
x = JSM ()
x
evalScheduled 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)
  -> Bool
  -- ^ Whether or not the Component is unmounting
  -> ComponentInfo parent
  -> Sink action
  -> [action]
  -> model
  -> JSM model
foldEffects :: forall action parent model.
(action -> Effect parent model action)
-> Bool
-> ComponentInfo parent
-> Sink action
-> [action]
-> model
-> JSM model
foldEffects action -> Effect parent model action
_ Bool
_ 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 Bool
drainSink ComponentInfo parent
info Sink action
snk (action
e:[action]
es) model
o =
  case Effect parent model action
-> ComponentInfo parent -> model -> (model, [Schedule action])
forall parent model action.
Effect parent model action
-> ComponentInfo parent -> model -> (model, [Schedule action])
runEffect (action -> Effect parent model action
update action
e) ComponentInfo parent
info model
o of
    (model
n, [Schedule action]
subs) -> do
      [Schedule action] -> (Schedule action -> JSM ()) -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Schedule action]
subs ((Schedule action -> JSM ()) -> JSM ())
-> (Schedule action -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \(Schedule Synchronicity
synchronicity Sink action -> JSM ()
sub) -> do
        let
          action :: JSM ()
action = 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)
        if Bool
drainSink
          then Synchronicity -> JSM () -> JSM ()
evalScheduled Synchronicity
Sync JSM ()
action
          else Synchronicity -> JSM () -> JSM ()
evalScheduled Synchronicity
synchronicity JSM ()
action
      (action -> Effect parent model action)
-> Bool
-> ComponentInfo parent
-> Sink action
-> [action]
-> model
-> JSM model
forall action parent model.
(action -> Effect parent model action)
-> Bool
-> ComponentInfo parent
-> Sink action
-> [action]
-> model
-> JSM model
foldEffects action -> Effect parent model action
update Bool
drainSink 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)
-----------------------------------------------------------------------------
-- | 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
Bool
[Binding parent model]
[JS]
[CSS]
[Sub action]
Maybe action
Maybe MisoString
Maybe (JSM model)
Events
LogLevel
model -> View model action
action -> Effect parent model action
Mail -> Maybe action
eventPropagation :: forall parent model action. Component parent model action -> Bool
bindings :: forall parent model action.
Component parent model action -> [Binding parent model]
mailbox :: forall parent model action.
Component parent model action -> 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
hydrateModel :: forall parent model action.
Component parent model action -> Maybe (JSM model)
model :: forall parent model action. Component parent model action -> model
model :: model
hydrateModel :: Maybe (JSM 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]
eventPropagation :: Bool
..} cs :: ComponentState model action
cs@ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
Events
ThreadId
TVar model
TVar Bool
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Mailbox
action -> JSM ()
componentNotify :: forall model action. ComponentState model action -> IO ()
componentEvents :: forall model action. ComponentState model action -> Events
componentParentId :: forall model action. ComponentState model action -> Int
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)
componentIsDirty :: forall model action. ComponentState model action -> TVar Bool
componentModel :: forall model action. ComponentState model action -> TVar 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
componentParentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: TVar model
componentIsDirty :: TVar Bool
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentNotify :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
componentEvents :: Events
..} = 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 -> Int -> JSVal -> ComponentInfo parent
forall parent. Int -> Int -> JSVal -> ComponentInfo parent
ComponentInfo Int
componentId Int
componentParentId JSVal
componentDOMRef
  if S.null actions then pure () else go info actions
      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 (TVar model -> IO model
forall a. TVar a -> IO a
readTVarIO TVar model
componentModel)
          y <- foldEffects update True info componentSink (toList actions) x
          liftIO $ atomically (writeTVar componentModel 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 ()
Events
ThreadId
TVar model
TVar Bool
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Mailbox
action -> JSM ()
componentNotify :: forall model action. ComponentState model action -> IO ()
componentEvents :: forall model action. ComponentState model action -> Events
componentParentId :: forall model action. ComponentState model action -> Int
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)
componentIsDirty :: forall model action. ComponentState model action -> TVar Bool
componentModel :: forall model action. ComponentState model action -> TVar 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
componentParentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: TVar model
componentIsDirty :: TVar Bool
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentNotify :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
componentEvents :: Events
..} = do
  head_ <- JSM JSVal
FFI.getHead
  forM_ componentScripts $ \JSVal
domRef ->
    JSVal -> JSVal -> JSM ()
FFI.removeChild JSVal
head_ JSVal
domRef
-----------------------------------------------------------------------------
-- | Helper to drop all lifecycle and mounting hooks if defined.
freeLifecycleHooks :: ComponentState model action -> JSM ()
freeLifecycleHooks :: forall model action. ComponentState model action -> JSM ()
freeLifecycleHooks ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
Events
ThreadId
TVar model
TVar Bool
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Mailbox
action -> JSM ()
componentNotify :: forall model action. ComponentState model action -> IO ()
componentEvents :: forall model action. ComponentState model action -> Events
componentParentId :: forall model action. ComponentState model action -> Int
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)
componentIsDirty :: forall model action. ComponentState model action -> TVar Bool
componentModel :: forall model action. ComponentState model action -> TVar 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
componentParentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: TVar model
componentIsDirty :: TVar Bool
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentNotify :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
componentEvents :: Events
..} = do
#ifndef GHCJS_BOTH
  VTree (Object vcomp) <- IO VTree -> JSM VTree
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef VTree -> IO VTree
forall a. IORef a -> IO a
readIORef IORef VTree
componentVTree)
  mapM_ freeFunction =<< fromJSVal =<< vcomp ! ("onMounted" :: MisoString)
  mapM_ freeFunction =<< fromJSVal =<< vcomp ! ("onUnmounted" :: MisoString)
  mapM_ freeFunction =<< fromJSVal =<< vcomp ! ("onBeforeMounted" :: MisoString)
  mapM_ freeFunction =<< fromJSVal =<< vcomp ! ("onBeforeUnmounted" :: MisoString)
  mapM_ freeFunction =<< fromJSVal =<< vcomp ! ("mount" :: MisoString)
  mapM_ freeFunction =<< fromJSVal =<< vcomp ! ("unmount" :: MisoString)
#else
  pure ()
#endif
-----------------------------------------------------------------------------
-- | Helper function for cleanly destroying a t'Miso.Types.Component'
unmount
  :: Component parent model action
  -> ComponentState model action
  -> JSM ()
unmount :: forall parent model action.
Component parent model action
-> ComponentState model action -> JSM ()
unmount Component parent model action
app cs :: ComponentState model action
cs@ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
Events
ThreadId
TVar model
TVar Bool
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Mailbox
action -> JSM ()
componentNotify :: forall model action. ComponentState model action -> IO ()
componentEvents :: forall model action. ComponentState model action -> Events
componentParentId :: forall model action. ComponentState model action -> Int
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)
componentIsDirty :: forall model action. ComponentState model action -> TVar Bool
componentModel :: forall model action. ComponentState model action -> TVar 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
componentParentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: TVar model
componentIsDirty :: TVar Bool
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentNotify :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
componentEvents :: Events
..} = 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
componentMailboxThreadId
    (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
    (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
    (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
  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
  ComponentState model action -> JSM ()
forall model action. ComponentState model action -> JSM ()
freeLifecycleHooks 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, ())
-----------------------------------------------------------------------------
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.
buildVTree
  :: Eq model
  => ComponentId
  -> ComponentId
  -> Hydrate
  -> Sink action
  -> LogLevel
  -> Events
  -> View model action
  -> JSM VTree
buildVTree :: forall model action.
Eq model =>
Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> Events
-> View model action
-> JSM VTree
buildVTree Int
parentId Int
vcompId Hydrate
hydrate Sink action
snk LogLevel
logLevel_ Events
events_ = \case
  VComp [Attribute action]
attrs (SomeComponent Component model model action
app) -> do
    vcomp <- JSM Object
create

    mountCallback <- do
      if hydrate == Hydrate
        then
          toJSVal jsNull
        else
          toJSVal =<< do
            FFI.syncCallback2 $ \JSVal
parent_ JSVal
continuation -> do
              ComponentState {..} <- Int
-> Hydrate
-> Bool
-> Component model model action
-> JSM JSVal
-> JSM (ComponentState model action)
forall parent model action.
(Eq parent, Eq model) =>
Int
-> Hydrate
-> Bool
-> Component parent model action
-> JSM JSVal
-> JSM (ComponentState model action)
initialize Int
vcompId Hydrate
Draw Bool
False Component model model action
app (JSVal -> JSM JSVal
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSVal
parent_)
              vtree <- toJSVal =<< liftIO (readIORef componentVTree)
              FFI.set "parent" vcomp (Object vtree)
              vcompId_ <- toJSVal componentId
              void $ call continuation global (vcompId_, vtree)

    unmountCallback <- toJSVal =<< do
      FFI.syncCallback1 $ \JSVal
vcompId_ -> do
        componentId_ <- JSVal -> JSM Int
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked JSVal
vcompId_
        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 ->
            Component model model action
-> ComponentState model action -> JSM ()
forall parent model action.
Component parent model action
-> ComponentState model action -> JSM ()
unmount Component model model action
app ComponentState model action
componentState

    case hydrate of
      Hydrate
Hydrate -> do
        -- Mock .domRef for use during hydration
        domRef <- Object -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal (Object -> JSM JSVal) -> JSM Object -> JSM JSVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSM Object
create
        ComponentState {..} <- initialize vcompId hydrate False app (pure domRef)
        vtree <- toJSVal =<< liftIO (readIORef componentVTree)
        FFI.set "parent" vcomp (Object vtree)
        vcompId_ <- toJSVal componentId
        FFI.set "componentId" vcompId_ vcomp
        FFI.set "child" vtree vcomp
      Hydrate
Draw -> do
        MisoString -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
FFI.set MisoString
"child" JSVal
jsNull Object
vcomp        
      
    setAttrs vcomp attrs snk (logLevel app) (events app)
    when (hydrate == Draw) (FFI.set "mount" mountCallback vcomp)
    FFI.set "unmount" unmountCallback vcomp
    FFI.set "eventPropagation" (eventPropagation app) vcomp
    flip (FFI.set "type") vcomp =<< toJSVal VCompType
    pure (VTree vcomp)
  VNode NS
ns MisoString
tag [Attribute action]
attrs [View model action]
kids -> do
    vnode <- MisoString -> NS -> MisoString -> JSM Object
createNode MisoString
"vnode" NS
ns MisoString
tag
    setAttrs vnode attrs snk logLevel_ events_
    vchildren <- toJSVal =<< procreate vnode
    flip (FFI.set "children") vnode vchildren
    flip (FFI.set "type") vnode =<< toJSVal VNodeType
    pure (VTree vnode)
      where
        procreate :: v -> JSM [Object]
procreate v
parentVTree = do
          kidsViews <- [View model action]
-> (View model action -> JSM Object) -> JSM [Object]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [View model action]
kids ((View model action -> JSM Object) -> JSM [Object])
-> (View model action -> JSM Object) -> JSM [Object]
forall a b. (a -> b) -> a -> b
$ \View model action
kid -> do
            VTree child <- Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> Events
-> View model action
-> JSM VTree
forall model action.
Eq model =>
Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> Events
-> View model action
-> JSM VTree
buildVTree Int
parentId Int
vcompId Hydrate
hydrate Sink action
snk LogLevel
logLevel_ Events
events_ View model action
kid
            FFI.set "parent" parentVTree child
            pure child
          setNextSibling kidsViews
          pure kidsViews
            where
              setNextSibling :: [b] -> JSM ()
setNextSibling [b]
xs =
                (b -> b -> JSM ()) -> [b] -> [b] -> JSM ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (b -> MisoString -> b -> JSM ()
forall this name val.
(MakeObject this, ToJSString name, ToJSVal val) =>
this -> name -> val -> JSM ()
<# (MisoString
"nextSibling" :: MisoString)) [b]
xs (Int -> [b] -> [b]
forall a. Int -> [a] -> [a]
drop Int
1 [b]
xs)
  VText Maybe Key
key MisoString
t -> do
    vtree <- JSM Object
create
    flip (FFI.set "type") vtree =<< toJSVal VTextType
    forM_ key $ \Key
k -> MisoString -> MisoString -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
FFI.set MisoString
"key" (Key -> MisoString
forall str. ToMisoString str => str -> MisoString
ms Key
k) Object
vtree
    FFI.set "ns" ("text" :: JSString) vtree
    FFI.set "text" t vtree
    pure (VTree vtree)
-----------------------------------------------------------------------------
-- | @createNode@
-- A helper function for constructing a vtree (used for @vcomp@ and @vnode@)
-- Doesn't handle children
createNode :: MisoString -> NS -> MisoString -> 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
  captures <- create
  bubbles <- create
  FFI.set "css" cssObj vnode
  FFI.set "type" typ vnode
  FFI.set "props" propsObj vnode
  FFI.set "events" eventsObj vnode
  FFI.set "captures" captures eventsObj
  FFI.set "bubbles" bubbles eventsObj
  FFI.set "ns" ns vnode
  FFI.set "tag" tag vnode
  pure vnode
-----------------------------------------------------------------------------
-- | Helper function for populating "props" and "css" fields on a virtual
-- DOM node
setAttrs
  :: Object
  -> [Attribute action]
  -> Sink action
  -> LogLevel
  -> Events
  -> JSM ()
setAttrs :: forall action.
Object
-> [Attribute action]
-> Sink action
-> LogLevel
-> Events
-> JSM ()
setAttrs vnode :: Object
vnode@(Object JSVal
jval) [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
    ClassList [MisoString]
classes ->
      JSVal -> [MisoString] -> JSM ()
FFI.populateClass JSVal
jval [MisoString]
classes
    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)
    On 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 <- MisoString -> Object -> JSM JSVal
getProp MisoString
"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)
-----------------------------------------------------------------------------
-- | 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 [DOMRef]
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 [DOMRef]
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 ->
      Bool -> MisoString -> JSM JSVal
FFI.addScript Bool
False MisoString
script
    Module MisoString
src ->
      Bool -> MisoString -> JSM JSVal
FFI.addScript Bool
True MisoString
src
    ImportMap [(MisoString, MisoString)]
importMap -> do
      o <- JSM Object
create
      imports <- 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
imports
      FFI.set "imports" imports o
      FFI.addScriptImportMap
        =<< fromJSValUnchecked
        =<< (jsg @MisoString "JSON" # ("stringify" :: MisoString) $ [o])
-----------------------------------------------------------------------------
-- | Starts a named 'Sub' dynamically, during the life of a t'Miso.Types.Component'.
-- The 'Sub' can be stopped by calling @Ord subKey => stop subKey@ from the 'update' function.
-- All 'Sub' started will be stopped if a t'Miso.Types.Component' is unmounted.
--
-- @
-- data SubType = LoggerSub | TimerSub
--   deriving (Eq, Ord)
--
-- update Action =
--   startSub LoggerSub $ \\sink -> forever (threadDelay (secs 1) >> consoleLog "test")
-- @
--
-- @since 1.9.0.0
startSub
  :: ToMisoString subKey
  => subKey
  -> Sub action
  -> Effect parent model action
startSub :: forall subKey action parent model.
ToMisoString subKey =>
subKey -> Sub action -> Effect parent model action
startSub subKey
subKey Sub action
sub = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    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 ()
Events
ThreadId
TVar Bool
TVar (ZonkAny 0)
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Mailbox
action -> JSM ()
componentNotify :: forall model action. ComponentState model action -> IO ()
componentEvents :: forall model action. ComponentState model action -> Events
componentParentId :: forall model action. ComponentState model action -> Int
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)
componentIsDirty :: forall model action. ComponentState model action -> TVar Bool
componentModel :: forall model action. ComponentState model action -> TVar 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
componentParentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: TVar (ZonkAny 0)
componentIsDirty :: TVar Bool
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentNotify :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
componentEvents :: Events
..} -> 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 ()
Events
ThreadId
TVar model
TVar Bool
IORef (Map MisoString ThreadId)
IORef (Seq action)
IORef VTree
JSVal
Mailbox
action -> JSM ()
componentNotify :: forall model action. ComponentState model action -> IO ()
componentEvents :: forall model action. ComponentState model action -> Events
componentParentId :: forall model action. ComponentState model action -> Int
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)
componentIsDirty :: forall model action. ComponentState model action -> TVar Bool
componentModel :: forall model action. ComponentState model action -> TVar 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
componentParentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: action -> JSM ()
componentModel :: TVar model
componentIsDirty :: TVar Bool
componentActions :: IORef (Seq action)
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentNotify :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
componentEvents :: Events
..} = do
      tid <- JSM () -> JSM ThreadId
FFI.forkJSM (Sub action
sub action -> JSM ()
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 t'Miso.Types.Component'.
-- All 'Sub' started will be stopped automatically if a t'Miso.Types.Component' is unmounted.
--
-- @
-- data SubType = LoggerSub | TimerSub
--   deriving (Eq, Ord)
--
-- update Action = do
--   stopSub LoggerSub
-- @
--
-- @since 1.9.0.0
stopSub :: ToMisoString subKey => subKey -> Effect parent model action
stopSub :: forall subKey parent model action.
ToMisoString subKey =>
subKey -> Effect parent model action
stopSub subKey
subKey = do
  vcompId <- (ComponentInfo parent -> Int)
-> RWST (ComponentInfo parent) [Schedule action] model Identity Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ComponentInfo parent -> Int
forall parent. ComponentInfo parent -> Int
_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 ()
Events
ThreadId
TVar Bool
TVar (ZonkAny 1)
IORef (Map MisoString ThreadId)
IORef (Seq (ZonkAny 2))
IORef VTree
JSVal
Mailbox
ZonkAny 2 -> JSM ()
componentNotify :: forall model action. ComponentState model action -> IO ()
componentEvents :: forall model action. ComponentState model action -> Events
componentParentId :: forall model action. ComponentState model action -> Int
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)
componentIsDirty :: forall model action. ComponentState model action -> TVar Bool
componentModel :: forall model action. ComponentState model action -> TVar 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
componentParentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: ZonkAny 2 -> JSM ()
componentModel :: TVar (ZonkAny 1)
componentIsDirty :: TVar Bool
componentActions :: IORef (Seq (ZonkAny 2))
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentNotify :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
componentEvents :: Events
..} -> 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 t'Miso.Types.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 a parent model action. JSM a -> 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 ()
Events
ThreadId
TVar Bool
TVar (ZonkAny 3)
IORef (Map MisoString ThreadId)
IORef (Seq (ZonkAny 4))
IORef VTree
JSVal
Mailbox
ZonkAny 4 -> JSM ()
componentNotify :: forall model action. ComponentState model action -> IO ()
componentEvents :: forall model action. ComponentState model action -> Events
componentParentId :: forall model action. ComponentState model action -> Int
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)
componentIsDirty :: forall model action. ComponentState model action -> TVar Bool
componentModel :: forall model action. ComponentState model action -> TVar 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
componentParentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: ZonkAny 4 -> JSM ()
componentModel :: TVar (ZonkAny 3)
componentIsDirty :: TVar Bool
componentActions :: IORef (Seq (ZonkAny 4))
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentNotify :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
componentEvents :: Events
..} ->
      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 t'Miso.Types.Component' mailbox
--
-- @
-- mailParent ("test message" :: MisoString) :: Effect parent model action
-- @
--
-- @since 1.9.0.0
mailParent
  :: ToJSON message
  => message
  -> Effect parent model action
mailParent :: forall message parent model action.
ToJSON message =>
message -> Effect parent model action
mailParent message
message = do
  vcompId <- (ComponentInfo parent -> Int)
-> RWST (ComponentInfo parent) [Schedule action] model Identity Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ComponentInfo parent -> Int
forall parent. ComponentInfo parent -> Int
_componentParentId
  io_ $ do
    IM.lookup vcompId <$> liftIO (readIORef components) >>= \case
      Maybe (ComponentState (ZonkAny 5) (ZonkAny 6))
Nothing ->
        -- dmj: TODO add DebugMail here, if '0' then you're at the root
        -- w/o a parent, so no message can be sent.
        () -> JSM ()
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
Events
ThreadId
TVar Bool
TVar (ZonkAny 5)
IORef (Map MisoString ThreadId)
IORef (Seq (ZonkAny 6))
IORef VTree
JSVal
Mailbox
ZonkAny 6 -> JSM ()
componentNotify :: forall model action. ComponentState model action -> IO ()
componentEvents :: forall model action. ComponentState model action -> Events
componentParentId :: forall model action. ComponentState model action -> Int
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)
componentIsDirty :: forall model action. ComponentState model action -> TVar Bool
componentModel :: forall model action. ComponentState model action -> TVar 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
componentParentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: ZonkAny 6 -> JSM ()
componentModel :: TVar (ZonkAny 5)
componentIsDirty :: TVar Bool
componentActions :: IORef (Seq (ZonkAny 6))
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentNotify :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
componentEvents :: Events
..} ->
        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 :: IO ()
-- main = app { mailbox = checkMail ParsedMail ErrorMail }
-- @
--
-- @since 1.9.0.0
checkMail
  :: FromJSON value
  => (value -> action)
  -> (MisoString -> action)
  -> Value
  -> Maybe action
checkMail :: forall value action.
FromJSON value =>
(value -> action) -> (MisoString -> action) -> 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)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink -> do
    Int
-> IntMap (ComponentState parent (ZonkAny 7))
-> Maybe (ComponentState parent (ZonkAny 7))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
_componentParentId (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 ()
Events
ThreadId
TVar parent
TVar Bool
IORef (Map MisoString ThreadId)
IORef (Seq (ZonkAny 7))
IORef VTree
JSVal
Mailbox
ZonkAny 7 -> JSM ()
componentNotify :: forall model action. ComponentState model action -> IO ()
componentEvents :: forall model action. ComponentState model action -> Events
componentParentId :: forall model action. ComponentState model action -> Int
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)
componentIsDirty :: forall model action. ComponentState model action -> TVar Bool
componentModel :: forall model action. ComponentState model action -> TVar 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
componentParentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: ZonkAny 7 -> JSM ()
componentModel :: TVar parent
componentIsDirty :: TVar Bool
componentActions :: IORef (Seq (ZonkAny 7))
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentNotify :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
componentEvents :: Events
..} -> do
        model <- IO parent -> JSM parent
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TVar parent -> IO parent
forall a. TVar a -> IO a
readTVarIO TVar parent
componentModel)
        sink (successful model)
-----------------------------------------------------------------------------
-- | Sends a message to all t'Miso.Types.Component' 'mailbox', excluding oneself.
--
-- @
--
-- update :: action -> Effect parent model action
-- update _ = broadcast (String "public service announcement")
-- @
--
-- @since 1.9.0.0
broadcast
  :: 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)
  [Schedule action]
  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 ()
Events
ThreadId
TVar Bool
TVar (ZonkAny 8)
IORef (Map MisoString ThreadId)
IORef (Seq (ZonkAny 9))
IORef VTree
JSVal
Mailbox
ZonkAny 9 -> JSM ()
componentNotify :: forall model action. ComponentState model action -> IO ()
componentEvents :: forall model action. ComponentState model action -> Events
componentParentId :: forall model action. ComponentState model action -> Int
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)
componentIsDirty :: forall model action. ComponentState model action -> TVar Bool
componentModel :: forall model action. ComponentState model action -> TVar 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
componentParentId :: Int
componentSubThreads :: IORef (Map MisoString ThreadId)
componentDOMRef :: JSVal
componentVTree :: IORef VTree
componentSink :: ZonkAny 9 -> JSM ()
componentModel :: TVar (ZonkAny 8)
componentIsDirty :: TVar Bool
componentActions :: IORef (Seq (ZonkAny 9))
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentNotify :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
componentEvents :: Events
..}) ->
      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))
-----------------------------------------------------------------------------
websocketConnectText
  :: URL
  -- ^ t'WebSocket' 'URL'
  -> (WebSocket -> action)
  -- ^ onOpen
  -> (Closed -> action)
  -- ^ onClosed
  -> (MisoString -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect parent model action
websocketConnectText :: forall action parent model.
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (MisoString -> action)
-> (MisoString -> action)
-> Effect parent model action
websocketConnectText MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed MisoString -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> JSM JSVal)
-> Effect parent model action
forall action parent model.
(WebSocket -> Sink action -> JSM JSVal)
-> Effect parent model action
websocketCore ((WebSocket -> Sink action -> JSM JSVal)
 -> Effect parent model action)
-> (WebSocket -> Sink action -> JSM JSVal)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> JSM ()
-> (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> (JSVal -> JSM ())
-> Bool
-> JSM JSVal
FFI.websocketConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ WebSocket -> action
onOpen WebSocket
webSocketId)
      (Sink action
sink Sink action -> (Closed -> action) -> Closed -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closed -> action
onClosed (Closed -> JSM ()) -> (JSVal -> JSM Closed) -> JSVal -> JSM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> JSM Closed
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked)
      ((JSVal -> JSM ()) -> Maybe (JSVal -> JSM ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> action
onMessage (MisoString -> JSM ())
-> (JSVal -> JSM MisoString) -> JSVal -> JSM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> JSM MisoString
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked))
      Maybe (JSVal -> JSM ())
forall a. Maybe a
Nothing
      Maybe (JSVal -> JSM ())
forall a. Maybe a
Nothing
      Maybe (JSVal -> JSM ())
forall a. Maybe a
Nothing
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> action
onError (MisoString -> JSM ())
-> (JSVal -> JSM MisoString) -> JSVal -> JSM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> JSM MisoString
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked)
      Bool
True
-----------------------------------------------------------------------------
websocketConnectBLOB
  :: URL
  -- ^ t'WebSocket' 'URL'
  -> (WebSocket -> action)
  -- ^ onOpen
  -> (Closed -> action)
  -- ^ onClosed
  -> (Blob -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect parent model action
websocketConnectBLOB :: forall action parent model.
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (Blob -> action)
-> (MisoString -> action)
-> Effect parent model action
websocketConnectBLOB MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed Blob -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> JSM JSVal)
-> Effect parent model action
forall action parent model.
(WebSocket -> Sink action -> JSM JSVal)
-> Effect parent model action
websocketCore ((WebSocket -> Sink action -> JSM JSVal)
 -> Effect parent model action)
-> (WebSocket -> Sink action -> JSM JSVal)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> JSM ()
-> (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> (JSVal -> JSM ())
-> Bool
-> JSM JSVal
FFI.websocketConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ WebSocket -> action
onOpen WebSocket
webSocketId)
      (Sink action
sink Sink action -> (Closed -> action) -> Closed -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closed -> action
onClosed (Closed -> JSM ()) -> (JSVal -> JSM Closed) -> JSVal -> JSM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> JSM Closed
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked)
      Maybe (JSVal -> JSM ())
forall a. Maybe a
Nothing
      Maybe (JSVal -> JSM ())
forall a. Maybe a
Nothing
      ((JSVal -> JSM ()) -> Maybe (JSVal -> JSM ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (JSVal -> action) -> JSVal -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blob -> action
onMessage (Blob -> action) -> (JSVal -> Blob) -> JSVal -> action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSVal -> Blob
Blob))
      Maybe (JSVal -> JSM ())
forall a. Maybe a
Nothing
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> action
onError (MisoString -> JSM ())
-> (JSVal -> JSM MisoString) -> JSVal -> JSM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> JSM MisoString
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked)
      Bool
False
-----------------------------------------------------------------------------
websocketConnectArrayBuffer
  :: URL
  -- ^ t'WebSocket' 'URL'
  -> (WebSocket -> action)
  -- ^ onOpen
  -> (Closed -> action)
  -- ^ onClosed
  -> (ArrayBuffer -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect parent model action
websocketConnectArrayBuffer :: forall action parent model.
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (ArrayBuffer -> action)
-> (MisoString -> action)
-> Effect parent model action
websocketConnectArrayBuffer MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed ArrayBuffer -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> JSM JSVal)
-> Effect parent model action
forall action parent model.
(WebSocket -> Sink action -> JSM JSVal)
-> Effect parent model action
websocketCore ((WebSocket -> Sink action -> JSM JSVal)
 -> Effect parent model action)
-> (WebSocket -> Sink action -> JSM JSVal)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> JSM ()
-> (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> (JSVal -> JSM ())
-> Bool
-> JSM JSVal
FFI.websocketConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ WebSocket -> action
onOpen WebSocket
webSocketId)
      (Sink action
sink Sink action -> (Closed -> action) -> Closed -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closed -> action
onClosed (Closed -> JSM ()) -> (JSVal -> JSM Closed) -> JSVal -> JSM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> JSM Closed
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked)
      Maybe (JSVal -> JSM ())
forall a. Maybe a
Nothing
      Maybe (JSVal -> JSM ())
forall a. Maybe a
Nothing
      Maybe (JSVal -> JSM ())
forall a. Maybe a
Nothing
      ((JSVal -> JSM ()) -> Maybe (JSVal -> JSM ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (JSVal -> action) -> JSVal -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArrayBuffer -> action
onMessage (ArrayBuffer -> action)
-> (JSVal -> ArrayBuffer) -> JSVal -> action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSVal -> ArrayBuffer
ArrayBuffer))
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> action
onError (MisoString -> JSM ())
-> (JSVal -> JSM MisoString) -> JSVal -> JSM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> JSM MisoString
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked)
      Bool
False
-----------------------------------------------------------------------------
websocketConnectJSON
  :: FromJSON json
  => URL
  -- ^ WebSocket URL
  -> (WebSocket -> action)
  -- ^ onOpen
  -> (Closed -> action)
  -- ^ onClosed
  -> (json -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect parent model action
websocketConnectJSON :: forall json action parent model.
FromJSON json =>
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (json -> action)
-> (MisoString -> action)
-> Effect parent model action
websocketConnectJSON MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed json -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> JSM JSVal)
-> Effect parent model action
forall action parent model.
(WebSocket -> Sink action -> JSM JSVal)
-> Effect parent model action
websocketCore ((WebSocket -> Sink action -> JSM JSVal)
 -> Effect parent model action)
-> (WebSocket -> Sink action -> JSM JSVal)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> JSM ()
-> (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> (JSVal -> JSM ())
-> Bool
-> JSM JSVal
FFI.websocketConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ WebSocket -> action
onOpen WebSocket
webSocketId)
      (Sink action
sink Sink action -> (Closed -> action) -> Closed -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closed -> action
onClosed (Closed -> JSM ()) -> (JSVal -> JSM Closed) -> JSVal -> JSM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> JSM Closed
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked)
      Maybe (JSVal -> JSM ())
forall a. Maybe a
Nothing
      ((JSVal -> JSM ()) -> Maybe (JSVal -> JSM ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\JSVal
bytes -> do
          value :: Value <- JSVal -> JSM Mail
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked JSVal
bytes
          case fromJSON value of
            Error String
msg -> Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ MisoString -> action
onError (String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms String
msg)
            Success json
x -> Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ json -> action
onMessage json
x))
      Maybe (JSVal -> JSM ())
forall a. Maybe a
Nothing
      Maybe (JSVal -> JSM ())
forall a. Maybe a
Nothing
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> action
onError (MisoString -> JSM ())
-> (JSVal -> JSM MisoString) -> JSVal -> JSM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> JSM MisoString
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked)
      Bool
False
-----------------------------------------------------------------------------
websocketConnect
  :: FromJSON json
  => URL
  -- ^ WebSocket URL
  -> (WebSocket -> action)
  -- ^ onOpen
  -> (Closed -> action)
  -- ^ onClosed
  -> (Payload json -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect parent model action
websocketConnect :: forall json action parent model.
FromJSON json =>
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (Payload json -> action)
-> (MisoString -> action)
-> Effect parent model action
websocketConnect MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed Payload json -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> JSM JSVal)
-> Effect parent model action
forall action parent model.
(WebSocket -> Sink action -> JSM JSVal)
-> Effect parent model action
websocketCore ((WebSocket -> Sink action -> JSM JSVal)
 -> Effect parent model action)
-> (WebSocket -> Sink action -> JSM JSVal)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> JSM ()
-> (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> (JSVal -> JSM ())
-> Bool
-> JSM JSVal
FFI.websocketConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ WebSocket -> action
onOpen WebSocket
webSocketId)
      (Sink action
sink Sink action -> (Closed -> action) -> Closed -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closed -> action
onClosed (Closed -> JSM ()) -> (JSVal -> JSM Closed) -> JSVal -> JSM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> JSM Closed
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked)
      ((JSVal -> JSM ()) -> Maybe (JSVal -> JSM ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Payload json -> action
onMessage (Payload json -> action)
-> (MisoString -> Payload json) -> MisoString -> action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> Payload json
forall value. MisoString -> Payload value
TEXT (MisoString -> JSM ())
-> (JSVal -> JSM MisoString) -> JSVal -> JSM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> JSM MisoString
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked))
      ((JSVal -> JSM ()) -> Maybe (JSVal -> JSM ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\JSVal
bytes -> do
          value :: Value <- JSVal -> JSM Mail
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked JSVal
bytes
          case fromJSON value of
            Error String
msg -> Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ MisoString -> action
onError (String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms String
msg)
            Success json
x -> Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ Payload json -> action
onMessage (json -> Payload json
forall value. value -> Payload value
JSON json
x)))
      ((JSVal -> JSM ()) -> Maybe (JSVal -> JSM ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (JSVal -> action) -> JSVal -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Payload json -> action
onMessage (Payload json -> action)
-> (JSVal -> Payload json) -> JSVal -> action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blob -> Payload json
forall value. Blob -> Payload value
BLOB (Blob -> Payload json) -> (JSVal -> Blob) -> JSVal -> Payload json
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSVal -> Blob
Blob))
      ((JSVal -> JSM ()) -> Maybe (JSVal -> JSM ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (JSVal -> action) -> JSVal -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Payload json -> action
onMessage (Payload json -> action)
-> (JSVal -> Payload json) -> JSVal -> action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArrayBuffer -> Payload json
forall value. ArrayBuffer -> Payload value
BUFFER (ArrayBuffer -> Payload json)
-> (JSVal -> ArrayBuffer) -> JSVal -> Payload json
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSVal -> ArrayBuffer
ArrayBuffer))
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> action
onError (MisoString -> JSM ())
-> (JSVal -> JSM MisoString) -> JSVal -> JSM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> JSM MisoString
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked)
      Bool
False
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/WebSocket/WebSocket>
websocketCore
  :: (WebSocket -> Sink action -> JSM Socket)
  -> Effect parent model action
websocketCore :: forall action parent model.
(WebSocket -> Sink action -> JSM JSVal)
-> Effect parent model action
websocketCore WebSocket -> Sink action -> JSM JSVal
core = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink -> do
    webSocketId <- JSM WebSocket
freshWebSocket
    socket <- core webSocketId sink
    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)
  [Schedule action]
  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
  :: ToJSON value
  => WebSocket
  -> Payload value
  -> Effect parent model action
websocketSend :: forall value parent model action.
ToJSON value =>
WebSocket -> Payload value -> Effect parent model action
websocketSend WebSocket
socketId Payload value
msg = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  io_ $ do
    getWebSocket _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 ->
        case Payload value
msg of
          JSON value
json_ ->
            JSVal -> JSVal -> JSM ()
FFI.websocketSend JSVal
socket (JSVal -> JSM ()) -> JSM JSVal -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< value -> JSM JSVal
forall json. ToJSON json => json -> JSM JSVal
FFI.jsonStringify value
json_
          BUFFER ArrayBuffer
arrayBuffer_ -> do
            JSVal -> JSVal -> JSM ()
FFI.websocketSend JSVal
socket (JSVal -> JSM ()) -> JSM JSVal -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ArrayBuffer -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal ArrayBuffer
arrayBuffer_
          TEXT MisoString
txt ->
            JSVal -> JSVal -> JSM ()
FFI.websocketSend JSVal
socket (JSVal -> JSM ()) -> JSM JSVal -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal MisoString
txt
          BLOB Blob
blob_ ->
            JSVal -> JSVal -> JSM ()
FFI.websocketSend JSVal
socket (JSVal -> JSM ()) -> JSM JSVal -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Blob -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal Blob
blob_
-----------------------------------------------------------------------------
-- | Retrieves current status of t'WebSocket'
--
-- If the t'WebSocket' identifier does not exist a 'CLOSED' is returned.
--
socketState :: WebSocket -> (SocketState -> action) -> Effect parent model action
socketState :: forall action parent model.
WebSocket -> (SocketState -> action) -> Effect parent model action
socketState WebSocket
socketId SocketState -> action
callback = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink -> do
     Int -> WebSocket -> WebSockets -> Maybe 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 = \case
  Int
1000 -> CloseCode
CLOSE_NORMAL
  Int
1001 -> CloseCode
CLOSE_GOING_AWAY
  Int
1002 -> CloseCode
CLOSE_PROTOCOL_ERROR
  Int
1003 -> CloseCode
CLOSE_UNSUPPORTED
  Int
1005 -> CloseCode
CLOSE_NO_STATUS
  Int
1006 -> CloseCode
CLOSE_ABNORMAL
  Int
1007 -> CloseCode
Unsupported_Data
  Int
1008 -> CloseCode
Policy_Violation
  Int
1009 -> CloseCode
CLOSE_TOO_LARGE
  Int
1010 -> CloseCode
Missing_Extension
  Int
1011 -> CloseCode
Internal_Error
  Int
1012 -> CloseCode
Service_Restart
  Int
1013 -> CloseCode
Try_Again_Later
  Int
1015 -> CloseCode
TLS_Handshake
  Int
n    -> Int -> CloseCode
OtherCode Int
n
-----------------------------------------------------------------------------
-- | Closed message is sent when a t'WebSocket' has closed
data Closed
  = Closed
  { Closed -> CloseCode
closedCode :: CloseCode
    -- ^ The code used to indicate why a socket closed
  , Closed -> Bool
wasClean :: Bool
    -- ^ If the connection was closed cleanly, or forcefully.
  , Closed -> MisoString
reason :: MisoString
    -- ^ The reason for socket closure.
  } deriving (Closed -> Closed -> Bool
(Closed -> Closed -> Bool)
-> (Closed -> Closed -> Bool) -> Eq Closed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Closed -> Closed -> Bool
== :: Closed -> Closed -> Bool
$c/= :: Closed -> Closed -> Bool
/= :: Closed -> Closed -> Bool
Eq, Int -> Closed -> ShowS
[Closed] -> ShowS
Closed -> String
(Int -> Closed -> ShowS)
-> (Closed -> String) -> ([Closed] -> ShowS) -> Show Closed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Closed -> ShowS
showsPrec :: Int -> Closed -> ShowS
$cshow :: Closed -> String
show :: Closed -> String
$cshowList :: [Closed] -> ShowS
showList :: [Closed] -> ShowS
Show)
-----------------------------------------------------------------------------
instance FromJSVal Closed where
  fromJSVal :: JSVal -> 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 t'WebSocket' will @connect@ to
type URL = MisoString
-----------------------------------------------------------------------------
-- | 'SocketState' corresponding to current t'WebSocket' connection
data SocketState
  = CONNECTING -- ^ 0
  | OPEN       -- ^ 1
  | CLOSING    -- ^ 2
  | CLOSED     -- ^ 3
  deriving (Int -> SocketState -> ShowS
[SocketState] -> ShowS
SocketState -> String
(Int -> SocketState -> ShowS)
-> (SocketState -> String)
-> ([SocketState] -> ShowS)
-> Show SocketState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SocketState -> ShowS
showsPrec :: Int -> SocketState -> ShowS
$cshow :: SocketState -> String
show :: SocketState -> String
$cshowList :: [SocketState] -> ShowS
showList :: [SocketState] -> ShowS
Show, SocketState -> SocketState -> Bool
(SocketState -> SocketState -> Bool)
-> (SocketState -> SocketState -> Bool) -> Eq SocketState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SocketState -> SocketState -> Bool
== :: SocketState -> SocketState -> Bool
$c/= :: SocketState -> SocketState -> Bool
/= :: SocketState -> SocketState -> Bool
Eq, Eq SocketState
Eq SocketState =>
(SocketState -> SocketState -> Ordering)
-> (SocketState -> SocketState -> Bool)
-> (SocketState -> SocketState -> Bool)
-> (SocketState -> SocketState -> Bool)
-> (SocketState -> SocketState -> Bool)
-> (SocketState -> SocketState -> SocketState)
-> (SocketState -> SocketState -> SocketState)
-> Ord SocketState
SocketState -> SocketState -> Bool
SocketState -> SocketState -> Ordering
SocketState -> SocketState -> SocketState
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SocketState -> SocketState -> Ordering
compare :: SocketState -> SocketState -> Ordering
$c< :: SocketState -> SocketState -> Bool
< :: SocketState -> SocketState -> Bool
$c<= :: SocketState -> SocketState -> Bool
<= :: SocketState -> SocketState -> Bool
$c> :: SocketState -> SocketState -> Bool
> :: SocketState -> SocketState -> Bool
$c>= :: SocketState -> SocketState -> Bool
>= :: SocketState -> SocketState -> Bool
$cmax :: SocketState -> SocketState -> SocketState
max :: SocketState -> SocketState -> SocketState
$cmin :: SocketState -> SocketState -> SocketState
min :: SocketState -> SocketState -> SocketState
Ord, Int -> SocketState
SocketState -> Int
SocketState -> [SocketState]
SocketState -> SocketState
SocketState -> SocketState -> [SocketState]
SocketState -> SocketState -> SocketState -> [SocketState]
(SocketState -> SocketState)
-> (SocketState -> SocketState)
-> (Int -> SocketState)
-> (SocketState -> Int)
-> (SocketState -> [SocketState])
-> (SocketState -> SocketState -> [SocketState])
-> (SocketState -> SocketState -> [SocketState])
-> (SocketState -> SocketState -> SocketState -> [SocketState])
-> Enum SocketState
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: SocketState -> SocketState
succ :: SocketState -> SocketState
$cpred :: SocketState -> SocketState
pred :: SocketState -> SocketState
$ctoEnum :: Int -> SocketState
toEnum :: Int -> SocketState
$cfromEnum :: SocketState -> Int
fromEnum :: SocketState -> Int
$cenumFrom :: SocketState -> [SocketState]
enumFrom :: SocketState -> [SocketState]
$cenumFromThen :: SocketState -> SocketState -> [SocketState]
enumFromThen :: SocketState -> SocketState -> [SocketState]
$cenumFromTo :: SocketState -> SocketState -> [SocketState]
enumFromTo :: SocketState -> SocketState -> [SocketState]
$cenumFromThenTo :: SocketState -> SocketState -> SocketState -> [SocketState]
enumFromThenTo :: SocketState -> SocketState -> SocketState -> [SocketState]
Enum)
-----------------------------------------------------------------------------
-- | Code corresponding to a closed connection
-- https://developer.mozilla.org/en-US/docs/Web/API/CloseEvent
data CloseCode
  = CLOSE_NORMAL
   -- ^ 1000, Normal closure; the connection successfully completed whatever purpose for which it was created.
  | CLOSE_GOING_AWAY
   -- ^ 1001, The endpoint is going away, either because of a server failure or because the browser is navigating away from the page that opened the connection.
  | CLOSE_PROTOCOL_ERROR
   -- ^ 1002, The endpoint is terminating the connection due to a protocol error.
  | CLOSE_UNSUPPORTED
   -- ^ 1003, The connection is being terminated because the endpoint received data of a type it cannot accept (for example, a textonly endpoint received binary data).
  | CLOSE_NO_STATUS
   -- ^ 1005, Reserved.  Indicates that no status code was provided even though one was expected.
  | CLOSE_ABNORMAL
   -- ^ 1006, Reserved. Used to indicate that a connection was closed abnormally (that is, with no close frame being sent) when a status code is expected.
  | Unsupported_Data
   -- ^ 1007, The endpoint is terminating the connection because a message was received that contained inconsistent data (e.g., nonUTF8 data within a text message).
  | Policy_Violation
   -- ^ 1008, The endpoint is terminating the connection because it received a message that violates its policy. This is a generic status code, used when codes 1003 and 1009 are not suitable.
  | CLOSE_TOO_LARGE
   -- ^ 1009, The endpoint is terminating the connection because a data frame was received that is too large.
  | Missing_Extension
   -- ^ 1010, The client is terminating the connection because it expected the server to negotiate one or more extension, but the server didn't.
  | Internal_Error
   -- ^ 1011, The server is terminating the connection because it encountered an unexpected condition that prevented it from fulfilling the request.
  | Service_Restart
   -- ^ 1012, The server is terminating the connection because it is restarting.
  | Try_Again_Later
   -- ^ 1013, The server is terminating the connection due to a temporary condition, e.g. it is overloaded and is casting off some of its clients.
  | TLS_Handshake
   -- ^ 1015, Reserved. Indicates that the connection was closed due to a failure to perform a TLS handshake (e.g., the server certificate can't be verified).
  | OtherCode Int
   -- ^ OtherCode that is reserved and not in the range 0999
  deriving (Int -> CloseCode -> ShowS
[CloseCode] -> ShowS
CloseCode -> String
(Int -> CloseCode -> ShowS)
-> (CloseCode -> String)
-> ([CloseCode] -> ShowS)
-> Show CloseCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CloseCode -> ShowS
showsPrec :: Int -> CloseCode -> ShowS
$cshow :: CloseCode -> String
show :: CloseCode -> String
$cshowList :: [CloseCode] -> ShowS
showList :: [CloseCode] -> ShowS
Show, CloseCode -> CloseCode -> Bool
(CloseCode -> CloseCode -> Bool)
-> (CloseCode -> CloseCode -> Bool) -> Eq CloseCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CloseCode -> CloseCode -> Bool
== :: CloseCode -> CloseCode -> Bool
$c/= :: CloseCode -> CloseCode -> Bool
/= :: CloseCode -> CloseCode -> Bool
Eq)
-----------------------------------------------------------------------------
-- | Type for holding a t'WebSocket' file descriptor.
newtype WebSocket = WebSocket Int
  deriving ([WebSocket] -> 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)
-----------------------------------------------------------------------------
-- | A null t'WebSocket' is one with a negative descriptor.
emptyWebSocket :: WebSocket
emptyWebSocket :: WebSocket
emptyWebSocket = (-WebSocket
1)
-----------------------------------------------------------------------------
-- | A type for holding an t'EventSource' descriptor.
newtype EventSource = EventSource Int
  deriving ([EventSource] -> 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)
-----------------------------------------------------------------------------
-- | A null t'EventSource' is one with a negative descriptor.
emptyEventSource :: EventSource
emptyEventSource :: EventSource
emptyEventSource = (-EventSource
1)
-----------------------------------------------------------------------------
eventSourceConnections :: IORef EventSources
{-# NOINLINE eventSourceConnections #-}
eventSourceConnections :: IORef WebSockets
eventSourceConnections = IO (IORef WebSockets) -> IORef WebSockets
forall a. IO a -> a
unsafePerformIO (WebSockets -> IO (IORef WebSockets)
forall a. a -> IO (IORef a)
newIORef WebSockets
forall a. IntMap a
IM.empty)
-----------------------------------------------------------------------------
eventSourceConnectionIds :: IORef Int
{-# NOINLINE eventSourceConnectionIds #-}
eventSourceConnectionIds :: IORef Int
eventSourceConnectionIds = IO (IORef Int) -> IORef Int
forall a. IO a -> a
unsafePerformIO (Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int))
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/EventSource/EventSource>
eventSourceConnectText
  :: URL
  -- ^ EventSource URL
  -> (EventSource -> action)
  -- ^ onOpen
  -> (MisoString -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect parent model action
eventSourceConnectText :: forall action parent model.
MisoString
-> (EventSource -> action)
-> (MisoString -> action)
-> (MisoString -> action)
-> Effect parent model action
eventSourceConnectText MisoString
url EventSource -> action
onOpen MisoString -> action
onMessage MisoString -> action
onError =
  (EventSource -> Sink action -> JSM JSVal)
-> Effect parent model action
forall action parent model.
(EventSource -> Sink action -> JSM JSVal)
-> Effect parent model action
eventSourceCore ((EventSource -> Sink action -> JSM JSVal)
 -> Effect parent model action)
-> (EventSource -> Sink action -> JSM JSVal)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \EventSource
eventSourceId Sink action
sink -> do
    MisoString
-> JSM ()
-> Maybe (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> (JSVal -> JSM ())
-> Bool
-> JSM JSVal
FFI.eventSourceConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ EventSource -> action
onOpen EventSource
eventSourceId)
      ((JSVal -> JSM ()) -> Maybe (JSVal -> JSM ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((JSVal -> JSM ()) -> Maybe (JSVal -> JSM ()))
-> (JSVal -> JSM ()) -> Maybe (JSVal -> JSM ())
forall a b. (a -> b) -> a -> b
$ \JSVal
e -> do
          txt <- JSVal -> JSM MisoString
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked JSVal
e
          sink (onMessage txt))
      Maybe (JSVal -> JSM ())
forall a. Maybe a
Nothing
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> action
onError (MisoString -> JSM ())
-> (JSVal -> JSM MisoString) -> JSVal -> JSM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> JSM MisoString
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked)
      Bool
True
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/EventSource/EventSource>
eventSourceConnectJSON
  :: FromJSON json
  => URL
  -- ^ EventSource URL
  -> (EventSource -> action)
  -- ^ onOpen
  -> (json -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect parent model action
eventSourceConnectJSON :: forall json action parent model.
FromJSON json =>
MisoString
-> (EventSource -> action)
-> (json -> action)
-> (MisoString -> action)
-> Effect parent model action
eventSourceConnectJSON MisoString
url EventSource -> action
onOpen json -> action
onMessage MisoString -> action
onError =
  (EventSource -> Sink action -> JSM JSVal)
-> Effect parent model action
forall action parent model.
(EventSource -> Sink action -> JSM JSVal)
-> Effect parent model action
eventSourceCore ((EventSource -> Sink action -> JSM JSVal)
 -> Effect parent model action)
-> (EventSource -> Sink action -> JSM JSVal)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \EventSource
eventSourceId Sink action
sink -> do
    MisoString
-> JSM ()
-> Maybe (JSVal -> JSM ())
-> Maybe (JSVal -> JSM ())
-> (JSVal -> JSM ())
-> Bool
-> JSM JSVal
FFI.eventSourceConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ EventSource -> action
onOpen EventSource
eventSourceId)
      Maybe (JSVal -> JSM ())
forall a. Maybe a
Nothing
      ((JSVal -> JSM ()) -> Maybe (JSVal -> JSM ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((JSVal -> JSM ()) -> Maybe (JSVal -> JSM ()))
-> (JSVal -> JSM ()) -> Maybe (JSVal -> JSM ())
forall a b. (a -> b) -> a -> b
$ \JSVal
e ->
         Mail -> Result json
forall a. FromJSON a => Mail -> Result a
fromJSON (Mail -> Result json) -> JSM Mail -> JSM (Result json)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSVal -> JSM Mail
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked JSVal
e JSM (Result json) -> (Result json -> 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
            Error String
errMsg -> Sink action
sink (MisoString -> action
onError (String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms String
errMsg))
            Success json
json_ -> Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ json -> action
onMessage json
json_)
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> action
onError (MisoString -> JSM ())
-> (JSVal -> JSM MisoString) -> JSVal -> JSM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> JSM MisoString
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked)
      Bool
False
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/EventSource/EventSource>
eventSourceCore
  :: (EventSource -> Sink action -> JSM Socket)
  -> Effect parent model action
eventSourceCore :: forall action parent model.
(EventSource -> Sink action -> JSM JSVal)
-> Effect parent model action
eventSourceCore EventSource -> Sink action -> JSM JSVal
core = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink -> do
    eventSourceId <- JSM EventSource
freshEventSource
    socket <- core eventSourceId sink
    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)
  [Schedule action]
  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, ())
-----------------------------------------------------------------------------
-- | Payload is used as the potential source of data when working with t'EventSource'
data Payload value
  = JSON value
  -- ^ JSON-encoded data
  | BLOB Blob
  -- ^ Binary encoded data
  | TEXT MisoString
  -- ^ Text encoded data
  | BUFFER ArrayBuffer
  -- ^ Buffered data
-----------------------------------------------------------------------------
-- | Smart constructor for sending JSON encoded data via an t'EventSource'
json :: ToJSON value => value -> Payload value
json :: forall value. ToJSON value => value -> Payload value
json = value -> Payload value
forall value. value -> Payload value
JSON
-----------------------------------------------------------------------------
-- | Smart constructor for sending binary encoded data via an t'EventSource'
blob :: Blob -> Payload value
blob :: forall value. Blob -> Payload value
blob = Blob -> Payload value
forall value. Blob -> Payload value
BLOB
-----------------------------------------------------------------------------
-- | Smart constructor for sending an @ArrayBuffer@ via an t'EventSource'
arrayBuffer :: ArrayBuffer -> Payload value
arrayBuffer :: forall value. ArrayBuffer -> Payload value
arrayBuffer = ArrayBuffer -> Payload value
forall value. ArrayBuffer -> Payload value
BUFFER
-----------------------------------------------------------------------------
#ifndef GHCJS_BOTH
instance FromJSVal Function where
  fromJSVal :: JSVal -> JSM (Maybe Function)
fromJSVal = Maybe Function -> JSM (Maybe Function)
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Function -> JSM (Maybe Function))
-> (JSVal -> Maybe Function) -> JSVal -> JSM (Maybe Function)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Maybe Function
forall a. a -> Maybe a
Just (Function -> Maybe Function)
-> (JSVal -> Function) -> JSVal -> Maybe Function
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Function
Function (Object -> Function) -> (JSVal -> Object) -> JSVal -> Function
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSVal -> Object
Object
#endif
-----------------------------------------------------------------------------