-----------------------------------------------------------------------------
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.FFI.Internal
-- 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.FFI.Internal
   ( JSM
   , forkJSM
   , syncCallback
   , syncCallback1
   , asyncCallback
   , asyncCallback1
   , ghcjsPure
   , syncPoint
   , addEventListener
   , windowAddEventListener
   , windowInnerHeight
   , windowInnerWidth
   , eventPreventDefault
   , eventStopPropagation
   , now
   , consoleWarn
   , consoleLog
   , consoleError
   , consoleLog'
   , jsonStringify
   , jsonParse
   , eventJSON
   , set
   , getBody
   , getDocument
   , getElementById
   , diff
   , integralToJSString
   , realFloatToJSString
   , jsStringToDouble
   , delegateEvent
   , undelegateEvent
   , hydrate
   , focus
   , blur
   , scrollIntoView
   , alert
   , reload
   , getComponent
   , setBodyComponent
   , addStyle
   , addStyleSheet
   , fetchJSON
   , shouldSync
   , setComponent
   ) where
-----------------------------------------------------------------------------
import           Control.Concurrent (ThreadId, forkIO)
import           Control.Monad (void, forM_)
import           Control.Monad.IO.Class (liftIO)
import           Data.Aeson hiding (Object)
import qualified Data.Aeson as A
import           Data.Maybe (isJust)
import qualified Data.JSString as JSS
#ifdef GHCJS_BOTH
import           Language.Javascript.JSaddle
#else
import           Language.Javascript.JSaddle hiding (Success)
#endif
import           Prelude hiding ((!!))
-----------------------------------------------------------------------------
import           Miso.String
----------------------------------------------------------------------------
-- | Run given `JSM` action asynchronously, in a separate thread.
forkJSM :: JSM () -> JSM ThreadId
forkJSM :: JSM () -> JSM ThreadId
forkJSM JSM ()
a = do
  ctx <- JSM JSContextRef
forall (m :: * -> *). MonadJSM m => m JSContextRef
askJSM
  liftIO (forkIO (runJSM a ctx))
-----------------------------------------------------------------------------
-- | Creates a synchronous callback function (no return value)
syncCallback :: JSM () -> JSM Function
syncCallback :: JSM () -> JSM Function
syncCallback JSM ()
a = JSCallAsFunction -> JSM Function
function (\JSVal
_ JSVal
_ [JSVal]
_ -> JSM ()
a)
-----------------------------------------------------------------------------
-- | Creates an asynchronous callback function
asyncCallback :: JSM () -> JSM Function
asyncCallback :: JSM () -> JSM Function
asyncCallback JSM ()
a = JSCallAsFunction -> JSM Function
asyncFunction (\JSVal
_ JSVal
_ [JSVal]
_ -> JSM ()
a)
-----------------------------------------------------------------------------
-- | Creates an asynchronous callback function with a single argument
asyncCallback1 :: (JSVal -> JSM ()) -> JSM Function
asyncCallback1 :: (JSVal -> JSM ()) -> JSM Function
asyncCallback1 JSVal -> JSM ()
f = JSCallAsFunction -> JSM Function
asyncFunction JSCallAsFunction
forall {p} {p}. p -> p -> [JSVal] -> JSM ()
handle
  where
    handle :: p -> p -> [JSVal] -> JSM ()
handle p
_ p
_ []    = String -> JSM ()
forall a. HasCallStack => String -> a
error String
"asyncCallback1: no args, impossible"
    handle p
_ p
_ (JSVal
x:[JSVal]
_) = JSVal -> JSM ()
f JSVal
x
-----------------------------------------------------------------------------
syncCallback1 :: (JSVal -> JSM ()) -> JSM Function
syncCallback1 :: (JSVal -> JSM ()) -> JSM Function
syncCallback1 JSVal -> JSM ()
f = JSCallAsFunction -> JSM Function
function JSCallAsFunction
forall {p} {p}. p -> p -> [JSVal] -> JSM ()
handle
  where
    handle :: p -> p -> [JSVal] -> JSM ()
handle p
_ p
_ []    = String -> JSM ()
forall a. HasCallStack => String -> a
error String
"syncCallback1: no args, impossible"
    handle p
