-----------------------------------------------------------------------------
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# 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
#ifdef WASM
  , evalFile
#endif
  ) where
-----------------------------------------------------------------------------
import           Control.Concurrent
import           Control.Concurrent.STM
import           Control.Exception (SomeException, catch)
import           Control.Monad (forM, forM_, when, void, forever, (<=<), zipWithM_)
import           Control.Monad.Reader (ask, asks)
import           Control.Monad.IO.Class
import           Miso.JSON (FromJSON, ToJSON, Result(..), fromJSON, toJSON, Value(Null))
import           Data.Foldable (toList)
import           Data.IORef (IORef, newIORef, atomicModifyIORef', readIORef, atomicWriteIORef, modifyIORef')
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import           Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM
import qualified Data.Sequence as S
import           Data.Sequence (Seq)
import           GHC.Conc (ThreadStatus(ThreadDied, ThreadFinished), threadStatus)
#ifdef WASM
import qualified Language.Haskell.TH as TH
#endif
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           Miso.DSL
#ifdef WASM
import           Miso.DSL.TH
#endif
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.JSON (encode)
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)
  => Events
  -> ComponentId
  -> Hydrate
  -> Bool
  -- ^ Is the root node being rendered?
  -> Component parent model action
  -> IO DOMRef
  -- ^ Callback function is used for obtaining the t'Miso.Types.Component' 'DOMRef'.
  -> IO (ComponentState model action)
initialize :: forall parent model action.
(Eq parent, Eq model) =>
Events
-> Int
-> Hydrate
-> Bool
-> Component parent model action
-> IO JSVal
-> IO (ComponentState model action)
initialize Events
events Int
componentParentId Hydrate
hydrate Bool
isRoot comp :: Component parent model action
comp@Component {model
Bool
[Binding parent model]
[JS]
[CSS]
[Sub action]
Maybe action
Maybe (IO model)
Maybe MisoString
LogLevel
model -> View model action
action -> Effect parent model action
Mail -> Maybe action
model :: model
hydrateModel :: Maybe (IO model)
update :: action -> Effect parent model action
view :: model -> View model action
subs :: [Sub action]
styles :: [CSS]
scripts :: [JS]
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]
subs :: forall parent model action.
Component parent model action -> [Sub action]
view :: forall parent model action.
Component parent model action -> model -> View model action
update :: forall parent model action.
Component parent model action
-> action -> Effect parent model action
hydrateModel :: forall parent model action.
Component parent model action -> Maybe (IO model)
model :: forall parent model action. Component parent model action -> model
..} IO JSVal
getComponentMountPoint = do
  Waiter {..} <- IO Waiter -> IO Waiter
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Waiter
waiter
  componentActions <- liftIO (newIORef S.empty)
  let
    componentSink = \action
action -> IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      IORef (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 IO model
action) ->
#ifdef SSR
         liftIO action
#else
         IO model
action
#endif
      (Hydrate, Maybe (IO model))
_ -> model -> IO model
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure model
model
  componentScripts <- (++) <$> renderScripts scripts <*> renderStyles styles
  componentDOMRef <- getComponentMountPoint
  componentIsDirty <- liftIO (newTVarIO False)
  componentVTree <- liftIO $ newIORef (VTree (Object jsNull))
  componentSubThreads <- liftIO (newIORef M.empty)
  forM_ subs $ \Sub action
sub -> do
    threadId <- IO () -> IO ThreadId
forkIO (Sub action
sub action -> IO ()
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, ())
  frame <- newEmptyMVar :: IO (MVar Double)
  rAFCallback <-
    asyncCallback1 $ \JSVal
jsval -> do
      MVar Double -> Double -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Double
frame (Double -> IO ()) -> IO Double -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal -> IO Double
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked JSVal
jsval
  componentModel <- liftIO (newTVarIO initializedModel)
  let
    eventLoop = IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
wait IO () -> IO b -> IO b
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> do
      currentModel <- IO model -> IO model
forall a. IO a -> IO 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 events componentParentId componentId Draw componentSink logLevel (view updatedModel)
        oldVTree <- liftIO (readIORef componentVTree)
        _frame <- requestAnimationFrame rAFCallback
        _timestamp :: Double <- takeMVar frame
        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.
      eventLoop

  -- mailbox
  componentMailbox <- liftIO newMailbox
  componentMailboxThreadId <- do
    forkIO . 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
TVar model
TVar Bool
ThreadId
IORef (Seq action)
IORef (Map MisoString ThreadId)
IORef VTree
Mailbox
JSVal
action -> IO ()
componentActions :: IORef (Seq action)
componentSink :: action -> IO ()
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 -> IO ()
componentVTree :: IORef VTree
componentDOMRef :: JSVal
componentSubThreads :: IORef (Map MisoString ThreadId)
componentId :: Int
..
        }

  registerComponent vcomp
  when isRoot $ do
    delegator componentDOMRef componentVTree events (logLevel `elem` [DebugEvents, DebugAll])
  initialDraw initializedModel events hydrate isRoot comp vcomp
  forM_ initialAction componentSink
  _ <- forkIO eventLoop
  pure vcomp
-----------------------------------------------------------------------------
initialDraw
  :: Eq m
  => m
  -> Events
  -> Hydrate
  -> Bool
  -> Component p m a
  -> ComponentState m a
  -> IO ()
initialDraw :: forall m p a.
Eq m =>
m
-> Events
-> Hydrate
-> Bool
-> Component p m a
-> ComponentState m a
-> IO ()
initialDraw m
initializedModel Events
events Hydrate
hydrate Bool
isRoot Component {m
Bool
[Binding p m]
[JS]
[CSS]
[Sub a]
Maybe a
Maybe (IO m)
Maybe MisoString
LogLevel
m -> View m a
a -> Effect p m a
Mail -> Maybe a
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]
subs :: forall parent model action.
Component parent model action -> [Sub action]
view :: forall parent model action.
Component parent model action -> model -> View model action
update :: forall parent model action.
Component parent model action
-> action -> Effect parent model action
hydrateModel :: forall parent model action.
Component parent model action -> Maybe (IO model)
model :: forall parent model action. Component parent model action -> model
model :: m
hydrateModel :: Maybe (IO m)
update :: a -> Effect p m a
view :: m -> View m a
subs :: [Sub a]
styles :: [CSS]
scripts :: [JS]
initialAction :: Maybe a
mountPoint :: Maybe MisoString
logLevel :: LogLevel
mailbox :: Mail -> Maybe a
bindings :: [Binding p m]
eventPropagation :: Bool
..} ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
TVar m
TVar Bool
ThreadId
IORef (Seq a)
IORef (Map MisoString ThreadId)
IORef VTree
Events
Mailbox
JSVal
a -> IO ()
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 -> IO ()
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 :: a -> IO ()
componentModel :: TVar m
componentIsDirty :: TVar Bool
componentActions :: IORef (Seq a)
componentMailbox :: Mailbox
componentScripts :: [JSVal]
componentMailboxThreadId :: ThreadId
componentDiffs :: Mailbox
componentNotify :: IO ()
componentParentToChildThreadId :: Maybe ThreadId
componentChildToParentThreadId :: Maybe ThreadId
componentEvents :: Events
..} = do
#ifdef BENCH
  start <- FFI.now
#endif
  vtree <- Events
-> Int
-> Int
-> Hydrate
-> (a -> IO ())
-> LogLevel
-> View m a
-> IO VTree
forall model action.
Eq model =>
Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> View model action
-> IO VTree
buildVTree Events
events Int
componentParentId Int
componentId Hydrate
hydrate a -> IO ()
componentSink LogLevel
logLevel (m -> View m a
view m
initializedModel)
#ifdef BENCH
  end <- FFI.now
  when isRoot $ FFI.consoleLog $ ms (printf "buildVTree: %.3f ms" (end - start) :: String)
#endif
  case hydrate of
    Hydrate
Draw -> do
      Maybe VTree -> Maybe VTree -> JSVal -> IO ()
Diff.diff Maybe VTree
forall a. Maybe a
Nothing (VTree -> Maybe VTree
forall a. a -> Maybe a
Just VTree
vtree) JSVal
componentDOMRef
      IORef VTree -> VTree -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef VTree
componentVTree VTree
vtree
    Hydrate
Hydrate -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isRoot (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        hydrated <- LogLevel -> JSVal -> VTree -> IO Bool
Hydrate.hydrate LogLevel
logLevel JSVal
componentDOMRef VTree
vtree
        if hydrated
          then atomicWriteIORef componentVTree vtree
          else do
            liftIO $ do -- dmj: reset state
              atomicWriteIORef components IM.empty
              atomicWriteIORef componentIds topLevelComponentId
              atomicWriteIORef subscribers mempty
              atomicWriteIORef mailboxes mempty
            newTree <- buildVTree events componentParentId componentId Draw componentSink logLevel (view initializedModel)
            Diff.diff Nothing (Just newTree) componentDOMRef
            liftIO (atomicWriteIORef componentVTree newTree)
-----------------------------------------------------------------------------
synchronizeChildToParent
  :: Eq parent
  => ComponentId
  -> TVar model
  -> Mailbox
  -> [ Binding parent model ]
  -> IO (Maybe ThreadId)
synchronizeChildToParent :: forall parent model.
Eq parent =>
Int
-> TVar model
-> Mailbox
-> [Binding parent model]
-> IO (Maybe ThreadId)
synchronizeChildToParent Int
_ TVar model
_ Mailbox
_ [] = Maybe ThreadId -> IO (Maybe ThreadId)
forall a. a -> IO 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 15))
-> Maybe (ComponentState parent (ZonkAny 15))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
parentId (IntMap (ComponentState parent (ZonkAny 15))
 -> Maybe (ComponentState parent (ZonkAny 15)))
-> IO (IntMap (ComponentState parent (ZonkAny 15)))
-> IO (Maybe (ComponentState parent (ZonkAny 15)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IntMap (ComponentState parent (ZonkAny 15)))
-> IO (IntMap (ComponentState parent (ZonkAny 15)))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (IntMap (ComponentState parent (ZonkAny 15)))
-> IO (IntMap (ComponentState parent (ZonkAny 15)))
forall a. IORef a -> IO a
readIORef IORef (IntMap (ComponentState parent (ZonkAny 15)))
forall model action. IORef (IntMap (ComponentState model action))
components) IO (Maybe (ComponentState parent (ZonkAny 15)))
-> (Maybe (ComponentState parent (ZonkAny 15))
    -> IO (Maybe ThreadId))
