{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Miso.Event
(
on
, onMain
, onCapture
, onWithOptions
, onMainWithOptions
, Phase (..)
, onCreated
, onCreatedWith
, onBeforeCreated
, onDestroyed
, onBeforeDestroyed
, onBeforeDestroyedWith
, module Miso.Event.Decoder
, module Miso.Event.Types
) where
import Control.Monad (when)
import qualified Data.Map.Strict as M
import qualified Data.IntMap.Strict as IM
import Data.IORef
import Miso.JSON (parseEither)
import Miso.DSL
import Miso.Event.Decoder
import Miso.Event.Types
import qualified Miso.FFI.Internal as FFI
import Miso.Types (LogLevel(..), DOMRef, VTree(..), EventHandler(..), Attribute(..))
import Miso.Runtime
import Miso.String (MisoString, ms)
onMain :: MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> EventHandler model action
onMain :: forall result model action.
MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> EventHandler model action
onMain = Phase
-> Options
-> MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> EventHandler model action
forall result model action.
Phase
-> Options
-> MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> EventHandler model action
onMainWithOptions Phase
BUBBLE Options
defaultOptions
on :: MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> Attribute model action
on :: forall result model action.
MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> Attribute model action
on = Phase
-> Options
-> MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> Attribute model action
forall result model action.
Phase
-> Options
-> MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> Attribute model action
onWithOptions Phase
BUBBLE Options
defaultOptions
onCapture
:: MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> Attribute model action
onCapture :: forall result model action.
MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> Attribute model action
onCapture = Phase
-> Options
-> MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> Attribute model action
forall result model action.
Phase
-> Options
-> MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> Attribute model action
onWithOptions Phase
CAPTURE Options
defaultOptions
onMainWithOptions
:: Phase
-> Options
-> MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> EventHandler model action
onMainWithOptions :: forall result model action.
Phase
-> Options
-> MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> EventHandler model action
onMainWithOptions Phase
phase Options
opts MisoString
name Decoder result
decoder result -> model -> DOMRef -> action
conversion =
EventHandler
{ eventHandlerInstall :: model -> Sink action -> VTree -> LogLevel -> Events -> IO ()
eventHandlerInstall = \model
m Sink action
snk VTree
tree LogLevel
ll Events
events ->
case Phase
-> Options
-> MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> Attribute model action
forall result model action.
Phase
-> Options
-> MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> Attribute model action
onWithOptions Phase
phase Options
opts MisoString
name Decoder result
decoder result -> model -> DOMRef -> action
conversion of
On model -> Sink action -> VTree -> LogLevel -> Events -> IO ()
cb -> do
MisoString -> Bool -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"pendingMainThread" Bool
True (Object -> IO ()) -> IO Object -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< VTree -> IO Object
forall a. ToObject a => a -> IO Object
toObject VTree
tree
model -> Sink action -> VTree -> LogLevel -> Events -> IO ()
cb model
m Sink action
snk VTree
tree LogLevel
ll Events
events
Attribute model action
_ ->
String -> IO ()
forall a. HasCallStack => String -> a
error String
"onMainWithOptions: impossible"
, eventHandlerDecoder :: Decoder result
eventHandlerDecoder = Decoder result
decoder
, eventHandlerConvert :: result -> model -> DOMRef -> action
eventHandlerConvert = result -> model -> DOMRef -> action
conversion
}
onWithOptions
:: Phase
-> Options
-> MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> Attribute model action
onWithOptions :: forall result model action.
Phase
-> Options
-> MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> Attribute model action
onWithOptions Phase
phase Options
options MisoString
eventName Decoder{DecodeTarget
Value -> Parser result
decoder :: Value -> Parser result
decodeAt :: DecodeTarget
decodeAt :: forall a. Decoder a -> DecodeTarget
decoder :: forall a. Decoder a -> Value -> Parser a
..} result -> model -> DOMRef -> action
toAction =
(model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
forall model action.
(model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
On ((model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action)
-> (model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
forall a b. (a -> b) -> a -> b
$ \model
_model Sink action
sink (VTree Object
n) LogLevel
logLevel Events
events -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel
logLevel LogLevel -> LogLevel -> Bool
forall a. Eq a => a -> a -> Bool
== LogLevel
DebugAll Bool -> Bool -> Bool
|| LogLevel
logLevel LogLevel -> LogLevel -> Bool
forall a. Eq a => a -> a -> Bool
== LogLevel
DebugEvents) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
case MisoString -> Events -> Maybe Phase
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MisoString
eventName Events
events of
Maybe Phase
Nothing ->
MisoString -> IO ()
FFI.consoleError (MisoString -> IO ()) -> MisoString -> IO ()
forall a b. (a -> b) -> a -> b
$ [MisoString] -> MisoString
forall a. Monoid a => [a] -> a
mconcat
[ MisoString
"Event \""
, MisoString
eventName
, MisoString
"\" is not being listened on. To use this event, "
, MisoString
"add to the 'events' Map in Component"
]
Maybe Phase
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
eventsVal <-
MisoString -> Object -> IO DOMRef
forall o. ToObject o => MisoString -> o -> IO DOMRef
getProp MisoString
"events" Object
n
eventObj <-
case phase of
Phase
CAPTURE -> MisoString -> Object -> IO DOMRef
forall o. ToObject o => MisoString -> o -> IO DOMRef
getProp MisoString
"captures" (DOMRef -> Object
Object DOMRef
eventsVal)
Phase
BUBBLE -> MisoString -> Object -> IO DOMRef
forall o. ToObject o => MisoString -> o -> IO DOMRef
getProp MisoString
"bubbles" (DOMRef -> Object
Object DOMRef
eventsVal)
eventHandlerObject@(Object eo) <- create
jsOptions <- toJSVal options
decodeAtVal <- toJSVal decodeAt
cb <- FFI.asyncCallback2 $ \DOMRef
e DOMRef
domRef -> do
Just v <- DOMRef -> IO (Maybe Value)
forall a. FromJSVal a => DOMRef -> IO (Maybe a)
fromJSVal (DOMRef -> IO (Maybe Value)) -> IO DOMRef -> IO (Maybe Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DOMRef -> DOMRef -> IO DOMRef
FFI.eventJSON DOMRef
decodeAtVal DOMRef
e
case parseEither decoder v of
Left MisoString
msg -> MisoString -> IO ()
FFI.consoleError (MisoString
"[EVENT DECODE ERROR]: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
ms MisoString
msg)
Right result
event -> do
vcompId <- DOMRef -> IO Key
forall a. FromJSVal a => DOMRef -> IO a
fromJSValUnchecked (DOMRef -> IO Key) -> IO DOMRef -> IO Key
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> Object -> IO DOMRef
forall o. ToObject o => MisoString -> o -> IO DOMRef
getProp MisoString
"pendingComponentId" Object
n
IM.lookup vcompId <$> readIORef components >>= \case
Maybe (ComponentState (ZonkAny 0) (ZonkAny 1) model (ZonkAny 2))
Nothing ->
MisoString -> IO ()
FFI.consoleError (MisoString
"[COMPONENT]: No component found at ID: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> Key -> MisoString
forall str. ToMisoString str => str -> MisoString
ms Key
vcompId)
Just ComponentState {model
Bool
Key
[DOMRef]
Maybe StaticKey
Maybe Key
ZonkAny 1
IORef (Map MisoString ThreadId)
IORef VTree
Events
Map MisoString (Value -> IO ())
ComponentIds
DOMRef
model -> IO ()
model -> model -> Bool
ZonkAny 1 -> ZonkAny 1 -> IO ()
Sink (ZonkAny 2)
Seq (ZonkAny 2)
-> model
-> ZonkAny 1
-> ZonkAny 0
-> (model, [Schedule (ZonkAny 0) (ZonkAny 2)])
Value -> Maybe (ZonkAny 2)
_componentId :: Key
_componentKey :: Maybe Key
_componentStaticKey :: Maybe StaticKey
_componentParentId :: Key
_componentProps :: ZonkAny 1
_prevComponentProps :: ZonkAny 1
_componentSubThreads :: IORef (Map MisoString ThreadId)
_componentDOMRef :: DOMRef
_componentVTree :: IORef VTree
_componentSink :: Sink (ZonkAny 2)
_componentPostEffect :: Sink (ZonkAny 2)
_componentModel :: model
_componentScripts :: [DOMRef]
_componentEvents :: Events
_componentUseContext :: Bool
_componentMailbox :: Value -> Maybe (ZonkAny 2)
_componentDraw :: model -> IO ()
_componentHydrate :: model -> IO ()
_componentPropsPhase :: ZonkAny 1 -> ZonkAny 1 -> IO ()
_componentModelDirty :: model -> model -> Bool
_componentApplyActions :: Seq (ZonkAny 2)
-> model
-> ZonkAny 1
-> ZonkAny 0
-> (model, [Schedule (ZonkAny 0) (ZonkAny 2)])
_componentTopics :: Map MisoString (Value -> IO ())
_componentChildren :: ComponentIds
_componentApplyActions :: forall context props model action.
ComponentState context props model action
-> Seq action
-> model
-> props
-> context
-> (model, [Schedule context action])
_componentChildren :: forall context props model action.
ComponentState context props model action -> ComponentIds
_componentDOMRef :: forall context props model action.
ComponentState context props model action -> DOMRef
_componentDraw :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentEvents :: forall context props model action.
ComponentState context props model action -> Events
_componentHydrate :: forall context props model action.
ComponentState context props model action -> model -> IO ()
_componentId :: forall context props model action.
ComponentState context props model action -> Key
_componentKey :: forall context props model action.
ComponentState context props model action -> Maybe Key
_componentMailbox :: forall context props model action.
ComponentState context props model action -> Value -> Maybe action
_componentModel :: forall context props model action.
ComponentState context props model action -> model
_componentModelDirty :: forall context props model action.
ComponentState context props model action -> model -> model -> Bool
_componentParentId :: forall context props model action.
ComponentState context props model action -> Key
_componentPostEffect :: forall context props model action.
ComponentState context props model action -> Sink action
_componentProps :: forall context props model action.
ComponentState context props model action -> props
_componentPropsPhase :: forall context props model action.
ComponentState context props model action
-> props -> props -> IO ()
_componentScripts :: forall context props model action.
ComponentState context props model action -> [DOMRef]
_componentSink :: forall context props model action.
ComponentState context props model action -> Sink action
_componentStaticKey :: forall context props model action.
ComponentState context props model action -> Maybe StaticKey
_componentSubThreads :: forall context props model action.
ComponentState context props model action
-> IORef (Map MisoString ThreadId)
_componentTopics :: forall context props model action.
ComponentState context props model action
-> Map MisoString (Value -> IO ())
_componentUseContext :: forall context props model action.
ComponentState context props model action -> Bool
_componentVTree :: forall context props model action.
ComponentState context props model action -> IORef VTree
_prevComponentProps :: forall context props model action.
ComponentState context props model action -> props
..} ->
Sink action
sink (result -> model -> DOMRef -> action
toAction result
event model
_componentModel DOMRef
domRef)
registerEventHandler cb
FFI.set "runEvent" cb eventHandlerObject
FFI.set "options" jsOptions eventHandlerObject
pendingMT <- getProp "pendingMainThread" n
isMainThread <- fromJSVal pendingMT :: IO (Maybe Bool)
when (isMainThread == Just True) $ do
pendingKey <- getProp "pendingStaticKey" n
mKey <- fromJSVal pendingKey :: IO (Maybe MisoString)
maybe (pure ()) (\MisoString
k -> MisoString -> MisoString -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"staticKey" (MisoString
k :: MisoString) Object
eventHandlerObject) mKey
pendingCid <- getProp "pendingComponentId" n
mCid <- fromJSVal pendingCid :: IO (Maybe Int)
maybe (pure ()) (\Key
c -> MisoString -> Key -> Object -> IO ()
forall v. ToJSVal v => MisoString -> v -> Object -> IO ()
FFI.set MisoString
"componentId" (Key
c :: Int) Object
eventHandlerObject) mCid
FFI.set eventName eo (Object eventObj)
mapM_ freeJSVal [eventsVal, eventObj, eo, jsOptions, pendingMT]
onCreated
:: action
-> Attribute model action
onCreated :: forall action model. action -> Attribute model action
onCreated action
action =
(model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
forall model action.
(model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
On ((model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action)
-> (model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
forall a b. (a -> b) -> a -> b
$ \model
_model Sink action
sink (VTree Object
object) LogLevel
_ Events
_ -> do
callback <- IO () -> IO DOMRef
FFI.syncCallback (Sink action
sink action
action)
FFI.set "onCreated" callback object
onCreatedWith
:: (DOMRef -> action)
-> Attribute model action
onCreatedWith :: forall action model. (DOMRef -> action) -> Attribute model action
onCreatedWith DOMRef -> action
action =
(model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
forall model action.
(model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
On ((model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action)
-> (model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
forall a b. (a -> b) -> a -> b
$ \model
_model Sink action
sink (VTree Object
object) LogLevel
_ Events
_ -> do
callback <- (DOMRef -> IO ()) -> IO DOMRef
FFI.syncCallback1 (Sink action
sink Sink action -> (DOMRef -> action) -> DOMRef -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DOMRef -> action
action)
FFI.set "onCreated" callback object
onDestroyed
:: action
-> Attribute model action
onDestroyed :: forall action model. action -> Attribute model action
onDestroyed action
action =
(model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
forall model action.
(model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
On ((model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action)
-> (model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
forall a b. (a -> b) -> a -> b
$ \model
_model Sink action
sink (VTree Object
object) LogLevel
_ Events
_ -> do
callback <- IO () -> IO DOMRef
FFI.syncCallback (Sink action
sink action
action)
FFI.set "onDestroyed" callback object
onBeforeDestroyed
:: action
-> Attribute model action
onBeforeDestroyed :: forall action model. action -> Attribute model action
onBeforeDestroyed action
action =
(model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
forall model action.
(model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
On ((model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action)
-> (model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
forall a b. (a -> b) -> a -> b
$ \model
_model Sink action
sink (VTree Object
object) LogLevel
_ Events
_ -> do
callback <- IO () -> IO DOMRef
FFI.syncCallback (Sink action
sink action
action)
FFI.set "onBeforeDestroyed" callback object
onBeforeDestroyedWith
:: (DOMRef -> action)
-> Attribute model action
onBeforeDestroyedWith :: forall action model. (DOMRef -> action) -> Attribute model action
onBeforeDestroyedWith DOMRef -> action
action =
(model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
forall model action.
(model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
On ((model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action)
-> (model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
forall a b. (a -> b) -> a -> b
$ \model
_model Sink action
sink (VTree Object
object) LogLevel
_ Events
_ -> do
callback <- (DOMRef -> IO ()) -> IO DOMRef
FFI.syncCallback1 (Sink action
sink Sink action -> (DOMRef -> action) -> DOMRef -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DOMRef -> action
action)
FFI.set "onBeforeDestroyed" callback object
onBeforeCreated
:: action
-> Attribute model action
onBeforeCreated :: forall action model. action -> Attribute model action
onBeforeCreated action
action =
(model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
forall model action.
(model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
On ((model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action)
-> (model -> Sink action -> VTree -> LogLevel -> Events -> IO ())
-> Attribute model action
forall a b. (a -> b) -> a -> b
$ \model
_model Sink action
sink (VTree Object
object) LogLevel
_ Events
_ -> do
callback <- IO () -> IO DOMRef
FFI.syncCallback (Sink action
sink action
action)
FFI.set "onBeforeCreated" callback object