_ p
_ (JSVal
x:[JSVal]
_) = JSVal -> JSM ()
f JSVal
x
-----------------------------------------------------------------------------
-- | Set property on object
set :: ToJSVal v => MisoString -> v -> Object -> JSM ()
set :: forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set (MisoString -> String
unpack -> String
"class") v
v Object
o = do
  classSet <- ((String -> JSString
JSS.pack String
"class") JSString -> [JSString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`Prelude.elem`) ([JSString] -> Bool) -> JSM [JSString] -> JSM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> JSM [JSString]
listProps Object
o
  if classSet
    then do
      classStr <- fromJSValUnchecked =<< getProp (JSS.pack "class") o
      vStr <- fromJSValUnchecked =<< toJSVal v
      v' <- toJSVal (classStr <> JSS.pack " " <> vStr)
      setProp (JSS.pack "class") v' o
    else do
      v' <- toJSVal v
      setProp (JSS.pack "class") v' o
set MisoString
k v
v Object
o = do
  v' <- v -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal v
v
  setProp (fromMisoString k) v' o
-----------------------------------------------------------------------------
-- | Register an event listener on given target.
addEventListener
  :: JSVal
  -- ^ Event target on which we want to register event listener
  -> MisoString
  -- ^ Type of event to listen to (e.g. "click")
  -> (JSVal -> JSM ())
  -- ^ Callback which will be called when the event occurs,
  -- the event will be passed to it as a parameter.
  -> JSM ()
addEventListener :: JSVal -> MisoString -> (JSVal -> JSM ()) -> JSM ()
addEventListener JSVal
self MisoString
name JSVal -> JSM ()
cb = do
  _ <- JSVal
self JSVal -> String -> (MisoString, JSM Function) -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"addEventListener" ((MisoString, JSM Function) -> JSM JSVal)
-> (MisoString, JSM Function) -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ (MisoString
name, JSCallAsFunction -> JSM Function
asyncFunction JSCallAsFunction
forall {p} {p}. p -> p -> [JSVal] -> JSM ()
handle)
  pure ()
    where
      handle :: p -> p -> [JSVal] -> JSM ()
handle p
_ p
_ []    = String -> JSM ()
forall a. HasCallStack => String -> a
error String
"addEventListener: no args, impossible"
      handle p
_ p
_ (JSVal
x:[JSVal]
_) = JSVal -> JSM ()
cb JSVal
x
-----------------------------------------------------------------------------
-- | Registers an event listener on window
windowAddEventListener
  :: MisoString
  -- ^ Type of event to listen to (e.g. "click")
  -> (JSVal -> JSM ())
  -- ^ Callback which will be called when the event occurs,
  -- the event will be passed to it as a parameter.
  -> JSM ()
windowAddEventListener :: MisoString -> (JSVal -> JSM ()) -> JSM ()
windowAddEventListener MisoString
name JSVal -> JSM ()
cb = do
  win <- String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"window"
  addEventListener win name cb
-----------------------------------------------------------------------------
-- | Stop propagation of events
eventStopPropagation :: JSVal -> JSM ()
eventStopPropagation :: JSVal -> JSM ()
eventStopPropagation JSVal
e = do
  _ <- JSVal
e JSVal -> String -> () -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"stopPropagation" (() -> JSM JSVal) -> () -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ ()
  pure ()
-----------------------------------------------------------------------------
-- | Prevent default event behavior
eventPreventDefault :: JSVal -> JSM ()
eventPreventDefault :: JSVal -> JSM ()
eventPreventDefault JSVal
e = do
  _ <- JSVal
e JSVal -> String -> () -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"preventDefault" (() -> JSM JSVal) -> () -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ ()
  pure ()
-----------------------------------------------------------------------------
-- | Retrieves the height (in pixels) of the browser window viewport including,
-- if rendered, the horizontal scrollbar.
--
-- See <https://developer.mozilla.org/en-US/docs/Web/API/Window/innerHeight>
windowInnerHeight :: JSM Int
windowInnerHeight :: JSM Int
windowInnerHeight =
  JSVal -> JSM Int
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked (JSVal -> JSM Int) -> JSM JSVal -> JSM Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"window" JSM JSVal -> String -> JSM JSVal
forall this name.
(MakeObject this, ToJSString name) =>
this -> name -> JSM JSVal
! String
"innerHeight"
-----------------------------------------------------------------------------
-- | Retrieves the width (in pixels) of the browser window viewport including
-- if rendered, the vertical scrollbar.
--
-- See <https://developer.mozilla.org/en-US/docs/Web/API/Window/innerWidth>
windowInnerWidth :: JSM Int
windowInnerWidth :: JSM Int
windowInnerWidth =
  JSVal -> JSM Int
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked (JSVal -> JSM Int) -> JSM JSVal -> JSM Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"window" JSM JSVal -> String -> JSM JSVal
forall this name.
(MakeObject this, ToJSString name) =>
this -> name -> JSM JSVal
! String
"innerWidth"
-----------------------------------------------------------------------------
-- | Retrieve high resolution time stamp
--
-- See <https://developer.mozilla.org/en-US/docs/Web/API/Performance/now>
now :: JSM Double
now :: JSM Double
now = JSVal -> JSM Double
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked (JSVal -> JSM Double) -> JSM JSVal -> JSM Double
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"performance" JSM JSVal -> String -> () -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"now" (() -> JSM JSVal) -> () -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ ())
-----------------------------------------------------------------------------
-- | Outputs a message to the web console
--
-- See <https://developer.mozilla.org/en-US/docs/Web/API/Console/log>
--
-- Console logging of JavaScript strings.
consoleLog :: MisoString -> JSM ()
consoleLog :: MisoString -> JSM ()
consoleLog MisoString
v = do
  _ <- String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"console" JSM JSVal -> String -> [JSString] -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"log" ([JSString] -> JSM JSVal) -> [JSString] -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ [MisoString -> JSString
forall a. ToJSString a => a -> JSString
toJSString MisoString
v]
  pure ()