-> IO (Maybe ThreadId)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (ComponentState parent (ZonkAny 15))
Nothing -> do
      -- dmj: another impossible case, parent always mounted in children
      Maybe ThreadId -> IO (Maybe ThreadId)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ThreadId
forall a. Maybe a
Nothing
    Just ComponentState parent (ZonkAny 15)
parentComponentState -> do
      ComponentState parent (ZonkAny 15) -> IO ()
forall {action}. ComponentState parent action -> IO ()
bindProperty ComponentState parent (ZonkAny 15)
parentComponentState
      -- dmj: ^ parent assumes child state on initialization
      (ThreadId -> Maybe ThreadId) -> IO ThreadId -> IO (Maybe ThreadId)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ThreadId -> Maybe ThreadId
forall a. a -> Maybe a
Just (IO ThreadId -> IO (Maybe ThreadId))
-> IO ThreadId -> IO (Maybe ThreadId)
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
        IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          _ <- IO Mail -> IO Mail
forall a. IO a -> IO 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 -> IO ()
bindProperty ComponentState parent action
parentComponentState = do
      isDirty <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding parent model]
-> (Binding parent model -> IO Bool) -> IO [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 -> IO Bool
forall parent model action.
Eq parent =>
ComponentState parent action
-> TVar model -> Binding parent model -> IO Bool
bindChildToParent ComponentState parent action
parentComponentState TVar model
componentModel)
      when isDirty $ do
        liftIO $ do
          atomically $ writeTVar (componentIsDirty parentComponentState) True
          componentNotify parentComponentState
-----------------------------------------------------------------------------
bindChildToParent
  :: forall parent model action
   . Eq parent
  => ComponentState parent action
  -- ^ Parent model
  -> TVar model
  -- ^ Child new model
  -> Binding parent model
  -- ^ Binding
  -> IO Bool
bindChildToParent :: forall parent model action.
Eq parent =>
ComponentState parent action
-> TVar model -> Binding parent model -> IO Bool
bindChildToParent ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
TVar parent
TVar Bool
ThreadId
IORef (Seq action)
IORef (Map MisoString ThreadId)
IORef VTree
Events
Mailbox
JSVal
action -> IO ()
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 -> IO ()
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 -> IO ()
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) -> IO 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) -> IO 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 -> IO Bool
forall a. a -> IO 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 ()
  -> IO (Maybe ThreadId)
synchronizeParentToChild :: forall model type_.
Eq model =>
Int
-> TVar model
-> TVar Bool
-> [Binding type_ model]
-> IO ()
-> IO (Maybe ThreadId)
synchronizeParentToChild Int
_ TVar model
_ TVar Bool
_ [] IO ()
_ = Maybe ThreadId -> IO (Maybe ThreadId)
forall a. a -> IO 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)))
-> IO (IntMap (ComponentState type_ (ZonkAny 14)))
-> IO (Maybe (ComponentState type_ (ZonkAny 14)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IntMap (ComponentState type_ (ZonkAny 14)))
-> IO (IntMap (ComponentState type_ (ZonkAny 14)))
forall a. IO a -> IO 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) IO (Maybe (ComponentState type_ (ZonkAny 14)))
-> (Maybe (ComponentState type_ (ZonkAny 14))
    -> IO (Maybe ThreadId))
-> IO (Maybe ThreadId)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (ComponentState type_ (ZonkAny 14))
Nothing -> do
      -- dmj: another impossible case, parent always mounted
      Maybe ThreadId -> IO (Maybe ThreadId)
forall a. a -> IO 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) -> IO ()
forall {action}. ComponentState type_ action -> IO ()
bindProperty ComponentState type_ (ZonkAny 14)
parentComponentState
      -- dmj: ^ assume parent state on initialization
      (ThreadId -> Maybe ThreadId) -> IO ThreadId -> IO (Maybe ThreadId)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ThreadId -> Maybe ThreadId
forall a. a -> Maybe a
Just (IO ThreadId -> IO (Maybe ThreadId))
-> IO ThreadId -> IO (Maybe ThreadId)
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Mail -> IO ()
Null <- IO Mail -> IO Mail
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Mail -> IO Mail) -> IO Mail -> IO 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 -> IO ()
bindProperty ComponentState type_ action
parentComponentState = do
      isDirty <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding type_ model]
-> (Binding type_ model -> IO Bool) -> IO [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 -> IO Bool
forall props model action.
Eq model =>
ComponentState props action
-> TVar model -> Binding props model -> IO 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
  -> IO Bool
bindParentToChild :: forall props model action.
Eq model =>
ComponentState props action
-> TVar model -> Binding props model -> IO Bool
bindParentToChild ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
TVar props
TVar Bool
ThreadId
IORef (Seq action)
IORef (Map MisoString ThreadId)
IORef VTree
Events
Mailbox
JSVal
action -> IO ()
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 -> IO ()
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 -> IO ()
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) -> IO 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) -> IO 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 -> IO Bool
forall a. a -> IO 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 -> IO ()
componentSink :: action -> IO ()
  -- ^ 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 -> IO ()
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)
-> IO (Map (Topic message) Mailbox) -> IO (Maybe Mailbox)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map (Topic message) Mailbox)
-> IO (Map (Topic message) Mailbox)
forall a. IO a -> IO 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) IO (Maybe Mailbox) -> (Maybe Mailbox -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe Mailbox
Nothing -> do
            -- no mailbox exists, create a new one, register it and subscribe
            mailbox <- IO Mailbox -> IO Mailbox
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Mailbox -> IO Mailbox) -> IO Mailbox -> IO 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 -> IO ()
forall {a}. (Int, Topic a) -> Mailbox -> Int -> IO ()
subscribeToMailbox (Int, Topic message)
key Mailbox
mailbox Int
vcompId
  where
    subscribeToMailbox :: (Int, Topic a) -> Mailbox -> Int -> IO ()
subscribeToMailbox (Int, Topic a)
key Mailbox
mailbox Int
vcompId = do
      threadId <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
        clonedMailbox <- IO Mailbox -> IO Mailbox
forall a. IO a -> IO 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 -> IO ()
componentSink (message -> action
successful message
msg)
            Error MisoString
msg ->
              action -> IO ()
componentSink (MisoString -> action
errorful (MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
ms MisoString
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 -> IO ()
unsubscribe_ :: forall message. Topic message -> Int -> IO ()
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)
-> IO (Map (Int, Topic message) ThreadId)
forall a. IO a -> IO 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 () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        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 ->
      () -> IO ()
forall a. a -> IO 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 = IO () -> Effect parent model action
forall a parent model action. IO a -> Effect parent model action
io_ (IO () -> Effect parent model action)
-> IO () -> 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)
-> IO (Map (Topic message) Mailbox) -> IO (Maybe Mailbox)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map (Topic message) Mailbox)
-> IO (Map (Topic message) Mailbox)
forall a. IO a -> IO 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 () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Mailbox -> Mail -> IO ()
sendMail Mailbox
mailbox (message -> Mail
forall a. ToJSON a => a -> Mail
toJSON message
value)
    Maybe Mailbox
Nothing -> IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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 -> IO () -> IO ()
evalScheduled :: Synchronicity -> IO () -> IO ()
evalScheduled Synchronicity
Sync IO ()
x = IO ()
x
evalScheduled Synchronicity
Async IO ()
x = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ThreadId
forkIO IO ()
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
  -> IO model
foldEffects :: forall action parent model.
(action -> Effect parent model action)
-> Bool
-> ComponentInfo parent
-> Sink action
-> [action]
-> model
-> IO model
foldEffects action -> Effect parent model action
_ Bool
_ ComponentInfo parent
_ Sink action
_ [] model
m = model -> IO model
forall a. a -> IO 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 -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Schedule action]
subs ((Schedule action -> IO ()) -> IO ())
-> (Schedule action -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Schedule Synchronicity
synchronicity Sink action -> IO ()
sub) -> do
        let
          action :: IO ()
action = Sink action -> IO ()
sub Sink action
snk IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ())
-> (SomeException -> IO ()) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> IO ()
exception)
        if Bool
drainSink
          then Synchronicity -> IO () -> IO ()
evalScheduled Synchronicity
Sync IO ()
action
          else Synchronicity -> IO () -> IO ()
evalScheduled Synchronicity
synchronicity IO ()
action
      (action -> Effect parent model action)
-> Bool
-> ComponentInfo parent
-> Sink action
-> [action]
-> model
-> IO model
forall action parent model.
(action -> Effect parent model action)
-> Bool
-> ComponentInfo parent
-> Sink action
-> [action]
-> model
-> IO model
foldEffects action -> Effect parent model action
update Bool
drainSink ComponentInfo parent
info Sink action
snk [action]
es model
n
  where
    exception :: SomeException -> IO ()
    exception :: SomeException -> IO ()
exception SomeException
ex = MisoString -> IO ()
FFI.consoleError (MisoString
"[EXCEPTION]: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> SomeException -> MisoString
forall str. ToMisoString str => str -> MisoString
ms SomeException
ex)
-----------------------------------------------------------------------------
-- | Drains the event queue before unmounting, executed synchronously
drain
  :: Component parent model action
  -> ComponentState model action
  -> IO ()
