{-# LANGUAGE RecordWildCards #-}
-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Delegate
-- 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.Delegate
  ( delegator
  , undelegator
  ) where
-----------------------------------------------------------------------------
import           Control.Monad.IO.Class (liftIO)
import           Data.IORef (IORef, readIORef)
import qualified Data.Map.Strict as M
import           Language.Javascript.JSaddle (create, JSM, JSVal, Object(..), ToJSVal(toJSVal))
import           Miso.Html.Types (VTree(..))
import           Miso.String (MisoString)
import qualified Miso.FFI.Internal as FFI
-----------------------------------------------------------------------------
-- | Local Event type, used to create field names for a delegated event
data Event
  = Event
  { Event -> MisoString
name :: MisoString
  -- ^ Event name
  , Event -> Bool
capture :: Bool
  -- ^ Capture settings for event
  } deriving (Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
(Int -> Event -> ShowS)
-> (Event -> String) -> ([Event] -> ShowS) -> Show Event
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Event -> ShowS
showsPrec :: Int -> Event -> ShowS
$cshow :: Event -> String
show :: Event -> String
$cshowList :: [Event] -> ShowS
showList :: [Event] -> ShowS
Show, Event -> Event -> Bool
(Event -> Event -> Bool) -> (Event -> Event -> Bool) -> Eq Event
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Event -> Event -> Bool
== :: Event -> Event -> Bool
$c/= :: Event -> Event -> Bool
/= :: Event -> Event -> Bool
Eq)
-----------------------------------------------------------------------------
-- | Instance used to initialize event delegation
instance ToJSVal Event where
  toJSVal :: Event -> JSM JSVal
toJSVal Event {Bool
MisoString
name :: Event -> MisoString
capture :: Event -> Bool
name :: MisoString
capture :: Bool
..} = do
    o <- JSM Object
create
    flip (FFI.set "name") o =<< toJSVal name
    flip (FFI.set "capture") o =<< toJSVal capture
    toJSVal o
-----------------------------------------------------------------------------
-- | Entry point for event delegation
delegator
  :: JSVal
  -> IORef VTree
  -> M.Map MisoString Bool
  -> Bool
  -> JSM ()
delegator :: JSVal -> IORef VTree -> Map MisoString Bool -> Bool -> JSM ()
delegator JSVal
mountPointElement IORef VTree
vtreeRef Map MisoString Bool
es Bool
debug = do
  evts <- [Event] -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal ((MisoString -> Bool -> Event) -> (MisoString, Bool) -> Event
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry MisoString -> Bool -> Event
Event ((MisoString, Bool) -> Event) -> [(MisoString, Bool)] -> [Event]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map MisoString Bool -> [(MisoString, Bool)]
forall k a. Map k a -> [(k, a)]
M.toList Map MisoString Bool
es)
  FFI.delegateEvent mountPointElement evts debug $ do
    VTree (Object vtree) <- liftIO (readIORef vtreeRef)
    pure vtree
-----------------------------------------------------------------------------
-- | Entry point for deinitalizing event delegation
undelegator
  :: JSVal
  -> IORef VTree
  -> M.Map MisoString Bool
  -> Bool
  -> JSM ()
undelegator :: JSVal -> IORef VTree -> Map MisoString Bool -> Bool -> JSM ()
undelegator JSVal
mountPointElement IORef VTree
vtreeRef Map MisoString Bool
es Bool
debug = do
  events <- [(MisoString, Bool)] -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal (Map MisoString Bool -> [(MisoString, Bool)]
forall k a. Map k a -> [(k, a)]
M.toList Map MisoString Bool
es)
  FFI.undelegateEvent mountPointElement events debug $ do
    VTree (Object vtree) <- liftIO (readIORef vtreeRef)
    pure vtree
-----------------------------------------------------------------------------