{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
module Miso.FFI
( JSM
, forkJSM
, asyncCallback
, asyncCallback1
, callbackToJSVal
, objectToJSVal
, ghcjsPure
, syncPoint
, addEventListener
, windowAddEventListener
, windowInnerHeight
, windowInnerWidth
, eventPreventDefault
, eventStopPropagation
, now
, consoleLog
, consoleLogJSVal
, stringify
, parse
, clearBody
, objectToJSON
, set
, getBody
, getDoc
, getElementById
, diff'
, integralToJSString
, realFloatToJSString
, jsStringToDouble
, delegateEvent
, copyDOMIntoVTree
, swapCallbacks
, releaseCallbacks
, registerCallback
, focus
, blur
, scrollIntoView
, alert
) where
import Control.Concurrent
import Control.Monad.IO.Class
import Data.Aeson hiding (Object)
import qualified Data.JSString as JSS
import GHCJS.Marshal
import GHCJS.Types
import qualified JavaScript.Object.Internal as OI
#ifdef __GHCJS__
import Language.Javascript.JSaddle hiding (obj, val)
#else
import Language.Javascript.JSaddle hiding (Success, obj, val)
#endif
import Miso.String
forkJSM :: JSM () -> JSM ()
forkJSM :: JSM () -> JSM ()
forkJSM JSM ()
a = do
JSContextRef
ctx <- JSM JSContextRef
forall (m :: * -> *). MonadJSM m => m JSContextRef
askJSM
ThreadId
_ <- IO ThreadId -> JSM ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ThreadId
forkIO (JSM () -> JSContextRef -> IO ()
forall (m :: * -> *) a. MonadIO m => JSM a -> JSContextRef -> m a
runJSM JSM ()
a JSContextRef
ctx))
() -> JSM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
asyncCallback :: JSM () -> JSM Function
asyncCallback :: JSM () -> JSM Function
asyncCallback JSM ()
a = JSCallAsFunction -> JSM Function
asyncFunction (\JSVal
_ JSVal
_ [JSVal]
_ -> JSM ()
a)
asyncCallback1 :: (JSVal -> JSM ()) -> JSM Function
asyncCallback1 :: (JSVal -> JSM ()) -> JSM Function
asyncCallback1 JSVal -> JSM ()
f = JSCallAsFunction -> JSM Function
asyncFunction (\JSVal
_ JSVal
_ [JSVal
x] -> JSVal -> JSM ()
f JSVal
x)
callbackToJSVal :: Function -> JSM JSVal
callbackToJSVal :: Function -> JSM JSVal
callbackToJSVal = Function -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal
objectToJSVal :: Object -> JSM JSVal
objectToJSVal :: Object -> JSM JSVal
objectToJSVal = Object -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal
set :: ToJSVal v => MisoString -> v -> OI.Object -> JSM ()
set :: MisoString -> v -> Object -> JSM ()
set (MisoString -> String
unpack -> String
"class") v
v Object
obj = do
Bool
classSet <- ((String -> JSString
JSS.pack String
"class") JSString -> [JSString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) ([JSString] -> Bool) -> JSM [JSString] -> JSM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> JSM [JSString]
listProps Object
obj
if Bool
classSet
then do
JSString
classStr <- JSVal -> JSM JSString
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked (JSVal -> JSM JSString) -> JSM JSVal -> JSM JSString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSString -> Object -> JSM JSVal
getProp (String -> JSString
JSS.pack String
"class") Object
obj
JSString
vStr <- JSVal -> JSM JSString
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked (JSVal -> JSM JSString) -> JSM JSVal -> JSM JSString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< v -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal v
v
JSVal
v' <- JSString -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal (JSString
classStr JSString -> JSString -> JSString
forall a. Semigroup a => a -> a -> a
<> String -> JSString
JSS.pack String
" " JSString -> JSString -> JSString
forall a. Semigroup a => a -> a -> a
<> JSString
vStr)
JSString -> JSVal -> Object -> JSM ()
setProp (String -> JSString
JSS.pack String
"class") JSVal
v' Object
obj
else do
JSVal
v' <- v -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal v
v
JSString -> JSVal -> Object -> JSM ()
setProp (String -> JSString
JSS.pack String
"class") JSVal
v' Object
obj
set MisoString
k v
v Object
obj = do
JSVal
v' <- v -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal v
v
JSString -> JSVal -> Object -> JSM ()
setProp (MisoString -> JSString
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
k) JSVal
v' Object
obj
addEventListener :: JSVal
-> MisoString
-> (JSVal -> JSM ())
-> JSM ()
addEventListener :: JSVal -> MisoString -> (JSVal -> JSM ()) -> JSM ()
addEventListener JSVal
self MisoString
name JSVal -> JSM ()
cb = do
JSVal
_ <- 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 (\JSVal
_ JSVal
_ [JSVal
a] -> JSVal -> JSM ()
cb JSVal
a))
() -> JSM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
windowAddEventListener :: MisoString
-> (JSVal -> JSM ())
-> JSM ()
windowAddEventListener :: MisoString -> (JSVal -> JSM ()) -> JSM ()
windowAddEventListener MisoString
name JSVal -> JSM ()
cb = do
JSVal
win <- String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"window"
JSVal -> MisoString -> (JSVal -> JSM ()) -> JSM ()
addEventListener JSVal
win MisoString
name JSVal -> JSM ()
cb
eventStopPropagation :: JSVal -> JSM ()
eventStopPropagation :: JSVal -> JSM ()
eventStopPropagation JSVal
e = do
JSVal
_ <- 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
$ ()
() -> JSM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
eventPreventDefault :: JSVal -> JSM ()
eventPreventDefault :: JSVal -> JSM ()
eventPreventDefault JSVal
e = do
JSVal
_ <- 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
$ ()
() -> JSM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
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"
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"
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
$ ())
consoleLog :: MisoString -> JSM ()
consoleLog :: MisoString -> JSM ()
consoleLog MisoString
v = do
JSVal
_ <- 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]
() -> JSM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
consoleLogJSVal :: JSVal -> JSM ()
consoleLogJSVal :: JSVal -> JSM ()
consoleLogJSVal JSVal
v = do
JSVal
_ <- 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]
() -> JSM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
stringify :: ToJSON json => json -> JSM MisoString
{-# INLINE stringify #-}
stringify :: json -> JSM MisoString
stringify json
j = do
JSVal
v <- Value -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal (json -> Value
forall a. ToJSON a => a -> Value
toJSON json
j)
JSVal -> JSM MisoString
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked (JSVal -> JSM MisoString) -> JSM JSVal -> JSM MisoString
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
"stringify" ([JSVal] -> JSM JSVal) -> [JSVal] -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ [JSVal
v])
parse :: FromJSON json => JSVal -> JSM json
{-# INLINE parse #-}
parse :: JSVal -> JSM json
parse JSVal
jval = do
Value
val <- 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 Value -> Result json
forall a. FromJSON a => Value -> Result a
fromJSON Value
val of
Success json
x -> json -> JSM json
forall (f :: * -> *) a. Applicative f => a -> f a
pure json
x
Error String
y -> String -> JSM json
forall a. HasCallStack => String -> a
error String
y
clearBody :: JSM ()
clearBody :: JSM ()
clearBody =
(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" JSM JSVal -> String -> [String] -> JSM ()
forall this name val.
(MakeObject this, ToJSString name, ToJSVal val) =>
this -> name -> val -> JSM ()
<# String
"innerHtml") [String
""]
objectToJSON
:: JSVal
-> JSVal
-> JSM JSVal
objectToJSON :: JSVal -> JSVal -> JSM JSVal
objectToJSON = String -> JSVal -> JSVal -> JSM JSVal
forall name a0 a1.
(ToJSString name, ToJSVal a0, ToJSVal a1) =>
name -> a0 -> a1 -> JSM JSVal
jsg2 String
"objectToJSON"
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"
getDoc :: JSM JSVal
getDoc :: JSM JSVal
getDoc = String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"document"
getElementById :: MisoString -> JSM JSVal
getElementById :: MisoString -> JSM JSVal
getElementById MisoString
e = JSM JSVal
getDoc 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'
:: OI.Object
-> OI.Object
-> JSVal
-> JSVal
-> JSM ()
diff' :: Object -> Object -> JSVal -> JSVal -> JSM ()
diff' Object
a Object
b JSVal
c JSVal
d = () () -> JSM JSVal -> JSM ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Object -> Object -> JSVal -> JSVal -> JSM JSVal
forall name a0 a1 a2 a3.
(ToJSString name, ToJSVal a0, ToJSVal a1, ToJSVal a2,
ToJSVal a3) =>
name -> a0 -> a1 -> a2 -> a3 -> JSM JSVal
jsg4 String
"diff" Object
a Object
b JSVal
c JSVal
d
integralToJSString :: Integral a => a -> MisoString
integralToJSString :: 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
realFloatToJSString :: RealFloat a => a -> MisoString
realFloatToJSString :: 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)
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
delegateEvent :: JSVal -> JSVal -> JSM JSVal -> JSM ()
delegateEvent :: JSVal -> JSVal -> JSM JSVal -> JSM ()
delegateEvent JSVal
mountPoint JSVal
events JSM JSVal
getVTree = do
Function
cb' <- JSCallAsFunction -> JSM Function
function (JSCallAsFunction -> JSM Function)
-> JSCallAsFunction -> JSM Function
forall a b. (a -> b) -> a -> b
$ \JSVal
_ JSVal
_ [JSVal
continuation] -> do
JSVal
res <- JSM JSVal
getVTree
JSVal
_ <- JSVal -> Object -> JSVal -> JSM JSVal
forall f this args.
(MakeObject f, MakeObject this, MakeArgs args) =>
f -> this -> args -> JSM JSVal
call JSVal
continuation Object
global JSVal
res
() -> JSM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
JSVal -> JSVal -> Function -> JSM ()
delegateEvent' JSVal
mountPoint JSVal
events Function
cb'
delegateEvent' :: JSVal -> JSVal -> Function -> JSM ()
delegateEvent' :: JSVal -> JSVal -> Function -> JSM ()
delegateEvent' JSVal
mountPoint JSVal
events Function
cb = () () -> JSM JSVal -> JSM ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> JSVal -> JSVal -> Function -> JSM JSVal
forall name a0 a1 a2.
(ToJSString name, ToJSVal a0, ToJSVal a1, ToJSVal a2) =>
name -> a0 -> a1 -> a2 -> JSM JSVal
jsg3 String
"delegate" JSVal
mountPoint JSVal
events Function
cb
copyDOMIntoVTree :: Bool -> JSVal -> JSVal -> JSM ()
copyDOMIntoVTree :: Bool -> JSVal -> JSVal -> JSM ()
copyDOMIntoVTree Bool
logLevel JSVal
mountPoint JSVal
a = () () -> JSM JSVal -> JSM ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Bool -> JSVal -> JSVal -> JSM JSVal
forall name a0 a1 a2.
(ToJSString name, ToJSVal a0, ToJSVal a1, ToJSVal a2) =>
name -> a0 -> a1 -> a2 -> JSM JSVal
jsg3 String
"copyDOMIntoVTree" Bool
logLevel JSVal
mountPoint JSVal
a
swapCallbacks :: JSM ()
swapCallbacks :: JSM ()
swapCallbacks = () -> JSM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
releaseCallbacks :: JSM ()
releaseCallbacks :: JSM ()
releaseCallbacks = () -> JSM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
registerCallback :: JSVal -> JSM ()
registerCallback :: JSVal -> JSM ()
registerCallback JSVal
_ = () -> JSM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
focus :: MisoString -> JSM ()
focus :: MisoString -> JSM ()
focus MisoString
a = () () -> JSM JSVal -> JSM ()
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
"callFocus" MisoString
a
blur :: MisoString -> JSM ()
blur :: MisoString -> JSM ()
blur MisoString
a = () () -> JSM JSVal -> JSM ()
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
"callBlur" MisoString
a
scrollIntoView :: MisoString -> JSM ()
scrollIntoView :: MisoString -> JSM ()
scrollIntoView MisoString
elId = do
JSVal
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]
JSVal
_ <- JSVal
el JSVal -> String -> () -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"scrollIntoView" (() -> JSM JSVal) -> () -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ ()
() -> JSM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
alert :: MisoString -> JSM ()
alert :: MisoString -> JSM ()
alert MisoString
a = () () -> JSM JSVal -> JSM ()
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