drain :: forall parent model action.
Component parent model action
-> ComponentState model action -> IO ()
drain app :: Component parent model action
app@Component{model
Bool
[Binding parent model]
[JS]
[CSS]
[Sub action]
Maybe action
Maybe (IO model)
Maybe MisoString
LogLevel
model -> View model action
action -> Effect parent model action
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]
subs :: forall parent model action.
Component parent model action -> [Sub action]
view :: forall parent model action.
Component parent model action -> model -> View model action
update :: forall parent model action.
Component parent model action
-> action -> Effect parent model action
hydrateModel :: forall parent model action.
Component parent model action -> Maybe (IO model)
model :: forall parent model action. Component parent model action -> model
model :: model
hydrateModel :: Maybe (IO model)
update :: action -> Effect parent model action
view :: model -> View model action
subs :: [Sub action]
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 ()
TVar model
TVar Bool
ThreadId
IORef (Seq action)
IORef (Map MisoString ThreadId)
IORef VTree
Events
Mailbox
JSVal
action -> IO ()
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 -> IO ()
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 -> IO ()
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) -> IO (Seq action)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Seq action) -> IO (Seq action))
-> IO (Seq action) -> IO (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 -> IO ()
go ComponentInfo parent
info t action
actions = do
          x <- IO model -> IO model
forall a. IO a -> IO 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 -> IO ()
unloadScripts :: forall model action. ComponentState model action -> IO ()
unloadScripts ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
TVar model
TVar Bool
ThreadId
IORef (Seq action)
IORef (Map MisoString ThreadId)
IORef VTree
Events
Mailbox
JSVal
action -> IO ()
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 -> IO ()
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 -> IO ()
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_ <- IO JSVal
FFI.getHead
  forM_ componentScripts $ \JSVal
domRef ->
    JSVal -> JSVal -> IO ()
FFI.removeChild JSVal
head_ JSVal
domRef
-----------------------------------------------------------------------------
-- | Helper to drop all lifecycle and mounting hooks if defined.
freeLifecycleHooks :: ComponentState model action -> IO ()
freeLifecycleHooks :: forall model action. ComponentState model action -> IO ()
freeLifecycleHooks ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
TVar model
TVar Bool
ThreadId
IORef (Seq action)
IORef (Map MisoString ThreadId)
IORef VTree
Events
Mailbox
JSVal
action -> IO ()
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 -> IO ()
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 -> IO ()
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
  VTree (Object vcomp) <- IO VTree -> IO VTree
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef VTree -> IO VTree
forall a. IORef a -> IO a
readIORef IORef VTree
componentVTree)
  mapM_ freeFunction =<< fromJSVal =<< vcomp ! ("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)
-----------------------------------------------------------------------------
-- | Helper function for cleanly destroying a t'Miso.Types.Component'
unmount
  :: Component parent model action
  -> ComponentState model action
  -> IO ()
unmount :: forall parent model action.
Component parent model action
-> ComponentState model action -> IO ()
unmount Component parent model action
app cs :: ComponentState model action
cs@ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
TVar model
TVar Bool
ThreadId
IORef (Seq action)
IORef (Map MisoString ThreadId)
IORef VTree
Events
Mailbox
JSVal
action -> IO ()
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 -> IO ()
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 -> IO ()
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 () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    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 -> IO ()
killSubscribers Int
componentId
  Component parent model action
-> ComponentState model action -> IO ()
forall parent model action.
Component parent model action
-> ComponentState model action -> IO ()
drain Component parent model action
app ComponentState model action
cs
  Int -> IO ()
finalizeWebSockets Int
componentId
  Int -> IO ()
finalizeEventSources Int
componentId
  ComponentState model action -> IO ()
forall model action. ComponentState model action -> IO ()
unloadScripts ComponentState model action
cs
  ComponentState model action -> IO ()
forall model action. ComponentState model action -> IO ()
freeLifecycleHooks ComponentState model action
cs
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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 -> IO ()
killSubscribers :: Int -> IO ()
killSubscribers Int
componentId =
  (Topic (ZonkAny 11) -> IO ()) -> [Topic (ZonkAny 11)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Topic (ZonkAny 11) -> Int -> IO ())
-> Int -> Topic (ZonkAny 11) -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Topic (ZonkAny 11) -> Int -> IO ()
forall message. Topic message -> Int -> IO ()
unsubscribe_ Int
componentId) ([Topic (ZonkAny 11)] -> IO ()) -> IO [Topic (ZonkAny 11)] -> IO ()
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)])
-> IO (Map (Topic (ZonkAny 11)) Mailbox) -> IO [Topic (ZonkAny 11)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map (Topic (ZonkAny 11)) Mailbox)
-> IO (Map (Topic (ZonkAny 11)) Mailbox)
forall a. IO a -> IO 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
  => Events
  -> ComponentId
  -> ComponentId
  -> Hydrate
  -> Sink action
  -> LogLevel
  -> View model action
  -> IO VTree
buildVTree :: forall model action.
Eq model =>
Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> View model action
-> IO VTree
buildVTree Events
events_ Int
parentId Int
vcompId Hydrate
hydrate Sink action
snk LogLevel
logLevel_ = \case
  VComp [Attribute action]
attrs (SomeComponent Component model model action
app) -> do
    vcomp <- IO Object
create

    mountCallback <- do
      if hydrate == Hydrate
        then
          toJSVal jsNull
        else
          syncCallback1' $ \JSVal
parent_ -> do
            ComponentState {..} <- Events
-> Int
-> Hydrate
-> Bool
-> Component model model action
-> IO JSVal
-> IO (ComponentState model action)
forall parent model action.
(Eq parent, Eq model) =>
Events
-> Int
-> Hydrate
-> Bool
-> Component parent model action
-> IO JSVal
-> IO (ComponentState model action)
initialize Events
events_ Int
vcompId Hydrate
Draw Bool
False Component model model action
app (JSVal -> IO JSVal
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSVal
parent_)
            vtree <- toJSVal =<< readIORef componentVTree
            FFI.set "parent" vcomp (Object vtree)
            obj <- create
            setProp "componentId" componentId obj
            setProp "componentTree" vtree obj
            toJSVal obj

    unmountCallback <- toJSVal =<< do
      FFI.syncCallback1 $ \JSVal
vcompId_ -> do
        componentId_ <- JSVal -> IO Int
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked JSVal
vcompId_
        IM.lookup componentId_ <$> readIORef components >>= \case
          Maybe (ComponentState model action)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just ComponentState model action
componentState ->
            Component model model action
-> ComponentState model action -> IO ()
forall parent model action.
Component parent model action
-> ComponentState model action -> IO ()
unmount Component model model action
app ComponentState model action
componentState

    case hydrate of
      Hydrate
Hydrate -> do
        -- Mock .domRef for use during hydration
        domRef <- Object -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (Object -> IO JSVal) -> IO Object -> IO JSVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Object
create
        ComponentState {..} <- initialize events_ vcompId hydrate False app (pure domRef)
        vtree <- toJSVal =<< liftIO (readIORef componentVTree)
        FFI.set "parent" vcomp (Object vtree)
        vcompId_ <- toJSVal componentId
        FFI.set "componentId" vcompId_ vcomp
        FFI.set "child" vtree vcomp
      Hydrate
Draw -> do
        MisoString -> JSVal -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"child" JSVal
jsNull Object
vcomp        
      
    setAttrs vcomp attrs snk (logLevel app) events_
    when (hydrate == Draw) (FFI.set "mount" mountCallback vcomp)
    FFI.set "unmount" unmountCallback vcomp
    FFI.set "eventPropagation" (eventPropagation app) vcomp
    flip (FFI.set "type") vcomp =<< toJSVal VCompType
    pure (VTree vcomp)
  VNode NS
ns MisoString
tag [Attribute action]
attrs [View model action]
kids -> do
    vnode <- MisoString -> NS -> MisoString -> IO Object
createNode MisoString
"vnode" NS
ns MisoString
tag
    setAttrs vnode attrs snk logLevel_ events_
    vchildren <- toJSVal =<< procreate vnode
    flip (FFI.set "children") vnode vchildren
    flip (FFI.set "type") vnode =<< toJSVal VNodeType
    pure (VTree vnode)
      where
        procreate :: v -> IO [Object]
procreate v
parentVTree = do
          kidsViews <- [View model action]
-> (View model action -> IO Object) -> IO [Object]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [View model action]
kids ((View model action -> IO Object) -> IO [Object])
-> (View model action -> IO Object) -> IO [Object]
forall a b. (a -> b) -> a -> b
$ \View model action
kid -> do
            VTree child <- Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> View model action
-> IO VTree
forall model action.
Eq model =>
Events
-> Int
-> Int
-> Hydrate
-> Sink action
-> LogLevel
-> View model action
-> IO VTree
buildVTree Events
events_ Int
parentId Int
vcompId Hydrate
hydrate Sink action
snk LogLevel
logLevel_ View model action
kid
            FFI.set "parent" parentVTree child
            pure child
          setNextSibling kidsViews
          pure kidsViews
            where
              setNextSibling :: [b] -> IO ()
setNextSibling [b]
xs =
                (b -> b -> IO ()) -> [b] -> [b] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ ((b -> MisoString -> b -> IO ()) -> MisoString -> b -> b -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> MisoString -> b -> IO ()
forall o v.
(ToObject o, ToJSVal v) =>
o -> MisoString -> v -> IO ()
setField MisoString
"nextSibling")
                  [b]
xs (Int -> [b] -> [b]
forall a. Int -> [a] -> [a]
drop Int
1 [b]
xs)
  VText Maybe Key
key MisoString
t -> do
    vtree <- IO Object
create
    flip (FFI.set "type") vtree =<< toJSVal VTextType
    forM_ key $ \Key
k -> MisoString -> MisoString -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"key" (Key -> MisoString
forall str. ToMisoString str => str -> MisoString
ms Key
k) Object
vtree
    FFI.set "ns" ("text" :: MisoString) vtree
    FFI.set "text" t vtree
    pure (VTree vtree)
-----------------------------------------------------------------------------
-- | @createNode@
-- A helper function for constructing a vtree (used for @vcomp@ and @vnode@)
-- Doesn't handle children
createNode :: MisoString -> NS -> MisoString -> IO Object
createNode :: MisoString -> NS -> MisoString -> IO Object
createNode MisoString
typ NS
ns MisoString
tag = do
  vnode <- IO Object
create
  cssObj <- create
  propsObj <- create
  eventsObj <- create
  captures <- create
  bubbles <- create
  FFI.set "css" cssObj vnode
  FFI.set "type" typ vnode
  FFI.set "props" propsObj vnode
  FFI.set "events" eventsObj vnode
  FFI.set "captures" captures eventsObj
  FFI.set "bubbles" bubbles eventsObj
  FFI.set "ns" ns vnode
  FFI.set "tag" tag vnode
  pure vnode
