#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)
#endif
module Language.Javascript.JSaddle.Object (
JSObjectRef
, MakeObjectRef(..)
, (!)
, (!!)
, js
, JSF(..)
, jsf
, js0
, js1
, js2
, js3
, js4
, js5
, jsg
, (<#)
, (#)
, new
, call
, obj
, function
, fun
, JSCallAsFunction(..)
, array
, global
, propertyNames
, objCallAsFunction
, objCallAsConstructor
) where
import Prelude hiding ((!!))
import Language.Javascript.JSaddle.Types
(JSPropertyNameArrayRef, JSStringRef, JSObjectRef, JSValueRefRef,
JSValueRef, JSContextRef, Index)
import Foreign.C.Types (CSize(..), CULong(..), CUInt(..), CULLong(..))
#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)
import GHCJS.Types (nullRef, castRef, JSArray, JSFun)
import GHCJS.Foreign (newObj, toArray, fromArray, syncCallback2, ForeignRetention(..))
import Control.Monad (liftM)
import Control.Applicative ((<$>))
#else
import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
(jsobjectmake, jspropertynamearraygetnameatindex,
jspropertynamearraygetcount, jsobjectcopypropertynames,
jsobjectsetpropertyatindex, jsobjectgetpropertyatindex,
jsobjectcallasconstructor, jsobjectmakearray,
jsobjectcallasfunction, jsobjectgetproperty, jsobjectsetproperty,
JSPropertyAttributes, JSObjectCallAsFunctionCallback,
jsobjectmakefunctionwithcallback, JSObjectCallAsFunctionCallback')
import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
(jsvaluemakeundefined)
import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSContextRef
(jscontextgetglobalobject)
import Foreign (peekArray, nullPtr, withArrayLen)
#endif
import Language.Javascript.JSaddle.Exception (rethrow)
import Language.Javascript.JSaddle.Value
(JSUndefined, valMakeUndefined, valToObject)
import Language.Javascript.JSaddle.PropRef (JSPropRef(..))
import Language.Javascript.JSaddle.Classes
(MakeValueRef(..), MakeStringRef(..), MakeArgRefs(..), MakePropRef(..),
MakeObjectRef(..))
import Language.Javascript.JSaddle.Monad
(JSM)
import Control.Monad.Trans.Reader (runReaderT, ask)
import Control.Monad.IO.Class (MonadIO(..))
import qualified Control.Exception as E (catch)
import Control.Exception (SomeException)
import qualified Data.Text as T (pack)
import Foreign.Storable (Storable(..))
import Language.Javascript.JSaddle.Properties
import Control.Lens
(IndexPreservingGetter, to, (^.))
import Language.Javascript.JSaddle.String (textToStr)
instance MakeObjectRef JSObjectRef where
makeObjectRef = return
instance MakeObjectRef v => MakeObjectRef (JSM v) where
makeObjectRef v = v >>= makeObjectRef
(!) :: (MakeObjectRef this, MakeStringRef name)
=> this
-> name
-> JSM JSPropRef
this ! name = do
rthis <- makeObjectRef this
return (JSPropRef rthis rname)
where
rname = makeStringRef name
(!!) :: (MakeObjectRef this)
=> this
-> Index
-> JSM JSPropRef
this !! index = do
rthis <- makeObjectRef this
return (JSPropIndexRef rthis index)
js :: (MakeObjectRef s, MakeStringRef name)
=> name
-> IndexPreservingGetter s (JSM JSPropRef)
js name = to (!name)
type JSF = MakeObjectRef o => IndexPreservingGetter o (JSM JSValueRef)
jsf :: (MakeStringRef name, MakeArgRefs args) => name -> args -> JSF
jsf name args = function . to (# args)
where
function = js name
js0 :: (MakeStringRef name) => name -> JSF
js0 name = jsf name ()
js1 :: (MakeStringRef name, MakeValueRef a0) => name -> a0 -> JSF
js1 name a0 = jsf name [a0]
js2 :: (MakeStringRef name, MakeValueRef a0, MakeValueRef a1) => name -> a0 -> a1 -> JSF
js2 name a0 a1 = jsf name (a0, a1)
js3 :: (MakeStringRef name, MakeValueRef a0, MakeValueRef a1, MakeValueRef a2)
=> name -> a0 -> a1 -> a2 -> JSF
js3 name a0 a1 a2 = jsf name (a0, a1, a2)
js4 :: (MakeStringRef name, MakeValueRef a0, MakeValueRef a1, MakeValueRef a2,
MakeValueRef a3)
=> name -> a0 -> a1 -> a2 -> a3 -> JSF
js4 name a0 a1 a2 a3 = jsf name (a0, a1, a2, a3)
js5 :: (MakeStringRef name, MakeValueRef a0, MakeValueRef a1, MakeValueRef a2,
MakeValueRef a3, MakeValueRef a4)
=> name -> a0 -> a1 -> a2 -> a3 -> a4 -> JSF
js5 name a0 a1 a2 a3 a4 = jsf name (a0, a1, a2, a3, a4)
jsg :: MakeStringRef a => a -> JSM JSPropRef
jsg name = global ! name
infixr 2 #
(#) :: (MakePropRef prop, MakeArgRefs args)
=> prop -> args -> JSM JSValueRef
prop # args = do
rprop <- makePropRef prop
(this, f) <- objGetProperty' rprop
rethrow $ objCallAsFunction f this args
infixr 0 <#
(<#) :: (MakePropRef prop, MakeValueRef val)
=> prop
-> val
-> JSM JSPropRef
prop <# val = do
p <- makePropRef prop
objSetProperty p val
return p
new :: (MakeObjectRef constructor, MakeArgRefs args)
=> constructor
-> args
-> JSM JSValueRef
new constructor args = do
f <- makeObjectRef constructor
rethrow $ objCallAsConstructor f args
call :: (MakeObjectRef function, MakeObjectRef this, MakeArgRefs args)
=> function -> this -> args -> JSM JSValueRef
call function this args = do
rfunction <- makeObjectRef function
rthis <- makeObjectRef this
rethrow $ objCallAsFunction rfunction rthis args
obj :: JSM JSObjectRef
#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)
obj = liftIO $ newObj
#else
obj = do
gctxt <- ask
liftIO $ jsobjectmake gctxt nullPtr nullPtr
#endif
type JSCallAsFunction = JSValueRef
-> JSValueRef
-> [JSValueRef]
-> JSM JSUndefined
fun :: JSCallAsFunction -> JSCallAsFunction
fun = id
#if (!defined(ghcjs_HOST_OS) || !defined(USE_JAVASCRIPTFFI)) && defined(USE_WEBKIT)
foreign import ccall "wrapper"
mkJSObjectCallAsFunctionCallback :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback
#endif
function :: MakeStringRef name
=> name
-> JSCallAsFunction
-> JSM JSObjectRef
#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)
function name f = liftIO $ do
callback <- syncCallback2 AlwaysRetain True $ \this args -> do
rargs <- fromArray args
runReaderT (f this this rargs) ()
makeFunctionWithCallback (makeStringRef name) callback
foreign import javascript unsafe "$r = function () { $2(this, arguments); }"
makeFunctionWithCallback :: JSStringRef -> JSFun (JSValueRef -> JSValueRefRef -> IO ()) -> IO JSObjectRef
#elif defined(USE_WEBKIT)
function name f = do
gctxt <- ask
callback <- liftIO $ mkJSObjectCallAsFunctionCallback wrap
liftIO $ jsobjectmakefunctionwithcallback gctxt (makeStringRef name) callback
where
wrap ctx fobj this argc argv exception = do
args <- peekArray (fromIntegral argc) argv
(`runReaderT` ctx) $
f fobj this args >>= makeValueRef
`E.catch` \(e :: SomeException) -> do
str <- runReaderT (makeValueRef . T.pack $ show e) ctx
poke exception str
jsvaluemakeundefined ctx
#else
function = undefined
#endif
instance MakeValueRef JSCallAsFunction where
#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)
makeValueRef = function (nullRef:: JSStringRef)
#else
makeValueRef = function (nullPtr:: JSStringRef)
#endif
instance MakeArgRefs JSCallAsFunction where
makeArgRefs f = do
#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)
rarg <- function (nullRef:: JSStringRef) f
#else
rarg <- function (nullPtr:: JSStringRef) f
#endif
return [rarg]
makeArray :: MakeArgRefs args => args -> JSValueRefRef -> JSM JSObjectRef
#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)
makeArray args exceptions = makeArgRefs args >>= liftM castRef . liftIO . toArray
#else
makeArray args exceptions = do
gctxt <- ask
rargs <- makeArgRefs args
liftIO $ withArrayLen rargs $ \ len ptr ->
jsobjectmakearray gctxt (fromIntegral len) ptr exceptions
#endif
array :: MakeArgRefs args => args -> JSM JSObjectRef
array = rethrow . makeArray
global :: JSM JSObjectRef
#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)
global = liftIO js_window
foreign import javascript unsafe "$r = window"
js_window :: IO JSObjectRef
#elif defined(USE_WEBKIT)
global = ask >>= (liftIO . jscontextgetglobalobject)
#else
global = undefined
#endif
#if (!defined(ghcjs_HOST_OS) || !defined(USE_JAVASCRIPTFFI)) && defined(USE_WEBKIT)
copyPropertyNames :: MakeObjectRef this => this -> JSM JSPropertyNameArrayRef
copyPropertyNames this = do
gctxt <- ask
rthis <- makeObjectRef this
liftIO $ jsobjectcopypropertynames gctxt rthis
propertyNamesCount :: MonadIO m => JSPropertyNameArrayRef -> m CSize
propertyNamesCount names = liftIO $ jspropertynamearraygetcount names
propertyNamesAt :: MonadIO m => JSPropertyNameArrayRef -> CSize -> m JSStringRef
propertyNamesAt names index = liftIO $ jspropertynamearraygetnameatindex names index
propertyNamesList :: MonadIO m => JSPropertyNameArrayRef -> m [JSStringRef]
propertyNamesList names = do
count <- propertyNamesCount names
mapM (propertyNamesAt names) $ enumFromTo 0 (count 1)
#endif
propertyNames :: MakeObjectRef this => this -> JSM [JSStringRef]
#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)
propertyNames this = makeObjectRef this >>= liftIO . js_propertyNames >>= liftIO . fromArray
foreign import javascript unsafe "$r = []; h$forIn($1, function(n){$r.push(n);})"
js_propertyNames :: JSObjectRef -> IO (JSArray a)
#elif defined(USE_WEBKIT)
propertyNames this = copyPropertyNames this >>= propertyNamesList
#else
propertyNames = undefined
#endif
properties :: MakeObjectRef this => this -> JSM [JSPropRef]
properties this = propertyNames this >>= mapM (this !)
objCallAsFunction :: MakeArgRefs args
=> JSObjectRef
-> JSObjectRef
-> args
-> JSValueRefRef
-> JSM JSValueRef
#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)
objCallAsFunction function this args exceptions = do
rargs <- makeArgRefs args >>= liftIO . toArray
liftIO $ js_apply function this rargs exceptions
foreign import javascript unsafe "try { $r = $1.apply($2, $3) } catch(e) { $4[0] = e }"
js_apply :: JSObjectRef -> JSObjectRef -> JSValueRefRef -> JSValueRefRef -> IO JSValueRef
#elif defined(USE_WEBKIT)
objCallAsFunction function this args exceptions = do
gctxt <- ask
rargs <- makeArgRefs args
liftIO $ withArrayLen rargs $ \ largs pargs ->
jsobjectcallasfunction gctxt function this (fromIntegral largs) pargs exceptions
#else
objCallAsFunction = undefined
#endif
objCallAsConstructor :: MakeArgRefs args
=> JSObjectRef
-> args
-> JSValueRefRef
-> JSM JSValueRef
#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)
objCallAsConstructor function args exceptions = do
rargs <- makeArgRefs args >>= liftIO . toArray
liftIO $ js_new function rargs exceptions
foreign import javascript unsafe "\
try {\
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 ret;\
var temp = function() {\
ret = $1.apply(this, $2);\
};\
temp.prototype = $1.prototype;\
var i = new temp();\
if(ret instanceof Object)\
return ret;\
i.constructor = $1;\
return i;\
}\
}\
catch(e) {\
$3[0] = e;\
}"
js_new :: JSObjectRef -> JSValueRefRef -> JSValueRefRef -> IO JSValueRef
#elif defined(USE_WEBKIT)
objCallAsConstructor function args exceptions = do
gctxt <- ask
rargs <- makeArgRefs args
liftIO $ withArrayLen rargs $ \ largs pargs ->
jsobjectcallasconstructor gctxt function (fromIntegral largs) pargs exceptions
#else
objCallAsConstructor = undefined
#endif