-----------------------------------------------------------------------------
-- | Outputs a warning message to the web console
--
-- See <https://developer.mozilla.org/en-US/docs/Web/API/Console/warn>
--
-- Console logging of JavaScript strings.
consoleWarn :: MisoString -> JSM ()
consoleWarn :: MisoString -> JSM ()
consoleWarn MisoString
v = do
  _ <- String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"console" JSM JSVal -> String -> [JSString] -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"warn" ([JSString] -> JSM JSVal) -> [JSString] -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ [MisoString -> JSString
forall a. ToJSString a => a -> JSString
toJSString MisoString
v]
  pure ()
-----------------------------------------------------------------------------
-- | Outputs an error message to the web console
--
-- See <https://developer.mozilla.org/en-US/docs/Web/API/Console/error>
--
-- Console logging of JavaScript strings.
consoleError :: MisoString -> JSM ()
consoleError :: MisoString -> JSM ()
consoleError MisoString
v = do
  _ <- String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"console" JSM JSVal -> String -> [JSString] -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"error" ([JSString] -> JSM JSVal) -> [JSString] -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ [MisoString -> JSString
forall a. ToJSString a => a -> JSString
toJSString MisoString
v]
  pure ()
-----------------------------------------------------------------------------
-- | Console-logging of JSVal
consoleLog' :: JSVal -> JSM ()
consoleLog' :: JSVal -> JSM ()
consoleLog' JSVal
v = do
  _ <- String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"console" JSM JSVal -> String -> [JSVal] -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"log" ([JSVal] -> JSM JSVal) -> [JSVal] -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ [JSVal
v]
  pure ()