-----------------------------------------------------------------------------
-- | Helper function for populating "props" and "css" fields on a virtual
-- DOM node
setAttrs
  :: Object
  -> [Attribute action]
  -> Sink action
  -> LogLevel
  -> Events
  -> IO ()
setAttrs :: forall action.
Object
-> [Attribute action] -> Sink action -> LogLevel -> Events -> IO ()
setAttrs vnode :: Object
vnode@(Object JSVal
jval) [Attribute action]
attrs Sink action
snk LogLevel
logLevel Events
events =
  [Attribute action] -> (Attribute action -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Attribute action]
attrs ((Attribute action -> IO ()) -> IO ())
-> (Attribute action -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
    Property MisoString
"key" Mail
v -> do
      value <- Mail -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal Mail
v
      FFI.set "key" value vnode
    ClassList [MisoString]
classes ->
      JSVal -> [MisoString] -> IO ()
FFI.populateClass JSVal
jval [MisoString]
classes
    Property MisoString
k Mail
v -> do
      value <- Mail -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal Mail
v
      o <- getProp "props" vnode
      FFI.set k value (Object o)
    On Sink action -> VTree -> LogLevel -> Events -> IO ()
callback ->
      Sink action -> VTree -> LogLevel -> Events -> IO ()
callback Sink action
snk (Object -> VTree
VTree Object
vnode) LogLevel
logLevel Events
events
    Styles Map MisoString MisoString
styles -> do
      cssObj <- MisoString -> Object -> IO JSVal
forall o. ToObject o => MisoString -> o -> IO JSVal
getProp MisoString
"css" Object
vnode
      forM_ (M.toList styles) $ \(MisoString
k,MisoString
v) -> do
        MisoString -> MisoString -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
k MisoString
v (JSVal -> Object
Object JSVal
cssObj)
-----------------------------------------------------------------------------
-- | Registers components in the global state
registerComponent :: MonadIO m => ComponentState 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] -> IO [DOMRef]
renderStyles :: [CSS] -> IO [JSVal]
renderStyles [CSS]
styles =
  [CSS] -> (CSS -> IO JSVal) -> IO [JSVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CSS]
styles ((CSS -> IO JSVal) -> IO [JSVal])
-> (CSS -> IO JSVal) -> IO [JSVal]
forall a b. (a -> b) -> a -> b
$ \case
    Href MisoString
url -> MisoString -> IO JSVal
FFI.addStyleSheet MisoString
url
    Style MisoString
css -> MisoString -> IO JSVal
FFI.addStyle MisoString
css
    Sheet StyleSheet
sheet -> MisoString -> IO JSVal
FFI.addStyle (StyleSheet -> MisoString
renderStyleSheet StyleSheet
sheet)
-----------------------------------------------------------------------------
-- | Renders scripts
--
-- Meant for development purposes
-- Appends JS to <head>
--
renderScripts :: [JS] -> IO [DOMRef]
renderScripts :: [JS] -> IO [JSVal]
renderScripts [JS]
scripts =
  [JS] -> (JS -> IO JSVal) -> IO [JSVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [JS]
scripts ((JS -> IO JSVal) -> IO [JSVal]) -> (JS -> IO JSVal) -> IO [JSVal]
forall a b. (a -> b) -> a -> b
$ \case
    Src MisoString
src ->
      MisoString -> IO JSVal
FFI.addSrc MisoString
src
    Script MisoString
script ->
      Bool -> MisoString -> IO JSVal
FFI.addScript Bool
False MisoString
script
    Module MisoString
src ->
      Bool -> MisoString -> IO JSVal
FFI.addScript Bool
True MisoString
src
    ImportMap [(MisoString, MisoString)]
importMap -> do
      o <- IO Object
create
      imports <- create
      forM_ importMap $ \(MisoString
k,MisoString
v) ->
        MisoString -> MisoString -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
k MisoString
v Object
imports
      FFI.set "imports" imports o
      FFI.addScriptImportMap
        =<< fromJSValUnchecked
        =<< do jsg "JSON" # "stringify" $ [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 -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just compState :: ComponentState (ZonkAny 0) action
compState@ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
TVar Bool
TVar (ZonkAny 0)
ThreadId
IORef (Seq action)
IORef (Map MisoString ThreadId)
IORef VTree
Events
Mailbox
JSVal
action -> IO ()
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 -> IO ()
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 -> IO ()
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) -> IO (Maybe ThreadId)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MisoString -> Map MisoString ThreadId -> Maybe ThreadId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (subKey -> MisoString
forall str. ToMisoString str => str -> MisoString
ms subKey
subKey) (Map MisoString ThreadId -> Maybe ThreadId)
-> IO (Map MisoString ThreadId) -> IO (Maybe ThreadId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map MisoString ThreadId) -> IO (Map MisoString ThreadId)
forall a. IORef a -> IO a
readIORef IORef (Map MisoString ThreadId)
componentSubThreads)
        case mtid of
          Maybe ThreadId
Nothing ->
            ComponentState (ZonkAny 0) action -> IO ()
forall {model}. ComponentState model action -> IO ()
startThread ComponentState (ZonkAny 0) action
compState
          Just ThreadId
tid -> do
            status <- IO ThreadStatus -> IO ThreadStatus
forall a. IO a -> IO 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 -> IO ()
forall {model}. ComponentState model action -> IO ()
startThread ComponentState (ZonkAny 0) action
compState
              ThreadStatus
ThreadDied -> ComponentState (ZonkAny 0) action -> IO ()
forall {model}. ComponentState model action -> IO ()
startThread ComponentState (ZonkAny 0) action
compState
              ThreadStatus
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    startThread :: ComponentState model action -> IO ()
startThread ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
TVar model
TVar Bool
ThreadId
IORef (Seq action)
IORef (Map MisoString ThreadId)
IORef VTree
Events
Mailbox
JSVal
action -> IO ()
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 -> IO ()
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 -> IO ()
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 <- IO () -> IO ThreadId
forkIO (Sub action
sub action -> IO ()
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
        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
TVar Bool
TVar (ZonkAny 1)
ThreadId
IORef (Seq (ZonkAny 2))
IORef (Map MisoString ThreadId)
IORef VTree
Events
Mailbox
JSVal
ZonkAny 2 -> IO ()
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 -> IO ()
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 -> IO ()
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) -> IO (Maybe ThreadId)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MisoString -> Map MisoString ThreadId -> Maybe ThreadId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (subKey -> MisoString
forall str. ToMisoString str => str -> MisoString
ms subKey
subKey) (Map MisoString ThreadId -> Maybe ThreadId)
-> IO (Map MisoString ThreadId) -> IO (Maybe ThreadId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map MisoString ThreadId) -> IO (Map MisoString ThreadId)
forall a. IORef a -> IO a
readIORef IORef (Map MisoString ThreadId)
componentSubThreads)
        forM_ mtid $ \ThreadId
tid ->
          IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            IORef (Map MisoString ThreadId)
-> (Map MisoString ThreadId -> (Map MisoString ThreadId, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map MisoString ThreadId)
componentSubThreads ((Map MisoString ThreadId -> (Map MisoString ThreadId, ()))
 -> IO ())
-> (Map MisoString ThreadId -> (Map MisoString ThreadId, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map MisoString ThreadId
m -> (MisoString -> Map MisoString ThreadId -> Map MisoString ThreadId
forall k a. Ord k => k -> Map k a -> Map k a
M.delete (subKey -> MisoString
forall str. ToMisoString str => str -> MisoString
ms subKey
subKey) Map MisoString ThreadId
m, ())
            ThreadId -> IO ()
killThread ThreadId
tid
-----------------------------------------------------------------------------
-- | Send any @ToJSON message => message@ to a t'Miso.Types.Component' mailbox, by 'ComponentId'
--
-- @
-- 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 = IO () -> Effect parent model action
forall a parent model action. IO a -> Effect parent model action
io_ (IO () -> Effect parent model action)
-> IO () -> 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)))
-> IO (IntMap (ComponentState (ZonkAny 3) (ZonkAny 4)))
-> IO (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)))
-> IO (IntMap (ComponentState (ZonkAny 3) (ZonkAny 4)))
forall a. IO a -> IO 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) IO (Maybe (ComponentState (ZonkAny 3) (ZonkAny 4)))
-> (Maybe (ComponentState (ZonkAny 3) (ZonkAny 4)) -> IO ())
-> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (ComponentState (ZonkAny 3) (ZonkAny 4))
Nothing ->
      -- dmj: TODO add DebugMail here
      () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
TVar Bool
TVar (ZonkAny 3)
ThreadId
IORef (Seq (ZonkAny 4))
IORef (Map MisoString ThreadId)
IORef VTree
Events
Mailbox
JSVal
ZonkAny 4 -> IO ()
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 -> IO ()
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 -> IO ()
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 () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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.
        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
TVar Bool
TVar (ZonkAny 5)
ThreadId
IORef (Seq (ZonkAny 6))
IORef (Map MisoString ThreadId)
IORef VTree
Events
Mailbox
JSVal
ZonkAny 6 -> IO ()
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 -> IO ()
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 -> IO ()
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 () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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 MisoString
err -> MisoString -> action
errorful (MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
ms MisoString
err)
-----------------------------------------------------------------------------
-- | Fetches the parent `model` from the child.
--
-- @since 1.9.0.0
parent
  :: (parent -> action)
  -> action
  -> Effect parent model action
parent :: forall parent action model.
(parent -> action) -> action -> Effect parent model action
parent parent -> action
successful action
errorful = do
  ComponentInfo {..} <- RWST
  (ComponentInfo parent)
  [Schedule action]
  model
  Identity
  (ComponentInfo parent)
forall r (m :: * -> *). MonadReader r m => m r
ask
  withSink $ \Sink action
sink -> do
    Int
