diff --git a/jsaddle.cabal b/jsaddle.cabal --- a/jsaddle.cabal +++ b/jsaddle.cabal @@ -1,85 +1,95 @@ name: jsaddle -version: 0.2.1.0 +version: 0.3.0.0 cabal-version: >=1.10 +build-type: Simple license: MIT license-file: LICENSE maintainer: Hamish Mackenzie synopsis: High level interface for webkit-javascriptcore -description: This package provides an EDSL for calling JavaScript code using - the JavaScriptCore engine and low level Haskell bindings - in the webkit-javascriptcore library . -author: Hamish Mackenzie -data-dir: "" +description: + This package provides an EDSL for calling JavaScript code using + the JavaScriptCore engine and low level Haskell bindings + in the webkit-javascriptcore library . category: Web, Javascript -build-type: Simple +author: Hamish Mackenzie -Source-Repository head - type: git - location: https://github.com/ghcjs/jsaddle +source-repository head + type: git + location: https://github.com/ghcjs/jsaddle flag gtk3 - Description: Use GTK3 rather than GTK2 - Default: True - -flag jsffi - description: Use JavaScriptFFI extension for GHCJS JavaScript output - default: True - -flag webkit - description: Use WebKitGtk and JavaScriptCore for GHCJS output - default: False + description: + Use GTK3 rather than GTK2 library - if impl(ghcjs) && flag(jsffi) - cpp-options: -DUSE_JAVASCRIPTFFI - build-depends: ghcjs-base - if !impl(ghcjs) || flag(webkit) - cpp-options: -DUSE_WEBKIT + if impl(ghcjs -any) + build-depends: + ghcjs-base -any, + ghcjs-prim -any + else if flag(gtk3) - build-depends: webkitgtk3 >=0.13.0.0 && <0.15, - webkitgtk3-javascriptcore >=0.13.0.0 && <0.14 + build-depends: + gtk3 >=0.14.2 && <0.15, + webkitgtk3 >=0.13.0.0 && <0.15, + webkitgtk3-javascriptcore >=0.13.0.0 && <0.14 else - build-depends: webkit >=0.13.0.0 && <0.15, - webkit-javascriptcore >=0.13.0.0 && <0.14 - - build-depends: template-haskell -any, base <5, lens >=3.8.5 && <4.13, - text >=0.11.2.3 && <1.3, transformers >=0.3.0.0 && <0.5 - - exposed-modules: Language.Javascript.JSaddle - Language.Javascript.JSaddle.Arguments Language.Javascript.JSaddle.Classes - Language.Javascript.JSaddle.Evaluate Language.Javascript.JSaddle.Exception - Language.Javascript.JSaddle.Monad - Language.Javascript.JSaddle.Object Language.Javascript.JSaddle.Properties - Language.Javascript.JSaddle.String Language.Javascript.JSaddle.Value - Language.Javascript.JSaddle.Types - exposed: True - buildable: True + build-depends: + gtk >=0.14.2 && <0.15, + webkit >=0.13.0.0 && <0.15, + webkit-javascriptcore >=0.13.0.0 && <0.14 + build-depends: + glib -any + exposed-modules: + Language.Javascript.JSaddle + Language.Javascript.JSaddle.Arguments + Language.Javascript.JSaddle.Classes + Language.Javascript.JSaddle.Evaluate + Language.Javascript.JSaddle.Exception + Language.Javascript.JSaddle.Monad + Language.Javascript.JSaddle.Native + Language.Javascript.JSaddle.Object + Language.Javascript.JSaddle.Properties + Language.Javascript.JSaddle.String + Language.Javascript.JSaddle.Value + Language.Javascript.JSaddle.Types + Language.Javascript.JSaddle.Test + build-depends: + template-haskell -any, + base <5, + lens >=3.8.5 && <4.14, + text >=0.11.2.3 && <1.3, + transformers >=0.3.0.0 && <0.5 default-language: Haskell2010 hs-source-dirs: src - other-modules: Language.Javascript.JSaddle.PropRef + ghc-options: -ferror-spans test-suite test-tool - if flag(jsffi) + + if impl(ghcjs -any) buildable: False else - buildable: True - - if impl(ghcjs) && flag(jsffi) - cpp-options: -DUSE_JAVASCRIPTFFI - build-depends: ghcjs-base - - if !impl(ghcjs) || flag(webkit) - cpp-options: -DUSE_WEBKIT - build-depends: glib if flag(gtk3) - build-depends: gtk3, webkitgtk3, webkitgtk3-javascriptcore + build-depends: + gtk3 -any, + webkitgtk3 -any, + webkitgtk3-javascriptcore -any else - build-depends: gtk, webkit, webkit-javascriptcore - - build-depends: template-haskell, base, lens, text, - transformers, hslogger, jsaddle + build-depends: + gtk -any, + webkit -any, + webkit-javascriptcore -any + build-depends: + glib -any type: exitcode-stdio-1.0 - main-is: TestJSaddle.hs + main-is: DocTest.hs + build-depends: + QuickCheck -any, + base -any, + doctest -any, + vector >=0.11.0.0 && <0.12, + text >=0.11.2.3 && <1.3, + jsaddle -any default-language: Haskell2010 hs-source-dirs: tests + ghc-options: -ferror-spans diff --git a/src/Language/Javascript/JSaddle.hs b/src/Language/Javascript/JSaddle.hs --- a/src/Language/Javascript/JSaddle.hs +++ b/src/Language/Javascript/JSaddle.hs @@ -18,11 +18,11 @@ -- with JavaScript the EDSL has -- -- * /Weakish typing/ - type classes are used to convert to JSValueRef - -- and JSObjectRef types + -- and Object types -- -- * /Strict evaluation/ - function in the 'JSM' monad can be passed in -- place of a value and will evaluated and converted to JSValueRef or - -- JSObjectRef and then passed on to JavaScript + -- Object and then passed on to JavaScript -- -- JSaddle should be used to write wrappers for JavaScript libraries that provide -- more type safety. @@ -52,6 +52,8 @@ module JSaddle ) where +import Language.Javascript.JSaddle.Types as JSaddle +import Language.Javascript.JSaddle.Classes as JSaddle import Language.Javascript.JSaddle.Monad as JSaddle import Language.Javascript.JSaddle.Exception as JSaddle import Language.Javascript.JSaddle.Value as JSaddle diff --git a/src/Language/Javascript/JSaddle/Arguments.hs b/src/Language/Javascript/JSaddle/Arguments.hs --- a/src/Language/Javascript/JSaddle/Arguments.hs +++ b/src/Language/Javascript/JSaddle/Arguments.hs @@ -13,46 +13,70 @@ ----------------------------------------------------------------------------- module Language.Javascript.JSaddle.Arguments ( - MakeArgRefs(..) + MakeArgs(..) ) where import Language.Javascript.JSaddle.Classes - (MakeValueRef(..), MakeValueRef, MakeArgRefs(..), MakeArgRefs) + (ToJSVal(..)) import Language.Javascript.JSaddle.Monad (JSM) +import Language.Javascript.JSaddle.Types (JSVal) -instance MakeArgRefs arg => MakeArgRefs (JSM arg) where - makeArgRefs arg = arg >>= makeArgRefs +-- | Anything that can be used to make a list of JavaScript value +-- references for use as function arguments +class MakeArgs this where + makeArgs :: this -> JSM [JSVal] -instance MakeValueRef arg => MakeArgRefs [arg] where - makeArgRefs = mapM makeValueRef +instance MakeArgs arg => MakeArgs (JSM arg) where + makeArgs arg = arg >>= makeArgs + {-# INLINE makeArgs #-} -instance (MakeValueRef arg1, MakeValueRef arg2) => MakeArgRefs (arg1, arg2) where - makeArgRefs (arg1, arg2) = do - rarg1 <- makeValueRef arg1 - rarg2 <- makeValueRef arg2 +instance ToJSVal arg => MakeArgs [arg] where + makeArgs = mapM toJSVal + {-# INLINE makeArgs #-} + +instance (ToJSVal arg1, ToJSVal arg2) => MakeArgs (arg1, arg2) where + makeArgs (arg1, arg2) = do + rarg1 <- toJSVal arg1 + rarg2 <- toJSVal arg2 return [rarg1, rarg2] + {-# INLINE makeArgs #-} -instance (MakeValueRef arg1, MakeValueRef arg2, MakeValueRef arg3) => MakeArgRefs (arg1, arg2, arg3) where - makeArgRefs (arg1, arg2, arg3) = do - rarg1 <- makeValueRef arg1 - rarg2 <- makeValueRef arg2 - rarg3 <- makeValueRef arg3 +instance (ToJSVal arg1, ToJSVal arg2, ToJSVal arg3) => MakeArgs (arg1, arg2, arg3) where + makeArgs (arg1, arg2, arg3) = do + rarg1 <- toJSVal arg1 + rarg2 <- toJSVal arg2 + rarg3 <- toJSVal arg3 return [rarg1, rarg2, rarg3] + {-# INLINE makeArgs #-} -instance (MakeValueRef arg1, MakeValueRef arg2, MakeValueRef arg3, MakeValueRef arg4) => MakeArgRefs (arg1, arg2, arg3, arg4) where - makeArgRefs (arg1, arg2, arg3, arg4) = do - rarg1 <- makeValueRef arg1 - rarg2 <- makeValueRef arg2 - rarg3 <- makeValueRef arg3 - rarg4 <- makeValueRef arg4 +instance (ToJSVal arg1, ToJSVal arg2, ToJSVal arg3, ToJSVal arg4) => MakeArgs (arg1, arg2, arg3, arg4) where + makeArgs (arg1, arg2, arg3, arg4) = do + rarg1 <- toJSVal arg1 + rarg2 <- toJSVal arg2 + rarg3 <- toJSVal arg3 + rarg4 <- toJSVal arg4 return [rarg1, rarg2, rarg3, rarg4] + {-# INLINE makeArgs #-} -instance (MakeValueRef arg1, MakeValueRef arg2, MakeValueRef arg3, MakeValueRef arg4, MakeValueRef arg5) => MakeArgRefs (arg1, arg2, arg3, arg4, arg5) where - makeArgRefs (arg1, arg2, arg3, arg4, arg5) = do - rarg1 <- makeValueRef arg1 - rarg2 <- makeValueRef arg2 - rarg3 <- makeValueRef arg3 - rarg4 <- makeValueRef arg4 - rarg5 <- makeValueRef arg5 +instance (ToJSVal arg1, ToJSVal arg2, ToJSVal arg3, ToJSVal arg4, ToJSVal arg5) => MakeArgs (arg1, arg2, arg3, arg4, arg5) where + makeArgs (arg1, arg2, arg3, arg4, arg5) = do + rarg1 <- toJSVal arg1 + rarg2 <- toJSVal arg2 + rarg3 <- toJSVal arg3 + rarg4 <- toJSVal arg4 + rarg5 <- toJSVal arg5 return [rarg1, rarg2, rarg3, rarg4, rarg5] + {-# INLINE makeArgs #-} + + +instance (ToJSVal arg1, ToJSVal arg2, ToJSVal arg3, ToJSVal arg4, ToJSVal arg5, ToJSVal arg6) => MakeArgs (arg1, arg2, arg3, arg4, arg5, arg6) where + makeArgs (arg1, arg2, arg3, arg4, arg5, arg6) = do + rarg1 <- toJSVal arg1 + rarg2 <- toJSVal arg2 + rarg3 <- toJSVal arg3 + rarg4 <- toJSVal arg4 + rarg5 <- toJSVal arg5 + rarg6 <- toJSVal arg6 + return [rarg1, rarg2, rarg3, rarg4, rarg5, rarg6] + {-# INLINE makeArgs #-} diff --git a/src/Language/Javascript/JSaddle/Classes.hs b/src/Language/Javascript/JSaddle/Classes.hs --- a/src/Language/Javascript/JSaddle/Classes.hs +++ b/src/Language/Javascript/JSaddle/Classes.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- -- Module : Language.Javascript.JSaddle.Classes @@ -14,39 +16,32 @@ module Language.Javascript.JSaddle.Classes ( -- * Type classes to convert Haskell data to JavaScript - MakeValueRef(..) - , MakeStringRef(..) - , MakeArgRefs(..) - , MakeObjectRef(..) - , MakePropRef(..) + ToJSVal(..) + , ToJSString(..) + , MakeObject(..) ) where -import Control.Monad.IO.Class (MonadIO) import Language.Javascript.JSaddle.Types - (JSObjectRef, JSStringRef, JSValueRef) -import Language.Javascript.JSaddle.Monad (JSM) -import Language.Javascript.JSaddle.PropRef (JSPropRef) + (JSM, Object(..), JSString, JSVal) -- | Anything that can be used to make a JavaScript value reference -class MakeValueRef a where - makeValueRef :: a -> JSM JSValueRef +class ToJSVal a where + toJSVal :: a -> JSM JSVal -- | Anything that can be used to make a JavaScript string reference -class MakeStringRef a where - makeStringRef :: a -> JSStringRef - --- | Anything that can be used to make a list of JavaScript value --- references for use as function arguments -class MakeArgRefs this where - makeArgRefs :: this -> JSM [JSValueRef] +class ToJSVal a => ToJSString a where + toJSString :: a -> JSString -- | Anything that can be used to make a JavaScript object reference -class MakeObjectRef this where - makeObjectRef :: this -> JSM JSObjectRef - --- | Anything that can be used to make a JavaScript property reference -class MakePropRef this where - makePropRef :: this -> JSM JSPropRef +class MakeObject this where + makeObject :: this -> JSM Object +instance ToJSVal Object where + toJSVal (Object r) = return r + {-# INLINE toJSVal #-} +-- | If we already have a Object we are fine +instance MakeObject Object where + makeObject = return + {-# INLINE makeObject #-} diff --git a/src/Language/Javascript/JSaddle/Evaluate.hs b/src/Language/Javascript/JSaddle/Evaluate.hs --- a/src/Language/Javascript/JSaddle/Evaluate.hs +++ b/src/Language/Javascript/JSaddle/Evaluate.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) +{-# LANGUAGE FlexibleInstances #-} +#ifdef ghcjs_HOST_OS {-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-} #endif ----------------------------------------------------------------------------- @@ -22,58 +23,66 @@ import Control.Monad.Trans.Reader (ask) import Control.Monad.IO.Class (MonadIO(..)) -import Language.Javascript.JSaddle.Types - (JSStringRef, JSValueRef, JSObjectRef, - JSValueRefRef) -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) +import Language.Javascript.JSaddle.Types (JSVal) +#ifdef ghcjs_HOST_OS import GHCJS.Types (nullRef) +import GHCJS.Marshal.Pure (pFromJSVal) +import Language.Javascript.JSaddle.Types (JSString) #else import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase (jsevaluatescript) -import Foreign (nullPtr) +import Language.Javascript.JSaddle.Native + (makeNewJSVal, withObject, withJSString) #endif import Language.Javascript.JSaddle.Exception (rethrow) -import Language.Javascript.JSaddle.Value () -import Language.Javascript.JSaddle.Object () +import Language.Javascript.JSaddle.String (nullJSString) +import Language.Javascript.JSaddle.Object (nullObject) import Language.Javascript.JSaddle.Classes - (MakeObjectRef(..), MakeStringRef(..)) + (MakeObject(..), ToJSString(..)) import Language.Javascript.JSaddle.Monad (JSM) +-- $setup +-- >>> import Language.Javascript.JSaddle.Test (testJSaddle) +-- >>> import Language.Javascript.JSaddle.Value (valToText) +-- >>> import Language.Javascript.JSaddle.Object (global, array, (!)) +-- >>> import Language.Javascript.JSaddle.Monad (catch) +-- >>> import Language.Javascript.JSaddle.Exception (JSException(..)) -- | Evaluates a script (like eval in java script). Unlike 'eval' this function lets you -- specify a source URL and starting line number for beter error information. -- -- >>> testJSaddle $ (evaluateScript "\n\n{" global "FileName" 53 >>= valToText) `catch` \(JSException e) -> array (e,e!"sourceURL", e!"line") >>= valToText -- SyntaxError: Expected token '}',FileName,55 -evaluateScript :: (MakeStringRef script, MakeObjectRef this, MakeStringRef url) +evaluateScript :: (ToJSString script, MakeObject this, ToJSString url) => script -- ^ JavaScript to evaluate -> this -> url -> Int -- ^ The Line number of the first line of the script - -> JSM JSValueRef -#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI) -evaluateScript script this url line = liftIO $ js_eval (makeStringRef script) + -> JSM JSVal +#ifdef ghcjs_HOST_OS +evaluateScript script this url line = liftIO $ js_eval (toJSString script) +{-# INLINE evaluateScript #-} foreign import javascript unsafe "$r = eval($1);" - js_eval :: JSStringRef -> IO JSValueRef -#elif defined(USE_WEBKIT) + js_eval :: JSString -> IO JSVal +#else evaluateScript script this url line = do gctxt <- ask - thisr <- makeObjectRef this - rethrow $ liftIO . jsevaluatescript gctxt (makeStringRef script) thisr (makeStringRef url) line -#else -evaluateScript = undefined + rthis <- makeObject this + result <- + withJSString (toJSString script) $ \script' -> + withObject rthis $ \this' -> + withJSString (toJSString url) $ \url' -> + rethrow $ liftIO . jsevaluatescript gctxt script' this' url' line + makeNewJSVal result +{-# INLINE evaluateScript #-} #endif -- | Evaluates a script (like eval in java script) -- -- >>> testJSaddle $ eval "1+1" -- 2 -eval :: MakeStringRef script +eval :: ToJSString script => script -- ^ JavaScript to evaluate - -> JSM JSValueRef -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) -eval script = evaluateScript script (nullRef::JSObjectRef) (nullRef::JSStringRef) 1 -#else -eval script = evaluateScript script (nullPtr::JSObjectRef) (nullPtr::JSStringRef) 1 -#endif - + -> JSM JSVal +eval script = evaluateScript script nullObject nullJSString 1 +{-# INLINE eval #-} diff --git a/src/Language/Javascript/JSaddle/Exception.hs b/src/Language/Javascript/JSaddle/Exception.hs --- a/src/Language/Javascript/JSaddle/Exception.hs +++ b/src/Language/Javascript/JSaddle/Exception.hs @@ -18,18 +18,18 @@ import qualified Control.Exception as E (throwIO, Exception) import Language.Javascript.JSaddle.Types - (JSValueRefRef, JSValueRef) + (MutableJSArray, JSVal) import Data.Typeable (Typeable) import Language.Javascript.JSaddle.Monad (catchval, JSM) import Control.Monad.IO.Class (MonadIO(..)) -import Data.Text (Text) -data JSException = JSException JSValueRef deriving (Show, Typeable) +newtype JSException = JSException JSVal deriving (Typeable) +instance Show JSException where show _ = "JSException" instance E.Exception JSException -- | Catch JavaScript exceptions and rethrow Haskell ones -rethrow :: (JSValueRefRef -> JSM a) -> JSM a +rethrow :: (MutableJSArray -> JSM a) -> JSM a rethrow f = f `catchval` \e -> liftIO . E.throwIO $ JSException e diff --git a/src/Language/Javascript/JSaddle/Monad.hs b/src/Language/Javascript/JSaddle/Monad.hs --- a/src/Language/Javascript/JSaddle/Monad.hs +++ b/src/Language/Javascript/JSaddle/Monad.hs @@ -13,27 +13,32 @@ module Language.Javascript.JSaddle.Monad ( -- * Types - JSM(..) + JSM , JSContextRef -- * Running JSaddle given a DOM Window , runJSaddle - , runJSaddle_ -- * Exception Handling , catchval , catch + , bracket + + -- * GUI thread support + , postGUIAsyncJS + , postGUISyncJS ) where -import Prelude hiding (catch) +import Prelude hiding (catch, read) import Control.Monad.Trans.Reader (runReaderT, ask, ReaderT(..)) import Language.Javascript.JSaddle.Types - (JSValueRefRef, JSValueRef, JSContextRef) + (JSM, JSVal, MutableJSArray, JSContextRef) import Control.Monad.IO.Class (MonadIO(..)) -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) +#ifdef ghcjs_HOST_OS import GHCJS.Types (isUndefined, isNull) -import GHCJS.Foreign (newArray, indexArray) +import qualified JavaScript.Array as Array (create, read) #else +import Language.Javascript.JSaddle.Native (makeNewJSVal) import Foreign (nullPtr, alloca) import Foreign.Storable (Storable(..)) import Graphics.UI.Gtk.WebKit.Types @@ -42,18 +47,9 @@ (webViewGetMainFrame) import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame (webFrameGetGlobalContext) +import Graphics.UI.Gtk.General.General (postGUIAsync, postGUISync) #endif -import qualified Control.Exception as E (Exception, catch) - --- | The @JSM@ monad keeps track of the JavaScript context. --- --- Given a @JSM@ function and a 'JSContextRef' you can run the --- function like this... --- --- > runReaderT jsmFunction javaScriptContext --- --- For an example of how to set up WebKitGTK+ see tests/TestJSaddle.hs -type JSM = ReaderT JSContextRef IO +import qualified Control.Exception as E (Exception, catch, bracket) -- | Wrapped version of 'E.catch' that runs in a MonadIO that works -- a bit better with 'JSM' @@ -64,15 +60,27 @@ t `catch` c = do r <- ask liftIO (runReaderT t r `E.catch` \e -> runReaderT (c e) r) +{-# INLINE catch #-} --- | Handle JavaScriptCore functions that take a JSValueRefRef in order +-- | Wrapped version of 'E.bracket' that runs in a MonadIO that works +-- a bit better with 'JSM' +bracket :: MonadIO m => ReaderT r IO a -> (a -> ReaderT r IO b) -> (a -> ReaderT r IO c) -> ReaderT r m c +bracket aquire release f = do + r <- ask + liftIO $ E.bracket + (runReaderT aquire r) + (\x -> runReaderT (release x) r) + (\x -> runReaderT (f x) r) +{-# INLINE bracket #-} + +-- | Handle JavaScriptCore functions that take a MutableJSArray in order -- to throw exceptions. -catchval :: (JSValueRefRef -> JSM a) -> (JSValueRef -> JSM a) -> JSM a +catchval :: (MutableJSArray -> JSM a) -> (JSVal -> JSM a) -> JSM a catchval f catcher = do -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) - pexc <- liftIO newArray +#ifdef ghcjs_HOST_OS + pexc <- liftIO Array.create result <- f pexc - exc <- liftIO $ indexArray 0 pexc + exc <- liftIO $ Array.read 0 pexc if isUndefined exc || isNull exc then return result else catcher exc @@ -84,10 +92,10 @@ exc <- liftIO $ peek pexc if exc == nullPtr then return result - else catcher exc + else makeNewJSVal exc >>= catcher #endif -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) +#ifdef ghcjs_HOST_OS runJSaddle :: w -> JSM a -> IO a runJSaddle _ f = runReaderT f () #else @@ -96,5 +104,25 @@ gctxt <- webViewGetMainFrame webView >>= webFrameGetGlobalContext runReaderT f gctxt #endif +{-# INLINE runJSaddle #-} -runJSaddle_ w f = runJSaddle w f >> return () +postGUIAsyncJS :: JSM () -> JSM () +#ifdef ghcjs_HOST_OS +postGUIAsyncJS = id +#else +postGUIAsyncJS f = do + r <- ask + liftIO . postGUIAsync $ runReaderT f r +#endif +{-# INLINE postGUIAsyncJS #-} + +postGUISyncJS :: JSM a -> JSM a +#ifdef ghcjs_HOST_OS +postGUISyncJS = id +#else +postGUISyncJS f = do + r <- ask + liftIO . postGUISync $ runReaderT f r +#endif +{-# INLINE postGUISyncJS #-} + diff --git a/src/Language/Javascript/JSaddle/Native.hs b/src/Language/Javascript/JSaddle/Native.hs new file mode 100644 --- /dev/null +++ b/src/Language/Javascript/JSaddle/Native.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- +-- Module : Language.Javascript.JSaddle.Native +-- Copyright : (c) Hamish Mackenzie +-- License : MIT +-- +-- Maintainer : Hamish Mackenzie +-- +-- | +-- +----------------------------------------------------------------------------- + +module Language.Javascript.JSaddle.Native ( +#if !defined(ghcjs_HOST_OS) + makeNewJSVal + , makeNewJSString + , wrapJSString + , withJSVal + , withJSVals + , withObject + , withJSString + , withToJSVal +#endif +) where + +#if !defined(ghcjs_HOST_OS) +import Control.Monad.Trans.Reader (ask) +import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase + (JSObjectRef, OpaqueJSString, JSStringRef, OpaqueJSContext, + OpaqueJSValue, JSValueRef) +import Foreign.ForeignPtr + (touchForeignPtr, FinalizerPtr, newForeignPtr, FinalizerEnvPtr, + newForeignPtrEnv, ForeignPtr) +import Control.Monad.IO.Class (MonadIO, MonadIO(..)) +import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef + (jsvalueprotect) +import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef + (jsstringretain) +import Language.Javascript.JSaddle.Types + (JSM, JSString, Object(..), JSVal) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import Language.Javascript.JSaddle.Classes (ToJSVal(..), ToJSVal) + +makeNewJSVal :: JSValueRef -> JSM (ForeignPtr OpaqueJSValue) +makeNewJSVal val = do + ctx <- ask + liftIO $ do + jsvalueprotect ctx val + newForeignPtrEnv jsValueUnprotect ctx val + +foreign import ccall unsafe "&JSValueUnprotect" + jsValueUnprotect :: FinalizerEnvPtr OpaqueJSContext OpaqueJSValue + +makeNewJSString :: MonadIO m => JSStringRef -> m (ForeignPtr OpaqueJSString) +makeNewJSString s = + liftIO $ do + s' <- jsstringretain s + newForeignPtr jsStringRelease s' + +wrapJSString :: MonadIO m => JSStringRef -> m (ForeignPtr OpaqueJSString) +wrapJSString s = liftIO $ newForeignPtr jsStringRelease s + +foreign import ccall unsafe "&JSStringRelease" + jsStringRelease :: FinalizerPtr OpaqueJSString + +withJSVal :: MonadIO m => JSVal -> (JSValueRef -> m a) -> m a +withJSVal v f = + do result <- f (unsafeForeignPtrToPtr v) + liftIO $ touchForeignPtr v + return result + +withJSVals :: MonadIO m => [JSVal] -> ([JSValueRef] -> m a) -> m a +withJSVals v f = + do result <- f (map unsafeForeignPtrToPtr v) + liftIO $ mapM_ touchForeignPtr v + return result + +withObject :: MonadIO m => Object -> (JSObjectRef -> m a) -> m a +withObject (Object o) f = do + result <- f (unsafeForeignPtrToPtr o) + liftIO $ touchForeignPtr o + return result + +withJSString :: MonadIO m => JSString -> (JSStringRef -> m a) -> m a +withJSString v f = + do result <- f (unsafeForeignPtrToPtr v) + liftIO $ touchForeignPtr v + return result + +withToJSVal :: ToJSVal val => val -> (JSValueRef -> JSM a) -> JSM a +withToJSVal val f = do + v <- toJSVal val + withJSVal v f +{-# INLINE withToJSVal #-} +#endif + diff --git a/src/Language/Javascript/JSaddle/Object.hs b/src/Language/Javascript/JSaddle/Object.hs --- a/src/Language/Javascript/JSaddle/Object.hs +++ b/src/Language/Javascript/JSaddle/Object.hs @@ -3,10 +3,11 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Rank2Types #-} +#ifdef ghcjs_HOST_OS {-# LANGUAGE ForeignFunctionInterface #-} -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) {-# LANGUAGE JavaScriptFFI #-} #endif +{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- -- Module : Language.Javascript.JSaddle.Object @@ -20,14 +21,15 @@ ----------------------------------------------------------------------------- module Language.Javascript.JSaddle.Object ( - JSObjectRef - , MakeObjectRef(..) + Object + , MakeObject(..) -- * Property lookup , (!) , (!!) , js - , JSF(..) + , jss + , JSF , jsf , js0 , js1 @@ -36,20 +38,31 @@ , js4 , js5 , jsg + , jsgf + , jsg0 + , jsg1 + , jsg2 + , jsg3 + , jsg4 + , jsg5 -- * Setting the value of a property , (<#) + , (<##) -- * Calling JavaSctipt , (#) + , (##) , new , call , obj -- * Calling Haskell From JavaScript + , Function(..) , function + , freeFunction , fun - , JSCallAsFunction(..) + , JSCallAsFunction -- ** Object Constructors -- | There is no good way to support calling haskell code as a JavaScript @@ -68,97 +81,110 @@ -- * Enumerating Properties , propertyNames + , properties -- * Low level , objCallAsFunction , objCallAsConstructor + , nullObject ) where +import Control.Applicative 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(..)) + (JSPropertyNameArray, JSString, Object(..), MutableJSArray, + JSVal, Index) +import Foreign.C.Types (CSize(..), CULong(..)) +#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 Control.Applicative ((<$>)) +import Data.Coerce (coerce) #else import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef (jsobjectmake, jspropertynamearraygetnameatindex, jspropertynamearraygetcount, jsobjectcopypropertynames, - jsobjectsetpropertyatindex, jsobjectgetpropertyatindex, jsobjectcallasconstructor, jsobjectmakearray, - jsobjectcallasfunction, jsobjectgetproperty, jsobjectsetproperty, - JSPropertyAttributes, JSObjectCallAsFunctionCallback, + jsobjectcallasfunction, + JSObjectCallAsFunctionCallback, jsobjectmakefunctionwithcallback, JSObjectCallAsFunctionCallback') 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 + (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, valMakeUndefined, valToObject) -import Language.Javascript.JSaddle.PropRef (JSPropRef(..)) + (JSUndefined, valToObject) import Language.Javascript.JSaddle.Classes - (MakeValueRef(..), MakeStringRef(..), MakeArgRefs(..), MakePropRef(..), - MakeObjectRef(..)) + (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 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) +import Control.Lens (IndexPreservingGetter, to) +import Language.Javascript.JSaddle.String (nullJSString) +import Data.Text (Text) --- | If we already have a JSObjectRef we are fine -instance MakeObjectRef JSObjectRef where - makeObjectRef = return +-- $setup +-- >>> import Language.Javascript.JSaddle.Test (testJSaddle) +-- >>> import Language.Javascript.JSaddle.Evaluate (eval) +-- >>> import Language.Javascript.JSaddle.Value (val) +-- >>> import Control.Lens.Operators ((^.)) --- | JSObjectRef can be made by evaluating a function in 'JSM' as long --- as it returns something we can make into a JSObjectRef. -instance MakeObjectRef v => MakeObjectRef (JSM v) where - makeObjectRef v = v >>= makeObjectRef +-- | Object can be made by evaluating a fnction in 'JSM' as long +-- as it returns something we can make into a Object. +instance MakeObject v => MakeObject (JSM v) where + makeObject v = v >>= makeObject + {-# INLINE makeObject #-} --- | Lookup a property based on its name. This function just constructs a JSPropRef --- the lookup is delayed until we use the JSPropRef. This makes it a bit lazy compared --- to JavaScript's @.@ operator. +-- | Lookup a property based on its name. -- -- >>> testJSaddle $ eval "'Hello World'.length" -- >>> testJSaddle $ val "Hello World" ! "length" -- 11 -(!) :: (MakeObjectRef this, MakeStringRef name) - => this -- ^ Object to look on - -> name -- ^ Name of the property to find - -> JSM JSPropRef -- ^ Property reference +(!) :: (MakeObject this, ToJSString name) + => this -- ^ Object to look on + -> name -- ^ Name of the property to find + -> JSM JSVal -- ^ Property reference this ! name = do - rthis <- makeObjectRef this - return (JSPropRef rthis rname) + rthis <- makeObject this + rethrow $ objGetPropertyByName rthis rname where - rname = makeStringRef name + rname = toJSString name +{-# INLINE (!) #-} --- | Lookup a property based on its index. This function just constructs a JSPropRef --- the lookup is delayed until we use the JSPropRef. This makes it a bit lazy compared --- to JavaScript's @[]@ operator. +-- | Lookup a property based on its index. -- -- >>> testJSaddle $ eval "'Hello World'[6]" -- >>> testJSaddle $ val "Hello World" !! 6 -- W -(!!) :: (MakeObjectRef this) - => this -- ^ Object to look on - -> Index -- ^ Index of the property to lookup - -> JSM JSPropRef -- ^ Property reference +(!!) :: (MakeObject this) + => this -- ^ Object to look on + -> Index -- ^ Index of the property to lookup + -> JSM JSVal -- ^ Property reference this !! index = do - rthis <- makeObjectRef this - return (JSPropIndexRef rthis index) + rthis <- makeObject this + rethrow $ objGetPropertyAtIndex rthis index +{-# INLINE (!!) #-} -- | Makes a getter for a particular property name. -- @@ -167,33 +193,48 @@ -- >>> testJSaddle $ eval "'Hello World'.length" -- >>> testJSaddle $ val "Hello World" ^. js "length" -- 11 -js :: (MakeObjectRef s, MakeStringRef name) +js :: (MakeObject s, ToJSString name) => name -- ^ Name of the property to find - -> IndexPreservingGetter s (JSM JSPropRef) + -> IndexPreservingGetter s (JSM JSVal) js name = to (!name) +{-# INLINE js #-} --- | Java script function applications have this type -type JSF = MakeObjectRef o => IndexPreservingGetter o (JSM JSValueRef) +-- | Makes a setter for a particular property name. +-- +-- > jss name = to (<#name) +-- +-- >>> testJSaddle $ eval "'Hello World'.length" +-- >>> testJSaddle $ val "Hello World" ^. js "length" +-- 11 +jss :: (ToJSString name, ToJSVal val) + => name -- ^ Name of the property to find + -> val + -> forall o . MakeObject o => IndexPreservingGetter o (JSM ()) +jss name val = to (\o -> o <# name $ val) +{-# INLINE jss #-} -- | Handy way to call a function -- --- > jsf name = js name . to (# args) +-- > jsf name = to (\o -> o # name $ args) -- -- >>> testJSaddle $ val "Hello World" ^. jsf "indexOf" ["World"] -- 6 -jsf :: (MakeStringRef name, MakeArgRefs args) => name -> args -> JSF -jsf name args = function . to (# args) - where - function = js name +jsf :: (ToJSString name, MakeArgs args) => name -> args -> JSF +jsf name args = to (\o -> o # name $ args) +{-# INLINE jsf #-} +-- | Java script function applications have this type +type JSF = forall o . MakeObject o => IndexPreservingGetter o (JSM JSVal) + -- | Handy way to call a function that expects no arguments -- -- > js0 name = jsf name () -- -- >>> testJSaddle $ val "Hello World" ^. js0 "toLowerCase" -- hello world -js0 :: (MakeStringRef name) => name -> JSF +js0 :: (ToJSString name) => name -> JSF js0 name = jsf name () +{-# INLINE js0 #-} -- | Handy way to call a function that expects one argument -- @@ -201,29 +242,34 @@ -- -- >>> testJSaddle $ val "Hello World" ^. js1 "indexOf" "World" -- 6 -js1 :: (MakeStringRef name, MakeValueRef a0) => name -> a0 -> JSF +js1 :: (ToJSString name, ToJSVal a0) => name -> a0 -> JSF js1 name a0 = jsf name [a0] +{-# INLINE js1 #-} -- | Handy way to call a function that expects two arguments -js2 :: (MakeStringRef name, MakeValueRef a0, MakeValueRef a1) => name -> a0 -> a1 -> JSF +js2 :: (ToJSString name, ToJSVal a0, ToJSVal a1) => name -> a0 -> a1 -> JSF js2 name a0 a1 = jsf name (a0, a1) +{-# INLINE js2 #-} -- | Handy way to call a function that expects three arguments -js3 :: (MakeStringRef name, MakeValueRef a0, MakeValueRef a1, MakeValueRef a2) +js3 :: (ToJSString name, ToJSVal a0, ToJSVal a1, ToJSVal a2) => name -> a0 -> a1 -> a2 -> JSF js3 name a0 a1 a2 = jsf name (a0, a1, a2) +{-# INLINE js3 #-} -- | Handy way to call a function that expects four arguments -js4 :: (MakeStringRef name, MakeValueRef a0, MakeValueRef a1, MakeValueRef a2, - MakeValueRef a3) +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) +{-# INLINE js4 #-} -- | Handy way to call a function that expects five arguments -js5 :: (MakeStringRef name, MakeValueRef a0, MakeValueRef a1, MakeValueRef a2, - MakeValueRef a3, MakeValueRef a4) +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) +{-# INLINE js5 #-} -- | Handy way to get and hold onto a reference top level javascript @@ -231,82 +277,175 @@ -- >>> testJSaddle $ eval "w = console; w.log('Hello World')" -- >>> testJSaddle $ do w <- jsg "console"; w ^. js "log" # ["Hello World"] -- 11 -jsg :: MakeStringRef a => a -> JSM JSPropRef +jsg :: ToJSString a => a -> JSM JSVal jsg name = global ! name +{-# INLINE jsg #-} +-- | Handy way to call a function +-- +-- > jsgf name = jsg name . to (# args) +-- +-- >>> testJSaddle $ eval "globalFunc = function(x) {x.length}" +-- >>> testJSaddle $ jsgf "globalFunc" ["World"] +-- 6 +jsgf :: (ToJSString name, MakeArgs args) => name -> args -> JSM JSVal +jsgf name = global # name +{-# INLINE jsgf #-} + +-- | Handy way to call a function that expects no arguments +-- +-- > jsg0 name = jsgf name () +-- +-- >>> testJSaddle $ jsg0 "globalFunc" +-- hello world +jsg0 :: (ToJSString name) => name -> JSM JSVal +jsg0 name = jsgf name () +{-# INLINE jsg0 #-} + +-- | Handy way to call a function that expects one argument +-- +-- > jsg1 name a0 = jsgf name [a0] +-- +-- >>> testJSaddle $ jsg1 "globalFunc" "World" +-- 6 +jsg1 :: (ToJSString name, ToJSVal a0) => name -> a0 -> JSM JSVal +jsg1 name a0 = jsgf name [a0] +{-# INLINE jsg1 #-} + +-- | Handy way to call a function that expects two arguments +jsg2 :: (ToJSString name, ToJSVal a0, ToJSVal a1) => name -> a0 -> a1 -> JSM JSVal +jsg2 name a0 a1 = jsgf name (a0, a1) +{-# INLINE jsg2 #-} + +-- | Handy way to call a function that expects three arguments +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) +{-# INLINE jsg3 #-} + +-- | Handy way to call a function that expects four arguments +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) +{-# INLINE jsg4 #-} + +-- | Handy way to call a function that expects five arguments +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) +{-# INLINE jsg5 #-} + -- | Call a JavaScript function -- -- >>> testJSaddle $ eval "'Hello World'.indexOf('World')" --- >>> testJSaddle $ val "Hello World" ! "indexOf" # ["World"] +-- >>> testJSaddle $ val "Hello World" # "indexOf" $ ["World"] -- 6 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 +(#) :: (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 +{-# INLINE (#) #-} -- | Call a JavaScript function -- +-- >>> testJSaddle $ eval "something[6]('World')" +-- >>> testJSaddle $ val something ## 6 ["World"] +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 +{-# INLINE (##) #-} + +-- | Set a JavaScript property +-- -- >>> testJSaddle $ eval "var j = {}; j.x = 1; j.x" --- >>> testJSaddle $ do {j <- eval "({})"; j!"x" <# 1; j!"x"} +-- >>> testJSaddle $ do {j <- eval "({})"; j <# "x" 1; j!"x"} -- 1 -infixr 0 <# -(<#) :: (MakePropRef prop, MakeValueRef val) - => prop -- ^ Property to set - -> val -- ^ Value to set it to - -> JSM JSPropRef -- ^ Reference to the property set -prop <# val = do - p <- makePropRef prop - objSetProperty p val - return p +infixr 1 <# +(<#) :: (MakeObject this, ToJSString name, ToJSVal val) + => this -- ^ Object to set the property on + -> name -- ^ Name of the property to set + -> val -- ^ Value to set it to + -> JSM () +(<#) this name val = do + rthis <- makeObject this + rethrow $ objSetPropertyByName rthis name val 0 +{-# INLINE (<#) #-} +-- | Set a JavaScript property +-- +-- >>> testJSaddle $ eval "var j = {}; j[6] = 1; j[6]" +-- >>> testJSaddle $ do {j <- eval "({})"; j <## 6 1; j!!6} +-- 1 +infixr 1 <## +(<##) :: (MakeObject this, ToJSVal val) + => this -- ^ Object to set the property on + -> Index -- ^ Index of the property to set + -> val -- ^ Value to set it to + -> JSM () +(<##) this index val = do + rthis <- makeObject this + rethrow $ objSetPropertyAtIndex rthis index val +{-# INLINE (<##) #-} + -- | Use this to create a new JavaScript object -- -- If you pass more than 7 arguments to a constructor for a built in -- JavaScript type (like Date) then this function will fail. -- --- >>> testJSaddle $ new "Date" (2013, 1, 1) +-- >>> testJSaddle $ new (jsg "Date") (2013, 1, 1) -- Fri Feb 01 2013 00:00:00 GMT+1300 (NZDT) -new :: (MakeObjectRef constructor, MakeArgRefs args) +new :: (MakeObject constructor, MakeArgs args) => constructor -> args - -> JSM JSValueRef + -> JSM JSVal new constructor args = do - f <- makeObjectRef constructor + f <- makeObject constructor rethrow $ objCallAsConstructor f args +{-# INLINE new #-} -- | Call function with a given @this@. In most cases you should use '#'. -- -- >>> testJSaddle $ eval "(function(){return this;}).apply('Hello', [])" -- >>> testJSaddle $ do { test <- eval "(function(){return this;})"; call test (val "Hello") () } -- Hello -call :: (MakeObjectRef function, MakeObjectRef this, MakeArgRefs args) - => function -> this -> args -> JSM JSValueRef -call function this args = do - rfunction <- makeObjectRef function - rthis <- makeObjectRef this +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 +{-# INLINE call #-} -- | Make an empty object using the default constuctor -- -- >>> testJSaddle $ eval "var a = {}; a.x = 'Hello'; a.x" -- >>> testJSaddle $ do { a <- obj; a ^. js "x" <# "Hello"; a ^. js "x" } -- Hello -obj :: JSM JSObjectRef -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) -obj = liftIO $ newObj +obj :: JSM Object +#ifdef ghcjs_HOST_OS +obj = liftIO Object.create #else obj = do gctxt <- ask - liftIO $ jsobjectmake gctxt nullPtr nullPtr + Object <$> (liftIO (jsobjectmake gctxt nullPtr nullPtr) >>= makeNewJSVal) #endif +{-# INLINE obj #-} -- | Type used for Haskell functions called from JavaScript. -type JSCallAsFunction = JSValueRef -- ^ Function object - -> JSValueRef -- ^ this - -> [JSValueRef] -- ^ Function arguments +type JSCallAsFunction = JSVal -- ^ Function object + -> JSVal -- ^ this + -> [JSVal] -- ^ Function arguments -> JSM JSUndefined -- ^ Only 'JSUndefined' can be returned because -- the function may need to be executed in a -- different thread. If you need to get a @@ -322,73 +461,98 @@ -- undefined fun :: JSCallAsFunction -> JSCallAsFunction fun = id +{-# INLINE fun #-} -#if (!defined(ghcjs_HOST_OS) || !defined(USE_JAVASCRIPTFFI)) && defined(USE_WEBKIT) +#if !defined(ghcjs_HOST_OS) foreign import ccall "wrapper" mkJSObjectCallAsFunctionCallback :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback #endif +#ifdef ghcjs_HOST_OS +type HaskellCallback = Callback (JSVal -> JSVal -> IO ()) +#else +type HaskellCallback = JSObjectCallAsFunctionCallback +#endif + +data Function = Function {functionCallback :: HaskellCallback, functionObject :: Object} + -- ^ Make a JavaScript function object that wraps a Haskell function. -function :: MakeStringRef name +function :: ToJSString name => name -- ^ Name of the function -> JSCallAsFunction -- ^ Haskell function to call - -> JSM JSObjectRef -- ^ Returns a JavaScript function object that will + -> JSM Function -- ^ Returns a JavaScript function object that will -- call the Haskell one when it is called -#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI) +#ifdef ghcjs_HOST_OS function name f = liftIO $ do - callback <- syncCallback2 AlwaysRetain True $ \this args -> do - rargs <- fromArray args + callback <- syncCallback2 ContinueAsync $ \this args -> do + rargs <- Array.toListIO (coerce args) runReaderT (f this this rargs) () -- TODO pass function object through - makeFunctionWithCallback (makeStringRef name) callback + Function callback <$> makeFunctionWithCallback (toJSString name) callback foreign import javascript unsafe "$r = function () { $2(this, arguments); }" - makeFunctionWithCallback :: JSStringRef -> JSFun (JSValueRef -> JSValueRefRef -> IO ()) -> IO JSObjectRef -#elif defined(USE_WEBKIT) + makeFunctionWithCallback :: JSString -> Callback (JSVal -> JSVal -> IO ()) -> IO Object +#else function name f = do gctxt <- ask - callback <- liftIO $ mkJSObjectCallAsFunctionCallback wrap - liftIO $ jsobjectmakefunctionwithcallback gctxt (makeStringRef name) callback + callback <- liftIO $ mkJSObjectCallAsFunctionCallback (wrap gctxt) + withJSString (toJSString name) $ \name' -> + Function callback . Object <$> + (liftIO (jsobjectmakefunctionwithcallback gctxt name' callback) >>= makeNewJSVal) 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 + 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 -function = undefined + freeHaskellFunPtr callback #endif +instance ToJSVal Function where + toJSVal (Function _ f) = toJSVal f + {-# INLINE toJSVal #-} + -- | A callback to Haskell can be used as a JavaScript value. This will create -- an anonymous JavaScript function object. Use 'function' to create one with -- a name. -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 ToJSVal JSCallAsFunction where + toJSVal f = functionObject <$> function nullJSString f >>= toJSVal + {-# INLINE toJSVal #-} -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 +instance MakeArgs JSCallAsFunction where + makeArgs f = do + rarg <- functionObject <$> function nullJSString f >>= toJSVal return [rarg] + {-# INLINE makeArgs #-} -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 +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 <- makeArgRefs args - liftIO $ withArrayLen rargs $ \ len ptr -> - jsobjectmakearray gctxt (fromIntegral len) ptr exceptions + rargs <- makeArgs args + result <- + withJSVals rargs $ \rargs' -> + liftIO $ withArrayLen rargs' $ \ len ptr -> + jsobjectmakearray gctxt (fromIntegral len) ptr exceptions + Object <$> makeNewJSVal result #endif +{-# INLINE makeArray #-} -- | Make an JavaScript array from a list of values -- @@ -398,96 +562,146 @@ -- >>> testJSaddle $ eval "['Hello', null, undefined, true, 1]" -- >>> testJSaddle $ array ("Hello", JSNull, (), True, 1.0::Double) -- Hello,,,true,1 -array :: MakeArgRefs args => args -> JSM JSObjectRef +array :: MakeArgs args => args -> JSM Object array = rethrow . makeArray +-- Make an array out of various lists +instance ToJSVal [JSVal] where + toJSVal = toJSVal . array + {-# INLINE toJSVal #-} + +instance ToJSVal [JSM JSVal] where + toJSVal = toJSVal . array + {-# INLINE toJSVal #-} + +instance ToJSVal [Double] where + toJSVal = toJSVal . array + {-# INLINE toJSVal #-} + +instance ToJSVal [Float] where + toJSVal = toJSVal . array + {-# INLINE toJSVal #-} + +instance ToJSVal [Int] where + toJSVal = toJSVal . array + {-# INLINE toJSVal #-} + +instance ToJSVal [JSString] where + toJSVal = toJSVal . array + {-# INLINE toJSVal #-} + +instance ToJSVal [String] where + toJSVal = toJSVal . array + {-# INLINE toJSVal #-} + +instance ToJSVal [Text] where + toJSVal = toJSVal . array + {-# INLINE toJSVal #-} + +instance ToJSVal [Bool] where + toJSVal = toJSVal . array + {-# INLINE toJSVal #-} + -- | JavaScript's global object -global :: JSM JSObjectRef -#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI) +global :: JSM Object +#ifdef ghcjs_HOST_OS global = liftIO js_window +{-# INLINE global #-} foreign import javascript unsafe "$r = window" - js_window :: IO JSObjectRef -#elif defined(USE_WEBKIT) -global = ask >>= (liftIO . jscontextgetglobalobject) + js_window :: IO Object #else -global = undefined +global = do + gctxt <- ask + result <- liftIO $ jscontextgetglobalobject gctxt + Object <$> makeNewJSVal result +{-# INLINE global #-} #endif -- | Get an array containing the property names present on a given object -#if (!defined(ghcjs_HOST_OS) || !defined(USE_JAVASCRIPTFFI)) && defined(USE_WEBKIT) -copyPropertyNames :: MakeObjectRef this => this -> JSM JSPropertyNameArrayRef +#if !defined(ghcjs_HOST_OS) +copyPropertyNames :: MakeObject this => this -> JSM JSPropertyNameArray copyPropertyNames this = do gctxt <- ask - rthis <- makeObjectRef this - liftIO $ jsobjectcopypropertynames gctxt rthis + this' <- makeObject this + withObject this' $ \rthis -> + liftIO $ jsobjectcopypropertynames gctxt rthis +{-# INLINE copyPropertyNames #-} -- | Get the number of names in a property name array -propertyNamesCount :: MonadIO m => JSPropertyNameArrayRef -> m CSize +propertyNamesCount :: MonadIO m => JSPropertyNameArray -> m CSize propertyNamesCount names = liftIO $ jspropertynamearraygetcount names +{-# INLINE propertyNamesCount #-} -- | Get a name out of a property name array -propertyNamesAt :: MonadIO m => JSPropertyNameArrayRef -> CSize -> m JSStringRef -propertyNamesAt names index = liftIO $ jspropertynamearraygetnameatindex names index +propertyNamesAt :: MonadIO m => JSPropertyNameArray -> CSize -> m JSString +propertyNamesAt names index = liftIO $ jspropertynamearraygetnameatindex names index >>= wrapJSString +{-# INLINE propertyNamesAt #-} -- | Convert property array to a list -propertyNamesList :: MonadIO m => JSPropertyNameArrayRef -> m [JSStringRef] +propertyNamesList :: MonadIO m => JSPropertyNameArray -> m [JSString] propertyNamesList names = do count <- propertyNamesCount names mapM (propertyNamesAt names) $ enumFromTo 0 (count - 1) +{-# INLINE propertyNamesList #-} #endif -- | Get a list containing the property names present on a given object -propertyNames :: MakeObjectRef this => this -> JSM [JSStringRef] -#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI) -propertyNames this = makeObjectRef this >>= liftIO . js_propertyNames >>= liftIO . fromArray +propertyNames :: MakeObject this => this -> JSM [JSString] +#ifdef ghcjs_HOST_OS +propertyNames this = makeObject this >>= liftIO . js_propertyNames >>= liftIO . (fmap (map pFromJSVal)) . Array.toListIO +{-# INLINE propertyNames #-} 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 + js_propertyNames :: Object -> IO JSArray #else -propertyNames = undefined +propertyNames this = copyPropertyNames this >>= propertyNamesList +{-# INLINE propertyNames #-} #endif -- | Get a list containing references to all the properties present on a given object -properties :: MakeObjectRef this => this -> JSM [JSPropRef] +properties :: MakeObject this => this -> JSM [JSVal] properties this = propertyNames this >>= mapM (this !) -- | Call a JavaScript object as function. Consider using '#'. -objCallAsFunction :: MakeArgRefs args - => JSObjectRef - -> JSObjectRef +objCallAsFunction :: MakeArgs args + => Object + -> Object -> 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 + -> 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 +{-# INLINE objCallAsFunction #-} 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 + js_apply :: Object -> Object -> MutableJSArray -> MutableJSArray -> IO JSVal #else -objCallAsFunction = undefined +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 +{-# INLINE objCallAsFunction #-} #endif -- | Call a JavaScript object as a constructor. Consider using 'new'. -- -- If you pass more than 7 arguments to a constructor for a built in -- JavaScript type (like Date) then this function will fail. -objCallAsConstructor :: MakeArgRefs args - => JSObjectRef +objCallAsConstructor :: MakeArgs args + => Object -> 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 + -> 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) {\ @@ -515,17 +729,25 @@ 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 + js_new :: Object -> MutableJSArray -> MutableJSArray -> IO JSVal #else -objCallAsConstructor = undefined +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 diff --git a/src/Language/Javascript/JSaddle/PropRef.hs b/src/Language/Javascript/JSaddle/PropRef.hs deleted file mode 100644 --- a/src/Language/Javascript/JSaddle/PropRef.hs +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Language.Javascript.JSaddle.PropRef --- Copyright : (c) Hamish Mackenzie --- License : MIT --- --- Maintainer : Hamish Mackenzie --- --- | Implements a reference to a property --- ------------------------------------------------------------------------------ - -module Language.Javascript.JSaddle.PropRef ( - JSPropRef(..) -) where - -import Language.Javascript.JSaddle.Types - (JSStringRef, JSObjectRef, Index) - --- | A reference to a property. --- Implemented as a reference to an object and something to find the property. -data JSPropRef = JSPropRef JSObjectRef JSStringRef -- ^ Object and property name. - | JSPropIndexRef JSObjectRef Index -- ^ Object and property index. - - diff --git a/src/Language/Javascript/JSaddle/Properties.hs b/src/Language/Javascript/JSaddle/Properties.hs --- a/src/Language/Javascript/JSaddle/Properties.hs +++ b/src/Language/Javascript/JSaddle/Properties.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) +#ifdef ghcjs_HOST_OS {-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-} #endif ----------------------------------------------------------------------------- @@ -21,176 +21,118 @@ ----------------------------------------------------------------------------- module Language.Javascript.JSaddle.Properties ( - -- * Propery Reference - JSPropRef(..) - , MakePropRef(..) - -- * Getting Property Values - , objGetPropertyByName + objGetPropertyByName , objGetPropertyAtIndex - , objGetProperty - , objGetProperty' -- * Setting Property Values , objSetPropertyByName , objSetPropertyAtIndex - , objSetProperty ) where -import Control.Applicative ((<$>)) -import Language.Javascript.JSaddle.PropRef (JSPropRef(..)) import Language.Javascript.JSaddle.Classes - (MakePropRef(..), MakeObjectRef(..), MakeValueRef(..), - MakeArgRefs(..), MakeStringRef(..)) + (ToJSVal(..), ToJSString(..)) import Language.Javascript.JSaddle.Monad (JSM) import Language.Javascript.JSaddle.Types - (JSValueRefRef, JSObjectRef, JSPropertyAttributes, - Index(..), JSStringRef) -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) + (MutableJSArray, Object(..), JSPropertyAttributes, + Index) +#ifdef ghcjs_HOST_OS +import Language.Javascript.JSaddle.Types (JSString) #else import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef (jsobjectgetpropertyatindex, jsobjectgetproperty, - jsobjectsetpropertyatindex, jsobjectsetproperty, - JSPropertyAttributes) + jsobjectsetpropertyatindex, jsobjectsetproperty) +import Language.Javascript.JSaddle.Native + (makeNewJSVal, withObject, withJSString, withToJSVal) #endif import Control.Monad.Trans.Reader (ask) import Control.Monad.IO.Class (MonadIO(..)) -import Language.Javascript.JSaddle.Exception (rethrow) -import Language.Javascript.JSaddle.Value (JSValueRef) +import Language.Javascript.JSaddle.Value (JSVal) import Language.Javascript.JSaddle.Arguments () import Language.Javascript.JSaddle.String () --- | If we already have a JSPropRef we are fine -instance MakePropRef JSPropRef where - makePropRef = return - --- | JSPropRef can be made by evaluating a function in 'JSM' as long --- as it returns something we can make into a JSPropRef. -instance MakePropRef prop => MakePropRef (JSM prop) where - makePropRef prop = prop >>= makePropRef - --- | We can use a property as an object. -instance MakeObjectRef JSPropRef where - makeObjectRef = objGetProperty - --- | We can use a property as a value. -instance MakeValueRef JSPropRef where - makeValueRef = objGetProperty - --- | We can pass a property as the only paramter to a function. -instance MakeArgRefs JSPropRef where - makeArgRefs p = do - rarg <- objGetProperty p - return [rarg] - -- | Get a property value given the object and the name of the property. -objGetPropertyByName :: MakeStringRef name - => JSObjectRef -- ^ object to find the property on. +objGetPropertyByName :: ToJSString name + => Object -- ^ object to find the property on. -> name -- ^ name of the property. - -> JSValueRefRef -- ^ exception if one is raised. - -> JSM JSValueRef -- ^ returns the property value. -#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI) -objGetPropertyByName this name = liftIO . js_tryGetProp (makeStringRef name) this + -> MutableJSArray -- ^ exception if one is raised. + -> JSM JSVal -- ^ returns the property value. +#ifdef ghcjs_HOST_OS +objGetPropertyByName this name = liftIO . js_tryGetProp (toJSString name) this +{-# INLINE objGetPropertyByName #-} foreign import javascript unsafe "try { $r=$2[$1] } catch(e) { $3[0] = e }" - js_tryGetProp :: JSStringRef -> JSObjectRef -> JSValueRefRef -> IO JSValueRef -#elif defined(USE_WEBKIT) + js_tryGetProp :: JSString -> Object -> MutableJSArray -> IO JSVal +#else objGetPropertyByName this name exceptions = do gctxt <- ask - liftIO $ jsobjectgetproperty gctxt this (makeStringRef name) exceptions -#else -objGetPropertyByName = undefined + withObject this $ \rthis -> + withJSString (toJSString name) $ \name' -> + (liftIO $ jsobjectgetproperty gctxt rthis name' exceptions) >>= makeNewJSVal +{-# INLINE objGetPropertyByName #-} #endif -- | Get a property value given the object and the index of the property. -objGetPropertyAtIndex :: JSObjectRef -- ^ object to find the property on. +objGetPropertyAtIndex :: Object -- ^ object to find the property on. -> Index -- ^ index of the property. - -> JSValueRefRef -- ^ exception if one is raised. - -> JSM JSValueRef -- ^ returns the property value. -#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI) + -> MutableJSArray -- ^ exception if one is raised. + -> JSM JSVal -- ^ returns the property value. +#ifdef ghcjs_HOST_OS objGetPropertyAtIndex this index = liftIO . js_tryIndex index this +{-# INLINE objGetPropertyAtIndex #-} foreign import javascript unsafe "try { $r=$2[$1] } catch(e) { $3[0] = e }" - js_tryIndex :: Index -> JSObjectRef -> JSValueRefRef -> IO JSValueRef -#elif defined(USE_WEBKIT) + js_tryIndex :: Index -> Object -> MutableJSArray -> IO JSVal +#else objGetPropertyAtIndex this index exceptions = do gctxt <- ask - liftIO $ jsobjectgetpropertyatindex gctxt this index exceptions -#else -objGetPropertyAtIndex = undefined + withObject this $ \rthis -> + (liftIO $ jsobjectgetpropertyatindex gctxt rthis index exceptions) >>= makeNewJSVal +{-# INLINE objGetPropertyAtIndex #-} #endif --- | Gets the value of a property given a 'JSPropRef'. -objGetProperty :: JSPropRef -- ^ property reference. - -> JSM JSValueRef -- ^ returns the property value. -objGetProperty (JSPropRef this name ) = - rethrow $ objGetPropertyByName this name -objGetProperty (JSPropIndexRef this index) = - rethrow $ objGetPropertyAtIndex this index - --- | This version of 'objGetProperty' is handy when you also need to perform. --- another operation on the object the property is on. -objGetProperty' :: JSPropRef -- ^ property reference. - -> JSM (JSObjectRef, JSValueRef) -- ^ returns the object and property value. -objGetProperty' (JSPropRef this name) = do - p <- rethrow $ objGetPropertyByName this name - return (this, p) -objGetProperty' (JSPropIndexRef this index) = do - p <- rethrow $ objGetPropertyAtIndex this index - return (this, p) - - -- | Set a property value given the object and the name of the property. -objSetPropertyByName :: (MakeStringRef name, MakeValueRef val) - => JSObjectRef -- ^ object to set the property on. +objSetPropertyByName :: (ToJSString name, ToJSVal val) + => Object -- ^ object to set the property on. -> name -- ^ name of the property. -> val -- ^ new value to set the property to. -> JSPropertyAttributes -- ^ property attributes to give the property. - -> JSValueRefRef -- ^ exception if one is raised. + -> MutableJSArray -- ^ exception if one is raised. -> JSM () -#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI) +#ifdef ghcjs_HOST_OS objSetPropertyByName this name val attributes exceptions = do - vref <- makeValueRef val - liftIO $ js_trySetProp (makeStringRef name) this vref exceptions + vref <- toJSVal val + liftIO $ js_trySetProp (toJSString name) this vref exceptions +{-# INLINE objSetPropertyByName #-} foreign import javascript unsafe "try { $2[$1]=$3 } catch(e) { $4[0] = e }" - js_trySetProp :: JSStringRef -> JSObjectRef -> JSValueRef -> JSValueRefRef -> IO () -#elif defined(USE_WEBKIT) + js_trySetProp :: JSString -> Object -> JSVal -> MutableJSArray -> IO () +#else objSetPropertyByName this name val attributes exceptions = do gctxt <- ask - vref <- makeValueRef val - liftIO $ jsobjectsetproperty gctxt this (makeStringRef name) vref attributes exceptions -#else -objSetPropertyByName = undefined + withObject this $ \rthis -> + withJSString (toJSString name) $ \name' -> + withToJSVal val $ \rval -> + liftIO $ jsobjectsetproperty gctxt rthis name' rval attributes exceptions +{-# INLINE objSetPropertyByName #-} #endif -- | Set a property value given the object and the index of the property. -objSetPropertyAtIndex :: (MakeValueRef val) - => JSObjectRef -- ^ object to find property on. +objSetPropertyAtIndex :: (ToJSVal val) + => Object -- ^ object to find property on. -> Index -- ^ index of the property. -> val -- ^ new value to set the property to. - -> JSValueRefRef -- ^ exception if one is raised. + -> MutableJSArray -- ^ exception if one is raised. -> JSM () -#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI) +#ifdef ghcjs_HOST_OS objSetPropertyAtIndex this index val exceptions = do - vref <- makeValueRef val + vref <- toJSVal val liftIO $ js_trySetAtIndex index this vref exceptions +{-# INLINE objSetPropertyAtIndex #-} foreign import javascript unsafe "try { $2[$1]=$3 } catch(e) { $4[0] = e }" - js_trySetAtIndex :: Index -> JSObjectRef -> JSValueRef -> JSValueRefRef -> IO () -#elif defined(USE_WEBKIT) + js_trySetAtIndex :: Index -> Object -> JSVal -> MutableJSArray -> IO () +#else objSetPropertyAtIndex this index val exceptions = do gctxt <- ask - vref <- makeValueRef val - liftIO $ jsobjectsetpropertyatindex gctxt this index vref exceptions -#else -objSetPropertyAtIndex = undefined + withObject this $ \rthis -> + withToJSVal val $ \rval -> + liftIO $ jsobjectsetpropertyatindex gctxt rthis index rval exceptions +{-# INLINE objSetPropertyAtIndex #-} #endif - --- | Sets the value of a property given a 'JSPropRef'. -objSetProperty :: (MakeValueRef val) - => JSPropRef -- ^ property reference. - -> val -- ^ new value to set the property to. - -> JSM () -objSetProperty (JSPropRef this name ) val = rethrow $ objSetPropertyByName this name val 0 -objSetProperty (JSPropIndexRef this index) val = rethrow $ objSetPropertyAtIndex this index val - - - - diff --git a/src/Language/Javascript/JSaddle/String.hs b/src/Language/Javascript/JSaddle/String.hs --- a/src/Language/Javascript/JSaddle/String.hs +++ b/src/Language/Javascript/JSaddle/String.hs @@ -14,61 +14,63 @@ ----------------------------------------------------------------------------- module Language.Javascript.JSaddle.String ( - JSStringRef - , MakeStringRef(..) + JSString + , ToJSString(..) -- * Data.Text helpers , strToText , textToStr + , nullJSString ) where import Data.Text (Text) -import qualified Data.Text as T (unpack, pack) import Control.Monad.IO.Class (MonadIO(..)) -import Language.Javascript.JSaddle.Types (JSStringRef) -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) -import GHCJS.Foreign (fromJSString, toJSString) +import Language.Javascript.JSaddle.Types (JSString) +#ifdef ghcjs_HOST_OS +import Data.JSString.Text (textFromJSString, textToJSString) +import GHCJS.Marshal.Internal (PFromJSVal(..)) +import GHCJS.Types (nullRef) #else import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef (jsstringcreatewithcharacters, jsstringgetcharactersptr, - jsstringgetlength, jsstringcreatewithutf8cstring) -#endif + jsstringgetlength) +import Language.Javascript.JSaddle.Native (makeNewJSString, withJSString) +import System.IO.Unsafe (unsafePerformIO) +import Foreign.ForeignPtr (newForeignPtr_) +import Foreign.Ptr (nullPtr) import qualified Data.Text.Foreign as T (fromPtr) import Foreign (castPtr) import Data.Text.Foreign (useAsPtr) -import Language.Javascript.JSaddle.Classes (MakeStringRef(..)) -import System.IO.Unsafe (unsafePerformIO) - --- | If we already have a JSStringRef we are fine -instance MakeStringRef JSStringRef where - makeStringRef = id - -instance MakeStringRef Text where - makeStringRef = textToStr - -instance MakeStringRef String where - makeStringRef = textToStr . T.pack +#endif +import Language.Javascript.JSaddle.Classes (ToJSString(..)) -- | Convert a JavaScript string to a Haskell 'Text' -strToText :: MonadIO m => JSStringRef -> m Text -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) -strToText = return . fromJSString +strToText :: MonadIO m => JSString -> m Text +#ifdef ghcjs_HOST_OS +strToText = return . textFromJSString #else -strToText jsstring = liftIO $ do +strToText jsstring' = liftIO $ withJSString jsstring' $ \jsstring -> do l <- jsstringgetlength jsstring p <- jsstringgetcharactersptr jsstring T.fromPtr (castPtr p) (fromIntegral l) #endif +{-# INLINE strToText #-} -- | Convert a Haskell 'Text' to a JavaScript string -textToStr :: Text -> JSStringRef -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) -textToStr = toJSString +textToStr :: Text -> JSString +#ifdef ghcjs_HOST_OS +textToStr = textToJSString #else textToStr text = unsafePerformIO $ useAsPtr text $ \p l -> - jsstringcreatewithcharacters (castPtr p) (fromIntegral l) + jsstringcreatewithcharacters (castPtr p) (fromIntegral l) >>= makeNewJSString #endif - +{-# INLINE textToStr #-} +nullJSString :: JSString +#ifdef ghcjs_HOST_OS +nullJSString = pFromJSVal nullRef +#else +nullJSString = unsafePerformIO $ newForeignPtr_ nullPtr +#endif diff --git a/src/Language/Javascript/JSaddle/Test.hs b/src/Language/Javascript/JSaddle/Test.hs new file mode 100644 --- /dev/null +++ b/src/Language/Javascript/JSaddle/Test.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE RecordWildCards #-} +----------------------------------------------------------------------------- +-- +-- Module : TestJSC +-- Copyright : (c) Hamish Mackenzie +-- License : MIT +-- +-- Maintainer : Hamish Mackenzie +-- +-- | +-- +----------------------------------------------------------------------------- + +module Language.Javascript.JSaddle.Test ( + testJSaddle + , showJSaddle + , listWindowProperties +) where + +import Control.Applicative +import Prelude hiding((!!), catch) +import Graphics.UI.Gtk + (Window, widgetDestroy, postGUIAsync, postGUISync, widgetShowAll, + mainGUI, mainQuit, on, objectDestroy, containerAdd, scrolledWindowNew, + windowSetPosition, windowSetDefaultSize, timeoutAddFull, windowNew, + initGUI) +import Control.Concurrent + (tryTakeMVar, forkIO, newMVar, putMVar, takeMVar, newEmptyMVar, + yield) +import System.Glib.MainLoop (priorityLow) +import Graphics.UI.Gtk.General.Enums (WindowPosition(..)) +import Graphics.UI.Gtk.WebKit.WebView + (webViewGetMainFrame, webViewNew) +import System.IO.Unsafe (unsafePerformIO) +import Control.Monad.Trans.Reader (runReaderT) +import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame + (webFrameGetGlobalContext) +import Language.Javascript.JSaddle +import qualified Data.Text as T +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad (forM, when) +import Control.Lens.Getter ((^.)) +import Data.Monoid ((<>)) +import Control.Concurrent.MVar (MVar) + +data TestState = TestState { jsContext :: JSContextRef, window :: Window } + +state :: MVar (Maybe TestState) +state = unsafePerformIO $ newMVar Nothing +{-# NOINLINE state #-} + +done :: MVar () +done = unsafePerformIO newEmptyMVar +{-# NOINLINE done #-} + +-- >>> testJSaddle $ ((global ^. js "console" . js "log") # ["Hello"]) +testJSaddle :: ToJSVal val => JSM val -> IO () +testJSaddle = testJSaddle' False + +-- >>> showJSaddle $ eval "document.body.innerHTML = 'Test'" +showJSaddle :: ToJSVal val => JSM val -> IO () +showJSaddle = testJSaddle' True + +debugLog :: String -> IO () +debugLog = putStrLn + +testJSaddle' :: ToJSVal val => Bool -> JSM val -> IO () +testJSaddle' showWindow f = do + debugLog "taking done" + _ <- tryTakeMVar done + debugLog "taking state" + mbState <- takeMVar state + TestState {..} <- case mbState of + Nothing -> do + debugLog "newState" + newState <- newEmptyMVar + debugLog "fork" + _ <- forkIO $ do + debugLog "initGUI" + _ <- initGUI + debugLog "windowNew" + window <- windowNew + debugLog "timeoutAdd" + _ <- timeoutAddFull (yield >> return True) priorityLow 10 + windowSetDefaultSize window 900 600 + windowSetPosition window WinPosCenter + scrollWin <- scrolledWindowNew Nothing Nothing + webView <- webViewNew + window `containerAdd` scrollWin + scrollWin `containerAdd` webView + _ <- on window objectDestroy $ do + debugLog "onDestroy" + _ <- tryTakeMVar state + debugLog "put state" + putMVar state Nothing + debugLog "mainQuit" + mainQuit + debugLog "put done" + putMVar done () + return () + debugLog "get context" + jsContext <- webViewGetMainFrame webView >>= webFrameGetGlobalContext + debugLog "put initial state" + putMVar newState TestState {..} + debugLog "maybe show" + when showWindow $ widgetShowAll window + debugLog "mainGUI" + mainGUI + debugLog "mainGUI exited" + takeMVar newState + Just s@TestState {..} -> do + debugLog "maybe show (2)" + when showWindow . postGUISync $ widgetShowAll window + return s + x <- postGUISync $ runReaderT ((f >>= valToText >>= liftIO . putStrLn . T.unpack) + `catch` \ (JSException e) -> valToText e >>= liftIO . putStrLn . T.unpack) jsContext + debugLog "put state" + putMVar state $ Just TestState {..} + return x + +listWindowProperties :: IO () +listWindowProperties = testJSaddle $ T.pack . show <$> do + window <- jsg "window" + names <- propertyNames window + forM names $ \name -> do + v <- window ^. js name >>= valToText + n <- strToText name + return (n, v) + `catch` + \(JSException e) -> do + n <- strToText name + msg <- valToText e + return (n, T.pack " error " <> msg) + + + + + + + + + diff --git a/src/Language/Javascript/JSaddle/Types.hs b/src/Language/Javascript/JSaddle/Types.hs --- a/src/Language/Javascript/JSaddle/Types.hs +++ b/src/Language/Javascript/JSaddle/Types.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP, FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- -- Module : Language.Javascript.JSaddle.Properties @@ -12,42 +13,57 @@ ----------------------------------------------------------------------------- module Language.Javascript.JSaddle.Types ( - JSValueRef(..) - , JSValueRefRef(..) - , JSObjectRef(..) - , JSPropertyNameArrayRef(..) - , JSPropertyAttributes(..) - , JSContextRef(..) - , JSStringRef(..) - , Index(..) + JSVal + , MutableJSArray + , Object(..) + , JSPropertyNameArray + , JSPropertyAttributes + , JSContextRef + , JSString + , Index + , Nullable(..) + , JSM ) where -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) +import Control.Monad.Trans.Reader (ReaderT(..)) +#ifdef ghcjs_HOST_OS import GHCJS.Types +import JavaScript.Object.Internal (Object(..)) +import JavaScript.Array (MutableJSArray) import Data.Word (Word(..)) +import GHCJS.Nullable (Nullable(..)) #else +import Foreign.ForeignPtr (ForeignPtr) import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase - (JSValueRef, JSValueRefRef, JSObjectRef, JSStringRef, - JSContextRef, JSPropertyNameArrayRef) + (OpaqueJSString, JSValueRefRef, + JSContextRef, JSPropertyNameArrayRef, OpaqueJSValue) import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef (JSPropertyAttributes) import Foreign.C (CUInt(..)) #endif -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) -data ValueOrObject -data Object -data PropertyNameArray -type JSValueRef = JSRef ValueOrObject -type JSValueRefRef = JSArray ValueOrObject -type JSObjectRef = JSRef ValueOrObject -type JSPropertyNameArrayRef = JSRef PropertyNameArray +#ifdef ghcjs_HOST_OS +newtype JSPropertyNameArray = JSPropertyNameArray { unJSPropertyNameArrayRef :: JSVal } type JSPropertyAttributes = Word type JSContextRef = () -type JSStringRef = JSString type Index = Int - -instance Show (JSRef ValueOrObject) -instance Eq (JSRef ValueOrObject) #else +type JSVal = ForeignPtr OpaqueJSValue +type MutableJSArray = JSValueRefRef +type JSPropertyNameArray = JSPropertyNameArrayRef type Index = CUInt +newtype Object = Object (ForeignPtr OpaqueJSValue) +type JSString = ForeignPtr OpaqueJSString +newtype Nullable a = Nullable a #endif + +-- | The @JSM@ monad keeps track of the JavaScript context. +-- +-- Given a @JSM@ function and a 'JSContextRef' you can run the +-- function like this... +-- +-- > runReaderT jsmFunction javaScriptContext +-- +-- For an example of how to set up WebKitGTK+ see tests/TestJSaddle.hs +type JSM = ReaderT JSContextRef IO + + diff --git a/src/Language/Javascript/JSaddle/Value.hs b/src/Language/Javascript/JSaddle/Value.hs --- a/src/Language/Javascript/JSaddle/Value.hs +++ b/src/Language/Javascript/JSaddle/Value.hs @@ -2,9 +2,11 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) +{-# LANGUAGE LambdaCase #-} +#ifdef ghcjs_HOST_OS {-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-} #endif +{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- -- Module : Language.Javascript.JSaddle.Value @@ -31,16 +33,15 @@ module Language.Javascript.JSaddle.Value ( -- * JavaScript value references - JSValueRef - , MakeValueRef(..) + JSVal + , ToJSVal(..) -- * Haskell types for JavaScript values , JSNull(..) - , JSUndefined(..) - , JSBool(..) - , JSNumber(..) - , JSString(..) + , JSUndefined + , JSString , JSValue(..) + , showJSValue -- * Converting JavaScript values , valToBool @@ -53,68 +54,92 @@ -- * Make JavaScript values from Haskell ones , val , valMakeNull + , valIsNull , valMakeUndefined + , valIsUndefined + , maybeNullOrUndefined + , maybeNullOrUndefined' , valMakeBool , valMakeNumber , valMakeString - -- * Conver to and from JSValue + -- * Convert to and from JSValue , deRefVal , valMakeRef + , strictEqual + , instanceOf ) where +import Control.Applicative import Prelude hiding (catch) import Language.Javascript.JSaddle.Types - (JSValueRefRef, JSObjectRef, JSStringRef, JSValueRef) -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) -import GHCJS.Types (castRef, JSRef(..)) -import GHCJS.Foreign (toJSBool, fromJSBool', jsNull, jsUndefined, toJSString) -import GHCJS.Marshal (toJSRef) + (Object(..), JSString, JSVal) +#ifdef ghcjs_HOST_OS +import Language.Javascript.JSaddle.Types + (MutableJSArray) +import GHCJS.Types (JSVal(..), isNull, isUndefined) +import GHCJS.Foreign (toJSBool, isTruthy, jsNull, jsUndefined) +import qualified GHCJS.Marshal as GHCJS (toJSVal) +import GHCJS.Marshal.Pure (pToJSVal) +import Data.JSString.Text (textToJSString) #else import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef - (jsvaluecreatejsonstring, JSType(..), jsvaluegettype, - jsvaluemakestring, jsvaluemakenumber, jsvaluemakeboolean, - jsvaluemakeundefined, jsvaluemakenull, jsvaluetoobject, - jsvaluetostringcopy, jsvaluetonumber, jsvaluetoboolean) -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef - (jsstringgetcharactersptr, jsstringgetlength) + (jsvalueisinstanceofconstructor, jsvaluecreatejsonstring, + JSType(..), jsvaluegettype, jsvaluemakestring, jsvaluemakenumber, + jsvaluemakeboolean, jsvaluemakeundefined, jsvaluemakenull, + jsvaluetoobject, jsvaluetostringcopy, jsvaluetonumber, + jsvaluetoboolean, jsvalueisnull, jsvalueisundefined, + jsvalueisstrictequal) +import Language.Javascript.JSaddle.Native + (makeNewJSVal, wrapJSString, withJSVal, withObject, withJSString, + withToJSVal) #endif -import Language.Javascript.JSaddle.Monad (JSM, catchval) +import Language.Javascript.JSaddle.Monad (JSM) import Language.Javascript.JSaddle.Exception (rethrow) import Control.Monad.Trans.Reader (ask) -import Control.Monad.IO.Class (MonadIO, MonadIO(..)) -import qualified Data.Text.Foreign as T (fromPtr) -import Foreign (castPtr) -import Data.Text.Foreign (useAsPtr) -import Control.Applicative ((<$>)) +import Control.Monad.IO.Class (MonadIO(..)) import Data.Text (Text) import qualified Data.Text as T (pack) import Language.Javascript.JSaddle.Classes - (MakeObjectRef(..), MakeStringRef(..), MakeValueRef(..), - MakeArgRefs(..)) + (MakeObject(..), ToJSString(..), ToJSVal(..)) import Language.Javascript.JSaddle.String (strToText, textToStr) -import Language.Javascript.JSaddle.Arguments () -import Data.Word (Word) +import Language.Javascript.JSaddle.Arguments (MakeArgs(..)) +import Data.Word (Word32, Word, Word64) +import Data.Int (Int32, Int64) +-- $setup +-- >>> import Language.Javascript.JSaddle.Test (testJSaddle) +-- >>> import Language.Javascript.JSaddle.Monad (catch) +-- >>> import Language.Javascript.JSaddle.Exception (JSException(..)) + data JSNull = JSNull -- ^ Type that represents a value that can only be null. -- Haskell of course has no null so we are adding this type. type JSUndefined = () -- ^ A type that can only be undefined in JavaScript. Using () -- because functions in JavaScript that have no return, impicitly -- return undefined. -type JSBool = Bool -- ^ JavaScript boolean values map the 'Bool' haskell type. -type JSNumber = Double -- ^ A number in JavaScript maps nicely to 'Double'. -type JSString = Text -- ^ JavaScript strings can be represented with the Haskell 'Text' type. +-- type JSBool = Bool -- ^ JavaScript boolean values map the 'Bool' haskell type. +-- type JSNumber = Double -- ^ A number in JavaScript maps nicely to 'Double'. +-- type JSString = Text -- ^ JavaScript strings can be represented with the Haskell 'Text' type. -- | An algebraic data type that can represent a JavaScript value. Any JavaScriptCore --- 'JSValueRef' can be converted into this type. +-- 'JSVal' can be converted into this type. data JSValue = ValNull -- ^ null | ValUndefined -- ^ undefined - | ValBool JSBool -- ^ true or false - | ValNumber JSNumber -- ^ a number - | ValString JSString -- ^ a string - | ValObject JSObjectRef -- ^ an object - deriving(Show, Eq) + | ValBool Bool -- ^ true or false + | ValNumber Double -- ^ a number + | ValString Text -- ^ a string + | ValObject Object -- ^ an object +-- | Show a JSValue but just say "object" if the value is a JavaScript object. +showJSValue :: JSValue -> String +showJSValue ValNull = "null" +showJSValue ValUndefined = "undefined" +showJSValue (ValBool True) = "true" +showJSValue (ValBool False) = "false" +showJSValue (ValNumber x) = show x +showJSValue (ValString s) = show s +showJSValue (ValObject _) = "object" + -- | Given a JavaScript value get its boolean value. -- All values in JavaScript convert to bool. -- @@ -134,15 +159,16 @@ -- false -- >>> testJSaddle $ valToBool "1" -- true -valToBool :: MakeValueRef val => val -> JSM JSBool -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) -valToBool val = fromJSBool' <$> makeValueRef val +valToBool :: ToJSVal value => value -> JSM Bool +#ifdef ghcjs_HOST_OS +valToBool value = isTruthy <$> toJSVal value #else -valToBool val = do +valToBool value = do gctxt <- ask - rval <- makeValueRef val - liftIO $ jsvaluetoboolean gctxt rval + withToJSVal value $ \rval -> + liftIO $ jsvaluetoboolean gctxt rval #endif +{-# INLINE valToBool #-} -- | Given a JavaScript value get its numeric value. -- May throw JSException. @@ -163,17 +189,17 @@ -- 0.0 -- >>> testJSaddle $ show <$> valToNumber "1" -- 1.0 -valToNumber :: MakeValueRef val => val -> JSM JSNumber -#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI) -valToNumber val = jsrefToNumber <$> makeValueRef val -foreign import javascript unsafe "$r = Number($1);" jsrefToNumber :: JSRef a -> Double -#elif defined(USE_WEBKIT) -valToNumber val = do - gctxt <- ask - rval <- makeValueRef val - rethrow $ liftIO . jsvaluetonumber gctxt rval +valToNumber :: ToJSVal value => value -> JSM Double +#ifdef ghcjs_HOST_OS +valToNumber value = jsrefToNumber <$> toJSVal value +{-# INLINE valToNumber #-} +foreign import javascript unsafe "$r = Number($1);" jsrefToNumber :: JSVal -> Double #else -valToNumber = undefined +valToNumber value = do + gctxt <- ask + withToJSVal value $ \rval -> + rethrow $ liftIO . jsvaluetonumber gctxt rval +{-# INLINE valToNumber #-} #endif -- | Given a JavaScript value get its string value (as a JavaScript string). @@ -195,17 +221,17 @@ -- -- >>> testJSaddle $ valToStr "1" >>= strToText -- 1 -valToStr :: MakeValueRef val => val -> JSM JSStringRef -#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI) -valToStr val = jsrefToString <$> makeValueRef val -foreign import javascript unsafe "$r = $1.toString();" jsrefToString :: JSRef a -> JSStringRef -#elif defined(USE_WEBKIT) -valToStr val = do - gctxt <- ask - rval <- makeValueRef val - rethrow $ liftIO . jsvaluetostringcopy gctxt rval +valToStr :: ToJSVal value => value -> JSM JSString +#ifdef ghcjs_HOST_OS +valToStr value = jsrefToString <$> toJSVal value +{-# INLINE valToStr #-} +foreign import javascript unsafe "$r = $1.toString();" jsrefToString :: JSVal -> JSString #else -valToStr = undefined +valToStr value = do + gctxt <- ask + withToJSVal value $ \rval -> + rethrow (liftIO . jsvaluetostringcopy gctxt rval) >>= wrapJSString +{-# INLINE valToStr #-} #endif -- | Given a JavaScript value get its string value (as a Haskell 'Text'). @@ -227,8 +253,9 @@ -- "" -- >>> testJSaddle $ show <$> valToText "1" -- "1" -valToText :: MakeValueRef val => val -> JSM Text +valToText :: ToJSVal value => value -> JSM Text valToText jsvar = valToStr jsvar >>= strToText +{-# INLINE valToText #-} -- | Given a JavaScript value get a JSON string value. -- May throw JSException. @@ -251,17 +278,17 @@ -- "1" -- >>> testJSaddle $ obj >>= valToJSON 0 >>= strToText -- {} -valToJSON :: MakeValueRef val => Word -> val -> JSM JSStringRef -#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI) -valToJSON indent val = jsrefToJSON <$> makeValueRef val -foreign import javascript unsafe "$r = JSON.stringify($1);" jsrefToJSON :: JSRef a -> JSStringRef -#elif defined(USE_WEBKIT) -valToJSON indent val = do - gctxt <- ask - rval <- makeValueRef val - rethrow $ liftIO . jsvaluecreatejsonstring gctxt rval (fromIntegral indent) +valToJSON :: ToJSVal value => Word -> value -> JSM JSString +#ifdef ghcjs_HOST_OS +valToJSON indent value = jsrefToJSON <$> toJSVal value +{-# INLINE valToJSON #-} +foreign import javascript unsafe "$r = JSON.stringify($1);" jsrefToJSON :: JSVal -> JSString #else -valToJSON = undefined +valToJSON indent value = do + gctxt <- ask + withToJSVal value $ \rval -> + rethrow (liftIO . jsvaluecreatejsonstring gctxt rval (fromIntegral indent)) >>= wrapJSString +{-# INLINE valToJSON #-} #endif -- | Given a JavaScript value get its object value. @@ -283,187 +310,320 @@ -- -- >>> testJSaddle $ valToObject "1" -- 1 -valToObject :: MakeValueRef val => val -> JSM JSObjectRef -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) -valToObject val = castRef <$> makeValueRef val +valToObject :: ToJSVal value => value -> JSM Object +valToObject value = Object <$> +#ifdef ghcjs_HOST_OS + toJSVal value #else -valToObject val = do - gctxt <- ask - rval <- makeValueRef val - rethrow $ liftIO . jsvaluetoobject gctxt rval + do gctxt <- ask + withToJSVal value $ \rval -> + rethrow (liftIO . jsvaluetoobject gctxt rval) >>= makeNewJSVal #endif +{-# INLINE valToObject #-} --- | Convert to a JavaScript value (just an alias for 'makeValueRef') -val :: MakeValueRef value +instance MakeObject JSVal where + makeObject = valToObject + {-# INLINE makeObject #-} + +-- | Convert to a JavaScript value (just an alias for 'toJSVal') +val :: ToJSVal value => value -- ^ value to convert to a JavaScript value - -> JSM JSValueRef -val = makeValueRef + -> JSM JSVal +val = toJSVal +{-# INLINE val #-} --- | If we already have a JSValueRef we are fine -instance MakeValueRef JSValueRef where - makeValueRef = return +-- | If we already have a JSVal we are fine +instance ToJSVal JSVal where + toJSVal = return + {-# INLINE toJSVal #-} --- | A single JSValueRef can be used as the argument list -instance MakeArgRefs JSValueRef where - makeArgRefs arg = return [arg] +-- | A single JSVal can be used as the argument list +instance MakeArgs JSVal where + makeArgs arg = return [arg] + {-# INLINE makeArgs #-} --- | JSValueRef can be made by evaluating a function in 'JSM' as long --- as it returns something we can make into a JSValueRef. -instance MakeValueRef v => MakeValueRef (JSM v) where - makeValueRef v = v >>= makeValueRef +-- | JSVal can be made by evaluating a function in 'JSM' as long +-- as it returns something we can make into a JSVal. +instance ToJSVal v => ToJSVal (JSM v) where + toJSVal v = v >>= toJSVal + {-# INLINE toJSVal #-} ----------- null --------------- -- | Make a @null@ JavaScript value -valMakeNull :: JSM JSValueRef -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) +valMakeNull :: JSM JSVal +#ifdef ghcjs_HOST_OS valMakeNull = return jsNull #else -valMakeNull = ask >>= (liftIO . jsvaluemakenull) +valMakeNull = ask >>= (liftIO . jsvaluemakenull) >>= makeNewJSVal #endif +{-# INLINE valMakeNull #-} -- | Makes a @null@ JavaScript value -instance MakeValueRef JSNull where - makeValueRef = const valMakeNull +instance ToJSVal JSNull where + toJSVal = const valMakeNull + {-# INLINE toJSVal #-} -- | Makes an argument list with just a single @null@ JavaScript value -instance MakeArgRefs JSNull where - makeArgRefs _ = valMakeNull >>= (\ref -> return [ref]) +instance MakeArgs JSNull where + makeArgs _ = valMakeNull >>= (\ref -> return [ref]) + {-# INLINE makeArgs #-} +-- | Makes a JSVal or @null@ JavaScript value +instance ToJSVal a => ToJSVal (Maybe a) where + toJSVal Nothing = valMakeNull + toJSVal (Just a) = toJSVal a + {-# INLINE toJSVal #-} + +-- | Test a JavaScript value to see if it is @null@ +valIsNull :: ToJSVal value => value -> JSM Bool +#ifdef ghcjs_HOST_OS +valIsNull value = isNull <$> toJSVal value +#else +valIsNull value = do + gctxt <- ask + withToJSVal value $ \rval -> + liftIO $ jsvalueisnull gctxt rval +#endif +{-# INLINE valIsNull #-} + ----------- undefined --------------- -- | Make an @undefined@ JavaScript value -valMakeUndefined :: JSM JSValueRef -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) +valMakeUndefined :: JSM JSVal +#ifdef ghcjs_HOST_OS valMakeUndefined = return jsUndefined #else -valMakeUndefined = ask >>= (liftIO . jsvaluemakeundefined) +valMakeUndefined = ask >>= (liftIO . jsvaluemakeundefined) >>= makeNewJSVal #endif +{-# INLINE valMakeUndefined #-} -- | Makes an @undefined@ JavaScript value -instance MakeValueRef JSUndefined where - makeValueRef = const valMakeUndefined +instance ToJSVal JSUndefined where + toJSVal = const valMakeUndefined + {-# INLINE toJSVal #-} --We can't allow this if JSUndefined is () as () is no args not "(null)". --Use [()] instead. ---instance MakeArgRefs JSUndefined where --- makeArgRefs _ = valMakeUndefined >>= (\ref -> return [ref]) +--instance MakeArgs JSUndefined where +-- makeArgs _ = valMakeUndefined >>= (\ref -> return [ref]) --- | This allows us to pass no arguments easily (altenative would be to use @[]::[JSValueRef]@). -instance MakeArgRefs () where - makeArgRefs _ = return [] +-- | This allows us to pass no arguments easily (altenative would be to use @[]::[JSVal]@). +instance MakeArgs () where + makeArgs _ = return [] + {-# INLINE makeArgs #-} +-- | Test a JavaScript value to see if it is @undefined@ +valIsUndefined :: ToJSVal value => value -> JSM Bool +#ifdef ghcjs_HOST_OS +valIsUndefined value = isUndefined <$> toJSVal value +#else +valIsUndefined value = do + gctxt <- ask + withToJSVal value $ \rval -> + liftIO $ jsvalueisundefined gctxt rval +#endif +{-# INLINE valIsUndefined #-} + +-- | Convert a JSVal to a Maybe JSVal (converting null and undefined to Nothing) +maybeNullOrUndefined :: ToJSVal value => value -> JSM (Maybe JSVal) +maybeNullOrUndefined value = do + rval <- toJSVal value + valIsNull rval >>= \case + True -> return Nothing + _ -> + valIsUndefined rval >>= \case + True -> return Nothing + _ -> return (Just rval) +{-# INLINE maybeNullOrUndefined #-} + +maybeNullOrUndefined' :: ToJSVal value => (JSVal -> JSM a) -> value -> JSM (Maybe a) +maybeNullOrUndefined' f value = do + rval <- toJSVal value + valIsNull rval >>= \case + True -> return Nothing + _ -> + valIsUndefined rval >>= \case + True -> return Nothing + _ -> Just <$> f rval +{-# INLINE maybeNullOrUndefined' #-} + ----------- booleans --------------- -- | Make a JavaScript boolean value -valMakeBool :: JSBool -> JSM JSValueRef -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) -valMakeBool b = return . castRef $ toJSBool b +valMakeBool :: Bool -> JSM JSVal +#ifdef ghcjs_HOST_OS +valMakeBool b = return $ toJSBool b #else valMakeBool b = do gctxt <- ask - liftIO $ jsvaluemakeboolean gctxt b + liftIO (jsvaluemakeboolean gctxt b) >>= makeNewJSVal #endif +{-# INLINE valMakeBool #-} -- | Make a JavaScript boolean value -instance MakeValueRef Bool where - makeValueRef = valMakeBool +instance ToJSVal Bool where + toJSVal = valMakeBool + {-# INLINE toJSVal #-} -- | Makes an argument list with just a single JavaScript boolean value -instance MakeArgRefs Bool where - makeArgRefs b = valMakeBool b >>= (\ref -> return [ref]) +instance MakeArgs Bool where + makeArgs b = valMakeBool b >>= (\ref -> return [ref]) + {-# INLINE makeArgs #-} ----------- numbers --------------- -- | Make a JavaScript number -valMakeNumber :: JSNumber -> JSM JSValueRef -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) -valMakeNumber n = liftIO $ castRef <$> toJSRef n +valMakeNumber :: Double -> JSM JSVal +#ifdef ghcjs_HOST_OS +valMakeNumber n = liftIO $ GHCJS.toJSVal n #else valMakeNumber n = do gctxt <- ask - liftIO $ jsvaluemakenumber gctxt n + liftIO (jsvaluemakenumber gctxt n) >>= makeNewJSVal #endif +{-# INLINE valMakeNumber #-} -- | Makes a JavaScript number -instance MakeValueRef Double where - makeValueRef = valMakeNumber +instance ToJSVal Double where + toJSVal = valMakeNumber + {-# INLINE toJSVal #-} +instance ToJSVal Float where + toJSVal = valMakeNumber . realToFrac + {-# INLINE toJSVal #-} + +instance ToJSVal Word where + toJSVal = valMakeNumber . fromIntegral + {-# INLINE toJSVal #-} + +instance ToJSVal Word32 where + toJSVal = valMakeNumber . fromIntegral + {-# INLINE toJSVal #-} + +instance ToJSVal Word64 where + toJSVal = valMakeNumber . fromIntegral + {-# INLINE toJSVal #-} + +instance ToJSVal Int where + toJSVal = valMakeNumber . fromIntegral + {-# INLINE toJSVal #-} + +instance ToJSVal Int32 where + toJSVal = valMakeNumber . fromIntegral + {-# INLINE toJSVal #-} + +instance ToJSVal Int64 where + toJSVal = valMakeNumber . fromIntegral + {-# INLINE toJSVal #-} + -- | Makes an argument list with just a single JavaScript number -instance MakeArgRefs Double where - makeArgRefs n = valMakeNumber n >>= (\ref -> return [ref]) +instance MakeArgs Double where + makeArgs n = valMakeNumber n >>= (\ref -> return [ref]) + {-# INLINE makeArgs #-} ------------ numbers --------------- --- | Make a JavaScript string -valMakeString :: Text -> JSM JSValueRef -#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT) -valMakeString = return . castRef . toJSString +-- | Make a JavaScript string from `Text` +valMakeText :: Text -> JSM JSVal +#ifdef ghcjs_HOST_OS +valMakeText = return . pToJSVal . textToJSString #else -valMakeString text = do +valMakeText text = do gctxt <- ask - liftIO $ jsvaluemakestring gctxt (textToStr text) + withJSString (textToStr text) $ \s -> + liftIO (jsvaluemakestring gctxt s) >>= makeNewJSVal #endif +{-# INLINE valMakeText #-} +-- | Make a JavaScript string from `JSString` +valMakeString :: JSString -> JSM JSVal +#ifdef ghcjs_HOST_OS +valMakeString = return . pToJSVal +#else +valMakeString str = do + gctxt <- ask + withJSString str $ \s -> + liftIO (jsvaluemakestring gctxt s) >>= makeNewJSVal +#endif +{-# INLINE valMakeString #-} + -- | Makes a JavaScript string -instance MakeValueRef Text where - makeValueRef = valMakeString +instance ToJSVal Text where + toJSVal = valMakeText + {-# INLINE toJSVal #-} -- | Makes an argument list with just a single JavaScript string -instance MakeArgRefs Text where - makeArgRefs t = valMakeString t >>= (\ref -> return [ref]) +instance MakeArgs Text where + makeArgs t = valMakeText t >>= (\ref -> return [ref]) + {-# INLINE makeArgs #-} -- | Makes a JavaScript string -instance MakeValueRef String where - makeValueRef = valMakeString . T.pack +instance ToJSVal String where + toJSVal = valMakeText . T.pack + {-# INLINE toJSVal #-} +-- | Makes a JavaScript string +instance ToJSVal JSString where + toJSVal = valMakeString + {-# INLINE toJSVal #-} + +-- | If we already have a JSString we are fine +instance ToJSString JSString where + toJSString = id + {-# INLINE toJSString #-} + +instance ToJSString Text where + toJSString = textToStr + {-# INLINE toJSString #-} + +instance ToJSString String where + toJSString = textToStr . T.pack + {-# INLINE toJSString #-} + -- | Derefernce a value reference. -- --- >>> testJSaddle $ show <$> deRefVal JSNull +-- >>> testJSaddle $ showJSValue <$> deRefVal JSNull -- ValNull --- >>> testJSaddle $ show <$> deRefVal () +-- >>> testJSaddle $ showJSValue <$> deRefVal () -- ValUndefined --- >>> testJSaddle $ show <$> deRefVal True +-- >>> testJSaddle $ showJSValue <$> deRefVal True -- ValBool True --- >>> testJSaddle $ show <$> deRefVal False +-- >>> testJSaddle $ showJSValue <$> deRefVal False -- ValBool False --- >>> testJSaddle $ show <$> deRefVal (1.0 :: Double) +-- >>> testJSaddle $ showJSValue <$> deRefVal (1.0 :: Double) -- ValNumber 1.0 --- >>> testJSaddle $ show <$> deRefVal (0.0 :: Double) +-- >>> testJSaddle $ showJSValue <$> deRefVal (0.0 :: Double) -- ValNumber 0.0 --- >>> testJSaddle $ show <$> deRefVal "" +-- >>> testJSaddle $ showJSValue <$> deRefVal "" -- ValString "" --- >>> testJSaddle $ show <$> deRefVal "1" +-- >>> testJSaddle $ showJSValue <$> deRefVal "1" -- ValString "1" --- >>> testJSaddle $ show <$> valToObject True >>= deRefVal +-- >>> testJSaddle $ showJSValue <$> valToObject True >>= deRefVal -- ValObject 0x... -deRefVal :: MakeValueRef val => val -> JSM JSValue -#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI) -deRefVal val = do - gctxt <- ask - valref <- makeValueRef val +deRefVal :: ToJSVal value => value -> JSM JSValue +#ifdef ghcjs_HOST_OS +deRefVal value = do + valref <- toJSVal value case (jsrefGetType valref :: Int) of 0 -> return ValUndefined 1 -> return ValNull 2 -> ValBool <$> valToBool valref 3 -> ValNumber <$> valToNumber valref - 4 -> ValString <$> (valToStr valref >>= strToText) + 4 -> ValString <$> valToText valref 5 -> ValObject <$> valToObject valref foreign import javascript unsafe "$r = ($1 === undefined)?0:\ ($1===null)?1:\ (typeof $1===\"boolean\")?2:\ (typeof $1===\"number\")?3:\ (typeof $1===\"string\")?4:\ - (typeof $1===\"object\")?5:-1;" jsrefGetType :: JSValueRef -> Int -#elif defined(USE_WEBKIT) -deRefVal val = do - gctxt <- ask - valref <- makeValueRef val - t <- liftIO $ jsvaluegettype gctxt valref - case t of - Kjstypenull -> return ValNull - Kjstypeundefined -> return ValUndefined - Kjstypeboolean -> ValBool <$> valToBool valref - Kjstypenumber -> ValNumber <$> valToNumber valref - Kjstypestring -> ValString <$> (valToStr valref >>= strToText) - Kjstypeobject -> ValObject <$> valToObject valref + (typeof $1===\"object\")?5:-1;" jsrefGetType :: JSVal -> Int #else -deRefVal = undefined +deRefVal value = do + gctxt <- ask + v <- toJSVal value + withJSVal v $ \rval -> + liftIO (jsvaluegettype gctxt rval) >>= \case + Kjstypenull -> return ValNull + Kjstypeundefined -> return ValUndefined + Kjstypeboolean -> ValBool <$> valToBool v + Kjstypenumber -> ValNumber <$> valToNumber v + Kjstypestring -> ValString <$> valToText v + Kjstypeobject -> ValObject <$> valToObject v #endif -- | Make a JavaScript value out of a 'JSValue' ADT. @@ -478,24 +638,80 @@ -- "1" -- >>> testJSaddle $ valMakeRef (ValString $ pack "Hello") -- "Hello" -valMakeRef :: JSValue -> JSM JSValueRef -valMakeRef val = - case val of - ValNull -> valMakeNull - ValUndefined -> valMakeUndefined - ValBool b -> valMakeBool b - ValNumber n -> valMakeNumber n - ValString s -> valMakeString s - ValObject o -> return o +valMakeRef :: JSValue -> JSM JSVal +valMakeRef value = + case value of + ValNull -> valMakeNull + ValUndefined -> valMakeUndefined + ValBool b -> valMakeBool b + ValNumber n -> valMakeNumber n + ValString s -> valMakeText s + ValObject (Object o) -> return o -- | Makes a JavaScript value from a 'JSValue' ADT. -instance MakeValueRef JSValue where - makeValueRef = valMakeRef +instance ToJSVal JSValue where + toJSVal = valMakeRef + {-# INLINE toJSVal #-} -- | Makes an argument list with just a single JavaScript value from a 'JSValue' ADT. -instance MakeArgRefs JSValue where - makeArgRefs v = valMakeRef v >>= (\ref -> return [ref]) +instance MakeArgs JSValue where + makeArgs v = valMakeRef v >>= (\ref -> return [ref]) + {-# INLINE makeArgs #-} -instance MakeObjectRef JSNull where - makeObjectRef = const valMakeNull +--instance MakeObjectRef JSNull where +-- makeObjectRef _ = Object <$> valMakeNull +-- {-# INLINE makeObjectRef #-} + +#ifdef ghcjs_HOST_OS +foreign import javascript unsafe + "$1===$2" jsvalueisstrictequal :: JSVal -> JSVal -> Bool +#endif + +strictEqual :: (ToJSVal a, ToJSVal b) => a -> b -> JSM Bool +strictEqual a b = do + aval <- toJSVal a + bval <- toJSVal b +#ifdef ghcjs_HOST_OS + return $ jsvalueisstrictequal aval bval +#else + gctxt <- ask + withJSVal aval $ \aref -> + withJSVal bval $ \bref -> + liftIO $ jsvalueisstrictequal gctxt aref bref +#endif + +#ifdef ghcjs_HOST_OS +foreign import javascript unsafe "\ + try {\ + $r = $1 instanceof $2\ + }\ + catch(e) {\ + $3[0] = e;\ + }" + js_isInstanceOf :: JSVal -> Object -> MutableJSArray -> Bool +#endif + +instanceOf :: (ToJSVal value, MakeObject constructor) => value -> constructor -> JSM Bool +instanceOf value constructor = do + v <- toJSVal value + c <- makeObject constructor +#ifdef ghcjs_HOST_OS + rethrow $ return . js_isInstanceOf v c +#else + gctxt <- ask + withJSVal v $ \rval -> + withObject c $ \c' -> + rethrow $ liftIO . jsvalueisinstanceofconstructor gctxt rval c' +#endif + + + + + + + + + + + diff --git a/tests/DocTest.hs b/tests/DocTest.hs new file mode 100644 --- /dev/null +++ b/tests/DocTest.hs @@ -0,0 +1,21 @@ +module Main ( + main +) where + +import Test.DocTest + +main :: IO () +main = doctest ["-isrc", + "src/Language/Javascript/JSaddle/Arguments.hs", + "src/Language/Javascript/JSaddle/Classes.hs", + "src/Language/Javascript/JSaddle/Evaluate.hs", + "src/Language/Javascript/JSaddle/Exception.hs", + "src/Language/Javascript/JSaddle/Monad.hs", + "src/Language/Javascript/JSaddle/Native.hs", + "src/Language/Javascript/JSaddle/Object.hs", + "src/Language/Javascript/JSaddle/Properties.hs", + "src/Language/Javascript/JSaddle/String.hs", + "src/Language/Javascript/JSaddle/Test.hs", + "src/Language/Javascript/JSaddle/Types.hs", + "src/Language/Javascript/JSaddle/Value.hs" ] + diff --git a/tests/TestJSaddle.hs b/tests/TestJSaddle.hs deleted file mode 100644 --- a/tests/TestJSaddle.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} ------------------------------------------------------------------------------ --- --- Module : TestJSC --- Copyright : (c) Hamish Mackenzie --- License : MIT --- --- Maintainer : Hamish Mackenzie --- --- | --- ------------------------------------------------------------------------------ - -module Main ( - main -) where - -import Prelude hiding((!!), catch) -import Graphics.UI.Gtk - (Window, widgetDestroy, postGUIAsync, postGUISync, widgetShowAll, - mainGUI, mainQuit, on, objectDestroy, containerAdd, scrolledWindowNew, - windowSetPosition, windowSetDefaultSize, timeoutAddFull, windowNew, - initGUI) -import Control.Concurrent - (tryTakeMVar, forkIO, newMVar, putMVar, takeMVar, newEmptyMVar, - yield) -import System.Glib.MainLoop (priorityLow) -import Graphics.UI.Gtk.General.Enums (WindowPosition(..)) -import Graphics.UI.Gtk.WebKit.WebView - (webViewGetMainFrame, webViewNew) -import System.IO.Unsafe (unsafePerformIO) -import Control.Monad.Trans.Reader (runReaderT) -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase (JSContextRef) -import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame - (webFrameGetGlobalContext) -import Language.Javascript.JSaddle -import Data.Text (Text) -import qualified Data.Text as T -import Control.Applicative -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad (forM, when) -import System.Log.Logger (debugM) -import Control.Lens.Getter ((^.)) -import Data.Monoid ((<>)) - -data TestState = TestState { jsContext :: JSContextRef, window :: Window } - -state = unsafePerformIO $ newMVar Nothing -done = unsafePerformIO $ newEmptyMVar - --- >>> testJSaddle $ ((global ^. js "console" . js "log") # ["Hello"]) -testJSaddle :: MakeValueRef val => JSM val -> IO () -testJSaddle = testJSaddle' False - --- >>> showJSaddle $ eval "document.body.innerHTML = 'Test'" -showJSaddle :: MakeValueRef val => JSM val -> IO () -showJSaddle = testJSaddle' True - -debugLog = debugM "jsaddle" - -testJSaddle' :: MakeValueRef val => Bool -> JSM val -> IO () -testJSaddle' showWindow f = do - debugLog "taking done" - tryTakeMVar done - debugLog "taking state" - mbState <- takeMVar state - TestState {..} <- case mbState of - Nothing -> do - debugLog "newState" - newState <- newEmptyMVar - debugLog "fork" - forkIO $ do - debugLog "initGUI" - initGUI - debugLog "windowNew" - window <- windowNew - debugLog "timeoutAdd" - timeoutAddFull (yield >> return True) priorityLow 10 - windowSetDefaultSize window 900 600 - windowSetPosition window WinPosCenter - scrollWin <- scrolledWindowNew Nothing Nothing - webView <- webViewNew - window `containerAdd` scrollWin - scrollWin `containerAdd` webView - on window objectDestroy $ do - debugLog "onDestroy" - tryTakeMVar state - debugLog "put state" - putMVar state Nothing - debugLog "mainQuit" - mainQuit - debugLog "put done" - putMVar done () - return True - debugLog "get context" - jsContext <- webViewGetMainFrame webView >>= webFrameGetGlobalContext - debugLog "put initial state" - putMVar newState TestState {..} - debugLog "maybe show" - when showWindow $ widgetShowAll window - debugLog "mainGUI" - mainGUI - debugLog "mainGUI exited" - takeMVar newState - Just s@TestState {..} -> do - debugLog "maybe show (2)" - when showWindow . postGUISync $ widgetShowAll window - return s - x <- postGUISync $ runReaderT ((f >>= valToText >>= liftIO . putStrLn . T.unpack) - `catch` \ (JSException e) -> valToText e >>= liftIO . putStrLn . T.unpack) jsContext - debugLog "put state" - putMVar state $ Just TestState {..} - return x - -main = do - testJSaddle $ return () - Just TestState{..} <- takeMVar state - postGUIAsync $ widgetDestroy window - takeMVar done - -listWindowProperties = testJSaddle $ T.pack . show <$> do - window <- jsg "window" - names <- propertyNames window - forM names $ \name -> do - v <- window ^. js name >>= valToText - n <- strToText name - return (n, v) - `catch` - \(JSException e) -> do - n <- strToText name - msg <- valToText e - return (n, (T.pack $ " error ") <> msg) - - - - - - - - -