#ifdef ghcjs_HOST_OS
#endif
module Language.Javascript.JSaddle.Object (
Object
, MakeObject(..)
, (!)
, (!!)
, js
, jss
, JSF
, jsf
, js0
, js1
, js2
, js3
, js4
, js5
, jsg
, jsgf
, jsg0
, jsg1
, jsg2
, jsg3
, jsg4
, jsg5
, (<#)
, (<##)
, (#)
, (##)
, new
, call
, obj
, Function(..)
, function
, freeFunction
, fun
, JSCallAsFunction
, array
, global
, propertyNames
, properties
, objCallAsFunction
, objCallAsConstructor
, nullObject
) where
import Control.Applicative
import Prelude hiding ((!!))
#ifdef ghcjs_HOST_OS
import GHCJS.Types (nullRef, jsval)
import GHCJS.Foreign.Callback
(releaseCallback, syncCallback2, OnBlocked(..), Callback)
import GHCJS.Marshal.Pure (pFromJSVal)
import JavaScript.Array (JSArray, MutableJSArray)
import qualified JavaScript.Array as Array (toListIO, fromListIO)
import JavaScript.Array.Internal (SomeJSArray(..))
import qualified JavaScript.Object as Object (create)
import Data.Coerce (coerce)
import Language.Javascript.JSaddle.Monad (JSM)
import Language.Javascript.JSaddle.Types
(JSString, Object(..),
JSVal(..), JSCallAsFunction)
#else
import Language.Javascript.JSaddle.Native
(wrapJSString, withJSVals, withObject)
import Language.Javascript.JSaddle.Run
(Command(..), AsyncCommand(..), Result(..), sendCommand, sendLazyCommand)
import Language.Javascript.JSaddle.Monad (askJSM, JSM)
import Language.Javascript.JSaddle.Types
(JSString, Object(..),
JSVal(..), JSCallAsFunction, JSContextRef(..))
#endif
import Language.Javascript.JSaddle.Value (valToObject)
import Language.Javascript.JSaddle.Classes
(ToJSVal(..), ToJSString(..), MakeObject(..))
import Language.Javascript.JSaddle.Arguments (MakeArgs(..))
import Control.Monad.IO.Class (MonadIO(..))
import Language.Javascript.JSaddle.Properties
import Control.Lens (IndexPreservingGetter, to)
import Data.Text (Text)
instance MakeObject v => MakeObject (JSM v) where
makeObject v = v >>= makeObject
(!) :: (MakeObject this, ToJSString name)
=> this
-> name
-> JSM JSVal
this ! name = do
rthis <- makeObject this
objGetPropertyByName rthis name
(!!) :: (MakeObject this)
=> this
-> Int
-> JSM JSVal
this !! index = do
rthis <- makeObject this
objGetPropertyAtIndex rthis index
js :: (MakeObject s, ToJSString name)
=> name
-> IndexPreservingGetter s (JSM JSVal)
js name = to (!name)
jss :: (ToJSString name, ToJSVal val)
=> name
-> val
-> forall o . MakeObject o => IndexPreservingGetter o (JSM ())
jss name val = to (\o -> o <# name $ val)
jsf :: (ToJSString name, MakeArgs args) => name -> args -> JSF
jsf name args = to (\o -> o # name $ args)
type JSF = forall o . MakeObject o => IndexPreservingGetter o (JSM JSVal)
js0 :: (ToJSString name) => name -> JSF
js0 name = jsf name ()
js1 :: (ToJSString name, ToJSVal a0) => name -> a0 -> JSF
js1 name a0 = jsf name [a0]
js2 :: (ToJSString name, ToJSVal a0, ToJSVal a1) => name -> a0 -> a1 -> JSF
js2 name a0 a1 = jsf name (a0, a1)
js3 :: (ToJSString name, ToJSVal a0, ToJSVal a1, ToJSVal a2)
=> name -> a0 -> a1 -> a2 -> JSF
js3 name a0 a1 a2 = jsf name (a0, a1, a2)
js4 :: (ToJSString name, ToJSVal a0, ToJSVal a1, ToJSVal a2,
ToJSVal a3)
=> name -> a0 -> a1 -> a2 -> a3 -> JSF
js4 name a0 a1 a2 a3 = jsf name (a0, a1, a2, a3)
js5 :: (ToJSString name, ToJSVal a0, ToJSVal a1, ToJSVal a2,
ToJSVal a3, ToJSVal a4)
=> name -> a0 -> a1 -> a2 -> a3 -> a4 -> JSF
js5 name a0 a1 a2 a3 a4 = jsf name (a0, a1, a2, a3, a4)
jsg :: ToJSString a => a -> JSM JSVal
jsg name = global ! name
jsgf :: (ToJSString name, MakeArgs args) => name -> args -> JSM JSVal
jsgf name = global # name
jsg0 :: (ToJSString name) => name -> JSM JSVal
jsg0 name = jsgf name ()
jsg1 :: (ToJSString name, ToJSVal a0) => name -> a0 -> JSM JSVal
jsg1 name a0 = jsgf name [a0]
jsg2 :: (ToJSString name, ToJSVal a0, ToJSVal a1) => name -> a0 -> a1 -> JSM JSVal
jsg2 name a0 a1 = jsgf name (a0, a1)
jsg3 :: (ToJSString name, ToJSVal a0, ToJSVal a1, ToJSVal a2)
=> name -> a0 -> a1 -> a2 -> JSM JSVal
jsg3 name a0 a1 a2 = jsgf name (a0, a1, a2)
jsg4 :: (ToJSString name, ToJSVal a0, ToJSVal a1, ToJSVal a2,
ToJSVal a3)
=> name -> a0 -> a1 -> a2 -> a3 -> JSM JSVal
jsg4 name a0 a1 a2 a3 = jsgf name (a0, a1, a2, a3)
jsg5 :: (ToJSString name, ToJSVal a0, ToJSVal a1, ToJSVal a2,
ToJSVal a3, ToJSVal a4)
=> name -> a0 -> a1 -> a2 -> a3 -> a4 -> JSM JSVal
jsg5 name a0 a1 a2 a3 a4 = jsgf name (a0, a1, a2, a3, a4)
infixr 2 #
(#) :: (MakeObject this, ToJSString name, MakeArgs args)
=> this -> name -> args -> JSM JSVal
(#) this name args = do
rthis <- makeObject this
f <- objGetPropertyByName rthis name
f' <- valToObject f
objCallAsFunction f' rthis args
infixr 2 ##
(##) :: (MakeObject this, MakeArgs args)
=> this -> Int -> args -> JSM JSVal
(##) this index args = do
rthis <- makeObject this
f <- objGetPropertyAtIndex rthis index
f' <- valToObject f
objCallAsFunction f' rthis args
infixr 1 <#
(<#) :: (MakeObject this, ToJSString name, ToJSVal val)
=> this
-> name
-> val
-> JSM ()
(<#) this name val = do
rthis <- makeObject this
objSetPropertyByName rthis name val
infixr 1 <##
(<##) :: (MakeObject this, ToJSVal val)
=> this
-> Int
-> val
-> JSM ()
(<##) this index val = do
rthis <- makeObject this
objSetPropertyAtIndex rthis index val
new :: (MakeObject constructor, MakeArgs args)
=> constructor
-> args
-> JSM JSVal
new constructor args = do
f <- makeObject constructor
objCallAsConstructor f args
call :: (MakeObject f, MakeObject this, MakeArgs args)
=> f -> this -> args -> JSM JSVal
call f this args = do
rfunction <- makeObject f
rthis <- makeObject this
objCallAsFunction rfunction rthis args
obj :: JSM Object
#ifdef ghcjs_HOST_OS
obj = liftIO Object.create
#else
obj = Object <$> sendLazyCommand NewEmptyObject
#endif
fun :: JSCallAsFunction -> JSCallAsFunction
fun = id
#ifdef ghcjs_HOST_OS
data Function = Function {functionCallback :: Callback (JSVal -> JSVal -> IO ()), functionObject :: Object}
#else
newtype Function = Function {functionObject :: Object}
#endif
function :: JSCallAsFunction
-> JSM Function
#ifdef ghcjs_HOST_OS
function f = do
callback <- syncCallback2 ContinueAsync $ \this args -> do
rargs <- Array.toListIO (coerce args)
f this this rargs
Function callback <$> makeFunctionWithCallback callback
foreign import javascript unsafe "$r = function () { $1(this, arguments); }"
makeFunctionWithCallback :: Callback (JSVal -> JSVal -> IO ()) -> IO Object
#else
function f = do
object <- Object <$> sendLazyCommand NewCallback
add <- addCallback <$> askJSM
liftIO $ add object f
return $ Function object
#endif
freeFunction :: Function -> JSM ()
#ifdef ghcjs_HOST_OS
freeFunction (Function callback _) = liftIO $
releaseCallback callback
#else
freeFunction (Function object) = do
free <- freeCallback <$> askJSM
liftIO $ free object
#endif
instance ToJSVal Function where
toJSVal = toJSVal . functionObject
instance ToJSVal JSCallAsFunction where
toJSVal f = functionObject <$> function f >>= toJSVal
instance MakeArgs JSCallAsFunction where
makeArgs f = do
rarg <- functionObject <$> function f >>= toJSVal
return [rarg]
array :: MakeArgs args => args -> JSM Object
#ifdef ghcjs_HOST_OS
array args = do
rargs <- makeArgs args
liftIO $ Object . jsval <$> Array.fromListIO rargs
#else
array args = do
rargs <- makeArgs args
withJSVals rargs $ \rargs' -> Object <$> sendLazyCommand (NewArray rargs')
#endif
instance ToJSVal [JSVal] where
toJSVal = toJSVal . array
instance ToJSVal [JSM JSVal] where
toJSVal = toJSVal . array
instance ToJSVal [Double] where
toJSVal = toJSVal . array
instance ToJSVal [Float] where
toJSVal = toJSVal . array
instance ToJSVal [Int] where
toJSVal = toJSVal . array
instance ToJSVal [JSString] where
toJSVal = toJSVal . array
instance ToJSVal [String] where
toJSVal = toJSVal . array
instance ToJSVal [Text] where
toJSVal = toJSVal . array
instance ToJSVal [Bool] where
toJSVal = toJSVal . array
global :: Object
#ifdef ghcjs_HOST_OS
global = js_window
foreign import javascript unsafe "$r = window"
js_window :: Object
#else
global = Object (JSVal 4)
#endif
propertyNames :: MakeObject this => this -> JSM [JSString]
#ifdef ghcjs_HOST_OS
propertyNames this = makeObject this >>= liftIO . js_propertyNames >>= liftIO . (fmap (map pFromJSVal)) . Array.toListIO
foreign import javascript unsafe "$r = []; h$forIn($1, function(n){$r.push(n);})"
js_propertyNames :: Object -> IO JSArray
#else
propertyNames this = do
this' <- makeObject this
withObject this' $ \rthis -> do
PropertyNamesResult result <- sendCommand $ PropertyNames rthis
mapM wrapJSString result
#endif
properties :: MakeObject this => this -> JSM [JSVal]
properties this = propertyNames this >>= mapM (this !)
objCallAsFunction :: MakeArgs args
=> Object
-> Object
-> args
-> JSM JSVal
#ifdef ghcjs_HOST_OS
objCallAsFunction f this args = do
rargs <- makeArgs args >>= liftIO . Array.fromListIO
liftIO $ js_apply f this rargs
foreign import javascript unsafe "$r = $1.apply($2, $3)"
js_apply :: Object -> Object -> MutableJSArray -> IO JSVal
#else
objCallAsFunction f this args = do
rargs <- makeArgs args
withObject f $ \rfunction ->
withObject this $ \rthis ->
withJSVals rargs $ sendLazyCommand . CallAsFunction rfunction rthis
#endif
objCallAsConstructor :: MakeArgs args
=> Object
-> args
-> JSM JSVal
#ifdef ghcjs_HOST_OS
objCallAsConstructor f args = do
rargs <- makeArgs args >>= liftIO . Array.fromListIO
liftIO $ js_new f rargs
foreign import javascript unsafe "\
switch($2.length) {\
case 0 : $r = new $1(); break;\
case 1 : $r = new $1($2[0]); break;\
case 2 : $r = new $1($2[0],$2[1]); break;\
case 3 : $r = new $1($2[0],$2[1],$2[2]); break;\
case 4 : $r = new $1($2[0],$2[1],$2[2],$2[3]); break;\
case 5 : $r = new $1($2[0],$2[1],$2[2],$2[3],$2[4]); break;\
case 6 : $r = new $1($2[0],$2[1],$2[2],$2[3],$2[4],$2[5]); break;\
case 7 : $r = new $1($2[0],$2[1],$2[2],$2[3],$2[4],$2[5],$2[6]); break;\
default:\
var temp = function() {\
ret = $1.apply(this, $2);\
};\
temp.prototype = $1.prototype;\
var i = new temp();\
if(ret instanceof Object) {\
$r = ret;\
} else {\
i.constructor = $1;\
$r = i;\
}\
}"
js_new :: Object -> MutableJSArray -> IO JSVal
#else
objCallAsConstructor f args = do
rargs <- makeArgs args
withObject f $ \rfunction ->
withJSVals rargs $ sendLazyCommand . CallAsConstructor rfunction
#endif
-- >>> testJSaddle $ strictEqual nullObject (eval "null")
nullObject :: Object
#ifdef ghcjs_HOST_OS
nullObject = Object nullRef
#else
nullObject = Object (JSVal 0)
#endif