-> IntMap (ComponentState 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)))
-> IO (IntMap (ComponentState parent (ZonkAny 7)))
-> IO (Maybe (ComponentState parent (ZonkAny 7)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IntMap (ComponentState parent (ZonkAny 7)))
-> IO (IntMap (ComponentState parent (ZonkAny 7)))
forall a. IO a -> IO 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) IO (Maybe (ComponentState parent (ZonkAny 7)))
-> (Maybe (ComponentState parent (ZonkAny 7)) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (ComponentState parent (ZonkAny 7))
Nothing -> Sink action
sink action
errorful
      Just ComponentState {Int
[JSVal]
Maybe ThreadId
IO ()
TVar parent
TVar Bool
ThreadId
IORef (Seq (ZonkAny 7))
IORef (Map MisoString ThreadId)
IORef VTree
Events
Mailbox
JSVal
ZonkAny 7 -> IO ()
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 -> IO ()
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 -> IO ()
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 -> IO parent
forall a. IO a -> IO 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 ()
TVar Bool
TVar (ZonkAny 8)
ThreadId
IORef (Seq (ZonkAny 9))
IORef (Map MisoString ThreadId)
IORef VTree
Events
Mailbox
JSVal
ZonkAny 9 -> IO ()
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 -> IO ()
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 -> IO ()
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 -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
_componentId Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
vcompId) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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 -> IO JSVal)
-> Effect parent model action
forall action parent model.
(WebSocket -> Sink action -> IO JSVal)
-> Effect parent model action
websocketCore ((WebSocket -> Sink action -> IO JSVal)
 -> Effect parent model action)
-> (WebSocket -> Sink action -> IO JSVal)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> IO ()
-> (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> (JSVal -> IO ())
-> Bool
-> IO JSVal
FFI.websocketConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ WebSocket -> action
onOpen WebSocket
webSocketId)
      (Sink action
sink Sink action -> (Closed -> action) -> Closed -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closed -> action
onClosed (Closed -> IO ()) -> (JSVal -> IO Closed) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO Closed
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> action
onMessage (MisoString -> IO ()) -> (JSVal -> IO MisoString) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked))
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> action
onError (MisoString -> IO ()) -> (JSVal -> IO MisoString) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Bool
True
-----------------------------------------------------------------------------
websocketConnectBLOB
  :: URL
  -- ^ t'WebSocket' 'URL'
  -> (WebSocket -> action)
  -- ^ onOpen
  -> (Closed -> action)
  -- ^ onClosed
  -> (Blob -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect parent model action
websocketConnectBLOB :: forall action parent model.
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (Blob -> action)
-> (MisoString -> action)
-> Effect parent model action
websocketConnectBLOB MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed Blob -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> IO JSVal)
-> Effect parent model action
forall action parent model.
(WebSocket -> Sink action -> IO JSVal)
-> Effect parent model action
websocketCore ((WebSocket -> Sink action -> IO JSVal)
 -> Effect parent model action)
-> (WebSocket -> Sink action -> IO JSVal)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> IO ()
-> (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> (JSVal -> IO ())
-> Bool
-> IO JSVal
FFI.websocketConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ WebSocket -> action
onOpen WebSocket
webSocketId)
      (Sink action
sink Sink action -> (Closed -> action) -> Closed -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closed -> action
onClosed (Closed -> IO ()) -> (JSVal -> IO Closed) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO Closed
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (JSVal -> action) -> JSVal -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blob -> action
onMessage (Blob -> action) -> (JSVal -> Blob) -> JSVal -> action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSVal -> Blob
Blob))
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> action
onError (MisoString -> IO ()) -> (JSVal -> IO MisoString) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Bool
False
-----------------------------------------------------------------------------
websocketConnectArrayBuffer
  :: URL
  -- ^ t'WebSocket' 'URL'
  -> (WebSocket -> action)
  -- ^ onOpen
  -> (Closed -> action)
  -- ^ onClosed
  -> (ArrayBuffer -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect parent model action
websocketConnectArrayBuffer :: forall action parent model.
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (ArrayBuffer -> action)
-> (MisoString -> action)
-> Effect parent model action
websocketConnectArrayBuffer MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed ArrayBuffer -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> IO JSVal)
-> Effect parent model action
forall action parent model.
(WebSocket -> Sink action -> IO JSVal)
-> Effect parent model action
websocketCore ((WebSocket -> Sink action -> IO JSVal)
 -> Effect parent model action)
-> (WebSocket -> Sink action -> IO JSVal)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> IO ()
-> (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> (JSVal -> IO ())
-> Bool
-> IO JSVal
FFI.websocketConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ WebSocket -> action
onOpen WebSocket
webSocketId)
      (Sink action
sink Sink action -> (Closed -> action) -> Closed -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closed -> action
onClosed (Closed -> IO ()) -> (JSVal -> IO Closed) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO Closed
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (JSVal -> action) -> JSVal -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> action
onError (MisoString -> IO ()) -> (JSVal -> IO MisoString) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Bool
False
-----------------------------------------------------------------------------
websocketConnectJSON
  :: FromJSON json
  => URL
  -- ^ WebSocket URL
  -> (WebSocket -> action)
  -- ^ onOpen
  -> (Closed -> action)
  -- ^ onClosed
  -> (json -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect parent model action
websocketConnectJSON :: forall json action parent model.
FromJSON json =>
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (json -> action)
-> (MisoString -> action)
-> Effect parent model action
websocketConnectJSON MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed json -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> IO JSVal)
-> Effect parent model action
forall action parent model.
(WebSocket -> Sink action -> IO JSVal)
-> Effect parent model action
websocketCore ((WebSocket -> Sink action -> IO JSVal)
 -> Effect parent model action)
-> (WebSocket -> Sink action -> IO JSVal)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> IO ()
-> (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> (JSVal -> IO ())
-> Bool
-> IO JSVal
FFI.websocketConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ WebSocket -> action
onOpen WebSocket
webSocketId)
      (Sink action
sink Sink action -> (Closed -> action) -> Closed -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closed -> action
onClosed (Closed -> IO ()) -> (JSVal -> IO Closed) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO Closed
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\JSVal
bytes -> do
          value :: Value <- JSVal -> IO Mail
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked JSVal
bytes
          case fromJSON value of
            Error MisoString
msg -> Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ MisoString -> action
onError (MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
ms MisoString
msg)
            Success json
x -> Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ json -> action
onMessage json
x))
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> action
onError (MisoString -> IO ()) -> (JSVal -> IO MisoString) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Bool
False
-----------------------------------------------------------------------------
websocketConnect
  :: FromJSON json
  => URL
  -- ^ WebSocket URL
  -> (WebSocket -> action)
  -- ^ onOpen
  -> (Closed -> action)
  -- ^ onClosed
  -> (Payload json -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect parent model action
websocketConnect :: forall json action parent model.
FromJSON json =>
MisoString
-> (WebSocket -> action)
-> (Closed -> action)
-> (Payload json -> action)
-> (MisoString -> action)
-> Effect parent model action
websocketConnect MisoString
url WebSocket -> action
onOpen Closed -> action
onClosed Payload json -> action
onMessage MisoString -> action
onError =
  (WebSocket -> Sink action -> IO JSVal)
-> Effect parent model action
forall action parent model.
(WebSocket -> Sink action -> IO JSVal)
-> Effect parent model action
websocketCore ((WebSocket -> Sink action -> IO JSVal)
 -> Effect parent model action)
-> (WebSocket -> Sink action -> IO JSVal)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \WebSocket
webSocketId Sink action
sink ->
    MisoString
-> IO ()
-> (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> (JSVal -> IO ())
-> Bool
-> IO JSVal
FFI.websocketConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ WebSocket -> action
onOpen WebSocket
webSocketId)
      (Sink action
sink Sink action -> (Closed -> action) -> Closed -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closed -> action
onClosed (Closed -> IO ()) -> (JSVal -> IO Closed) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO Closed
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> IO ()) -> (JSVal -> IO MisoString) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked))
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\JSVal
bytes -> do
          value :: Value <- JSVal -> IO Mail
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked JSVal
bytes
          case fromJSON value of
            Error MisoString
msg -> Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ MisoString -> action
onError (MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
ms MisoString
msg)
            Success json
x -> Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ Payload json -> action
onMessage (json -> Payload json
forall value. value -> Payload value
JSON json
x)))
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (JSVal -> action) -> JSVal -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sink action
sink Sink action -> (JSVal -> action) -> JSVal -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> action
onError (MisoString -> IO ()) -> (JSVal -> IO MisoString) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Bool
False
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/WebSocket/WebSocket>
websocketCore
  :: (WebSocket -> Sink action -> IO Socket)
  -> Effect parent model action
websocketCore :: forall action parent model.
(WebSocket -> Sink action -> IO JSVal)
-> Effect parent model action
websocketCore WebSocket -> Sink action -> IO 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 <- IO WebSocket
freshWebSocket
    socket <- core webSocketId sink
    insertWebSocket _componentId webSocketId socket
  where
    insertWebSocket :: ComponentId -> WebSocket -> Socket -> IO ()
    insertWebSocket :: Int -> WebSocket -> JSVal -> IO ()
