jsaddle 0.4.0.5 → 0.5.0.0
raw patch · 16 files changed
+1007/−778 lines, 16 filesdep +aesondep +bytestringdep +containersdep −gi-glibdep −gi-gtkdep −gi-javascriptcoredep ~doctestdep ~textdep ~transformers
Dependencies added: aeson, bytestring, containers, filepath, http-types, primitive, process, stm, wai, wai-app-static, wai-websockets, warp, websockets
Dependencies removed: gi-glib, gi-gtk, gi-javascriptcore, gi-webkit, haskell-gi-base, webkitgtk3-javascriptcore
Dependency ranges changed: doctest, text, transformers, vector
Files
- data/index.html +9/−0
- data/jsaddle.js +187/−0
- jsaddle.cabal +42/−28
- src/Language/Javascript/JSaddle/Evaluate.hs +17/−40
- src/Language/Javascript/JSaddle/Exception.hs +9/−10
- src/Language/Javascript/JSaddle/Monad.hs +27/−83
- src/Language/Javascript/JSaddle/Native.hs +32/−57
- src/Language/Javascript/JSaddle/Object.hs +87/−184
- src/Language/Javascript/JSaddle/Properties.hs +31/−42
- src/Language/Javascript/JSaddle/String.hs +5/−30
- src/Language/Javascript/JSaddle/Test.hs +33/−125
- src/Language/Javascript/JSaddle/Types.hs +127/−22
- src/Language/Javascript/JSaddle/Value.hs +127/−130
- src/Language/Javascript/JSaddle/WebSockets.hs +173/−0
- src/Language/Javascript/JSaddle/WebSockets/Files.hs +36/−0
- tests/DocTest.hs +65/−27
+ data/index.html view
@@ -0,0 +1,9 @@+<!DOCTYPE html>+<html>+<head>+<title>JSaddle</title>+</head>+<body>+</body>+<script src="jsaddle.js"></script>+</html>
+ data/jsaddle.js view
@@ -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();
jsaddle.cabal view
@@ -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 <https://github.com/ghcjs/webkit-javascriptcore>. 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
src/Language/Javascript/JSaddle/Evaluate.hs view
@@ -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
src/Language/Javascript/JSaddle/Exception.hs view
@@ -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
src/Language/Javascript/JSaddle/Monad.hs view
@@ -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
src/Language/Javascript/JSaddle/Native.hs view
@@ -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
src/Language/Javascript/JSaddle/Object.hs view
@@ -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--- <BLANKLINE> -- undefined -- >>> testJSaddle $ do w <- jsg "console"; w ^. js1 "log" "Hello World"--- ** Message: console message:...@0: Hello World--- <BLANKLINE> -- 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--- <BLANKLINE> -- 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
src/Language/Javascript/JSaddle/Properties.hs view
@@ -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
src/Language/Javascript/JSaddle/String.hs view
@@ -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
src/Language/Javascript/JSaddle/Test.hs view
@@ -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)
src/Language/Javascript/JSaddle/Types.hs view
@@ -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
src/Language/Javascript/JSaddle/Value.hs view
@@ -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 "" -- <BLANKLINE>--- >>> 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 () -- <BLANKLINE>--- >>> 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
+ src/Language/Javascript/JSaddle/WebSockets.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+--+-- Module : Language.Javascript.JSaddle.WebSockets+-- Copyright : (c) Hamish Mackenzie+-- License : MIT+--+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>+--+-- |+--+-----------------------------------------------------------------------------++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
+ src/Language/Javascript/JSaddle/WebSockets/Files.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}+-----------------------------------------------------------------------------+--+-- Module : Language.Javascript.JSaddle.WebSockets.Files+-- Copyright : (c) Hamish Mackenzie+-- License : MIT+--+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@gmail.com>+--+-- |+--+-----------------------------------------------------------------------------++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]+
tests/DocTest.hs view
@@ -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