diff --git a/data/index.html b/data/index.html new file mode 100644 --- /dev/null +++ b/data/index.html @@ -0,0 +1,9 @@ + + + +JSaddle + + + + + diff --git a/data/jsaddle.js b/data/jsaddle.js new file mode 100644 --- /dev/null +++ b/data/jsaddle.js @@ -0,0 +1,187 @@ +if(typeof global !== "undefined") { + global.window = global; + global.WebSocket = require('ws'); +} + +var connect = function() { + var wsaddress = + typeof window.location === "undefined" + ? "ws://localhost:3709/" + : window.location.protocol.replace('http', 'ws')+"//"+window.location.hostname+(window.location.port?(":"+window.location.port):""); + + var ws = new WebSocket(wsaddress); + + ws.onopen = function(e) { + var jsaddle_values = new Map(); + jsaddle_values.set(0, null); + jsaddle_values.set(1, undefined); + jsaddle_values.set(2, false); + jsaddle_values.set(3, true); + jsaddle_values.set(4, window); + var jsaddle_index = 100; + + ws.onmessage = function(e) { + try { + var batch = JSON.parse(e.data); + var nAsyncLength = batch[0].length; + for (var nAsync = 0; nAsync != nAsyncLength; nAsync++) { + var d = batch[0][nAsync]; + switch (d.tag) { + case "FreeRef": + jsaddle_values.delete(d.contents); + break; + case "SetPropertyByName": + jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]); + break; + case "SetPropertyAtIndex": + jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]); + break; + case "EvaluateScript": + var n = d.contents[1]; + jsaddle_values.set(n, eval(d.contents[0])); + break; + case "StringToValue": + var n = d.contents[1]; + jsaddle_values.set(n, d.contents[0]); + break; + case "GetPropertyByName": + var n = d.contents[2]; + jsaddle_values.set(n, jsaddle_values.get(d.contents[0])[d.contents[1]]); + break; + case "GetPropertyAtIndex": + var n = d.contents[2]; + jsaddle_values.set(n, jsaddle_values.get(d.contents[0])[d.contents[1]]); + break; + case "NumberToValue": + var n = d.contents[1]; + jsaddle_values.set(n, d.contents[0]); + break; + case "NewEmptyObject": + var n = d.contents; + jsaddle_values.set(n, {}); + break; + case "NewCallback": + var nFunction = d.contents; + jsaddle_values.set(nFunction, function() { + var nThis = ++jsaddle_index; + jsaddle_values.set(nThis, this); + var args = []; + for (var i = 0; i != arguments.length; i++) { + var nArg = ++jsaddle_index; + jsaddle_values.set(nArg, arguments[i]); + args[i] = nArg; + } + ws.send(JSON.stringify({"tag": "Callback", "contents": [nFunction, nThis, args]})); + }); + break; + case "CallAsFunction": + var n = d.contents[3]; + jsaddle_values.set(n, + jsaddle_values.get(d.contents[0]).apply(jsaddle_values.get(d.contents[1]), + d.contents[2].map(function(arg){return jsaddle_values.get(arg);}))); + break; + case "CallAsConstructor": + var n = d.contents[2]; + var r; + var f = jsaddle_values.get(d.contents[0]); + var a = d.contents[1].map(function(arg){return jsaddle_values.get(arg);}); + switch(a.length) { + case 0 : r = new f(); break; + case 1 : r = new f(a[0]); break; + case 2 : r = new f(a[0],a[1]); break; + case 3 : r = new f(a[0],a[1],a[2]); break; + case 4 : r = new f(a[0],a[1],a[2],a[3]); break; + case 5 : r = new f(a[0],a[1],a[2],a[3],a[4]); break; + case 6 : r = new f(a[0],a[1],a[2],a[3],a[4],a[5]); break; + case 7 : r = new f(a[0],a[1],a[2],a[3],a[4],a[5],a[6]); break; + default: + var ret; + var temp = function() { + ret = f.apply(this, a); + }; + temp.prototype = f.prototype; + var i = new temp(); + if(ret instanceof Object) + r = ret; + else { + i.constructor = f; + r = i; + } + } + jsaddle_values.set(n, r); + break; + case "NewArray": + var n = d.contents[1]; + jsaddle_values.set(n, d.contents[0].map(function(v){return jsaddle_values.get(v);})); + break; + default: + ws.send(JSON.stringify({"tag": "ProtocolError", "contents": e.data})); + return; + } + } + var d = batch[1]; + switch (d.tag) { + case "ValueToString": + var val = jsaddle_values.get(d.contents); + var s = val === null ? "null" : val === undefined ? "undefined" : val.toString(); + ws.send(JSON.stringify({"tag": "ValueToStringResult", "contents": s})); + break; + case "ValueToBool": + ws.send(JSON.stringify({"tag": "ValueToBoolResult", "contents": jsaddle_values.get(d.contents) ? true : false})); + break; + case "ValueToNumber": + ws.send(JSON.stringify({"tag": "ValueToNumberResult", "contents": Number(jsaddle_values.get(d.contents))})); + break; + case "ValueToJSON": + var s = jsaddle_values.get(d.contents) === undefined ? "" : JSON.stringify(jsaddle_values.get(d.contents)); + ws.send(JSON.stringify({"tag": "ValueToJSONResult", "contents": s})); + break; + case "DeRefVal": + var n = d.contents; + var v = jsaddle_values.get(n); + var c = (v === null ) ? [0, ""] : + (v === undefined ) ? [1, ""] : + (v === false ) ? [2, ""] : + (v === true ) ? [3, ""] : + (typeof v === "number") ? [-1, v.toString()] : + (typeof v === "string") ? [-2, v] + : [n, ""]; + ws.send(JSON.stringify({"tag": "DeRefValResult", "contents": c})); + break; + case "IsNull": + ws.send(JSON.stringify({"tag": "IsNullResult", "contents": jsaddle_values.get(d.contents) === null})); + break; + case "IsUndefined": + ws.send(JSON.stringify({"tag": "IsUndefinedResult", "contents": jsaddle_values.get(d.contents) === undefined})); + break; + case "InstanceOf": + ws.send(JSON.stringify({"tag": "InstanceOfResult", "contents": jsaddle_values.get(d.contents[0]) instanceof jsaddle_values.get(d.contents[1])})); + break; + case "StrictEqual": + ws.send(JSON.stringify({"tag": "StrictEqualResult", "contents": jsaddle_values.get(d.contents[0]) === jsaddle_values.get(d.contents[1])})); + break; + case "PropertyNames": + var result = []; + for (name in jsaddle_values.get(d.contents)) { result.push(name); } + ws.send(JSON.stringify({"tag": "PropertyNamesResult", "contents": result})); + break; + case "Sync": + ws.send(JSON.stringify({"tag": "SyncResult", "contents": []})); + break; + default: + ws.send(JSON.stringify({"tag": "ProtocolError", "contents": e.data})); + } + } + catch (err) { + var n = ++jsaddle_index; + jsaddle_values.set(n, err); + ws.send(JSON.stringify({"tag": "ThrowJSValue", "contents": n})); + } + }; + }; + ws.onerror = function() { + setTimeout(connect, 1000); + }; +} + +connect(); diff --git a/jsaddle.cabal b/jsaddle.cabal --- a/jsaddle.cabal +++ b/jsaddle.cabal @@ -1,5 +1,5 @@ name: jsaddle -version: 0.4.0.5 +version: 0.5.0.0 cabal-version: >=1.10 build-type: Simple license: MIT @@ -12,6 +12,9 @@ in the webkit-javascriptcore library . category: Web, Javascript author: Hamish Mackenzie +data-files: + data/index.html + data/jsaddle.js source-repository head type: git @@ -24,15 +27,23 @@ ghcjs-base -any, ghcjs-prim -any else - build-depends: - haskell-gi-base >= 0.17 && < 0.19, - gi-glib >=2.0.2 && <2.1, - gi-gtk >=3.0.2 && <3.1, - gi-webkit >=3.0.2 && <3.1, - gi-javascriptcore >=3.0.2 && <3.1, - webkitgtk3-javascriptcore >=0.14.0.0 && <0.15 exposed-modules: + Language.Javascript.JSaddle.WebSockets + Language.Javascript.JSaddle.WebSockets.Files Language.Javascript.JSaddle.Test + build-depends: + aeson >=0.8.0.2 && <1.1, + bytestring >=0.10.6.0 && <0.11, + containers >=0.5.6.2 && <0.6, + filepath >=1.4.0.0 && <1.5, + http-types >=0.8.6 && <0.10, + process >=1.2.3.0 && <1.5, + stm >=2.4.4 && <2.5, + wai >=3.0.3.0 && <3.3, + wai-app-static >=3.1.1 && <3.2, + wai-websockets >=3.0.0.6 && <3.1, + warp >=3.1.2 && <3.3, + websockets >=0.9.5.0 && <0.10 exposed-modules: Language.Javascript.JSaddle Language.Javascript.JSaddle.Arguments @@ -46,37 +57,40 @@ Language.Javascript.JSaddle.String Language.Javascript.JSaddle.Value Language.Javascript.JSaddle.Types + Paths_jsaddle build-depends: - template-haskell -any, base <5, lens >=3.8.5 && <4.15, - text >=0.11.2.3 && <1.3, - transformers >=0.3.0.0 && <0.6 + primitive >=0.6.1.0 && <0.7, + template-haskell -any, + text >=1.2.1.3 && <1.3, + transformers >=0.4.2.0 && <0.6 default-language: Haskell2010 hs-source-dirs: src ghc-options: -ferror-spans test-suite test-tool - if impl(ghcjs -any) - buildable: False - else - build-depends: - haskell-gi-base >= 0.17 && < 0.19, - gi-glib >=2.0.2 && <2.1, - gi-gtk >=3.0.2 && <3.1, - gi-webkit >=3.0.2 && <3.1, - gi-javascriptcore >=3.0.2 && <3.1, - webkitgtk3-javascriptcore >=0.14.0.0 && <0.15 type: exitcode-stdio-1.0 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 + base -any + if !impl(ghcjs) + build-depends: + QuickCheck -any, + bytestring >=0.10.6.0 && <0.11, + doctest >=0.10.1 && <0.12, + filepath >=1.4.0.0 && <1.5, + http-types >=0.8.6 && <0.10, + jsaddle -any, + process >=1.2.3.0 && <1.5, + text >=1.2.1.3 && <1.3, + vector >=0.10.12.3 && <0.12, + wai >=3.0.3.0 && <3.3, + wai-app-static >=3.1.1 && <3.2, + wai-websockets >=3.0.0.6 && <3.1, + warp >=3.1.2 && <3.3, + websockets >=0.9.5.0 && <0.10 default-language: Haskell2010 hs-source-dirs: tests - ghc-options: -ferror-spans + ghc-options: -ferror-spans -threaded diff --git a/src/Language/Javascript/JSaddle/Evaluate.hs b/src/Language/Javascript/JSaddle/Evaluate.hs --- a/src/Language/Javascript/JSaddle/Evaluate.hs +++ b/src/Language/Javascript/JSaddle/Evaluate.hs @@ -17,28 +17,24 @@ ----------------------------------------------------------------------------- module Language.Javascript.JSaddle.Evaluate ( - evaluateScript - , eval + eval ) where -import Control.Monad.Trans.Reader (ask) -import Control.Monad.IO.Class (MonadIO(..)) import Language.Javascript.JSaddle.Types (JSVal) #ifdef ghcjs_HOST_OS +import Control.Monad.IO.Class (MonadIO(..)) 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 Language.Javascript.JSaddle.Native - (makeNewJSVal, withObject, withJSString) + (wrapJSVal, withJSString) +import Language.Javascript.JSaddle.WebSockets + (AsyncCommand(..), Result(..), sendLazyCommand) +import Language.Javascript.JSaddle.Types (Result(..)) #endif -import Language.Javascript.JSaddle.Exception (rethrow) -import Language.Javascript.JSaddle.String (nullJSString) -import Language.Javascript.JSaddle.Object (nullObject) import Language.Javascript.JSaddle.Classes - (MakeObject(..), ToJSString(..)) + (ToJSString(..)) import Language.Javascript.JSaddle.Monad (JSM) -- $setup @@ -50,38 +46,19 @@ -- >>> testJSaddle $ return () -- ... --- | 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: ...,FileName,55 -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 JSVal -#ifdef ghcjs_HOST_OS -evaluateScript script this url line = liftIO $ js_eval (toJSString script) -foreign import javascript unsafe "$r = eval($1);" - js_eval :: JSString -> IO JSVal -#else -evaluateScript script this url line = do - gctxt <- ask - 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 -#endif - -- | Evaluates a script (like eval in java script) -- -- >>> testJSaddle $ eval "1+1" -- 2 -eval :: ToJSString script +eval :: (ToJSString script) => script -- ^ JavaScript to evaluate -> JSM JSVal -eval script = evaluateScript script nullObject nullJSString 1 +#ifdef ghcjs_HOST_OS +eval script = liftIO $ js_eval (toJSString script) +foreign import javascript unsafe "$r = eval($1);" + js_eval :: JSString -> IO JSVal +#else +eval script = do + let rscript = toJSString script + withJSString rscript $ sendLazyCommand . EvaluateScript +#endif diff --git a/src/Language/Javascript/JSaddle/Exception.hs b/src/Language/Javascript/JSaddle/Exception.hs --- a/src/Language/Javascript/JSaddle/Exception.hs +++ b/src/Language/Javascript/JSaddle/Exception.hs @@ -13,23 +13,22 @@ module Language.Javascript.JSaddle.Exception ( JSException(..) - , rethrow +-- , rethrow ) where -import qualified Control.Exception as E (throwIO, Exception) -import Language.Javascript.JSaddle.Types - (MutableJSArray, JSVal) +import qualified Control.Exception as E (Exception) +import Language.Javascript.JSaddle.Types (JSVal) import Data.Typeable (Typeable) -import Language.Javascript.JSaddle.Monad (catchval, JSM) -import Control.Monad.IO.Class (MonadIO(..)) newtype JSException = JSException JSVal deriving (Typeable) +-- | JavaScript exception +-- >>> instance Show JSException where show _ = "JSException" instance E.Exception JSException --- | Catch JavaScript exceptions and rethrow Haskell ones -rethrow :: (MutableJSArray -> JSM a) -> JSM a -rethrow f = f `catchval` \e -> - liftIO . E.throwIO $ JSException e +---- | Catch JavaScript exceptions and rethrow Haskell ones +--rethrow :: (MutableJSArray -> JSM a) -> JSM a +--rethrow f = f `catchval` \e -> +-- liftIO . E.throwIO $ JSException e diff --git a/src/Language/Javascript/JSaddle/Monad.hs b/src/Language/Javascript/JSaddle/Monad.hs --- a/src/Language/Javascript/JSaddle/Monad.hs +++ b/src/Language/Javascript/JSaddle/Monad.hs @@ -17,87 +17,58 @@ JSM , JSContextRef - -- * Running JSaddle given a DOM Window + -- * Running JSaddle given a JSContextRef , runJSaddle + , run -- * Exception Handling - , catchval + , syncPoint + , syncAfter , catch , bracket - - -- * GUI thread support - , postGUIAsyncJS - , postGUISyncJS ) where import Prelude hiding (catch, read) import Control.Monad.Trans.Reader (runReaderT, ask, ReaderT(..)) -import Language.Javascript.JSaddle.Types - (JSM, JSVal, MutableJSArray, JSContextRef) import Control.Monad.IO.Class (MonadIO(..)) -#ifdef ghcjs_HOST_OS -import GHCJS.Types (isUndefined, isNull) -import qualified JavaScript.Array as Array (create, read) -#else -import Language.Javascript.JSaddle.Native (makeNewJSVal) -import Foreign (nullPtr, alloca) -import Foreign.Storable (Storable(..)) -import GI.WebKit.Objects.WebView - (WebView(..), webViewGetMainFrame) -import GI.WebKit.Objects.WebFrame - (webFrameGetGlobalContext) -import GI.GLib (idleAdd) -import GI.GLib.Constants(pattern PRIORITY_DEFAULT) -import Foreign.Ptr (castPtr) -import GI.JavaScriptCore.Structs.GlobalContext (GlobalContext(..)) -import Foreign.ForeignPtr (withForeignPtr) -#endif import qualified Control.Exception as E (Exception, catch, bracket) -import Control.Concurrent.MVar (takeMVar, putMVar, newEmptyMVar) +import Language.Javascript.JSaddle.Types (JSM, runJSaddle, JSContextRef(..)) +import Control.Monad.Trans.Reader (ReaderT(..)) +#ifdef ghcjs_HOST_OS +import Control.Monad.Trans.Reader (ReaderT(..)) +run :: Int -> JSM () -> IO () +run _port = (`runReaderT` ()) -#ifndef ghcjs_HOST_OS --- | Post an action to be run in the main GUI thread. --- --- The current thread blocks until the action completes and the result is --- returned. --- -postGUISync :: IO a -> IO a -postGUISync action = do - resultVar <- newEmptyMVar - idleAdd PRIORITY_DEFAULT $ action >>= putMVar resultVar >> return False - takeMVar resultVar +syncPoint :: JSM () +syncPoint = return () --- | Post an action to be run in the main GUI thread. --- --- The current thread continues and does not wait for the result of the --- action. --- -postGUIAsync :: IO () -> IO () -postGUIAsync action = do - idleAdd PRIORITY_DEFAULT $ action >> return False - return () +syncAfter :: JSM a -> JSM a +syncAfter = id +#else +import Language.Javascript.JSaddle.WebSockets (run, syncPoint, syncAfter) #endif -- | Wrapped version of 'E.catch' that runs in a MonadIO that works -- a bit better with 'JSM' -catch :: (MonadIO m, E.Exception e) - => ReaderT r IO b - -> (e -> ReaderT r IO b) - -> ReaderT r m b +catch :: E.Exception e + => JSM b + -> (e -> JSM b) + -> JSM b t `catch` c = do r <- ask - liftIO (runReaderT t r `E.catch` \e -> runReaderT (c e) r) + liftIO (runReaderT (syncAfter t) r `E.catch` \e -> runReaderT (c e) r) -- | 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 :: JSM a -> (a -> JSM b) -> (a -> JSM c) -> JSM c bracket aquire release f = do r <- ask liftIO $ E.bracket - (runReaderT aquire r) - (\x -> runReaderT (release x) r) - (\x -> runReaderT (f x) r) + (runReaderT (syncAfter aquire) r) + (\x -> runReaderT (syncAfter $ release x) r) + (\x -> runReaderT (syncAfter $ f x) r) +{- -- | Handle JavaScriptCore functions that take a MutableJSArray in order -- to throw exceptions. catchval :: (MutableJSArray -> JSM a) -> (JSVal -> JSM a) -> JSM a @@ -119,33 +90,6 @@ then return result else makeNewJSVal exc >>= catcher #endif - -#ifdef ghcjs_HOST_OS -runJSaddle :: MonadIO m => w -> JSM a -> m a -runJSaddle _ f = liftIO $ runReaderT f () -#else -runJSaddle :: MonadIO m => WebView -> JSM a -> m a -runJSaddle webView f = liftIO $ do - GlobalContext gctxt <- webViewGetMainFrame webView >>= webFrameGetGlobalContext - withForeignPtr gctxt $ \ptr -> - runReaderT f (castPtr ptr) -#endif - -postGUIAsyncJS :: JSM () -> JSM () -#ifdef ghcjs_HOST_OS -postGUIAsyncJS = id -#else -postGUIAsyncJS f = do - r <- ask - liftIO . postGUIAsync $ runReaderT f r -#endif +-} -postGUISyncJS :: JSM a -> JSM a -#ifdef ghcjs_HOST_OS -postGUISyncJS = id -#else -postGUISyncJS f = do - r <- ask - liftIO . postGUISync $ runReaderT f r -#endif diff --git a/src/Language/Javascript/JSaddle/Native.hs b/src/Language/Javascript/JSaddle/Native.hs --- a/src/Language/Javascript/JSaddle/Native.hs +++ b/src/Language/Javascript/JSaddle/Native.hs @@ -13,8 +13,7 @@ module Language.Javascript.JSaddle.Native ( #if !defined(ghcjs_HOST_OS) - makeNewJSVal - , makeNewJSString + wrapJSVal , wrapJSString , withJSVal , withJSVals @@ -26,74 +25,50 @@ #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 - (newForeignPtr_, 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) -import Foreign.Ptr (nullPtr) - -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 | s == nullPtr = - liftIO $ newForeignPtr_ s -makeNewJSString s = - liftIO $ do - s' <- jsstringretain s - newForeignPtr jsStringRelease s' + (JSContextRef(..), AsyncCommand(..), JSM, JSString(..), + Object(..), JSVal(..), JSValueReceived(..), JSValueForSend(..), + JSStringReceived(..), JSStringForSend(..), JSObjectForSend(..)) +import Language.Javascript.JSaddle.Classes (ToJSVal(..)) +import System.Mem.Weak (addFinalizer) +import Control.Monad.Primitive (touch) +import Control.Monad (when) -wrapJSString :: MonadIO m => JSStringRef -> m (ForeignPtr OpaqueJSString) -wrapJSString s | s == nullPtr = - liftIO $ newForeignPtr_ s -wrapJSString s = liftIO $ newForeignPtr jsStringRelease s +wrapJSVal :: JSValueReceived -> JSM JSVal +wrapJSVal (JSValueReceived ref) = do + -- TODO make sure this ref has not already been wrapped (perhaps only in debug version) + let result = JSVal ref + when (ref >= 5) $ do + ctx <- ask + liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref + return result -foreign import ccall unsafe "&JSStringRelease" - jsStringRelease :: FinalizerPtr OpaqueJSString +wrapJSString :: MonadIO m => JSStringReceived -> m JSString +wrapJSString (JSStringReceived ref) = return $ JSString ref -withJSVal :: MonadIO m => JSVal -> (JSValueRef -> m a) -> m a -withJSVal v f = - do result <- f (unsafeForeignPtrToPtr v) - liftIO $ touchForeignPtr v +withJSVal :: MonadIO m => JSVal -> (JSValueForSend -> m a) -> m a +withJSVal v@(JSVal ref) f = + do result <- f (JSValueForSend ref) + liftIO $ touch v return result -withJSVals :: MonadIO m => [JSVal] -> ([JSValueRef] -> m a) -> m a +withJSVals :: MonadIO m => [JSVal] -> ([JSValueForSend] -> m a) -> m a withJSVals v f = - do result <- f (map unsafeForeignPtrToPtr v) - liftIO $ mapM_ touchForeignPtr v + do result <- f (map (\(JSVal ref) -> JSValueForSend ref) v) + liftIO $ mapM_ touch 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 +withObject :: MonadIO m => Object -> (JSObjectForSend -> m a) -> m a +withObject (Object o) f = withJSVal o (f . JSObjectForSend) -withJSString :: MonadIO m => JSString -> (JSStringRef -> m a) -> m a -withJSString v f = - do result <- f (unsafeForeignPtrToPtr v) - liftIO $ touchForeignPtr v +withJSString :: MonadIO m => JSString -> (JSStringForSend -> m a) -> m a +withJSString v@(JSString ref) f = + do result <- f (JSStringForSend ref) + liftIO $ touch v return result -withToJSVal :: ToJSVal val => val -> (JSValueRef -> JSM a) -> JSM a +withToJSVal :: ToJSVal val => val -> (JSValueForSend -> JSM a) -> JSM a withToJSVal val f = do v <- toJSVal val withJSVal v f diff --git a/src/Language/Javascript/JSaddle/Object.hs b/src/Language/Javascript/JSaddle/Object.hs --- a/src/Language/Javascript/JSaddle/Object.hs +++ b/src/Language/Javascript/JSaddle/Object.hs @@ -92,62 +92,43 @@ import Control.Applicative import Prelude hiding ((!!)) import Language.Javascript.JSaddle.Types - (JSPropertyNameArray, JSString, Object(..), MutableJSArray, - JSVal, Index) -import Foreign.C.Types (CSize(..), CULong(..), CUInt(..), CULLong(..)) + (JSString, Object(..), + JSVal(..), Index, JSCallAsFunction, JSContextRef(..)) #ifdef ghcjs_HOST_OS +import Control.Monad.Trans.Reader (runReaderT) import GHCJS.Types (nullRef, jsval) import GHCJS.Foreign.Callback (releaseCallback, syncCallback2, OnBlocked(..), Callback) import GHCJS.Marshal.Pure (pFromJSVal) -import JavaScript.Array (JSArray) +import JavaScript.Array (JSArray, MutableJSArray) import qualified JavaScript.Array as Array (toListIO, fromListIO) import JavaScript.Array.Internal (SomeJSArray(..)) import qualified JavaScript.Object as Object (create) import Control.Monad (liftM) import Data.Coerce (coerce) #else -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef - (jsobjectmake, jspropertynamearraygetnameatindex, - jspropertynamearraygetcount, jsobjectcopypropertynames, - jsobjectcallasconstructor, jsobjectmakearray, - jsobjectcallasfunction, - JSObjectCallAsFunctionCallback, mkJSObjectCallAsFunctionCallback, - jsobjectmakefunctionwithcallback) -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef - (jsvaluemakeundefined) -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSContextRef - (jscontextgetglobalobject) -import Foreign (peekArray, nullPtr, withArrayLen) -import Foreign.Ptr (freeHaskellFunPtr) import Language.Javascript.JSaddle.Native - (makeNewJSString, makeNewJSVal, wrapJSString, withJSVals, - withObject, withJSString, withToJSVal) -import System.IO.Unsafe (unsafePerformIO) -import Foreign.ForeignPtr (newForeignPtr_) + (wrapJSString, withJSVals, withObject) +import Language.Javascript.JSaddle.WebSockets + (Command(..), AsyncCommand(..), Result(..), sendCommand, sendLazyCommand) #endif -import Language.Javascript.JSaddle.Exception (rethrow) -import Language.Javascript.JSaddle.Value - (JSUndefined, valToObject) +import Language.Javascript.JSaddle.Value (valToObject) import Language.Javascript.JSaddle.Classes (ToJSVal(..), ToJSString(..), MakeObject(..)) import Language.Javascript.JSaddle.Arguments (MakeArgs(..)) import Language.Javascript.JSaddle.Monad (JSM) -import Control.Monad.Trans.Reader (runReaderT, ask) +import Control.Monad.Trans.Reader (asks) import Control.Monad.IO.Class (MonadIO(..)) -import qualified Control.Exception as E (catch) -import Control.Exception (SomeException) -import Foreign.Storable (Storable(..)) import Language.Javascript.JSaddle.Properties import Control.Lens (IndexPreservingGetter, to) -import Language.Javascript.JSaddle.String (nullJSString) import Data.Text (Text) -- $setup -- >>> import Language.Javascript.JSaddle.Test (testJSaddle) -- >>> import Language.Javascript.JSaddle.Evaluate (eval) --- >>> import Language.Javascript.JSaddle.Value (val, valToText, JSNull(..)) +-- >>> import Language.Javascript.JSaddle.Value (val, valToText, JSNull(..), deRefVal) +-- >>> import Language.Javascript.JSaddle.String (strToText) -- >>> import Control.Lens.Operators ((^.)) -- >>> import qualified Data.Text as T (unpack) @@ -168,9 +149,7 @@ -> JSM JSVal -- ^ Property reference this ! name = do rthis <- makeObject this - rethrow $ objGetPropertyByName rthis rname - where - rname = toJSString name + objGetPropertyByName rthis name -- | Lookup a property based on its index. -- @@ -184,7 +163,7 @@ -> JSM JSVal -- ^ Property reference this !! index = do rthis <- makeObject this - rethrow $ objGetPropertyAtIndex rthis index + objGetPropertyAtIndex rthis index -- | Makes a getter for a particular property name. -- @@ -206,7 +185,7 @@ -- >>> testJSaddle $ eval "'Hello World'.length = 12" -- 12 -- >>> testJSaddle $ val "Hello World" ^. jss "length" 12 --- 12 +-- undefined jss :: (ToJSString name, ToJSVal val) => name -- ^ Name of the property to find -> val @@ -268,12 +247,8 @@ -- | Handy way to get and hold onto a reference top level javascript -- -- >>> testJSaddle $ eval "w = console; w.log('Hello World')" --- ** Message: console message: @1: Hello World --- -- undefined -- >>> testJSaddle $ do w <- jsg "console"; w ^. js1 "log" "Hello World" --- ** Message: console message:...@0: Hello World --- -- undefined jsg :: ToJSString a => a -> JSM JSVal jsg name = global ! name @@ -293,8 +268,8 @@ -- -- > jsg0 name = jsgf name () -- --- >>> testJSaddle $ jsg0 "globalFunc" --- TypeError:...undefined...is not an objec... +-- >>> testJSaddle $ jsg0 "globalFunc" >>= valToText +-- TypeError:...undefine... jsg0 :: (ToJSString name) => name -> JSM JSVal jsg0 name = jsgf name () @@ -339,9 +314,9 @@ => this -> name -> args -> JSM JSVal (#) this name args = do rthis <- makeObject this - f <- rethrow $ objGetPropertyByName rthis name + f <- objGetPropertyByName rthis name f' <- valToObject f - rethrow $ objCallAsFunction f' rthis args + objCallAsFunction f' rthis args -- | Call a JavaScript function -- @@ -354,9 +329,9 @@ => this -> Index -> args -> JSM JSVal (##) this index args = do rthis <- makeObject this - f <- rethrow $ objGetPropertyAtIndex rthis index + f <- objGetPropertyAtIndex rthis index f' <- valToObject f - rethrow $ objCallAsFunction f' rthis args + objCallAsFunction f' rthis args -- | Set a JavaScript property -- @@ -372,7 +347,7 @@ -> JSM () (<#) this name val = do rthis <- makeObject this - rethrow $ objSetPropertyByName rthis name val 0 + objSetPropertyByName rthis name val -- | Set a JavaScript property -- @@ -388,7 +363,7 @@ -> JSM () (<##) this index val = do rthis <- makeObject this - rethrow $ objSetPropertyAtIndex rthis index val + objSetPropertyAtIndex rthis index val -- | Use this to create a new JavaScript object -- @@ -403,7 +378,7 @@ -> JSM JSVal new constructor args = do f <- makeObject constructor - rethrow $ objCallAsConstructor f args + objCallAsConstructor f args -- | Call function with a given @this@. In most cases you should use '#'. -- @@ -416,7 +391,7 @@ call f this args = do rfunction <- makeObject f rthis <- makeObject this - rethrow $ objCallAsFunction rfunction rthis args + objCallAsFunction rfunction rthis args -- | Make an empty object using the default constuctor -- @@ -428,29 +403,15 @@ #ifdef ghcjs_HOST_OS obj = liftIO Object.create #else -obj = do - gctxt <- ask - Object <$> (liftIO (jsobjectmake gctxt nullPtr nullPtr) >>= makeNewJSVal) +obj = Object <$> sendLazyCommand NewEmptyObject #endif --- | Type used for Haskell functions called from JavaScript. -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 - -- value out pass in a continuation function - -- as an argument and invoke it from haskell. - -- | Short hand @::JSCallAsFunction@ so a haskell function can be passed to -- a to a JavaScipt one. -- -- >>> testJSaddle $ eval "(function(f) {f('Hello');})(function (a) {console.log(a)})" --- ** Message: console message: @1: Hello --- -- undefined --- >>> testJSaddle $ call (eval "(function(f) {f('Hello');})") global [fun $ \ _ _ args -> valToText (head args) >>= (liftIO . putStrLn . T.unpack) ] +-- >>> testJSaddle . deRefVal $ call (eval "(function(f) {f('Hello');})") global [fun $ \ _ _ args -> valToText (head args) >>= (liftIO . putStrLn . T.unpack) ] -- Hello -- undefined fun :: JSCallAsFunction -> JSCallAsFunction @@ -459,53 +420,36 @@ #ifdef ghcjs_HOST_OS type HaskellCallback = Callback (JSVal -> JSVal -> IO ()) #else -type HaskellCallback = JSObjectCallAsFunctionCallback +type HaskellCallback = () #endif data Function = Function {functionCallback :: HaskellCallback, functionObject :: Object} -- ^ Make a JavaScript function object that wraps a Haskell function. -function :: ToJSString name - => name -- ^ Name of the function - -> JSCallAsFunction -- ^ Haskell function to call +function :: JSCallAsFunction -- ^ Haskell function to call -> JSM Function -- ^ Returns a JavaScript function object that will -- call the Haskell one when it is called #ifdef ghcjs_HOST_OS -function name f = liftIO $ do +function f = liftIO $ do callback <- syncCallback2 ContinueAsync $ \this args -> do rargs <- Array.toListIO (coerce args) runReaderT (f this this rargs) () -- TODO pass function object through - Function callback <$> makeFunctionWithCallback (toJSString name) callback -foreign import javascript unsafe "$r = function () { $2(this, arguments); }" - makeFunctionWithCallback :: JSString -> Callback (JSVal -> JSVal -> IO ()) -> IO Object + Function callback <$> makeFunctionWithCallback callback +foreign import javascript unsafe "$r = function () { $1(this, arguments); }" + makeFunctionWithCallback :: Callback (JSVal -> JSVal -> IO ()) -> IO Object #else -function name f = do - gctxt <- ask - callback <- liftIO $ mkJSObjectCallAsFunctionCallback (wrap gctxt) - withJSString (toJSString name) $ \name' -> - Function callback . Object <$> - (liftIO (jsobjectmakefunctionwithcallback gctxt name' callback) >>= makeNewJSVal) - where - wrap gctxt _ctx fobj' this' argc argv exception = do - args' <- peekArray (fromIntegral argc) argv - (`runReaderT` gctxt) $ do - fobj <- makeNewJSVal fobj' - this <- makeNewJSVal this' - args <- mapM makeNewJSVal args' - f fobj this args - liftIO $ jsvaluemakeundefined gctxt - `E.catch` \(e :: SomeException) -> - (`runReaderT` gctxt) $ do - withToJSVal (show e) $ liftIO . poke exception - liftIO $ jsvaluemakeundefined gctxt +function f = do + obj <- Object <$> sendLazyCommand NewCallback + asks addCallback >>= \add -> liftIO $ add obj f + return $ Function () obj #endif -freeFunction :: MonadIO m => Function -> m () -freeFunction (Function callback _) = liftIO $ +freeFunction :: Function -> JSM () #ifdef ghcjs_HOST_OS +freeFunction (Function callback _) = liftIO $ releaseCallback callback #else - freeHaskellFunPtr callback +freeFunction (Function callback obj) = asks freeCallback >>= \f -> liftIO $ f obj #endif instance ToJSVal Function where @@ -515,29 +459,13 @@ -- an anonymous JavaScript function object. Use 'function' to create one with -- a name. instance ToJSVal JSCallAsFunction where - toJSVal f = functionObject <$> function nullJSString f >>= toJSVal + toJSVal f = functionObject <$> function f >>= toJSVal instance MakeArgs JSCallAsFunction where makeArgs f = do - rarg <- functionObject <$> function nullJSString f >>= toJSVal + rarg <- functionObject <$> function f >>= toJSVal return [rarg] -makeArray :: MakeArgs args => args -> MutableJSArray -> JSM Object -#ifdef ghcjs_HOST_OS -makeArray args exceptions = do - rargs <- makeArgs args - liftIO $ Object . jsval <$> Array.fromListIO rargs -#else -makeArray args exceptions = do - gctxt <- ask - rargs <- makeArgs args - result <- - withJSVals rargs $ \rargs' -> - liftIO $ withArrayLen rargs' $ \ len ptr -> - jsobjectmakearray gctxt (fromIntegral len) ptr exceptions - Object <$> makeNewJSVal result -#endif - -- | Make an JavaScript array from a list of values -- -- >>> testJSaddle $ eval "['Hello', 'World'][1]" @@ -549,7 +477,15 @@ -- >>> testJSaddle $ array ("Hello", JSNull, (), True, 1.0::Double) -- Hello,,,true,1 array :: MakeArgs args => args -> JSM Object -array = rethrow . makeArray +#ifdef ghcjs_HOST_OS +array args = do + rargs <- makeArgs args + liftIO $ Object . jsval <$> Array.fromListIO rargs +#else +array args = do + rargs <- makeArgs args + withJSVals rargs $ \rargs' -> Object <$> sendLazyCommand (NewArray rargs') +#endif -- Make an array out of various lists instance ToJSVal [JSVal] where @@ -580,50 +516,31 @@ toJSVal = toJSVal . array -- | JavaScript's global object -global :: JSM Object +global :: Object #ifdef ghcjs_HOST_OS -global = liftIO js_window +global = js_window foreign import javascript unsafe "$r = window" - js_window :: IO Object + js_window :: Object #else -global = do - gctxt <- ask - result <- liftIO $ jscontextgetglobalobject gctxt - Object <$> makeNewJSVal result -#endif - --- | Get an array containing the property names present on a given object -#if !defined(ghcjs_HOST_OS) -copyPropertyNames :: MakeObject this => this -> JSM JSPropertyNameArray -copyPropertyNames this = do - gctxt <- ask - this' <- makeObject this - withObject this' $ \rthis -> - liftIO $ jsobjectcopypropertynames gctxt rthis - --- | Get the number of names in a property name array -propertyNamesCount :: MonadIO m => JSPropertyNameArray -> m CSize -propertyNamesCount names = liftIO $ jspropertynamearraygetcount names - --- | Get a name out of a property name array -propertyNamesAt :: MonadIO m => JSPropertyNameArray -> CSize -> m JSString -propertyNamesAt names index = liftIO $ jspropertynamearraygetnameatindex names index >>= makeNewJSString - --- | Convert property array to a list -propertyNamesList :: MonadIO m => JSPropertyNameArray -> m [JSString] -propertyNamesList names = do - count <- propertyNamesCount names - mapM (propertyNamesAt names) $ enumFromTo 0 (count - 1) +global = Object (JSVal 4) #endif -- | Get a list containing the property names present on a given object +-- >>> testJSaddle $ show . map strToText <$> propertyNames obj +-- [] +-- >>> testJSaddle $ show . map strToText <$> propertyNames (eval "({x:1, y:2})") +-- ["x","y"] propertyNames :: MakeObject this => this -> JSM [JSString] #ifdef ghcjs_HOST_OS propertyNames this = makeObject this >>= liftIO . js_propertyNames >>= liftIO . (fmap (map pFromJSVal)) . Array.toListIO foreign import javascript unsafe "$r = []; h$forIn($1, function(n){$r.push(n);})" js_propertyNames :: Object -> IO JSArray #else -propertyNames this = copyPropertyNames this >>= propertyNamesList +propertyNames this = do + this' <- makeObject this + withObject this' $ \rthis -> do + PropertyNamesResult result <- sendCommand $ PropertyNames rthis + mapM wrapJSString result #endif -- | Get a list containing references to all the properties present on a given object @@ -635,25 +552,19 @@ => Object -> Object -> args - -> MutableJSArray -> JSM JSVal #ifdef ghcjs_HOST_OS -objCallAsFunction f this args exceptions = do +objCallAsFunction f this args = do rargs <- makeArgs args >>= liftIO . Array.fromListIO - liftIO $ js_apply f this rargs exceptions -foreign import javascript unsafe "try { $r = $1.apply($2, $3) } catch(e) { $4[0] = e }" - js_apply :: Object -> Object -> MutableJSArray -> MutableJSArray -> IO JSVal + liftIO $ js_apply f this rargs +foreign import javascript unsafe "$r = $1.apply($2, $3)" + js_apply :: Object -> Object -> MutableJSArray -> IO JSVal #else -objCallAsFunction f this args exceptions = do - gctxt <- ask +objCallAsFunction f this args = do 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 + withObject f $ \rfunction -> + withObject this $ \rthis -> + withJSVals rargs $ sendLazyCommand . CallAsFunction rfunction rthis #endif -- | Call a JavaScript object as a constructor. Consider using 'new'. @@ -663,14 +574,12 @@ objCallAsConstructor :: MakeArgs args => Object -> args - -> MutableJSArray -> JSM JSVal #ifdef ghcjs_HOST_OS -objCallAsConstructor f args exceptions = do +objCallAsConstructor f args = do rargs <- makeArgs args >>= liftIO . Array.fromListIO - liftIO $ js_new f rargs exceptions + liftIO $ js_new f rargs foreign import javascript unsafe "\ - try {\ switch($2.length) {\ case 0 : $r = new $1(); break;\ case 1 : $r = new $1($2[0]); break;\ @@ -681,37 +590,31 @@ case 6 : $r = new $1($2[0],$2[1],$2[2],$2[3],$2[4],$2[5]); break;\ case 7 : $r = new $1($2[0],$2[1],$2[2],$2[3],$2[4],$2[5],$2[6]); break;\ default:\ - var ret;\ var temp = function() {\ ret = $1.apply(this, $2);\ };\ temp.prototype = $1.prototype;\ var i = new temp();\ - if(ret instanceof Object)\ - return ret;\ - i.constructor = $1;\ - return i;\ - }\ - }\ - catch(e) {\ - $3[0] = e;\ - }" - js_new :: Object -> MutableJSArray -> MutableJSArray -> IO JSVal + if(ret instanceof Object) {\ + $r = ret;\ + } else {\ + i.constructor = $1;\ + $r = i;\ + }\ + }" + js_new :: Object -> MutableJSArray -> IO JSVal #else -objCallAsConstructor f args exceptions = do - gctxt <- ask +objCallAsConstructor f args = do rargs <- makeArgs args - result <- - withObject f $ \rfunction -> - withJSVals rargs $ \rargs' -> - liftIO $ withArrayLen rargs' $ \ largs pargs -> - jsobjectcallasconstructor gctxt rfunction (fromIntegral largs) pargs exceptions - makeNewJSVal result + withObject f $ \rfunction -> + withJSVals rargs $ sendLazyCommand . CallAsConstructor rfunction #endif +-- >>> testJSaddle $ strictEqual nullObject (eval "null") +-- true nullObject :: Object #ifdef ghcjs_HOST_OS nullObject = Object nullRef #else -nullObject = Object . unsafePerformIO $ newForeignPtr_ nullPtr +nullObject = Object (JSVal 0) #endif diff --git a/src/Language/Javascript/JSaddle/Properties.hs b/src/Language/Javascript/JSaddle/Properties.hs --- a/src/Language/Javascript/JSaddle/Properties.hs +++ b/src/Language/Javascript/JSaddle/Properties.hs @@ -32,56 +32,48 @@ import Language.Javascript.JSaddle.Classes (ToJSVal(..), ToJSString(..)) import Language.Javascript.JSaddle.Monad (JSM) -import Language.Javascript.JSaddle.Types - (MutableJSArray, Object(..), JSPropertyAttributes, - Index) +import Language.Javascript.JSaddle.Types (Object(..), Index) #ifdef ghcjs_HOST_OS import Language.Javascript.JSaddle.Types (JSString) #else -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef - (jsobjectgetpropertyatindex, jsobjectgetproperty, - jsobjectsetpropertyatindex, jsobjectsetproperty) import Language.Javascript.JSaddle.Native - (makeNewJSVal, withObject, withJSString, withToJSVal) + (wrapJSVal, withObject, withJSString, withToJSVal) +import Language.Javascript.JSaddle.WebSockets + (Command(..), AsyncCommand(..), Result(..), sendLazyCommand, sendAsyncCommand) #endif import Control.Monad.Trans.Reader (ask) -import Control.Monad.IO.Class (MonadIO(..)) import Language.Javascript.JSaddle.Value (JSVal) import Language.Javascript.JSaddle.Arguments () import Language.Javascript.JSaddle.String () +import Control.Monad.IO.Class (MonadIO(..)) -- | Get a property value given the object and the name of the property. objGetPropertyByName :: ToJSString name => Object -- ^ object to find the property on. -> name -- ^ name of the property. - -> 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 -foreign import javascript unsafe "try { $r=$2[$1] } catch(e) { $3[0] = e }" - js_tryGetProp :: JSString -> Object -> MutableJSArray -> IO JSVal +objGetPropertyByName this name = liftIO $ js_tryGetProp (toJSString name) this +foreign import javascript unsafe "$r=$2[$1]" + js_tryGetProp :: JSString -> Object -> IO JSVal #else -objGetPropertyByName this name exceptions = do - gctxt <- ask +objGetPropertyByName this name = withObject this $ \rthis -> - withJSString (toJSString name) $ \name' -> - (liftIO $ jsobjectgetproperty gctxt rthis name' exceptions) >>= makeNewJSVal + withJSString (toJSString name) $ + sendLazyCommand . GetPropertyByName rthis #endif -- | Get a property value given the object and the index of the property. objGetPropertyAtIndex :: Object -- ^ object to find the property on. -> Index -- ^ index of the property. - -> MutableJSArray -- ^ exception if one is raised. -> JSM JSVal -- ^ returns the property value. #ifdef ghcjs_HOST_OS -objGetPropertyAtIndex this index = liftIO . js_tryIndex index this -foreign import javascript unsafe "try { $r=$2[$1] } catch(e) { $3[0] = e }" - js_tryIndex :: Index -> Object -> MutableJSArray -> IO JSVal +objGetPropertyAtIndex this index = liftIO $ js_tryIndex index this +foreign import javascript unsafe "$r=$2[$1]" + js_tryIndex :: Index -> Object -> IO JSVal #else -objGetPropertyAtIndex this index exceptions = do - gctxt <- ask - withObject this $ \rthis -> - (liftIO $ jsobjectgetpropertyatindex gctxt rthis index exceptions) >>= makeNewJSVal +objGetPropertyAtIndex this index = + withObject this $ \rthis -> sendLazyCommand $ GetPropertyAtIndex rthis index #endif -- | Set a property value given the object and the name of the property. @@ -89,22 +81,20 @@ => 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. - -> MutableJSArray -- ^ exception if one is raised. -> JSM () #ifdef ghcjs_HOST_OS -objSetPropertyByName this name val attributes exceptions = do +objSetPropertyByName this name val = do vref <- toJSVal val - liftIO $ js_trySetProp (toJSString name) this vref exceptions -foreign import javascript unsafe "try { $2[$1]=$3 } catch(e) { $4[0] = e }" - js_trySetProp :: JSString -> Object -> JSVal -> MutableJSArray -> IO () + liftIO $ js_trySetProp (toJSString name) this vref +foreign import javascript unsafe "$2[$1]=$3" + js_trySetProp :: JSString -> Object -> JSVal -> IO () #else -objSetPropertyByName this name val attributes exceptions = do - gctxt <- ask +objSetPropertyByName this name val = do + let name' = toJSString name withObject this $ \rthis -> - withJSString (toJSString name) $ \name' -> - withToJSVal val $ \rval -> - liftIO $ jsobjectsetproperty gctxt rthis name' rval attributes exceptions + withJSString name' $ \rname -> + withToJSVal val $ \rval -> + sendAsyncCommand $ SetPropertyByName rthis rname rval #endif -- | Set a property value given the object and the index of the property. @@ -112,19 +102,18 @@ => Object -- ^ object to find property on. -> Index -- ^ index of the property. -> val -- ^ new value to set the property to. - -> MutableJSArray -- ^ exception if one is raised. -> JSM () #ifdef ghcjs_HOST_OS -objSetPropertyAtIndex this index val exceptions = do +objSetPropertyAtIndex this index val = do vref <- toJSVal val - liftIO $ js_trySetAtIndex index this vref exceptions -foreign import javascript unsafe "try { $2[$1]=$3 } catch(e) { $4[0] = e }" - js_trySetAtIndex :: Index -> Object -> JSVal -> MutableJSArray -> IO () + liftIO $ js_trySetAtIndex index this vref +foreign import javascript unsafe "$2[$1]=$3" + js_trySetAtIndex :: Index -> Object -> JSVal -> IO () #else -objSetPropertyAtIndex this index val exceptions = do +objSetPropertyAtIndex this index val = do gctxt <- ask withObject this $ \rthis -> withToJSVal val $ \rval -> - liftIO $ jsobjectsetpropertyatindex gctxt rthis index rval exceptions + sendAsyncCommand $ SetPropertyAtIndex rthis index rval #endif diff --git a/src/Language/Javascript/JSaddle/String.hs b/src/Language/Javascript/JSaddle/String.hs --- a/src/Language/Javascript/JSaddle/String.hs +++ b/src/Language/Javascript/JSaddle/String.hs @@ -20,39 +20,23 @@ -- * Data.Text helpers , strToText , textToStr - , nullJSString ) where import Data.Text (Text) -import Control.Monad.IO.Class (MonadIO(..)) -import Language.Javascript.JSaddle.Types (JSString) +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) -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) #endif import Language.Javascript.JSaddle.Classes (ToJSString(..)) -- | Convert a JavaScript string to a Haskell 'Text' -strToText :: MonadIO m => JSString -> m Text +strToText :: JSString -> Text #ifdef ghcjs_HOST_OS -strToText = return . textFromJSString +strToText = textFromJSString #else -strToText jsstring' = liftIO $ withJSString jsstring' $ \jsstring -> do - l <- jsstringgetlength jsstring - p <- jsstringgetcharactersptr jsstring - T.fromPtr (castPtr p) (fromIntegral l) +strToText (JSString text) = text #endif -- | Convert a Haskell 'Text' to a JavaScript string @@ -60,15 +44,6 @@ #ifdef ghcjs_HOST_OS textToStr = textToJSString #else -textToStr text = unsafePerformIO $ - useAsPtr text $ \p l -> - jsstringcreatewithcharacters (castPtr p) (fromIntegral l) >>= makeNewJSString -#endif - -nullJSString :: JSString -#ifdef ghcjs_HOST_OS -nullJSString = pFromJSVal nullRef -#else -nullJSString = unsafePerformIO $ newForeignPtr_ nullPtr +textToStr = JSString #endif diff --git a/src/Language/Javascript/JSaddle/Test.hs b/src/Language/Javascript/JSaddle/Test.hs --- a/src/Language/Javascript/JSaddle/Test.hs +++ b/src/Language/Javascript/JSaddle/Test.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- -- Module : TestJSC @@ -14,157 +14,65 @@ module Language.Javascript.JSaddle.Test ( testJSaddle - , showJSaddle , listWindowProperties ) where import Control.Applicative import Prelude hiding((!!), catch) -import GI.Gtk - (Window, widgetDestroy, widgetShowAll, - mainQuit, containerAdd, scrolledWindowNew, - windowSetPosition, windowSetDefaultSize, windowNew) -import Control.Concurrent - (tryTakeMVar, forkIO, newMVar, putMVar, takeMVar, newEmptyMVar, - yield) -import GI.Gtk.Enums (WindowType(..), WindowPosition(..)) -import GI.WebKit.Objects.WebView - (webViewGetMainFrame, webViewNew) -import System.IO.Unsafe (unsafePerformIO) -import Control.Monad.Trans.Reader (runReaderT) -import GI.WebKit.Objects.WebFrame - (webFrameGetGlobalContext) +import Control.Monad.Trans.Reader (ask, runReaderT) import Language.Javascript.JSaddle import qualified Data.Text as T import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad (forM, when) +import Control.Monad (forever, forM) import Control.Lens.Getter ((^.)) import Data.Monoid ((<>)) -import Control.Concurrent.MVar (MVar) -import qualified GI.Gtk.Functions as Gtk (init, main) -import GI.GLib.Functions (timeoutAdd) -import GI.Gtk.Enums (WindowPosition(..)) -import Data.GI.Base.Signals (on) -import GI.GLib (idleAdd) -import GI.GLib.Constants(pattern PRIORITY_DEFAULT, pattern PRIORITY_LOW) -import GI.Gtk.Objects.Widget (onWidgetDestroy) -import GI.JavaScriptCore.Structs.GlobalContext (GlobalContext(..)) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (castPtr) -import GI.Gtk.Objects.Adjustment (Adjustment(..)) - --- | Post an action to be run in the main GUI thread. --- --- The current thread blocks until the action completes and the result is --- returned. --- -postGUISync :: IO a -> IO a -postGUISync action = do - resultVar <- newEmptyMVar - idleAdd PRIORITY_DEFAULT $ action >>= putMVar resultVar >> return False - takeMVar resultVar - --- | Post an action to be run in the main GUI thread. --- --- The current thread continues and does not wait for the result of the --- action. --- -postGUIAsync :: IO () -> IO () -postGUIAsync action = do - idleAdd PRIORITY_DEFAULT $ action >> return False - return () +import Control.Concurrent.MVar + (tryTakeMVar, putMVar, takeMVar, newEmptyMVar, MVar) +import System.IO.Unsafe (unsafePerformIO) +import Control.Concurrent (threadDelay, forkIO, ThreadId) +import Data.Text (Text) +import Language.Javascript.JSaddle.WebSockets (run) -data TestState = TestState { jsContext :: GlobalContext, window :: Window } +context :: MVar JSContextRef +context = unsafePerformIO newEmptyMVar +{-# NOINLINE context #-} -state :: MVar (Maybe TestState) -state = unsafePerformIO $ newMVar Nothing -{-# NOINLINE state #-} +server :: MVar ThreadId +server = unsafePerformIO newEmptyMVar +{-# NOINLINE server #-} -done :: MVar () -done = unsafePerformIO newEmptyMVar -{-# NOINLINE done #-} +startServer :: IO () +startServer = + tryTakeMVar server >>= maybe (forkIO $ + run 3709 $ do + liftIO $ tryTakeMVar context + liftIO . putMVar context =<< ask + liftIO . forever $ threadDelay 1000000 + ) return >>= putMVar server -- >>> 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 +testJSaddle f = do + startServer + c <- takeMVar context + runReaderT ((f >>= valToText >>= liftIO . putStrLn . T.unpack) + `catch` \ (JSException e) -> valToText e >>= liftIO . putStrLn . T.unpack) c + putMVar context c debugLog :: String -> IO () debugLog _ = return () -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" - _ <- Gtk.init mempty - debugLog "windowNew" - window <- windowNew WindowTypeToplevel - debugLog "timeoutAdd" - _ <- timeoutAdd PRIORITY_LOW 10 $ yield >> return True - windowSetDefaultSize window 900 600 - windowSetPosition window WindowPositionCenter - scrollWin <- scrolledWindowNew (Nothing :: Maybe Adjustment) (Nothing :: Maybe Adjustment) - webView <- webViewNew - window `containerAdd` scrollWin - scrollWin `containerAdd` webView - _ <- onWidgetDestroy window $ 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" - Gtk.main - debugLog "mainGUI exited" - takeMVar newState - Just s@TestState {..} -> do - debugLog "maybe show (2)" - when showWindow . postGUISync $ widgetShowAll window - return s - x <- postGUISync $ withContext jsContext $ runReaderT ((f >>= valToText >>= liftIO . putStrLn . T.unpack) - `catch` \ (JSException e) -> valToText e >>= liftIO . putStrLn . T.unpack) - debugLog "put state" - putMVar state $ Just TestState {..} - return x - -withContext :: GlobalContext -> (JSContextRef -> IO a) -> IO a -withContext (GlobalContext fptr) f = withForeignPtr fptr $ f . castPtr - listWindowProperties :: IO () listWindowProperties = testJSaddle $ T.pack . show <$> do - window <- jsg "window" + window <- jsg ("window" :: Text) names <- propertyNames window forM names $ \name -> do v <- window ^. js name >>= valToText - n <- strToText name - return (n, v) + return (strToText name, v) `catch` \(JSException e) -> do - n <- strToText name msg <- valToText e - return (n, T.pack " error " <> msg) + return (strToText name, T.pack " error " <> msg) diff --git a/src/Language/Javascript/JSaddle/Types.hs b/src/Language/Javascript/JSaddle/Types.hs --- a/src/Language/Javascript/JSaddle/Types.hs +++ b/src/Language/Javascript/JSaddle/Types.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- -- Module : Language.Javascript.JSaddle.Properties @@ -13,19 +15,31 @@ ----------------------------------------------------------------------------- module Language.Javascript.JSaddle.Types ( - JSVal - , MutableJSArray + JSVal(..) + , MutableJSArray(..) , Object(..) - , JSPropertyNameArray - , JSPropertyAttributes - , JSContextRef - , JSString + , JSContextRef(..) + , JSString(..) , Index , Nullable(..) , JSM + , runJSaddle + , JSCallAsFunction +#ifndef ghcjs_HOST_OS + , JSValueReceived(..) + , JSValueForSend(..) + , JSStringReceived(..) + , JSStringForSend(..) + , JSObjectForSend(..) + , AsyncCommand(..) + , Command(..) + , Batch(..) + , Result(..) +#endif ) where import Control.Monad.Trans.Reader (ReaderT(..)) +import Control.Monad.IO.Class (MonadIO(..)) #ifdef ghcjs_HOST_OS import GHCJS.Types import JavaScript.Object.Internal (Object(..)) @@ -33,29 +47,118 @@ import Data.Word (Word(..)) import GHCJS.Nullable (Nullable(..)) #else -import Foreign.ForeignPtr (ForeignPtr) -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase - (OpaqueJSString, JSValueRefRef, - JSContextRef, JSPropertyNameArrayRef, OpaqueJSValue) -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef (JSPropertyAttributes) -import Foreign.C (CUInt(..)) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Aeson + (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..)) +import GHC.Generics (Generic) +import Control.Concurrent.STM.TVar (TVar) #endif #ifdef ghcjs_HOST_OS -newtype JSPropertyNameArray = JSPropertyNameArray { unJSPropertyNameArrayRef :: JSVal } -type JSPropertyAttributes = Word type JSContextRef = () type Index = Int #else -type JSVal = ForeignPtr OpaqueJSValue -type MutableJSArray = JSValueRefRef -type JSPropertyNameArray = JSPropertyNameArrayRef -type Index = CUInt -newtype Object = Object (ForeignPtr OpaqueJSValue) -type JSString = ForeignPtr OpaqueJSString +type JSRef = Int64 +newtype JSValueReceived = JSValueReceived JSRef deriving(Show, ToJSON, FromJSON) +newtype JSValueForSend = JSValueForSend JSRef deriving(Show, ToJSON, FromJSON) +newtype JSVal = JSVal JSRef deriving(Show, ToJSON, FromJSON) +newtype MutableJSArray = MutableJSArray JSRef deriving(Show, ToJSON, FromJSON) +type Index = Int +newtype JSObjectForSend = JSObjectForSend JSValueForSend deriving(Show, ToJSON, FromJSON) +newtype Object = Object JSVal deriving(Show, ToJSON, FromJSON) +newtype JSStringReceived = JSStringReceived Text deriving(Show, ToJSON, FromJSON) +newtype JSStringForSend = JSStringForSend Text deriving(Show, ToJSON, FromJSON) +newtype JSString = JSString Text deriving(Show, ToJSON, FromJSON) newtype Nullable a = Nullable a + +data AsyncCommand = FreeRef JSValueForSend + | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend + | SetPropertyAtIndex JSObjectForSend Index JSValueForSend + | StringToValue JSStringForSend JSValueForSend + | NumberToValue Double JSValueForSend + | GetPropertyByName JSObjectForSend JSStringForSend JSValueForSend + | GetPropertyAtIndex JSObjectForSend Index JSValueForSend + | CallAsFunction JSObjectForSend JSObjectForSend [JSValueForSend] JSValueForSend + | CallAsConstructor JSObjectForSend [JSValueForSend] JSValueForSend + | NewEmptyObject JSValueForSend + | NewCallback JSValueForSend + | NewArray [JSValueForSend] JSValueForSend + | EvaluateScript JSStringForSend JSValueForSend + deriving (Show, Generic) + +instance ToJSON AsyncCommand where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON AsyncCommand + +data Command = DeRefVal JSValueForSend + | ValueToBool JSValueForSend + | ValueToNumber JSValueForSend + | ValueToString JSValueForSend + | ValueToJSON JSValueForSend + | IsNull JSValueForSend + | IsUndefined JSValueForSend + | StrictEqual JSValueForSend JSValueForSend + | InstanceOf JSValueForSend JSObjectForSend + | PropertyNames JSObjectForSend + | Sync + deriving (Show, Generic) + +instance ToJSON Command where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON Command + +data Batch = Batch [AsyncCommand] Command + deriving (Show, Generic) + +instance ToJSON Batch where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON Batch + +data Result = DeRefValResult JSRef Text + | ValueToBoolResult Bool + | ValueToNumberResult Double + | ValueToStringResult JSStringReceived + | ValueToJSONResult JSStringReceived + | IsNullResult Bool + | IsUndefinedResult Bool + | StrictEqualResult Bool + | InstanceOfResult Bool + | Callback JSValueReceived JSValueReceived [JSValueReceived] + | PropertyNamesResult [JSStringReceived] + | ThrowJSValue JSValueReceived + | ProtocolError Text + | SyncResult + deriving (Show, Generic) + +instance ToJSON Result where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON Result + +data JSContextRef = JSContextRef { + doSendCommand :: Command -> IO Result + , doSendAsyncCommand :: AsyncCommand -> IO () + , addCallback :: Object -> JSCallAsFunction -> IO () + , freeCallback :: Object -> IO () + , nextRef :: TVar JSRef +} + #endif +-- | Type used for Haskell functions called from JavaScript. +type JSCallAsFunction = JSVal -- ^ Function object + -> JSVal -- ^ this + -> [JSVal] -- ^ Function arguments + -> JSM () -- ^ Only () (aka 'JSUndefined') can be returned because + -- the function may need to be executed in a + -- different thread. If you need to get a + -- value out pass in a continuation function + -- as an argument and invoke it from haskell. + -- | The @JSM@ monad keeps track of the JavaScript context. -- -- Given a @JSM@ function and a 'JSContextRef' you can run the @@ -66,4 +169,6 @@ -- For an example of how to set up WebKitGTK+ see tests/TestJSaddle.hs type JSM = ReaderT JSContextRef IO +runJSaddle :: MonadIO m => JSContextRef -> JSM a -> m a +runJSaddle context f = liftIO $ runReaderT f context diff --git a/src/Language/Javascript/JSaddle/Value.hs b/src/Language/Javascript/JSaddle/Value.hs --- a/src/Language/Javascript/JSaddle/Value.hs +++ b/src/Language/Javascript/JSaddle/Value.hs @@ -53,13 +53,13 @@ -- * Make JavaScript values from Haskell ones , val - , valMakeNull + , valNull , valIsNull - , valMakeUndefined + , valUndefined , valIsUndefined , maybeNullOrUndefined , maybeNullOrUndefined' - , valMakeBool + , valBool , valMakeNumber , valMakeString @@ -73,8 +73,9 @@ import Control.Applicative import Prelude hiding (catch) import Language.Javascript.JSaddle.Types - (Object(..), JSString, JSVal) + (Object(..), JSString(..), JSVal(..)) #ifdef ghcjs_HOST_OS +import Control.Monad.IO.Class (MonadIO(..)) import Language.Javascript.JSaddle.Types (MutableJSArray) import GHCJS.Types (JSVal(..), isNull, isUndefined) @@ -83,23 +84,16 @@ import GHCJS.Marshal.Pure (pToJSVal) import Data.JSString.Text (textToJSString) #else -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef - (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) + (wrapJSString, withJSVal, withObject, withJSString, + withToJSVal, wrapJSVal) +import Language.Javascript.JSaddle.WebSockets + (Command(..), AsyncCommand(..), Result(..), sendCommand, + sendLazyCommand) #endif import Language.Javascript.JSaddle.Monad (JSM) -import Language.Javascript.JSaddle.Exception (rethrow) -import Control.Monad.Trans.Reader (ask) -import Control.Monad.IO.Class (MonadIO(..)) import Data.Text (Text) -import qualified Data.Text as T (pack) +import qualified Data.Text as T (pack, unpack) import Language.Javascript.JSaddle.Classes (MakeObject(..), ToJSString(..), ToJSVal(..)) import Language.Javascript.JSaddle.String (strToText, textToStr) @@ -111,7 +105,7 @@ -- >>> import Language.Javascript.JSaddle.Test (testJSaddle) -- >>> import Language.Javascript.JSaddle.Monad (catch) -- >>> import Language.Javascript.JSaddle.Exception (JSException(..)) --- >>> import Language.Javascript.JSaddle.Object (obj) +-- >>> import Language.Javascript.JSaddle.Object (obj, jsg) -- >>> import qualified Data.Text as T (pack) data JSNull = JSNull -- ^ Type that represents a value that can only be null. @@ -165,10 +159,16 @@ #ifdef ghcjs_HOST_OS valToBool value = isTruthy <$> toJSVal value #else -valToBool value = do - gctxt <- ask - withToJSVal value $ \rval -> - liftIO $ jsvaluetoboolean gctxt rval +valToBool value = + toJSVal value >>= \case + (JSVal 0) -> return False -- null + (JSVal 1) -> return False -- undefined + (JSVal 2) -> return False -- false + (JSVal 3) -> return True -- true + val -> + withJSVal val $ \rval -> do + ValueToBoolResult result <- sendCommand (ValueToBool rval) + return result #endif -- | Given a JavaScript value get its numeric value. @@ -195,40 +195,40 @@ valToNumber value = jsrefToNumber <$> toJSVal value foreign import javascript unsafe "$r = Number($1);" jsrefToNumber :: JSVal -> Double #else -valToNumber value = do - gctxt <- ask - withToJSVal value $ \rval -> - rethrow $ liftIO . jsvaluetonumber gctxt rval +valToNumber value = + withToJSVal value $ \rval -> do + ValueToNumberResult result <- sendCommand (ValueToNumber rval) + return result #endif -- | Given a JavaScript value get its string value (as a JavaScript string). -- May throw JSException. -- --- >>> testJSaddle $ valToStr JSNull >>= strToText +-- >>> testJSaddle $ strToText <$> valToStr JSNull -- null --- >>> testJSaddle $ valToStr () >>= strToText +-- >>> testJSaddle $ strToText <$> valToStr () -- undefined --- >>> testJSaddle $ valToStr True >>= strToText +-- >>> testJSaddle $ strToText <$> valToStr True -- true --- >>> testJSaddle $ valToStr False >>= strToText +-- >>> testJSaddle $ strToText <$> valToStr False -- false --- >>> testJSaddle $ valToStr (1.0 :: Double) >>= strToText +-- >>> testJSaddle $ strToText <$> valToStr (1.0 :: Double) -- 1 --- >>> testJSaddle $ valToStr (0.0 :: Double) >>= strToText +-- >>> testJSaddle $ strToText <$> valToStr (0.0 :: Double) -- 0 --- >>> testJSaddle $ valToStr "" >>= strToText +-- >>> testJSaddle $ strToText <$> valToStr "" -- --- >>> testJSaddle $ valToStr "1" >>= strToText +-- >>> testJSaddle $ strToText <$> valToStr "1" -- 1 valToStr :: ToJSVal value => value -> JSM JSString #ifdef ghcjs_HOST_OS valToStr value = jsrefToString <$> toJSVal value foreign import javascript unsafe "$r = $1.toString();" jsrefToString :: JSVal -> JSString #else -valToStr value = do - gctxt <- ask - withToJSVal value $ \rval -> - rethrow (liftIO . jsvaluetostringcopy gctxt rval) >>= wrapJSString +valToStr value = + withToJSVal value $ \rval -> do + ValueToStringResult result <- sendCommand (ValueToString rval) + wrapJSString result #endif -- | Given a JavaScript value get its string value (as a Haskell 'Text'). @@ -251,47 +251,47 @@ -- >>> testJSaddle $ show <$> valToText "1" -- "1" valToText :: ToJSVal value => value -> JSM Text -valToText jsvar = valToStr jsvar >>= strToText +valToText jsvar = strToText <$> valToStr jsvar -- | Given a JavaScript value get a JSON string value. -- May throw JSException. -- --- >>> testJSaddle $ valToJSON 0 JSNull >>= strToText +-- >>> testJSaddle $ strToText <$> valToJSON JSNull -- null --- >>> testJSaddle $ valToJSON 0 () >>= strToText +-- >>> testJSaddle $ strToText <$> valToJSON () -- --- >>> testJSaddle $ valToJSON 0 True >>= strToText +-- >>> testJSaddle $ strToText <$> valToJSON True -- true --- >>> testJSaddle $ valToJSON 0 False >>= strToText +-- >>> testJSaddle $ strToText <$> valToJSON False -- false --- >>> testJSaddle $ valToJSON 0 (1.0 :: Double) >>= strToText +-- >>> testJSaddle $ strToText <$> valToJSON (1.0 :: Double) -- 1 --- >>> testJSaddle $ valToJSON 0 (0.0 :: Double) >>= strToText +-- >>> testJSaddle $ strToText <$> valToJSON (0.0 :: Double) -- 0 --- >>> testJSaddle $ valToJSON 0 "" >>= strToText +-- >>> testJSaddle $ strToText <$> valToJSON "" -- "" --- >>> testJSaddle $ valToJSON 0 "1" >>= strToText +-- >>> testJSaddle $ strToText <$> valToJSON "1" -- "1" --- >>> testJSaddle $ obj >>= valToJSON 0 >>= strToText +-- >>> testJSaddle $ strToText <$> (obj >>= valToJSON) -- {} -valToJSON :: ToJSVal value => Word -> value -> JSM JSString +valToJSON :: ToJSVal value => value -> JSM JSString #ifdef ghcjs_HOST_OS -valToJSON indent value = jsrefToJSON <$> toJSVal value -foreign import javascript unsafe "$r = JSON.stringify($1);" jsrefToJSON :: JSVal -> JSString +valToJSON value = jsrefToJSON <$> toJSVal value +foreign import javascript unsafe "$r = $1 === undefined ? \"\" : JSON.stringify($1);" jsrefToJSON :: JSVal -> JSString #else -valToJSON indent value = do - gctxt <- ask - withToJSVal value $ \rval -> - rethrow (liftIO . jsvaluecreatejsonstring gctxt rval (fromIntegral indent)) >>= wrapJSString +valToJSON value = + withToJSVal value $ \rval -> do + ValueToJSONResult result <- sendCommand (ValueToJSON rval) + wrapJSString result #endif -- | Given a JavaScript value get its object value. -- May throw JSException. -- -- >>> testJSaddle $ (valToObject JSNull >>= valToText) `catch` \ (JSException e) -> valToText e --- TypeError:...null...is not an object +-- null -- >>> testJSaddle $ (valToObject () >>= valToText) `catch` \ (JSException e) -> valToText e --- TypeError:...undefined...is not an object +-- undefined -- >>> testJSaddle $ valToObject True -- true -- >>> testJSaddle $ valToObject False @@ -305,14 +305,7 @@ -- >>> testJSaddle $ valToObject "1" -- 1 valToObject :: ToJSVal value => value -> JSM Object -valToObject value = Object <$> -#ifdef ghcjs_HOST_OS - toJSVal value -#else - do gctxt <- ask - withToJSVal value $ \rval -> - rethrow (liftIO . jsvaluetoobject gctxt rval) >>= makeNewJSVal -#endif +valToObject value = Object <$> toJSVal value instance MakeObject JSVal where makeObject = valToObject @@ -337,25 +330,25 @@ toJSVal v = v >>= toJSVal ----------- null --------------- --- | Make a @null@ JavaScript value -valMakeNull :: JSM JSVal +-- | A @null@ JavaScript value +valNull :: JSVal #ifdef ghcjs_HOST_OS -valMakeNull = return jsNull +valNull = jsNull #else -valMakeNull = ask >>= (liftIO . jsvaluemakenull) >>= makeNewJSVal +valNull = JSVal 0 #endif -- | Makes a @null@ JavaScript value instance ToJSVal JSNull where - toJSVal = const valMakeNull + toJSVal = const (return valNull) -- | Makes an argument list with just a single @null@ JavaScript value instance MakeArgs JSNull where - makeArgs _ = valMakeNull >>= (\ref -> return [ref]) + makeArgs _ = return [valNull] -- | Makes a JSVal or @null@ JavaScript value instance ToJSVal a => ToJSVal (Maybe a) where - toJSVal Nothing = valMakeNull + toJSVal Nothing = return valNull toJSVal (Just a) = toJSVal a -- | Test a JavaScript value to see if it is @null@ @@ -363,24 +356,27 @@ #ifdef ghcjs_HOST_OS valIsNull value = isNull <$> toJSVal value #else -valIsNull value = do - gctxt <- ask - withToJSVal value $ \rval -> - liftIO $ jsvalueisnull gctxt rval +valIsNull value = + toJSVal value >>= \case + JSVal 0 -> return True + v -> + withJSVal v $ \rval -> do + IsNullResult result <- sendCommand $ IsNull rval + return result #endif ----------- undefined --------------- --- | Make an @undefined@ JavaScript value -valMakeUndefined :: JSM JSVal +-- | An @undefined@ JavaScript value +valUndefined :: JSVal #ifdef ghcjs_HOST_OS -valMakeUndefined = return jsUndefined +valUndefined = jsUndefined #else -valMakeUndefined = ask >>= (liftIO . jsvaluemakeundefined) >>= makeNewJSVal +valUndefined = JSVal 1 #endif -- | Makes an @undefined@ JavaScript value instance ToJSVal JSUndefined where - toJSVal = const valMakeUndefined + toJSVal = const (return valUndefined) --We can't allow this if JSUndefined is () as () is no args not "(null)". --Use [()] instead. @@ -396,10 +392,12 @@ #ifdef ghcjs_HOST_OS valIsUndefined value = isUndefined <$> toJSVal value #else -valIsUndefined value = do - gctxt <- ask - withToJSVal value $ \rval -> - liftIO $ jsvalueisundefined gctxt rval +valIsUndefined value = toJSVal value >>= \case + JSVal 1 -> return True + v -> + withJSVal v $ \rval -> do + IsUndefinedResult result <- sendCommand $ IsUndefined rval + return result #endif -- | Convert a JSVal to a Maybe JSVal (converting null and undefined to Nothing) @@ -424,23 +422,21 @@ _ -> Just <$> f rval ----------- booleans --------------- --- | Make a JavaScript boolean value -valMakeBool :: Bool -> JSM JSVal +-- | A JavaScript boolean value +valBool :: Bool -> JSVal #ifdef ghcjs_HOST_OS -valMakeBool b = return $ toJSBool b +valBool b = toJSBool b #else -valMakeBool b = do - gctxt <- ask - liftIO (jsvaluemakeboolean gctxt b) >>= makeNewJSVal +valBool b = JSVal $ if b then 3 else 2 #endif -- | Make a JavaScript boolean value instance ToJSVal Bool where - toJSVal = valMakeBool + toJSVal = return . valBool -- | Makes an argument list with just a single JavaScript boolean value instance MakeArgs Bool where - makeArgs b = valMakeBool b >>= (\ref -> return [ref]) + makeArgs b = return [valBool b] ----------- numbers --------------- -- | Make a JavaScript number @@ -448,9 +444,7 @@ #ifdef ghcjs_HOST_OS valMakeNumber n = liftIO $ GHCJS.toJSVal n #else -valMakeNumber n = do - gctxt <- ask - liftIO (jsvaluemakenumber gctxt n) >>= makeNewJSVal +valMakeNumber = sendLazyCommand . NumberToValue #endif -- | Makes a JavaScript number @@ -487,10 +481,7 @@ #ifdef ghcjs_HOST_OS valMakeText = return . pToJSVal . textToJSString #else -valMakeText text = do - gctxt <- ask - withJSString (textToStr text) $ \s -> - liftIO (jsvaluemakestring gctxt s) >>= makeNewJSVal +valMakeText text = valMakeString (textToStr text) #endif -- | Make a JavaScript string from `JSString` @@ -498,10 +489,8 @@ #ifdef ghcjs_HOST_OS valMakeString = return . pToJSVal #else -valMakeString str = do - gctxt <- ask - withJSString str $ \s -> - liftIO (jsvaluemakestring gctxt s) >>= makeNewJSVal +valMakeString s = + withJSString s $ sendLazyCommand . StringToValue #endif -- | Makes a JavaScript string @@ -549,6 +538,8 @@ -- >>> testJSaddle $ showJSValue <$> deRefVal "1" -- "1" -- >>> testJSaddle $ showJSValue <$> (valToObject True >>= deRefVal) +-- true +-- >>> testJSaddle $ showJSValue <$> (obj >>= deRefVal) -- object deRefVal :: ToJSVal value => value -> JSM JSValue #ifdef ghcjs_HOST_OS @@ -569,16 +560,16 @@ (typeof $1===\"object\")?5:-1;" jsrefGetType :: JSVal -> Int #else 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 + sendCommand (DeRefVal rval) >>= \case + DeRefValResult 0 _ -> return ValNull + DeRefValResult 1 _ -> return ValUndefined + DeRefValResult 2 _ -> return $ ValBool False + DeRefValResult 3 _ -> return $ ValBool True + DeRefValResult (-1) s -> return $ ValNumber (read (T.unpack s)) + DeRefValResult (-2) s -> return $ ValString s + DeRefValResult ref _ -> return $ ValObject (Object (JSVal ref)) #endif -- | Make a JavaScript value out of a 'JSValue' ADT. @@ -596,9 +587,9 @@ valMakeRef :: JSValue -> JSM JSVal valMakeRef value = case value of - ValNull -> valMakeNull - ValUndefined -> valMakeUndefined - ValBool b -> valMakeBool b + ValNull -> return valNull + ValUndefined -> return valUndefined + ValBool b -> return $ valBool b ValNumber n -> valMakeNumber n ValString s -> valMakeText s ValObject (Object o) -> return o @@ -620,6 +611,15 @@ "$1===$2" jsvalueisstrictequal :: JSVal -> JSVal -> Bool #endif +-- | Determine if two values are equal (JavaScripts ===) +-- >>> testJSaddle $ strictEqual True False +-- false +-- >>> testJSaddle $ strictEqual True True +-- true +-- >>> testJSaddle $ strictEqual "Hello" () +-- false +-- >>> testJSaddle $ strictEqual "Hello" "Hello" +-- true strictEqual :: (ToJSVal a, ToJSVal b) => a -> b -> JSM Bool strictEqual a b = do aval <- toJSVal a @@ -627,34 +627,31 @@ #ifdef ghcjs_HOST_OS return $ jsvalueisstrictequal aval bval #else - gctxt <- ask withJSVal aval $ \aref -> - withJSVal bval $ \bref -> - liftIO $ jsvalueisstrictequal gctxt aref bref + withJSVal bval $ \bref -> do + StrictEqualResult result <- sendCommand $ StrictEqual aref bref + return result #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 +foreign import javascript unsafe "$1 instanceof $2" + js_isInstanceOf :: JSVal -> Object -> Bool #endif +-- | Determine if two values are equal (JavaScripts ===) +-- >>> testJSaddle $ instanceOf obj (Object <$> jsg "Object") +-- true 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 + return $ js_isInstanceOf v c #else - gctxt <- ask withJSVal v $ \rval -> - withObject c $ \c' -> - rethrow $ liftIO . jsvalueisinstanceofconstructor gctxt rval c' + withObject c $ \c' -> do + InstanceOfResult result <- sendCommand $ InstanceOf rval c' + return result #endif diff --git a/src/Language/Javascript/JSaddle/WebSockets.hs b/src/Language/Javascript/JSaddle/WebSockets.hs new file mode 100644 --- /dev/null +++ b/src/Language/Javascript/JSaddle/WebSockets.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- +-- Module : Language.Javascript.JSaddle.WebSockets +-- Copyright : (c) Hamish Mackenzie +-- License : MIT +-- +-- Maintainer : Hamish Mackenzie +-- +-- | +-- +----------------------------------------------------------------------------- + +module Language.Javascript.JSaddle.WebSockets ( + jsaddleOr + , run + , AsyncCommand(..) + , Command(..) + , Result(..) + , sendCommand + , sendLazyCommand + , sendAsyncCommand + , syncPoint + , syncAfter +) where + +import Control.Exception (throwIO) +import Control.Monad (void, forever) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans.Reader (asks) +import Control.Monad.STM (STM, atomically) +import Control.Concurrent (forkIO) +import Control.Concurrent.STM.TChan + (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO) +import Control.Concurrent.STM.TVar + (writeTVar, readTVar, readTVarIO, modifyTVar, newTVarIO) +import Control.Concurrent.MVar + (MVar, MVar, putMVar, takeMVar, newEmptyMVar) + +import Data.Monoid ((<>)) +import qualified Data.Text as T (unpack) +import qualified Data.Map as M (lookup, delete, insert, empty) +import Data.Aeson (encode, decode) + +import Network.Wai (Application) +import Network.WebSockets + (ConnectionOptions(..), sendTextData, receiveDataMessage, + acceptRequest, defaultConnectionOptions, ServerApp) +import qualified Network.WebSockets as WS (DataMessage(..)) +import Network.Wai.Handler.WebSockets (websocketsOr) + +import Language.Javascript.JSaddle.Types + (Command(..), AsyncCommand(..), Result(..), JSContextRef(..), JSVal(..), + Object(..), JSValueReceived(..), JSM, Batch(..), JSValueForSend(..), runJSaddle) +import Language.Javascript.JSaddle.Exception (JSException(..)) +import Language.Javascript.JSaddle.Native (wrapJSVal) +import Language.Javascript.JSaddle.WebSockets.Files (mkEmbedded) +import Network.Wai.Handler.Warp + (defaultSettings, setTimeout, setPort, runSettings) +import Network.Wai.Application.Static + (ssIndices, staticApp) +import WaiAppStatic.Storage.Embedded (mkSettings) +import WaiAppStatic.Types (unsafeToPiece) + +sendCommand :: Command -> JSM Result +sendCommand cmd = do + s <- asks doSendCommand + liftIO $ s cmd + +sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal +sendLazyCommand cmd = do + nextRefTVar <- asks nextRef + n <- liftIO . atomically $ do + n <- subtract 1 <$> readTVar nextRefTVar + writeTVar nextRefTVar n + return n + s <- asks doSendAsyncCommand + liftIO $ s (cmd $ JSValueForSend n) + wrapJSVal (JSValueReceived n) + +sendAsyncCommand :: AsyncCommand -> JSM () +sendAsyncCommand cmd = do + s <- asks doSendAsyncCommand + liftIO $ s cmd + +-- | Forces execution of pending asyncronous code +syncPoint :: JSM () +syncPoint = void $ sendCommand Sync + +-- | Forces execution of pending asyncronous code after performing `f` +syncAfter :: JSM a -> JSM a +syncAfter f = do + result <- f + syncPoint + return result + +jsaddleOr :: ConnectionOptions -> JSM () -> Application -> Application +jsaddleOr opts entryPoint = websocketsOr opts wsApp + where + wsApp :: ServerApp + wsApp pending_conn = do + conn <- acceptRequest pending_conn + recvChan <- newTChanIO + commandChan <- newTChanIO + callbacks <- newTVarIO M.empty + nextRef <- newTVarIO 0 + let ctx = JSContextRef { + doSendCommand = \cmd -> do + result <- newEmptyMVar + atomically $ writeTChan commandChan (Right (cmd, result)) + takeMVar result >>= \case + (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v) + result -> return result + , doSendAsyncCommand = atomically . writeTChan commandChan . Left + , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar callbacks (M.insert val cb) + , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar callbacks (M.delete val) + , nextRef = nextRef + } + forkIO . forever $ + receiveDataMessage conn >>= \case + (WS.Text t) -> + case decode t of + Nothing -> error $ "jsaddle WebSocket decode failed : " <> show t + Just (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err + Just (Callback f this a) -> do + f'@(JSVal fNumber) <- runJSaddle ctx $ wrapJSVal f + this' <- runJSaddle ctx $ wrapJSVal this + args <- runJSaddle ctx $ mapM wrapJSVal a + (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case + Nothing -> liftIO $ putStrLn "Callback called after it was freed" + Just cb -> void . forkIO . runJSaddle ctx $ cb f' this' args + Just m -> atomically $ writeTChan recvChan m + _ -> error "jsaddle WebSocket unexpected binary data" + forkIO . forever $ atomically (readBatch commandChan) >>= \case + (batch, Just resultMVar) -> do + sendTextData conn $ encode batch + atomically (readTChan recvChan) >>= putMVar resultMVar + (batch, Nothing) -> do + sendTextData conn $ encode batch + atomically (readTChan recvChan) >>= \case + SyncResult -> return () + ThrowJSValue e -> atomically (discardToSyncPoint commandChan) >>= (`putMVar` ThrowJSValue e) + _ -> error "Unexpected result processing batch" + return () + runJSaddle ctx entryPoint + + readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> STM (Batch, Maybe (MVar Result)) + readBatch chan = do + first <- readTChan chan -- We want at least one command to send + loop first [] + where + loop (Right (cmd, resultMVar)) asyncCmds = + return (Batch (reverse asyncCmds) cmd, Just resultMVar) + loop (Left asyncCmd) asyncCmds' = do + let asyncCmds = asyncCmd:asyncCmds' + tryReadTChan chan >>= \case + Nothing -> return (Batch (reverse asyncCmds) Sync, Nothing) + Just cmd -> loop cmd asyncCmds + discardToSyncPoint :: TChan (Either AsyncCommand (Command, MVar Result)) -> STM (MVar Result) + discardToSyncPoint chan = + readTChan chan >>= \case + Right (_, resultMVar) -> return resultMVar + _ -> discardToSyncPoint chan + +jsaddleApp :: Application +jsaddleApp = staticApp ($(mkSettings mkEmbedded)) {ssIndices = [unsafeToPiece "index.html"]} + +run :: Int -> JSM () -> IO () +run port f = + runSettings (setPort port (setTimeout 3600 defaultSettings)) $ + jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp diff --git a/src/Language/Javascript/JSaddle/WebSockets/Files.hs b/src/Language/Javascript/JSaddle/WebSockets/Files.hs new file mode 100644 --- /dev/null +++ b/src/Language/Javascript/JSaddle/WebSockets/Files.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} +----------------------------------------------------------------------------- +-- +-- Module : Language.Javascript.JSaddle.WebSockets.Files +-- Copyright : (c) Hamish Mackenzie +-- License : MIT +-- +-- Maintainer : Hamish Mackenzie +-- +-- | +-- +----------------------------------------------------------------------------- + +module Language.Javascript.JSaddle.WebSockets.Files ( + mkEmbedded +) where + +import WaiAppStatic.Storage.Embedded +import qualified Data.ByteString.Lazy as BL + +mkEmbedded :: IO [EmbeddableEntry] +mkEmbedded = do + indexFile <- BL.readFile "data/index.html" + jsFile <- BL.readFile "data/jsaddle.js" + let index = EmbeddableEntry { + eLocation = "index.html" + , eMimeType = "text/html" + , eContent = Left ("", indexFile) + } + js = EmbeddableEntry { + eLocation = "jsaddle.js" + , eMimeType = "text/plain" + , eContent = Left ("", jsFile) + } + return [index, js] + diff --git a/tests/DocTest.hs b/tests/DocTest.hs --- a/tests/DocTest.hs +++ b/tests/DocTest.hs @@ -1,35 +1,73 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE LambdaCase #-} module Main ( main ) where +#ifndef ghcjs_HOST_OS import Test.DocTest +import System.IO (stderr, BufferMode(..), stdout, hSetBuffering) +import System.FilePath (()) +import System.Exit (exitWith, ExitCode(..)) +import System.Process (system) +import Control.Concurrent (forkIO) +import Control.Monad (void) +import Data.Monoid ((<>)) +import Paths_jsaddle (getDataDir) +#endif main :: IO () -main = doctest [ - "-hide-all-packages", - "-package=webkitgtk3-javascriptcore-" ++ VERSION_webkitgtk3_javascriptcore, - "-package=template-haskell-" ++ VERSION_template_haskell, - "-package=base-" ++ VERSION_base, - "-package=lens-" ++ VERSION_lens, - "-package=text-" ++ VERSION_text, - "-package=transformers-" ++ VERSION_transformers, - "-package=haskell-gi-base-" ++ VERSION_haskell_gi_base, - "-package=gi-glib-" ++ VERSION_gi_glib, - "-package=gi-gtk-" ++ VERSION_gi_gtk, - "-package=gi-webkit-" ++ VERSION_gi_webkit, - "-package=gi-javascriptcore-" ++ VERSION_gi_javascriptcore, - "-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" ] - +main = do + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering +#ifdef ghcjs_HOST_OS + putStrLn "TODO find a way to run doctest tests with GHCJS" + return () +#else + dataDir <- getDataDir + node <- system "nodejs --version" >>= \case + ExitSuccess -> return "nodejs" + _ -> return "node" + system (node <> " --version") >>= \case + ExitSuccess -> putStrLn "Node.js found" + e -> do + putStrLn "Node.js not found" + exitWith e + forkIO . void . system $ node <> " --harmony " <> dataDir "data/jsaddle.js" + doctest [ + "-hide-all-packages", + "-package=template-haskell-" ++ VERSION_template_haskell, + "-package=base-" ++ VERSION_base, + "-package=lens-" ++ VERSION_lens, + "-package=text-" ++ VERSION_text, + "-package=bytestring-" ++ VERSION_bytestring, + "-package=transformers-" ++ VERSION_transformers, + "-package=websockets-" ++ VERSION_websockets, + "-package=primitive-" ++ VERSION_primitive, + "-package=aeson-" ++ VERSION_aeson, + "-package=websockets-" ++ VERSION_websockets, + "-package=wai-" ++ VERSION_wai, + "-package=wai-websockets-" ++ VERSION_wai_websockets, + "-package=wai-app-static-" ++ VERSION_wai_app_static, + "-package=warp-" ++ VERSION_warp, + "-package=http-types-" ++ VERSION_http_types, + "-package=stm-" ++ VERSION_stm, + "-package=containers-" ++ VERSION_containers, + "-package=process-" ++ VERSION_process, + "-package=filepath-" ++ VERSION_filepath, + "-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" ] +#endif