insertWebSocket Int
componentId (WebSocket Int
socketId) JSVal
socket =
      IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IORef WebSockets -> (WebSockets -> (WebSockets, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef WebSockets
websocketConnections ((WebSockets -> (WebSockets, ())) -> IO ())
-> (WebSockets -> (WebSockets, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WebSockets
websockets ->
          (WebSockets -> WebSockets
update WebSockets
websockets, ())
      where
        update :: WebSockets -> WebSockets
update WebSockets
websockets =
          (IntMap JSVal -> IntMap JSVal -> IntMap JSVal)
-> WebSockets -> WebSockets -> WebSockets
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith IntMap JSVal -> IntMap JSVal -> IntMap JSVal
forall a. IntMap a -> IntMap a -> IntMap a
IM.union WebSockets
websockets
            (WebSockets -> WebSockets) -> WebSockets -> WebSockets
forall a b. (a -> b) -> a -> b
$ Int -> IntMap JSVal -> WebSockets
forall a. Int -> a -> IntMap a
IM.singleton Int
componentId
            (IntMap JSVal -> WebSockets) -> IntMap JSVal -> WebSockets
forall a b. (a -> b) -> a -> b
$ Int -> JSVal -> IntMap JSVal
forall a. Int -> a -> IntMap a
IM.singleton Int
socketId JSVal
socket

    freshWebSocket :: IO WebSocket
    freshWebSocket :: IO WebSocket
freshWebSocket = Int -> WebSocket
WebSocket (Int -> WebSocket) -> IO Int -> IO WebSocket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      IO Int -> IO Int
forall a. IO a -> IO 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 -> IO ()
finalizeWebSockets :: Int -> IO ()
finalizeWebSockets Int
vcompId = do
  (IntMap JSVal -> IO ()) -> Maybe (IntMap JSVal) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((JSVal -> IO ()) -> [JSVal] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ JSVal -> IO ()
FFI.websocketClose ([JSVal] -> IO ())
-> (IntMap JSVal -> [JSVal]) -> IntMap JSVal -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap JSVal -> [JSVal]
forall a. IntMap a -> [a]
IM.elems) (Maybe (IntMap JSVal) -> IO ())
-> IO (Maybe (IntMap JSVal)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (WebSockets -> Maybe (IntMap JSVal))
-> IO WebSockets -> IO (Maybe (IntMap JSVal))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO WebSockets -> IO WebSockets
forall a. IO a -> IO 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)
  IO ()
dropComponentWebSockets
    where
      dropComponentWebSockets :: IO ()
      dropComponentWebSockets :: IO ()
dropComponentWebSockets = IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IORef 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 ->
        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just JSVal
socket ->
        JSVal -> IO ()
FFI.websocketClose JSVal
socket
  where
    dropWebSocket :: ComponentId -> WebSocket -> WebSockets -> WebSockets
    dropWebSocket :: Int -> WebSocket -> WebSockets -> WebSockets
dropWebSocket Int
vcompId (WebSocket Int
websocketId) WebSockets
websockets = do
      case Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId WebSockets
websockets of
        Maybe (IntMap JSVal)
Nothing ->
          WebSockets
websockets
        Just IntMap JSVal
componentSockets ->
          Int -> IntMap JSVal -> WebSockets -> WebSockets
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
vcompId (Int -> IntMap JSVal -> IntMap JSVal
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
websocketId IntMap JSVal
componentSockets) WebSockets
websockets
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/WebSocket/send>
websocketSend
  :: ToJSON value
  => WebSocket
  -> Payload value
  -> Effect parent 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 -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just JSVal
socket ->
        case Payload value
msg of
          JSON value
json_ ->
            JSVal -> JSVal -> IO ()
FFI.websocketSend JSVal
socket (JSVal -> IO ()) -> IO JSVal -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal (value -> MisoString
forall a. ToJSON a => a -> MisoString
encode value
json_)
          BUFFER ArrayBuffer
arrayBuffer_ -> do
            JSVal -> JSVal -> IO ()
FFI.websocketSend JSVal
socket (JSVal -> IO ()) -> IO JSVal -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ArrayBuffer -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal ArrayBuffer
arrayBuffer_
          TEXT MisoString
txt ->
            JSVal -> JSVal -> IO ()
FFI.websocketSend JSVal
socket (JSVal -> IO ()) -> IO JSVal -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal MisoString
txt
          BLOB Blob
blob_ ->
            JSVal -> JSVal -> IO ()
FFI.websocketSend JSVal
socket (JSVal -> IO ()) -> IO JSVal -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Blob -> IO JSVal
forall a. ToJSVal a => a -> IO JSVal
toJSVal Blob
blob_
-----------------------------------------------------------------------------
-- | Retrieves current status of t'WebSocket'
--
-- If the t'WebSocket' identifier does not exist a 'CLOSED' is returned.
--
socketState :: WebSocket -> (SocketState -> action) -> Effect parent 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) -> IO WebSockets -> IO (Maybe JSVal)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO WebSockets -> IO WebSockets
forall a. IO a -> IO 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) IO (Maybe JSVal) -> (Maybe JSVal -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just JSVal
socket -> do
        x <- JSVal
socket JSVal -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! (MisoString
"socketState" :: MisoString)
        socketstate <- toEnum <$> fromJSValUnchecked x
        sink (callback socketstate)
      Maybe JSVal
Nothing ->
        Sink action
sink (SocketState -> action
callback SocketState
CLOSED)
-----------------------------------------------------------------------------
codeToCloseCode :: Int -> CloseCode
codeToCloseCode :: Int -> CloseCode
codeToCloseCode = \case
  Int
1000 -> CloseCode
CLOSE_NORMAL
  Int
1001 -> CloseCode
CLOSE_GOING_AWAY
  Int
1002 -> CloseCode
CLOSE_PROTOCOL_ERROR
  Int
1003 -> CloseCode
CLOSE_UNSUPPORTED
  Int
1005 -> CloseCode
CLOSE_NO_STATUS
  Int
1006 -> CloseCode
CLOSE_ABNORMAL
  Int
1007 -> CloseCode
Unsupported_Data
  Int
1008 -> CloseCode
Policy_Violation
  Int
1009 -> CloseCode
CLOSE_TOO_LARGE
  Int
1010 -> CloseCode
Missing_Extension
  Int
1011 -> CloseCode
Internal_Error
  Int
1012 -> CloseCode
Service_Restart
  Int
1013 -> CloseCode
Try_Again_Later
  Int
1015 -> CloseCode
TLS_Handshake
  Int
n    -> Int -> CloseCode
OtherCode Int
n
-----------------------------------------------------------------------------
-- | Closed message is sent when a t'WebSocket' has closed
data Closed
  = Closed
  { Closed -> CloseCode
closedCode :: CloseCode
    -- ^ The code used to indicate why a socket closed
  , Closed -> Bool
wasClean :: Bool
    -- ^ If the connection was closed cleanly, or forcefully.
  , Closed -> MisoString
reason :: MisoString
    -- ^ The reason for socket closure.
  } deriving (Closed -> Closed -> Bool
(Closed -> Closed -> Bool)
-> (Closed -> Closed -> Bool) -> Eq Closed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Closed -> Closed -> Bool
== :: Closed -> Closed -> Bool
$c/= :: Closed -> Closed -> Bool
/= :: Closed -> Closed -> Bool
Eq, Int -> Closed -> ShowS
[Closed] -> ShowS
Closed -> String
(Int -> Closed -> ShowS)
-> (Closed -> String) -> ([Closed] -> ShowS) -> Show Closed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Closed -> ShowS
showsPrec :: Int -> Closed -> ShowS
$cshow :: Closed -> String
show :: Closed -> String
$cshowList :: [Closed] -> ShowS
showList :: [Closed] -> ShowS
Show)
-----------------------------------------------------------------------------
instance FromJSVal Closed where
  fromJSVal :: JSVal -> IO (Maybe Closed)
fromJSVal JSVal
o = do
    closed_ <- (Int -> CloseCode) -> Maybe Int -> Maybe CloseCode
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> CloseCode
codeToCloseCode (Maybe Int -> Maybe CloseCode)
-> IO (Maybe Int) -> IO (Maybe CloseCode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do JSVal -> IO (Maybe Int)
forall a. FromJSVal a => JSVal -> IO (Maybe a)
fromJSVal (JSVal -> IO (Maybe Int)) -> IO JSVal -> IO (Maybe Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal
o JSVal -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! (MisoString
"code" :: MisoString)
    wasClean_ <- fromJSVal =<< o ! ("wasClean" :: MisoString)
    reason_ <- fromJSVal =<< o ! ("reason" :: MisoString)
    pure (Closed <$> closed_ <*> wasClean_ <*> reason_)
-----------------------------------------------------------------------------
-- | URL that the t'WebSocket' will @connect@ to
type URL = MisoString
-----------------------------------------------------------------------------
-- | 'SocketState' corresponding to current t'WebSocket' connection
data SocketState
  = CONNECTING -- ^ 0
  | OPEN       -- ^ 1
  | CLOSING    -- ^ 2
  | CLOSED     -- ^ 3
  deriving (Int -> SocketState -> ShowS
[SocketState] -> ShowS
SocketState -> String
(Int -> SocketState -> ShowS)
-> (SocketState -> String)
-> ([SocketState] -> ShowS)
-> Show SocketState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SocketState -> ShowS
showsPrec :: Int -> SocketState -> ShowS
$cshow :: SocketState -> String
show :: SocketState -> String
$cshowList :: [SocketState] -> ShowS
showList :: [SocketState] -> ShowS
Show, SocketState -> SocketState -> Bool
(SocketState -> SocketState -> Bool)
-> (SocketState -> SocketState -> Bool) -> Eq SocketState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SocketState -> SocketState -> Bool
== :: SocketState -> SocketState -> Bool
$c/= :: SocketState -> SocketState -> Bool
/= :: SocketState -> SocketState -> Bool
Eq, Eq SocketState
Eq SocketState =>
(SocketState -> SocketState -> Ordering)
-> (SocketState -> SocketState -> Bool)
-> (SocketState -> SocketState -> Bool)
-> (SocketState -> SocketState -> Bool)
-> (SocketState -> SocketState -> Bool)
-> (SocketState -> SocketState -> SocketState)
-> (SocketState -> SocketState -> SocketState)
-> Ord SocketState
SocketState -> SocketState -> Bool
SocketState -> SocketState -> Ordering
SocketState -> SocketState -> SocketState
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SocketState -> SocketState -> Ordering
compare :: SocketState -> SocketState -> Ordering
$c< :: SocketState -> SocketState -> Bool
< :: SocketState -> SocketState -> Bool
$c<= :: SocketState -> SocketState -> Bool
<= :: SocketState -> SocketState -> Bool
$c> :: SocketState -> SocketState -> Bool
> :: SocketState -> SocketState -> Bool
$c>= :: SocketState -> SocketState -> Bool
>= :: SocketState -> SocketState -> Bool
$cmax :: SocketState -> SocketState -> SocketState
max :: SocketState -> SocketState -> SocketState
$cmin :: SocketState -> SocketState -> SocketState
min :: SocketState -> SocketState -> SocketState
Ord, Int -> SocketState
SocketState -> Int
SocketState -> [SocketState]
SocketState -> SocketState
SocketState -> SocketState -> [SocketState]
SocketState -> SocketState -> SocketState -> [SocketState]
(SocketState -> SocketState)
-> (SocketState -> SocketState)
-> (Int -> SocketState)
-> (SocketState -> Int)
-> (SocketState -> [SocketState])
-> (SocketState -> SocketState -> [SocketState])
-> (SocketState -> SocketState -> [SocketState])
-> (SocketState -> SocketState -> SocketState -> [SocketState])
-> Enum SocketState
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: SocketState -> SocketState
succ :: SocketState -> SocketState
$cpred :: SocketState -> SocketState
pred :: SocketState -> SocketState
$ctoEnum :: Int -> SocketState
toEnum :: Int -> SocketState
$cfromEnum :: SocketState -> Int
fromEnum :: SocketState -> Int
$cenumFrom :: SocketState -> [SocketState]
enumFrom :: SocketState -> [SocketState]
$cenumFromThen :: SocketState -> SocketState -> [SocketState]
enumFromThen :: SocketState -> SocketState -> [SocketState]
$cenumFromTo :: SocketState -> SocketState -> [SocketState]
enumFromTo :: SocketState -> SocketState -> [SocketState]
$cenumFromThenTo :: SocketState -> SocketState -> SocketState -> [SocketState]
enumFromThenTo :: SocketState -> SocketState -> SocketState -> [SocketState]
Enum)
-----------------------------------------------------------------------------
-- | Code corresponding to a closed connection
-- https://developer.mozilla.org/en-US/docs/Web/API/CloseEvent
data CloseCode
  = CLOSE_NORMAL
   -- ^ 1000, Normal closure; the connection successfully completed whatever purpose for which it was created.
  | CLOSE_GOING_AWAY
   -- ^ 1001, The endpoint is going away, either because of a server failure or because the browser is navigating away from the page that opened the connection.
  | CLOSE_PROTOCOL_ERROR
   -- ^ 1002, The endpoint is terminating the connection due to a protocol error.
  | CLOSE_UNSUPPORTED
   -- ^ 1003, The connection is being terminated because the endpoint received data of a type it cannot accept (for example, a textonly endpoint received binary data).
  | CLOSE_NO_STATUS
   -- ^ 1005, Reserved.  Indicates that no status code was provided even though one was expected.
  | CLOSE_ABNORMAL
   -- ^ 1006, Reserved. Used to indicate that a connection was closed abnormally (that is, with no close frame being sent) when a status code is expected.
  | Unsupported_Data
   -- ^ 1007, The endpoint is terminating the connection because a message was received that contained inconsistent data (e.g., nonUTF8 data within a text message).
  | Policy_Violation
   -- ^ 1008, The endpoint is terminating the connection because it received a message that violates its policy. This is a generic status code, used when codes 1003 and 1009 are not suitable.
  | CLOSE_TOO_LARGE
   -- ^ 1009, The endpoint is terminating the connection because a data frame was received that is too large.
  | Missing_Extension
   -- ^ 1010, The client is terminating the connection because it expected the server to negotiate one or more extension, but the server didn't.
  | Internal_Error
   -- ^ 1011, The server is terminating the connection because it encountered an unexpected condition that prevented it from fulfilling the request.
  | Service_Restart
   -- ^ 1012, The server is terminating the connection because it is restarting.
  | Try_Again_Later
   -- ^ 1013, The server is terminating the connection due to a temporary condition, e.g. it is overloaded and is casting off some of its clients.
  | TLS_Handshake
   -- ^ 1015, Reserved. Indicates that the connection was closed due to a failure to perform a TLS handshake (e.g., the server certificate can't be verified).
  | OtherCode Int
   -- ^ OtherCode that is reserved and not in the range 0999
  deriving (Int -> CloseCode -> ShowS
[CloseCode] -> ShowS
CloseCode -> String
(Int -> CloseCode -> ShowS)
-> (CloseCode -> String)
-> ([CloseCode] -> ShowS)
-> Show CloseCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CloseCode -> ShowS
showsPrec :: Int -> CloseCode -> ShowS
$cshow :: CloseCode -> String
show :: CloseCode -> String
$cshowList :: [CloseCode] -> ShowS
showList :: [CloseCode] -> ShowS
Show, CloseCode -> CloseCode -> Bool
(CloseCode -> CloseCode -> Bool)
-> (CloseCode -> CloseCode -> Bool) -> Eq CloseCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CloseCode -> CloseCode -> Bool
== :: CloseCode -> CloseCode -> Bool
$c/= :: CloseCode -> CloseCode -> Bool
/= :: CloseCode -> CloseCode -> Bool
Eq)
-----------------------------------------------------------------------------
-- | Type for holding a t'WebSocket' file descriptor.
newtype WebSocket = WebSocket Int
  deriving (WebSocket -> IO JSVal
(WebSocket -> IO JSVal) -> ToJSVal WebSocket
forall a. (a -> IO JSVal) -> ToJSVal a
$ctoJSVal :: WebSocket -> IO JSVal
toJSVal :: WebSocket -> IO JSVal
ToJSVal, WebSocket -> WebSocket -> Bool
(WebSocket -> WebSocket -> Bool)
-> (WebSocket -> WebSocket -> Bool) -> Eq WebSocket
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WebSocket -> WebSocket -> Bool
== :: WebSocket -> WebSocket -> Bool
$c/= :: WebSocket -> WebSocket -> Bool
/= :: WebSocket -> WebSocket -> Bool
Eq, Integer -> WebSocket
WebSocket -> WebSocket
WebSocket -> WebSocket -> WebSocket
(WebSocket -> WebSocket -> WebSocket)
-> (WebSocket -> WebSocket -> WebSocket)
-> (WebSocket -> WebSocket -> WebSocket)
-> (WebSocket -> WebSocket)
-> (WebSocket -> WebSocket)
-> (WebSocket -> WebSocket)
-> (Integer -> WebSocket)
-> Num WebSocket
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: WebSocket -> WebSocket -> WebSocket
+ :: WebSocket -> WebSocket -> WebSocket
$c- :: WebSocket -> WebSocket -> WebSocket
- :: WebSocket -> WebSocket -> WebSocket
$c* :: WebSocket -> WebSocket -> WebSocket
* :: WebSocket -> WebSocket -> WebSocket
$cnegate :: WebSocket -> WebSocket
negate :: WebSocket -> WebSocket
$cabs :: WebSocket -> WebSocket
abs :: WebSocket -> WebSocket
$csignum :: WebSocket -> WebSocket
signum :: WebSocket -> WebSocket
$cfromInteger :: Integer -> WebSocket
fromInteger :: Integer -> WebSocket
Num)
-----------------------------------------------------------------------------
-- | A null t'WebSocket' is one with a negative descriptor.
emptyWebSocket :: WebSocket
emptyWebSocket :: WebSocket
emptyWebSocket = (-WebSocket
1)
-----------------------------------------------------------------------------
-- | A type for holding an t'EventSource' descriptor.
newtype EventSource = EventSource Int
  deriving (EventSource -> IO JSVal
(EventSource -> IO JSVal) -> ToJSVal EventSource
forall a. (a -> IO JSVal) -> ToJSVal a
$ctoJSVal :: EventSource -> IO JSVal
toJSVal :: EventSource -> IO JSVal
ToJSVal, EventSource -> EventSource -> Bool
(EventSource -> EventSource -> Bool)
-> (EventSource -> EventSource -> Bool) -> Eq EventSource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EventSource -> EventSource -> Bool
== :: EventSource -> EventSource -> Bool
$c/= :: EventSource -> EventSource -> Bool
/= :: EventSource -> EventSource -> Bool
Eq, Integer -> EventSource
EventSource -> EventSource
EventSource -> EventSource -> EventSource
(EventSource -> EventSource -> EventSource)
-> (EventSource -> EventSource -> EventSource)
-> (EventSource -> EventSource -> EventSource)
-> (EventSource -> EventSource)
-> (EventSource -> EventSource)
-> (EventSource -> EventSource)
-> (Integer -> EventSource)
-> Num EventSource
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: EventSource -> EventSource -> EventSource
+ :: EventSource -> EventSource -> EventSource
$c- :: EventSource -> EventSource -> EventSource
- :: EventSource -> EventSource -> EventSource
$c* :: EventSource -> EventSource -> EventSource
* :: EventSource -> EventSource -> EventSource
$cnegate :: EventSource -> EventSource
negate :: EventSource -> EventSource
$cabs :: EventSource -> EventSource
abs :: EventSource -> EventSource
$csignum :: EventSource -> EventSource
signum :: EventSource -> EventSource
$cfromInteger :: Integer -> EventSource
fromInteger :: Integer -> EventSource
Num)
-----------------------------------------------------------------------------
-- | A null t'EventSource' is one with a negative descriptor.
emptyEventSource :: EventSource
emptyEventSource :: EventSource
emptyEventSource = (-EventSource
1)
-----------------------------------------------------------------------------
eventSourceConnections :: IORef EventSources
{-# NOINLINE eventSourceConnections #-}
eventSourceConnections :: IORef WebSockets
eventSourceConnections = IO (IORef WebSockets) -> IORef WebSockets
forall a. IO a -> a
unsafePerformIO (WebSockets -> IO (IORef WebSockets)
forall a. a -> IO (IORef a)
newIORef WebSockets
forall a. IntMap a
IM.empty)
-----------------------------------------------------------------------------
eventSourceConnectionIds :: IORef Int
{-# NOINLINE eventSourceConnectionIds #-}
eventSourceConnectionIds :: IORef Int
eventSourceConnectionIds = IO (IORef Int) -> IORef Int
forall a. IO a -> a
unsafePerformIO (Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int))
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/EventSource/EventSource>
eventSourceConnectText
  :: URL
  -- ^ EventSource URL
  -> (EventSource -> action)
  -- ^ onOpen
  -> (MisoString -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect parent model action
eventSourceConnectText :: forall action parent model.
MisoString
-> (EventSource -> action)
-> (MisoString -> action)
-> (MisoString -> action)
-> Effect parent model action
eventSourceConnectText MisoString
url EventSource -> action
onOpen MisoString -> action
onMessage MisoString -> action
onError =
  (EventSource -> Sink action -> IO JSVal)
-> Effect parent model action
forall action parent model.
(EventSource -> Sink action -> IO JSVal)
-> Effect parent model action
eventSourceCore ((EventSource -> Sink action -> IO JSVal)
 -> Effect parent model action)
-> (EventSource -> Sink action -> IO JSVal)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \EventSource
eventSourceId Sink action
sink -> do
    MisoString
-> IO ()
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> (JSVal -> IO ())
-> Bool
-> IO JSVal
FFI.eventSourceConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ EventSource -> action
onOpen EventSource
eventSourceId)
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((JSVal -> IO ()) -> Maybe (JSVal -> IO ()))
-> (JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a b. (a -> b) -> a -> b
$ \JSVal
e -> do
          txt <- JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked JSVal
e
          sink (onMessage txt))
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> action
onError (MisoString -> IO ()) -> (JSVal -> IO MisoString) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Bool
True
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/EventSource/EventSource>
eventSourceConnectJSON
  :: FromJSON json
  => URL
  -- ^ EventSource URL
  -> (EventSource -> action)
  -- ^ onOpen
  -> (json -> action)
  -- ^ onMessage
  -> (MisoString -> action)
  -- ^ onError
  -> Effect parent model action
eventSourceConnectJSON :: forall json action parent model.
FromJSON json =>
MisoString
-> (EventSource -> action)
-> (json -> action)
-> (MisoString -> action)
-> Effect parent model action
eventSourceConnectJSON MisoString
url EventSource -> action
onOpen json -> action
onMessage MisoString -> action
onError =
  (EventSource -> Sink action -> IO JSVal)
-> Effect parent model action
forall action parent model.
(EventSource -> Sink action -> IO JSVal)
-> Effect parent model action
eventSourceCore ((EventSource -> Sink action -> IO JSVal)
 -> Effect parent model action)
-> (EventSource -> Sink action -> IO JSVal)
-> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \EventSource
eventSourceId Sink action
sink -> do
    MisoString
-> IO ()
-> Maybe (JSVal -> IO ())
-> Maybe (JSVal -> IO ())
-> (JSVal -> IO ())
-> Bool
-> IO JSVal
FFI.eventSourceConnect MisoString
url
      (Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ EventSource -> action
onOpen EventSource
eventSourceId)
      Maybe (JSVal -> IO ())
forall a. Maybe a
Nothing
      ((JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((JSVal -> IO ()) -> Maybe (JSVal -> IO ()))
-> (JSVal -> IO ()) -> Maybe (JSVal -> IO ())
forall a b. (a -> b) -> a -> b
$ \JSVal
e ->
         Mail -> Result json
forall a. FromJSON a => Mail -> Result a
fromJSON (Mail -> Result json) -> IO Mail -> IO (Result json)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSVal -> IO Mail
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked JSVal
e IO (Result json) -> (Result json -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Error MisoString
errMsg -> Sink action
sink (MisoString -> action
onError (MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
ms MisoString
errMsg))
            Success json
json_ -> Sink action
sink Sink action -> Sink action
forall a b. (a -> b) -> a -> b
$ json -> action
onMessage json
json_)
      (Sink action
sink Sink action -> (MisoString -> action) -> MisoString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> action
onError (MisoString -> IO ()) -> (JSVal -> IO MisoString) -> JSVal -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSVal -> IO MisoString
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked)
      Bool
False
-----------------------------------------------------------------------------
-- | <https://developer.mozilla.org/en-US/docs/Web/API/EventSource/EventSource>
eventSourceCore
  :: (EventSource -> Sink action -> IO Socket)
  -> Effect parent model action
eventSourceCore :: forall action parent model.
(EventSource -> Sink action -> IO JSVal)
-> Effect parent model action
eventSourceCore EventSource -> Sink action -> IO 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 <- IO EventSource
freshEventSource
    socket <- core eventSourceId sink
    insertEventSource _componentId eventSourceId socket
  where
    insertEventSource :: ComponentId -> EventSource -> Socket -> IO ()
    insertEventSource :: Int -> EventSource -> JSVal -> IO ()
insertEventSource Int
componentId (EventSource Int
socketId) JSVal
socket =
      IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IORef WebSockets -> (WebSockets -> (WebSockets, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef WebSockets
eventSourceConnections ((WebSockets -> (WebSockets, ())) -> IO ())
-> (WebSockets -> (WebSockets, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WebSockets
eventSources ->
          (WebSockets -> WebSockets
update WebSockets
eventSources, ())
      where
        update :: WebSockets -> WebSockets
update WebSockets
eventSources =
          (IntMap JSVal -> IntMap JSVal -> IntMap JSVal)
-> WebSockets -> WebSockets -> WebSockets
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith IntMap JSVal -> IntMap JSVal -> IntMap JSVal
forall a. IntMap a -> IntMap a -> IntMap a
IM.union WebSockets
eventSources
            (WebSockets -> WebSockets) -> WebSockets -> WebSockets
forall a b. (a -> b) -> a -> b
$ Int -> IntMap JSVal -> WebSockets
forall a. Int -> a -> IntMap a
IM.singleton Int
componentId
            (IntMap JSVal -> WebSockets) -> IntMap JSVal -> WebSockets
forall a b. (a -> b) -> a -> b
$ Int -> JSVal -> IntMap JSVal
forall a. Int -> a -> IntMap a
IM.singleton Int
socketId JSVal
socket

    freshEventSource :: IO EventSource
    freshEventSource :: IO EventSource
freshEventSource = Int -> EventSource
EventSource (Int -> EventSource) -> IO Int -> IO EventSource
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      IO Int -> IO Int
forall a. IO a -> IO 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 ->
        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just JSVal
socket ->
        JSVal -> IO ()
FFI.eventSourceClose JSVal
socket
  where
    dropEventSource :: ComponentId -> EventSource -> EventSources -> EventSources
    dropEventSource :: Int -> EventSource -> WebSockets -> WebSockets
dropEventSource Int
vcompId (EventSource Int
eventSourceId) WebSockets
eventSources = do
      case Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId WebSockets
eventSources of
        Maybe (IntMap JSVal)
Nothing ->
          WebSockets
eventSources
        Just IntMap JSVal
componentSockets ->
          Int -> IntMap JSVal -> WebSockets -> WebSockets
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
vcompId (Int -> IntMap JSVal -> IntMap JSVal
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
eventSourceId IntMap JSVal
componentSockets) WebSockets
eventSources

    getEventSource :: ComponentId -> EventSource -> EventSources -> Maybe Socket
    getEventSource :: Int -> EventSource -> WebSockets -> Maybe JSVal
getEventSource Int
vcompId (EventSource Int
eventSourceId) =
      Int -> IntMap JSVal -> Maybe JSVal
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
eventSourceId (IntMap JSVal -> Maybe JSVal)
-> (WebSockets -> Maybe (IntMap JSVal))
-> WebSockets
-> Maybe JSVal
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId
-----------------------------------------------------------------------------
finalizeEventSources :: ComponentId -> IO ()
finalizeEventSources :: Int -> IO ()
finalizeEventSources Int
vcompId = do
  (IntMap JSVal -> IO ()) -> Maybe (IntMap JSVal) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((JSVal -> IO ()) -> [JSVal] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ JSVal -> IO ()
FFI.eventSourceClose ([JSVal] -> IO ())
-> (IntMap JSVal -> [JSVal]) -> IntMap JSVal -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap JSVal -> [JSVal]
forall a. IntMap a -> [a]
IM.elems) (Maybe (IntMap JSVal) -> IO ())
-> IO (Maybe (IntMap JSVal)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Int -> WebSockets -> Maybe (IntMap JSVal)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
vcompId (WebSockets -> Maybe (IntMap JSVal))
-> IO WebSockets -> IO (Maybe (IntMap JSVal))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO WebSockets -> IO WebSockets
forall a. IO a -> IO 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)
  IO ()
dropComponentEventSources
    where
      dropComponentEventSources :: IO ()
      dropComponentEventSources :: IO ()
dropComponentEventSources = IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IORef WebSockets -> (WebSockets -> (WebSockets, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef WebSockets
eventSourceConnections ((WebSockets -> (WebSockets, ())) -> IO ())
-> (WebSockets -> (WebSockets, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WebSockets
eventSources ->
          (Int -> WebSockets -> WebSockets
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
vcompId WebSockets
eventSources, ())
-----------------------------------------------------------------------------
-- | Payload is used as the potential source of data when working with t'EventSource'
data Payload value
  = JSON value
  -- ^ JSON-encoded data
  | BLOB Blob
  -- ^ Binary encoded data
  | TEXT MisoString
  -- ^ Text encoded data
  | BUFFER ArrayBuffer
  -- ^ Buffered data
-----------------------------------------------------------------------------
-- | Smart constructor for sending JSON encoded data via an t'EventSource'
json :: ToJSON value => value -> Payload value
json :: forall value. ToJSON value => value -> Payload value
json = value -> Payload value
forall value. value -> Payload value
JSON
-----------------------------------------------------------------------------
-- | Smart constructor for sending binary encoded data via an t'EventSource'
blob :: Blob -> Payload value
blob :: forall value. Blob -> Payload value
blob = Blob -> Payload value
forall value. Blob -> Payload value
BLOB
-----------------------------------------------------------------------------
-- | Smart constructor for sending an @ArrayBuffer@ via an t'EventSource'
arrayBuffer :: ArrayBuffer -> Payload value
arrayBuffer :: forall value. ArrayBuffer -> Payload value
arrayBuffer = ArrayBuffer -> Payload value
forall value. ArrayBuffer -> Payload value
BUFFER
-----------------------------------------------------------------------------
#ifdef WASM
-----------------------------------------------------------------------------
-- | Like 'eval', but read the JS code to evaluate from a file.
evalFile :: FilePath -> TH.Q TH.Exp
evalFile path = eval_ =<< TH.runIO (readFile path)
  where
    eval_ :: String -> TH.Q TH.Exp
    eval_ chunk = [| $(Miso.DSL.TH.evalTH chunk []) :: IO () |]
-----------------------------------------------------------------------------
#endif
-----------------------------------------------------------------------------