#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 ((!!))
import Language.Javascript.JSaddle.Types
(JSPropertyNameArray, JSString, Object(..), MutableJSArray,
JSVal, Index)
import Foreign.C.Types (CSize(..), CULong(..), CUInt(..), CULLong(..))
#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)
import qualified JavaScript.Array as Array (toListIO, fromListIO)
import JavaScript.Array.Internal (SomeJSArray(..))
import qualified JavaScript.Object as Object (create)
import Control.Monad (liftM)
import Data.Coerce (coerce)
#else
import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
(jsobjectmake, jspropertynamearraygetnameatindex,
jspropertynamearraygetcount, jsobjectcopypropertynames,
jsobjectcallasconstructor, jsobjectmakearray,
jsobjectcallasfunction,
JSObjectCallAsFunctionCallback, mkJSObjectCallAsFunctionCallback,
jsobjectmakefunctionwithcallback)
import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
(jsvaluemakeundefined)
import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSContextRef
(jscontextgetglobalobject)
import Foreign (peekArray, nullPtr, withArrayLen)
import Foreign.Ptr (freeHaskellFunPtr)
import Language.Javascript.JSaddle.Native
(makeNewJSString, makeNewJSVal, wrapJSString, withJSVals,
withObject, withJSString, withToJSVal)
import System.IO.Unsafe (unsafePerformIO)
import Foreign.ForeignPtr (newForeignPtr_)
#endif
import Language.Javascript.JSaddle.Exception (rethrow)
import Language.Javascript.JSaddle.Value
(JSUndefined, valToObject)
import Language.Javascript.JSaddle.Classes
(ToJSVal(..), ToJSString(..), MakeObject(..))
import Language.Javascript.JSaddle.Arguments (MakeArgs(..))
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 Foreign.Storable (Storable(..))
import Language.Javascript.JSaddle.Properties
import Control.Lens (IndexPreservingGetter, to)
import Language.Javascript.JSaddle.String (nullJSString)
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
rethrow $ objGetPropertyByName rthis rname
where
rname = toJSString name
(!!) :: (MakeObject this)
=> this
-> Index
-> JSM JSVal
this !! index = do
rthis <- makeObject this
rethrow $ 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 <- rethrow $ objGetPropertyByName rthis name
f' <- valToObject f
rethrow $ objCallAsFunction f' rthis args
infixr 2 ##
(##) :: (MakeObject this, MakeArgs args)
=> this -> Index -> args -> JSM JSVal
(##) this index args = do
rthis <- makeObject this
f <- rethrow $ objGetPropertyAtIndex rthis index
f' <- valToObject f
rethrow $ objCallAsFunction f' rthis args
infixr 1 <#
(<#) :: (MakeObject this, ToJSString name, ToJSVal val)
=> this
-> name
-> val
-> JSM ()
(<#) this name val = do
rthis <- makeObject this
rethrow $ objSetPropertyByName rthis name val 0
infixr 1 <##
(<##) :: (MakeObject this, ToJSVal val)
=> this
-> Index
-> val
-> JSM ()
(<##) this index val = do
rthis <- makeObject this
rethrow $ objSetPropertyAtIndex rthis index val
new :: (MakeObject constructor, MakeArgs args)
=> constructor
-> args
-> JSM JSVal
new constructor args = do
f <- makeObject constructor
rethrow $ 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
rethrow $ objCallAsFunction rfunction rthis args
obj :: JSM Object
#ifdef ghcjs_HOST_OS
obj = liftIO Object.create
#else
obj = do
gctxt <- ask
Object <$> (liftIO (jsobjectmake gctxt nullPtr nullPtr) >>= makeNewJSVal)
#endif
type JSCallAsFunction = JSVal
-> JSVal
-> [JSVal]
-> JSM JSUndefined
fun :: JSCallAsFunction -> JSCallAsFunction
fun = id
#ifdef ghcjs_HOST_OS
type HaskellCallback = Callback (JSVal -> JSVal -> IO ())
#else
type HaskellCallback = JSObjectCallAsFunctionCallback
#endif
data Function = Function {functionCallback :: HaskellCallback, functionObject :: Object}
function :: ToJSString name
=> name
-> JSCallAsFunction
-> JSM Function
#ifdef ghcjs_HOST_OS
function name f = liftIO $ do
callback <- syncCallback2 ContinueAsync $ \this args -> do
rargs <- Array.toListIO (coerce args)
runReaderT (f this this rargs) ()
Function callback <$> makeFunctionWithCallback (toJSString name) callback
foreign import javascript unsafe "$r = function () { $2(this, arguments); }"
makeFunctionWithCallback :: JSString -> Callback (JSVal -> JSVal -> IO ()) -> IO Object
#else
function name f = do
gctxt <- ask
callback <- liftIO $ mkJSObjectCallAsFunctionCallback (wrap gctxt)
withJSString (toJSString name) $ \name' ->
Function callback . Object <$>
(liftIO (jsobjectmakefunctionwithcallback gctxt name' callback) >>= makeNewJSVal)
where
wrap gctxt _ctx fobj' this' argc argv exception = do
args' <- peekArray (fromIntegral argc) argv
(`runReaderT` gctxt) $ do
fobj <- makeNewJSVal fobj'
this <- makeNewJSVal this'
args <- mapM makeNewJSVal args'
f fobj this args
liftIO $ jsvaluemakeundefined gctxt
`E.catch` \(e :: SomeException) ->
(`runReaderT` gctxt) $ do
withToJSVal (show e) $ liftIO . poke exception
liftIO $ jsvaluemakeundefined gctxt
#endif
freeFunction :: MonadIO m => Function -> m ()
freeFunction (Function callback _) = liftIO $
#ifdef ghcjs_HOST_OS
releaseCallback callback
#else
freeHaskellFunPtr callback
#endif
instance ToJSVal Function where
toJSVal (Function _ f) = toJSVal f
instance ToJSVal JSCallAsFunction where
toJSVal f = functionObject <$> function nullJSString f >>= toJSVal
instance MakeArgs JSCallAsFunction where
makeArgs f = do
rarg <- functionObject <$> function nullJSString f >>= toJSVal
return [rarg]
makeArray :: MakeArgs args => args -> MutableJSArray -> JSM Object
#ifdef ghcjs_HOST_OS
makeArray args exceptions = do
rargs <- makeArgs args
liftIO $ Object . jsval <$> Array.fromListIO rargs
#else
makeArray args exceptions = do
gctxt <- ask
rargs <- makeArgs args
result <-
withJSVals rargs $ \rargs' ->
liftIO $ withArrayLen rargs' $ \ len ptr ->
jsobjectmakearray gctxt (fromIntegral len) ptr exceptions
Object <$> makeNewJSVal result
#endif
array :: MakeArgs args => args -> JSM Object
array = rethrow . makeArray
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 :: JSM Object
#ifdef ghcjs_HOST_OS
global = liftIO js_window
foreign import javascript unsafe "$r = window"
js_window :: IO Object
#else
global = do
gctxt <- ask
result <- liftIO $ jscontextgetglobalobject gctxt
Object <$> makeNewJSVal result
#endif
#if !defined(ghcjs_HOST_OS)
copyPropertyNames :: MakeObject this => this -> JSM JSPropertyNameArray
copyPropertyNames this = do
gctxt <- ask
this' <- makeObject this
withObject this' $ \rthis ->
liftIO $ jsobjectcopypropertynames gctxt rthis
propertyNamesCount :: MonadIO m => JSPropertyNameArray -> m CSize
propertyNamesCount names = liftIO $ jspropertynamearraygetcount names
propertyNamesAt :: MonadIO m => JSPropertyNameArray -> CSize -> m JSString
propertyNamesAt names index = liftIO $ jspropertynamearraygetnameatindex names index >>= makeNewJSString
propertyNamesList :: MonadIO m => JSPropertyNameArray -> m [JSString]
propertyNamesList names = do
count <- propertyNamesCount names
mapM (propertyNamesAt names) $ enumFromTo 0 (count 1)
#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 = copyPropertyNames this >>= propertyNamesList
#endif
properties :: MakeObject this => this -> JSM [JSVal]
properties this = propertyNames this >>= mapM (this !)
objCallAsFunction :: MakeArgs args
=> Object
-> Object
-> args
-> MutableJSArray
-> JSM JSVal
#ifdef ghcjs_HOST_OS
objCallAsFunction f this args exceptions = do
rargs <- makeArgs args >>= liftIO . Array.fromListIO
liftIO $ js_apply f this rargs exceptions
foreign import javascript unsafe "try { $r = $1.apply($2, $3) } catch(e) { $4[0] = e }"
js_apply :: Object -> Object -> MutableJSArray -> MutableJSArray -> IO JSVal
#else
objCallAsFunction f this args exceptions = do
gctxt <- ask
rargs <- makeArgs args
result <-
withObject f $ \rfunction ->
withObject this $ \rthis ->
withJSVals rargs $ \rargs' ->
liftIO $ withArrayLen rargs' $ \ largs pargs ->
jsobjectcallasfunction gctxt rfunction rthis (fromIntegral largs) pargs exceptions
makeNewJSVal result
#endif
objCallAsConstructor :: MakeArgs args
=> Object
-> args
-> MutableJSArray
-> JSM JSVal
#ifdef ghcjs_HOST_OS
objCallAsConstructor f args exceptions = do
rargs <- makeArgs args >>= liftIO . Array.fromListIO
liftIO $ js_new f 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 :: Object -> MutableJSArray -> MutableJSArray -> IO JSVal
#else
objCallAsConstructor f args exceptions = do
gctxt <- ask
rargs <- makeArgs args
result <-
withObject f $ \rfunction ->
withJSVals rargs $ \rargs' ->
liftIO $ withArrayLen rargs' $ \ largs pargs ->
jsobjectcallasconstructor gctxt rfunction (fromIntegral largs) pargs exceptions
makeNewJSVal result
#endif
nullObject :: Object
#ifdef ghcjs_HOST_OS
nullObject = Object nullRef
#else
nullObject = Object . unsafePerformIO $ newForeignPtr_ nullPtr
#endif