-----------------------------------------------------------------------------
-- | Encodes a Haskell object as a JSON string by way of a JavaScript object
jsonStringify :: ToJSON json => json -> JSM MisoString
{-# INLINE jsonStringify #-}
jsonStringify :: forall json. ToJSON json => json -> JSM MisoString
jsonStringify json
j = do
  v <- Value -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal (json -> Value
forall a. ToJSON a => a -> Value
toJSON json
j)
  fromJSValUnchecked =<< (jsg "JSON" # "stringify" $ [v])
-----------------------------------------------------------------------------
-- | Parses a MisoString
jsonParse :: FromJSON json => JSVal -> JSM json
{-# INLINE jsonParse #-}
jsonParse :: forall json. FromJSON json => JSVal -> JSM json
jsonParse JSVal
jval = do
  v <- JSVal -> JSM Value
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked (JSVal -> JSM Value) -> JSM JSVal -> JSM Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"JSON" JSM JSVal -> String -> [JSVal] -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"parse" ([JSVal] -> JSM JSVal) -> [JSVal] -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ [JSVal
jval])
  case fromJSON v of
    A.Success json
x -> json -> JSM json
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure json
x
    A.Error String
y -> String -> JSM json
forall a. HasCallStack => String -> a
error String
y
-----------------------------------------------------------------------------
-- | Convert a JavaScript object to JSON
-- JSONified representation of events
eventJSON
    :: JSVal -- ^ decodeAt :: [JSString]
    -> JSVal -- ^ object with impure references to the DOM
    -> JSM JSVal
eventJSON :: JSVal -> JSVal -> JSM JSVal
eventJSON JSVal
x JSVal
y = do
  moduleMiso <- String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"miso"
  moduleMiso # "eventJSON" $ [x,y]
-----------------------------------------------------------------------------
-- | Retrieves the component id
getComponent :: MisoString -> JSM JSVal
getComponent :: MisoString -> JSM JSVal
getComponent MisoString
name = JSM JSVal
nodeList JSM JSVal -> Int -> JSM JSVal
forall this. MakeObject this => this -> Int -> JSM JSVal
!! Int
0
  where
    nodeList :: JSM JSVal
nodeList
      = String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"document"
      # "querySelectorAll"
      ([String] -> JSM JSVal) -> [String] -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ [ String
"[data-component-id='" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> MisoString -> String
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"']" ]
-----------------------------------------------------------------------------
-- | Retrieves a reference to document body.
--
-- See <https://developer.mozilla.org/en-US/docs/Web/API/Document/body>
getBody :: JSM JSVal
getBody :: JSM JSVal
getBody = String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"document" JSM JSVal -> String -> JSM JSVal
forall this name.
(MakeObject this, ToJSString name) =>
this -> name -> JSM JSVal
! String
"body"
-----------------------------------------------------------------------------
-- | Retrieves a reference to the document.
--
-- See <https://developer.mozilla.org/en-US/docs/Web/API/Document>
getDocument :: JSM JSVal
getDocument :: JSM JSVal
getDocument = String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"document"
-----------------------------------------------------------------------------
-- | Returns an Element object representing the element whose id property matches
-- the specified string.
--
-- See <https://developer.mozilla.org/en-US/docs/Web/API/Document/getElementById>
getElementById :: MisoString -> JSM JSVal
getElementById :: MisoString -> JSM JSVal
getElementById MisoString
e = JSM JSVal
getDocument JSM JSVal -> String -> [MisoString] -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"getElementById" ([MisoString] -> JSM JSVal) -> [MisoString] -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ [MisoString
e]
-----------------------------------------------------------------------------
-- | Diff two virtual DOMs
diff
  :: Object
  -- ^ current object
  -> Object
  -- ^ new object
  -> JSVal
  -- ^ parent node
  -> JSM ()
diff :: Object -> Object -> JSVal -> JSM ()
diff (Object JSVal
a) (Object JSVal
b) JSVal
c = do
  moduleMiso <- String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"miso"
  void $ moduleMiso # "diff" $ [a,b,c]
-----------------------------------------------------------------------------
-- | Helper function for converting Integral types to JavaScript strings
integralToJSString :: Integral a => a -> MisoString
integralToJSString :: forall a. Integral a => a -> MisoString
integralToJSString = String -> MisoString
pack (String -> MisoString) -> (a -> String) -> a -> MisoString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> (a -> Integer) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Integer
forall a. Integral a => a -> Integer
toInteger
-----------------------------------------------------------------------------
-- | Helper function for converting RealFloat types to JavaScript strings
realFloatToJSString :: RealFloat a => a -> MisoString
realFloatToJSString :: forall a. RealFloat a => a -> MisoString
realFloatToJSString a
x = (String -> MisoString
pack (String -> MisoString)
-> (Double -> String) -> Double -> MisoString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> String
forall a. Show a => a -> String
show) (a -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
x :: Double)
-----------------------------------------------------------------------------
-- | Helper function for converting RealFloat types to JavaScript strings
jsStringToDouble :: MisoString -> Double
jsStringToDouble :: MisoString -> Double
jsStringToDouble = String -> Double
forall a. Read a => String -> a
read (String -> Double)
-> (MisoString -> String) -> MisoString -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> String
unpack
-----------------------------------------------------------------------------
-- | Initialize event delegation from a mount point.
delegateEvent :: JSVal -> JSVal -> Bool -> JSM JSVal -> JSM ()
delegateEvent :: JSVal -> JSVal -> Bool -> JSM JSVal -> JSM ()
delegateEvent JSVal
mountPoint JSVal
events Bool
debug JSM JSVal
getVTree =
  JSVal -> JSVal -> Bool -> Function -> JSM ()
delegate JSVal
mountPoint JSVal
events Bool
debug (Function -> JSM ()) -> JSM Function -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSCallAsFunction -> JSM Function
function JSCallAsFunction
forall {f} {p} {p}. MakeObject f => p -> p -> [f] -> JSM ()
handler
    where
      handler :: p -> p -> [f] -> JSM ()
handler p
_ p
_ [] = String -> JSM ()
forall a. HasCallStack => String -> a
error String
"delegate: no args - impossible state"
      handler p
_ p
_ (f
continuation : [f]
_) =
        JSM JSVal -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (f -> Object -> JSVal -> JSM JSVal
forall f this args.
(MakeObject f, MakeObject this, MakeArgs args) =>
f -> this -> args -> JSM JSVal
call f
continuation Object
global (JSVal -> JSM JSVal) -> JSM JSVal -> JSM JSVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSM JSVal
getVTree)
-----------------------------------------------------------------------------
-- | Deinitialize event delegation from a mount point.
undelegateEvent :: JSVal -> JSVal -> Bool -> JSM JSVal -> JSM ()
undelegateEvent :: JSVal -> JSVal -> Bool -> JSM JSVal -> JSM ()
undelegateEvent JSVal
mountPoint JSVal
events Bool
debug JSM JSVal
getVTree =
  JSVal -> JSVal -> Bool -> Function -> JSM ()
undelegate JSVal
mountPoint JSVal
events Bool
debug (Function -> JSM ()) -> JSM Function -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSCallAsFunction -> JSM Function
function JSCallAsFunction
forall {f} {p} {p}. MakeObject f => p -> p -> [f] -> JSM ()
handler
    where
      handler :: p -> p -> [f] -> JSM ()
handler p
_ p
_ [] = String -> JSM ()
forall a. HasCallStack => String -> a
error String
"undelegate: no args - impossible state"
      handler p
_ p
_ (f
continuation : [f]
_) =
        JSM JSVal -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (f -> Object -> JSVal -> JSM JSVal
forall f this args.
(MakeObject f, MakeObject this, MakeArgs args) =>
f -> this -> args -> JSM JSVal
call f
continuation Object
global (JSVal -> JSM JSVal) -> JSM JSVal -> JSM JSVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSM JSVal
getVTree)
-----------------------------------------------------------------------------
-- | Call 'delegateEvent' JavaScript function
delegate :: JSVal -> JSVal -> Bool -> Function -> JSM ()
delegate :: JSVal -> JSVal -> Bool -> Function -> JSM ()
delegate JSVal
mountPoint JSVal
events Bool
debug Function
callback = do
  d <- Bool -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal Bool
debug
  cb <- toJSVal callback
  moduleMiso <- jsg "miso"
  void $ moduleMiso # "delegate" $ [mountPoint,events,cb,d]
-----------------------------------------------------------------------------
undelegate :: JSVal -> JSVal -> Bool -> Function -> JSM ()
undelegate :: JSVal -> JSVal -> Bool -> Function -> JSM ()
undelegate JSVal
mountPoint JSVal
events Bool
debug Function
callback = do
  d <- Bool -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal Bool
debug
  cb <- toJSVal callback
  moduleMiso <- jsg "miso"
  void $ moduleMiso # "undelegate" $ [mountPoint,events,cb,d]
-----------------------------------------------------------------------------
-- | Copies DOM pointers into virtual dom
-- entry point into isomorphic javascript
--
-- <https://en.wikipedia.org/wiki/Hydration_(web_development)>
--
hydrate :: Bool -> JSVal -> JSVal -> JSM ()
hydrate :: Bool -> JSVal -> JSVal -> JSM ()
hydrate Bool
logLevel JSVal
mountPoint JSVal
vtree = JSM () -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
  ll <- Bool -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal Bool
logLevel
  moduleMiso <- jsg "miso"
  void $ moduleMiso # "hydrate" $ [ll, mountPoint, vtree]
-----------------------------------------------------------------------------
-- | Fails silently if the element is not found.
--
-- Analogous to @document.getElementById(id).focus()@.
focus :: MisoString -> JSM ()
focus :: MisoString -> JSM ()
focus MisoString
x = do
  moduleMiso <- String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"miso"
  el <- toJSVal x
  delay <- toJSVal (50 :: Int)
  void $ moduleMiso # "callFocus" $ [el,delay]
-----------------------------------------------------------------------------
-- | Fails silently if the element is not found.
--
-- Analogous to @document.getElementById(id).blur()@
blur :: MisoString -> JSM ()
blur :: MisoString -> JSM ()
blur MisoString
x = do
  moduleMiso <- String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"miso"
  el <- toJSVal x
  delay <- toJSVal (50 :: Int)
  void $ moduleMiso # "callBlur" $ [el,delay]
-----------------------------------------------------------------------------
-- | Calls @document.getElementById(id).scrollIntoView()@
scrollIntoView :: MisoString -> JSM ()
scrollIntoView :: MisoString -> JSM ()
scrollIntoView MisoString
elId = do
  el <- String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"document" JSM JSVal -> String -> [MisoString] -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"getElementById" ([MisoString] -> JSM JSVal) -> [MisoString] -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ [MisoString
elId]
  _ <- el # "scrollIntoView" $ ()
  pure ()
-----------------------------------------------------------------------------
-- | Calls the @alert()@ function.
alert :: MisoString -> JSM ()
alert :: MisoString -> JSM ()
alert MisoString
a = () () -> JSM JSVal -> JSM ()
forall a b. a -> JSM b -> JSM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> MisoString -> JSM JSVal
forall name a0.
(ToJSString name, ToJSVal a0) =>
name -> a0 -> JSM JSVal
jsg1 String
"alert" MisoString
a
-----------------------------------------------------------------------------
-- | Calls the @location.reload()@ function.
reload :: JSM ()
reload :: JSM ()
reload = JSM JSVal -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM JSVal -> JSM ()) -> JSM JSVal -> JSM ()
forall a b. (a -> b) -> a -> b
$ String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"location" JSM JSVal -> String -> [MisoString] -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"reload" ([MisoString] -> JSM JSVal) -> [MisoString] -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ ([] :: [MisoString])
-----------------------------------------------------------------------------
-- | Sets the body with data-component-id
setBodyComponent :: MisoString -> JSM ()
setBodyComponent :: MisoString -> JSM ()
setBodyComponent MisoString
name = do
  component <- MisoString -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal MisoString
name
  node <- jsg "document" ! "body"
  moduleMiso <- jsg "miso"
  void $ moduleMiso # "setComponent" $ [node, component]
-----------------------------------------------------------------------------
-- | Sets @data-component-id@ on the node given by second argument to a value given by the first argument
setComponent :: MisoString -> JSVal -> JSM ()
setComponent :: MisoString -> JSVal -> JSM ()
setComponent MisoString
name JSVal
node = do
  component <- MisoString -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal MisoString
name
  moduleMiso <- jsg "miso"
  void $ moduleMiso # "setComponent" $ [node, component]
-----------------------------------------------------------------------------
-- | Appends a 'style_' element containing CSS to 'head_'
--
-- > addStyle "body { background-color: green; }"
--
-- > <head><style>body { background-color: green; }</style></head>
--
addStyle :: MisoString -> JSM ()
addStyle :: MisoString -> JSM ()
addStyle MisoString
css = do
  style <- String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"document" JSM JSVal -> String -> [String] -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"createElement" ([String] -> JSM JSVal) -> [String] -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ [String
"style"]
  (style <# "innerHTML") css
  void $ jsg "document" ! "head" # "appendChild" $ [style]
-----------------------------------------------------------------------------
-- | Appends a StyleSheet 'link_' element to 'head_'
-- The 'link_' tag will contain a URL to a CSS file.
--
-- > addStyleSheet "https://cdn.jsdelivr.net/npm/todomvc-common@1.0.5/base.min.css"
--
-- > <head><link href="https://cdn.jsdelivr.net/npm/todomvc-common@1.0.5/base.min.css" ref="stylesheet"></head>
--
addStyleSheet :: MisoString -> JSM ()
addStyleSheet :: MisoString -> JSM ()
addStyleSheet MisoString
url = do
  link <- String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"document" JSM JSVal -> String -> [String] -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"createElement" ([String] -> JSM JSVal) -> [String] -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ [String
"link"]
  _ <- link # "setAttribute" $ ["rel","stylesheet"]
  _ <- link # "setAttribute" $ ["href", fromMisoString url]
  void $ jsg "document" ! "head" # "appendChild" $ [link]
-----------------------------------------------------------------------------
-- | Retrieve JSON via Fetch API
--
-- Basic GET of JSON using Fetch API, will be expanded upon.
--
-- See <https://developer.mozilla.org/en-US/docs/Web/API/Fetch_API>
--
fetchJSON
  :: FromJSON action
  => MisoString
  -- ^ url
  -> MisoString
  -- ^ method
  -> Maybe MisoString
  -- ^ body
  -> [(MisoString,MisoString)]
  -- ^ headers
  -> (action -> JSM ())
  -- ^ successful callback
  -> (MisoString -> JSM ())
  -- ^ errorful callback
  -> JSM ()
fetchJSON :: forall action.
FromJSON action =>
MisoString
-> MisoString
-> Maybe MisoString
-> [(MisoString, MisoString)]
-> (action -> JSM ())
-> (MisoString -> JSM ())
-> JSM ()
fetchJSON MisoString
url MisoString
method Maybe MisoString
maybeBody [(MisoString, MisoString)]
headers action -> JSM ()
successful MisoString -> JSM ()
errorful = do
  successful_ <- Function -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal (Function -> JSM JSVal) -> JSM Function -> JSM JSVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
    (JSVal -> JSM ()) -> JSM Function
asyncCallback1 ((JSVal -> JSM ()) -> JSM Function)
-> (JSVal -> JSM ()) -> JSM Function
forall a b. (a -> b) -> a -> b
$ \JSVal
jval ->
      Value -> Result action
forall a. FromJSON a => Value -> Result a
fromJSON (Value -> Result action) -> JSM Value -> JSM (Result action)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSVal -> JSM Value
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked JSVal
jval JSM (Result action) -> (Result action -> JSM ()) -> JSM ()
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Error String
string ->
          String -> JSM ()
forall a. HasCallStack => String -> a
error (String
"fetchJSON: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
string String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": decode failure")
        Success action
result -> do
          action -> JSM ()
successful action
result
  errorful_ <- toJSVal =<< do
    asyncCallback1 $ \JSVal
jval ->
       MisoString -> JSM ()
errorful (MisoString -> JSM ()) -> JSM MisoString -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal -> JSM MisoString
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked JSVal
jval
  moduleMiso <- jsg "miso"
  url_ <- toJSVal url
  method_ <- toJSVal method
  body_ <- toJSVal maybeBody
  let jsonHeaders =
        [(String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms String
"Content-Type", String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms String
"application/json") | Maybe MisoString -> Bool
forall a. Maybe a -> Bool
isJust Maybe MisoString
maybeBody]
        [(MisoString, MisoString)]
-> [(MisoString, MisoString)] -> [(MisoString, MisoString)]
forall a. Semigroup a => a -> a -> a
<>
        [(String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms String
"Accept", String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms String
"application/json")]
  Object headers_ <- do
    o <- create
    forM_ (headers <> jsonHeaders) $ \(MisoString
k,MisoString
v) -> do
      MisoString -> MisoString -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
k MisoString
v Object
o
    pure o
  void $ moduleMiso # "fetchJSON" $ [url_, method_, body_, headers_, successful_, errorful_]
-----------------------------------------------------------------------------
-- | shouldSync
--
-- Used to set whether or not the current VNode should enter the 'syncChildren'
-- function during diffing. The criteria for entrance is that all children
-- have a populated 'key' node. We can determine this property more efficiently
-- at tree construction time rather than dynamic detection during diffing.
--
shouldSync :: JSVal -> JSM Bool
shouldSync :: JSVal -> JSM Bool
shouldSync JSVal
vnode = do
  moduleMiso <- String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"miso"
  fromJSValUnchecked =<< do
    moduleMiso # "shouldSync" $ [vnode]
-----------------------------------------------------------------------------