jsaddle 0.2.1.0 → 0.3.0.0

raw patch · 17 files changed

+1447/−887 lines, 17 filesdep +QuickCheckdep +doctestdep +ghcjs-primdep −hsloggerdep ~gtkdep ~gtk3dep ~lens

Dependencies added: QuickCheck, doctest, ghcjs-prim, vector

Dependencies removed: hslogger

Dependency ranges changed: gtk, gtk3, lens, text, transformers

Files

• jsaddle.cabal +69/−59
• src/Language/Javascript/JSaddle.hs +4/−2
• src/Language/Javascript/JSaddle/Arguments.hs +52/−28
• src/Language/Javascript/JSaddle/Classes.hs +19/−24
• src/Language/Javascript/JSaddle/Evaluate.hs +36/−27
• src/Language/Javascript/JSaddle/Exception.hs +4/−4
• src/Language/Javascript/JSaddle/Monad.hs +53/−25
• src/Language/Javascript/JSaddle/Native.hs +97/−0
• src/Language/Javascript/JSaddle/Object.hs +417/−195
• src/Language/Javascript/JSaddle/PropRef.hs +0/−25
• src/Language/Javascript/JSaddle/Properties.hs +60/−118
• src/Language/Javascript/JSaddle/String.hs +31/−29
• src/Language/Javascript/JSaddle/Test.hs +142/−0
• src/Language/Javascript/JSaddle/Types.hs +40/−24
• src/Language/Javascript/JSaddle/Value.hs +402/−186
• tests/DocTest.hs +21/−0
• tests/TestJSaddle.hs +0/−141

@@ -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 <Hamish.K.Mackenzie@googlemail.com> 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 <https://github.com/ghcjs/webkit-javascriptcore>.-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 <https://github.com/ghcjs/webkit-javascriptcore>. 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

@@ -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

@@ -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 #-} 

@@ -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 #-} 

@@ -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 #-}

@@ -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 

@@ -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 #-}+

@@ -0,0 +1,97 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+--+-- Module      :  Language.Javascript.JSaddle.Native+-- Copyright   :  (c) Hamish Mackenzie+-- License     :  MIT+--+-- Maintainer  :  Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>+--+-- |+--+-----------------------------------------------------------------------------++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+

@@ -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   

@@ -1,25 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.Javascript.JSaddle.PropRef--- Copyright   :  (c) Hamish Mackenzie--- License     :  MIT------ Maintainer  :  Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>------ | 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.--

@@ -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---- 

@@ -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 

@@ -0,0 +1,142 @@+{-# LANGUAGE RecordWildCards #-}+-----------------------------------------------------------------------------+--+-- Module      :  TestJSC+-- Copyright   :  (c) Hamish Mackenzie+-- License     :  MIT+--+-- Maintainer  :  Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>+--+-- |+--+-----------------------------------------------------------------------------++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)+++++++++

@@ -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++

@@ -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+++++++++++ 

@@ -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" ]+

@@ -1,141 +0,0 @@-{-# LANGUAGE RecordWildCards #-}------------------------------------------------------------------------------------ Module      :  TestJSC--- Copyright   :  (c) Hamish Mackenzie--- License     :  MIT------ Maintainer  :  Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>------ |-----------------------------------------------------------------------------------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)---------