diff --git a/data/index.html b/data/index.html
deleted file mode 100644
--- a/data/index.html
+++ /dev/null
@@ -1,9 +0,0 @@
-
-
-
-JSaddle
-
-
-
-
-
diff --git a/data/jsaddle.js b/data/jsaddle.js
deleted file mode 100644
--- a/data/jsaddle.js
+++ /dev/null
@@ -1,201 +0,0 @@
-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) {
- var batch = JSON.parse(e.data);
-
- var processBatch = function(timestamp) {
- try {
- 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":
- (function() {
- 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;
- case "SyncWithAnimationFrame":
- var n = d.contents[0];
- jsaddle_values.set(n, timestamp);
- 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}));
- }
- };
- if(batch[2]) {
- window.requestAnimationFrame(processBatch);
- }
- else {
- processBatch(window.performance ? window.performance.now() : null);
- }
- };
- };
- 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.5.2.0
+version: 0.6.0.0
cabal-version: >=1.10
build-type: Simple
license: MIT
@@ -13,9 +13,6 @@
drive a small JavaScipt helper.
category: Web, Javascript
author: Hamish Mackenzie
-data-files:
- data/index.html
- data/jsaddle.js
source-repository head
type: git
@@ -28,10 +25,6 @@
ghcjs-base -any,
ghcjs-prim -any
else
- 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,
@@ -41,12 +34,7 @@
process >=1.2.3.0 && <1.5,
ref-tf >=0.4.0.1 && <0.5,
stm >=2.4.4 && <2.5,
- time >=1.5.0.1 && <1.7,
- 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
+ time >=1.5.0.1 && <1.7
exposed-modules:
Language.Javascript.JSaddle
Language.Javascript.JSaddle.Arguments
@@ -57,43 +45,20 @@
Language.Javascript.JSaddle.Native
Language.Javascript.JSaddle.Object
Language.Javascript.JSaddle.Properties
+ Language.Javascript.JSaddle.Run
+ Language.Javascript.JSaddle.Run.Files
Language.Javascript.JSaddle.String
Language.Javascript.JSaddle.Value
Language.Javascript.JSaddle.Types
- Paths_jsaddle
build-depends:
base <5,
- lens >=3.8.5 && <4.15,
+ lens >=3.8.5 && <4.16,
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
+ ghc-options: -ferror-spans -Wall
-test-suite test-tool
- if !impl(ghcjs -any)
- 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
- type: exitcode-stdio-1.0
- main-is: DocTest.hs
- build-depends:
- base -any
- default-language: Haskell2010
- hs-source-dirs: tests
- 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
@@ -29,7 +29,7 @@
#else
import Language.Javascript.JSaddle.Native
(withJSString)
-import Language.Javascript.JSaddle.WebSockets
+import Language.Javascript.JSaddle.Run
(AsyncCommand(..), sendLazyCommand)
#endif
import Language.Javascript.JSaddle.Classes
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
@@ -21,7 +21,6 @@
-- * Running JavaScript in a JavaScript context
, askJSM
- , run
, runJSM
, runJSaddle
@@ -36,12 +35,12 @@
, bracket
) where
-import Prelude hiding (catch, read)
+import Prelude hiding (read)
import Control.Monad.Trans.Reader (runReaderT, ask, ReaderT(..))
import Control.Monad.IO.Class (MonadIO(..))
import qualified Control.Exception as E (Exception, catch, bracket)
import Language.Javascript.JSaddle.Types (JSM(..), MonadJSM, liftJSM, JSContextRef(..))
-import Language.Javascript.JSaddle.WebSockets (run, syncPoint, syncAfter, waitForAnimationFrame, nextAnimationFrame)
+import Language.Javascript.JSaddle.Run (syncPoint, syncAfter, waitForAnimationFrame, nextAnimationFrame)
-- | Gets the JavaScript context from the monad
askJSM :: MonadJSM m => m JSContextRef
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
@@ -109,7 +109,7 @@
#else
import Language.Javascript.JSaddle.Native
(wrapJSString, withJSVals, withObject)
-import Language.Javascript.JSaddle.WebSockets
+import Language.Javascript.JSaddle.Run
(Command(..), AsyncCommand(..), Result(..), sendCommand, sendLazyCommand)
#endif
import Language.Javascript.JSaddle.Value (valToObject)
@@ -443,10 +443,10 @@
makeFunctionWithCallback :: Callback (JSVal -> JSVal -> IO ()) -> IO Object
#else
function f = do
- obj <- Object <$> sendLazyCommand NewCallback
+ object <- Object <$> sendLazyCommand NewCallback
add <- addCallback <$> askJSM
- liftIO $ add obj f
- return $ Function obj
+ liftIO $ add object f
+ return $ Function object
#endif
freeFunction :: Function -> JSM ()
@@ -454,9 +454,9 @@
freeFunction (Function callback _) = liftIO $
releaseCallback callback
#else
-freeFunction (Function obj) = do
+freeFunction (Function object) = do
free <- freeCallback <$> askJSM
- liftIO $ free obj
+ liftIO $ free object
#endif
instance ToJSVal Function where
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
@@ -31,14 +31,14 @@
import Language.Javascript.JSaddle.Classes
(ToJSVal(..), ToJSString(..))
-import Language.Javascript.JSaddle.Monad (askJSM, JSM)
+import Language.Javascript.JSaddle.Monad (JSM)
import Language.Javascript.JSaddle.Types (Object(..))
#ifdef ghcjs_HOST_OS
import Language.Javascript.JSaddle.Types (JSString)
#else
import Language.Javascript.JSaddle.Native
(withObject, withJSString, withToJSVal)
-import Language.Javascript.JSaddle.WebSockets
+import Language.Javascript.JSaddle.Run
(AsyncCommand(..), sendLazyCommand, sendAsyncCommand)
#endif
import Language.Javascript.JSaddle.Value (JSVal)
@@ -108,8 +108,7 @@
foreign import javascript unsafe "$2[$1]=$3"
js_trySetAtIndex :: Int -> Object -> JSVal -> IO ()
#else
-objSetPropertyAtIndex this index val = do
- gctxt <- askJSM
+objSetPropertyAtIndex this index val =
withObject this $ \rthis ->
withToJSVal val $ \rval ->
sendAsyncCommand $ SetPropertyAtIndex rthis index rval
diff --git a/src/Language/Javascript/JSaddle/Run.hs b/src/Language/Javascript/JSaddle/Run.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Javascript/JSaddle/Run.hs
@@ -0,0 +1,196 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Language.Javascript.JSaddle.Run
+-- Copyright : (c) Hamish Mackenzie
+-- License : MIT
+--
+-- Maintainer : Hamish Mackenzie
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Language.Javascript.JSaddle.Run (
+ -- * Running JSM
+ runJavaScript
+ , syncPoint
+ , syncAfter
+ , waitForAnimationFrame
+ , nextAnimationFrame
+#ifndef ghcjs_HOST_OS
+ -- * Functions used to implement JSaddle using JSON messaging
+ , AsyncCommand(..)
+ , Command(..)
+ , Result(..)
+ , sendCommand
+ , sendLazyCommand
+ , sendAsyncCommand
+#endif
+) where
+
+#ifdef ghcjs_HOST_OS
+import Language.Javascript.JSaddle.Types (JSM)
+import qualified JavaScript.Web.AnimationFrame as GHCJS
+ (waitForAnimationFrame)
+#else
+import Control.Exception (throwIO)
+import Control.Monad (void, forever)
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Trans.Reader (ask, runReaderT)
+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.Time.Clock (getCurrentTime,diffUTCTime)
+
+import Language.Javascript.JSaddle.Types
+ (Command(..), AsyncCommand(..), Result(..), JSContextRef(..), JSVal(..),
+ Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
+import Language.Javascript.JSaddle.Exception (JSException(..))
+import Language.Javascript.JSaddle.Native (wrapJSVal)
+#endif
+
+-- | Forces execution of pending asyncronous code
+syncPoint :: JSM ()
+#ifdef ghcjs_HOST_OS
+syncPoint = return ()
+#else
+syncPoint = void $ sendCommand Sync
+#endif
+
+-- | Forces execution of pending asyncronous code after performing `f`
+syncAfter :: JSM a -> JSM a
+#ifdef ghcjs_HOST_OS
+syncAfter = id
+#else
+syncAfter f = do
+ result <- f
+ syncPoint
+ return result
+#endif
+
+-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
+-- On GHC it will delay the execution of the current batch of asynchronous
+-- command when they are sent to JavaScript. It will not delay the Haskell
+-- code execution. The time returned will be based on the Haskell clock
+-- (not the JavaScript clock).
+waitForAnimationFrame :: JSM Double
+#ifdef ghcjs_HOST_OS
+waitForAnimationFrame = GHCJS.waitForAnimationFrame
+#else
+waitForAnimationFrame = do
+ -- We can't get the timestamp from requestAnimationFrame so this will have to do
+ start <- startTime <$> JSM ask
+ now <- liftIO getCurrentTime
+ void $ sendLazyCommand SyncWithAnimationFrame
+ return $ realToFrac (diffUTCTime now start)
+#endif
+
+-- | Tries to executes the given code in the next animation frame callback.
+-- Avoid synchronous opperations where possible.
+nextAnimationFrame :: (Double -> JSM a) -> JSM a
+nextAnimationFrame f = do
+ t <- waitForAnimationFrame
+ syncAfter (f t)
+
+#ifndef ghcjs_HOST_OS
+sendCommand :: Command -> JSM Result
+sendCommand cmd = do
+ s <- doSendCommand <$> JSM ask
+ liftIO $ s cmd
+
+sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
+sendLazyCommand cmd = do
+ nextRefTVar <- nextRef <$> JSM ask
+ n <- liftIO . atomically $ do
+ n <- subtract 1 <$> readTVar nextRefTVar
+ writeTVar nextRefTVar n
+ return n
+ s <- doSendAsyncCommand <$> JSM ask
+ liftIO $ s (cmd $ JSValueForSend n)
+ wrapJSVal (JSValueReceived n)
+
+sendAsyncCommand :: AsyncCommand -> JSM ()
+sendAsyncCommand cmd = do
+ s <- doSendAsyncCommand <$> JSM ask
+ liftIO $ s cmd
+
+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Result -> IO (), IO ())
+runJavaScript sendBatch entryPoint = do
+ startTime' <- getCurrentTime
+ recvChan <- newTChanIO
+ commandChan <- newTChanIO
+ callbacks <- newTVarIO M.empty
+ nextRef' <- newTVarIO 0
+ let ctx = JSContextRef {
+ startTime = startTime'
+ , doSendCommand = \cmd -> do
+ result <- newEmptyMVar
+ atomically $ writeTChan commandChan (Right (cmd, result))
+ takeMVar result >>= \case
+ (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
+ r -> return r
+ , 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'
+ }
+ let processResult = \case
+ (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
+ (Callback f this a) -> do
+ f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
+ this' <- runReaderT (unJSM $ wrapJSVal this) ctx
+ args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
+ (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
+ Nothing -> liftIO $ putStrLn "Callback called after it was freed"
+ Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
+ m -> atomically $ writeTChan recvChan m
+ _ <- forkIO . forever $ readBatch commandChan >>= \case
+ (batch, Just resultMVar) -> do
+ sendBatch batch
+ atomically (readTChan recvChan) >>= putMVar resultMVar
+ (batch, Nothing) -> do
+ sendBatch batch
+ atomically (readTChan recvChan) >>= \case
+ SyncResult -> return ()
+ ThrowJSValue e -> atomically (discardToSyncPoint commandChan) >>= (`putMVar` ThrowJSValue e)
+ _ -> error "Unexpected result processing batch"
+ return ()
+ return (processResult, runReaderT (unJSM entryPoint) ctx)
+ where
+ readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, Maybe (MVar Result))
+ readBatch chan = do
+ first <- atomically $ readTChan chan -- We want at least one command to send
+ loop first []
+ where
+ loop (Left asyncCmd@(SyncWithAnimationFrame _)) asyncCmds =
+ atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (asyncCmd:asyncCmds)
+ loop (Right (cmd, resultMVar)) asyncCmds =
+ return (Batch (reverse asyncCmds) cmd False, Just resultMVar)
+ loop (Left asyncCmd) asyncCmds' = do
+ let asyncCmds = asyncCmd:asyncCmds'
+ atomically (tryReadTChan chan) >>= \case
+ Nothing -> return (Batch (reverse asyncCmds) Sync False, Nothing)
+ Just cmd -> loop cmd asyncCmds
+ -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
+ loopAnimation (Right (cmd, resultMVar)) asyncCmds =
+ return (Batch (reverse asyncCmds) cmd True, Just resultMVar)
+ loopAnimation (Left asyncCmd) asyncCmds =
+ atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (asyncCmd:asyncCmds)
+ discardToSyncPoint :: TChan (Either AsyncCommand (Command, MVar Result)) -> STM (MVar Result)
+ discardToSyncPoint chan =
+ readTChan chan >>= \case
+ Right (_, resultMVar) -> return resultMVar
+ _ -> discardToSyncPoint chan
+#endif
diff --git a/src/Language/Javascript/JSaddle/Run/Files.hs b/src/Language/Javascript/JSaddle/Run/Files.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Javascript/JSaddle/Run/Files.hs
@@ -0,0 +1,251 @@
+{-# LANGUAGE OverloadedStrings #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Language.Javascript.JSaddle.WebSockets.Files
+-- Copyright : (c) Hamish Mackenzie
+-- License : MIT
+--
+-- Maintainer : Hamish Mackenzie
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Language.Javascript.JSaddle.Run.Files (
+ indexHtml
+ , jsaddleJs
+ , initState
+ , runBatch
+) where
+
+import Data.ByteString.Lazy (ByteString)
+import Data.Monoid ((<>))
+
+indexHtml :: ByteString
+indexHtml =
+ "\n\
+ \\n\
+ \\n\
+ \JSaddle\n\
+ \\n\
+ \\n\
+ \\n\
+ \\n\
+ \"
+
+initState :: ByteString
+initState = "\
+ \ var jsaddle_values = new Map();\n\
+ \ jsaddle_values.set(0, null);\n\
+ \ jsaddle_values.set(1, undefined);\n\
+ \ jsaddle_values.set(2, false);\n\
+ \ jsaddle_values.set(3, true);\n\
+ \ jsaddle_values.set(4, window);\n\
+ \ var jsaddle_index = 100;\n\
+ \"
+
+runBatch :: (ByteString -> ByteString) -> ByteString
+runBatch send = "\
+ \ var processBatch = function(timestamp) {\n\
+ \ try {\n\
+ \ var nAsyncLength = batch[0].length;\n\
+ \ for (var nAsync = 0; nAsync != nAsyncLength; nAsync++) {\n\
+ \ var d = batch[0][nAsync];\n\
+ \ switch (d.tag) {\n\
+ \ case \"FreeRef\":\n\
+ \ jsaddle_values.delete(d.contents);\n\
+ \ break;\n\
+ \ case \"SetPropertyByName\":\n\
+ \ jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]);\n\
+ \ break;\n\
+ \ case \"SetPropertyAtIndex\":\n\
+ \ jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]);\n\
+ \ break;\n\
+ \ case \"EvaluateScript\":\n\
+ \ var n = d.contents[1];\n\
+ \ jsaddle_values.set(n, eval(d.contents[0]));\n\
+ \ break;\n\
+ \ case \"StringToValue\":\n\
+ \ var n = d.contents[1];\n\
+ \ jsaddle_values.set(n, d.contents[0]);\n\
+ \ break;\n\
+ \ case \"GetPropertyByName\":\n\
+ \ var n = d.contents[2];\n\
+ \ jsaddle_values.set(n, jsaddle_values.get(d.contents[0])[d.contents[1]]);\n\
+ \ break;\n\
+ \ case \"GetPropertyAtIndex\":\n\
+ \ var n = d.contents[2];\n\
+ \ jsaddle_values.set(n, jsaddle_values.get(d.contents[0])[d.contents[1]]);\n\
+ \ break;\n\
+ \ case \"NumberToValue\":\n\
+ \ var n = d.contents[1];\n\
+ \ jsaddle_values.set(n, d.contents[0]);\n\
+ \ break;\n\
+ \ case \"NewEmptyObject\":\n\
+ \ var n = d.contents;\n\
+ \ jsaddle_values.set(n, {});\n\
+ \ break;\n\
+ \ case \"NewCallback\":\n\
+ \ (function() {\n\
+ \ var nFunction = d.contents;\n\
+ \ jsaddle_values.set(nFunction, function() {\n\
+ \ var nThis = ++jsaddle_index;\n\
+ \ jsaddle_values.set(nThis, this);\n\
+ \ var args = [];\n\
+ \ for (var i = 0; i != arguments.length; i++) {\n\
+ \ var nArg = ++jsaddle_index;\n\
+ \ jsaddle_values.set(nArg, arguments[i]);\n\
+ \ args[i] = nArg;\n\
+ \ }\n\
+ \ " <> send "{\"tag\": \"Callback\", \"contents\": [nFunction, nThis, args]}" <> "\n\
+ \ })})();\n\
+ \ break;\n\
+ \ case \"CallAsFunction\":\n\
+ \ var n = d.contents[3];\n\
+ \ jsaddle_values.set(n,\n\
+ \ jsaddle_values.get(d.contents[0]).apply(jsaddle_values.get(d.contents[1]),\n\
+ \ d.contents[2].map(function(arg){return jsaddle_values.get(arg);})));\n\
+ \ break;\n\
+ \ case \"CallAsConstructor\":\n\
+ \ var n = d.contents[2];\n\
+ \ var r;\n\
+ \ var f = jsaddle_values.get(d.contents[0]);\n\
+ \ var a = d.contents[1].map(function(arg){return jsaddle_values.get(arg);});\n\
+ \ switch(a.length) {\n\
+ \ case 0 : r = new f(); break;\n\
+ \ case 1 : r = new f(a[0]); break;\n\
+ \ case 2 : r = new f(a[0],a[1]); break;\n\
+ \ case 3 : r = new f(a[0],a[1],a[2]); break;\n\
+ \ case 4 : r = new f(a[0],a[1],a[2],a[3]); break;\n\
+ \ case 5 : r = new f(a[0],a[1],a[2],a[3],a[4]); break;\n\
+ \ case 6 : r = new f(a[0],a[1],a[2],a[3],a[4],a[5]); break;\n\
+ \ case 7 : r = new f(a[0],a[1],a[2],a[3],a[4],a[5],a[6]); break;\n\
+ \ default:\n\
+ \ var ret;\n\
+ \ var temp = function() {\n\
+ \ ret = f.apply(this, a);\n\
+ \ };\n\
+ \ temp.prototype = f.prototype;\n\
+ \ var i = new temp();\n\
+ \ if(ret instanceof Object)\n\
+ \ r = ret;\n\
+ \ else {\n\
+ \ i.constructor = f;\n\
+ \ r = i;\n\
+ \ }\n\
+ \ }\n\
+ \ jsaddle_values.set(n, r);\n\
+ \ break;\n\
+ \ case \"NewArray\":\n\
+ \ var n = d.contents[1];\n\
+ \ jsaddle_values.set(n, d.contents[0].map(function(v){return jsaddle_values.get(v);}));\n\
+ \ break;\n\
+ \ case \"SyncWithAnimationFrame\":\n\
+ \ var n = d.contents[0];\n\
+ \ jsaddle_values.set(n, timestamp);\n\
+ \ break;\n\
+ \ default:\n\
+ \ " <> send "{\"tag\": \"ProtocolError\", \"contents\": e.data}" <> "\n\
+ \ return;\n\
+ \ }\n\
+ \ }\n\
+ \ var d = batch[1];\n\
+ \ switch (d.tag) {\n\
+ \ case \"ValueToString\":\n\
+ \ var val = jsaddle_values.get(d.contents);\n\
+ \ var s = val === null ? \"null\" : val === undefined ? \"undefined\" : val.toString();\n\
+ \ " <> send "{\"tag\": \"ValueToStringResult\", \"contents\": s}" <> "\n\
+ \ break;\n\
+ \ case \"ValueToBool\":\n\
+ \ " <> send "{\"tag\": \"ValueToBoolResult\", \"contents\": jsaddle_values.get(d.contents) ? true : false}" <> "\n\
+ \ break;\n\
+ \ case \"ValueToNumber\":\n\
+ \ " <> send "{\"tag\": \"ValueToNumberResult\", \"contents\": Number(jsaddle_values.get(d.contents))}" <> "\n\
+ \ break;\n\
+ \ case \"ValueToJSON\":\n\
+ \ var s = jsaddle_values.get(d.contents) === undefined ? \"\" : JSON.stringify(jsaddle_values.get(d.contents));\n\
+ \ " <> send "{\"tag\": \"ValueToJSONResult\", \"contents\": s}" <> "\n\
+ \ break;\n\
+ \ case \"DeRefVal\":\n\
+ \ var n = d.contents;\n\
+ \ var v = jsaddle_values.get(n);\n\
+ \ var c = (v === null ) ? [0, \"\"] :\n\
+ \ (v === undefined ) ? [1, \"\"] :\n\
+ \ (v === false ) ? [2, \"\"] :\n\
+ \ (v === true ) ? [3, \"\"] :\n\
+ \ (typeof v === \"number\") ? [-1, v.toString()] :\n\
+ \ (typeof v === \"string\") ? [-2, v]\n\
+ \ : [n, \"\"];\n\
+ \ " <> send "{\"tag\": \"DeRefValResult\", \"contents\": c}" <> "\n\
+ \ break;\n\
+ \ case \"IsNull\":\n\
+ \ " <> send "{\"tag\": \"IsNullResult\", \"contents\": jsaddle_values.get(d.contents) === null}" <> "\n\
+ \ break;\n\
+ \ case \"IsUndefined\":\n\
+ \ " <> send "{\"tag\": \"IsUndefinedResult\", \"contents\": jsaddle_values.get(d.contents) === undefined}" <> "\n\
+ \ break;\n\
+ \ case \"InstanceOf\":\n\
+ \ " <> send "{\"tag\": \"InstanceOfResult\", \"contents\": jsaddle_values.get(d.contents[0]) instanceof jsaddle_values.get(d.contents[1])}" <> "\n\
+ \ break;\n\
+ \ case \"StrictEqual\":\n\
+ \ " <> send "{\"tag\": \"StrictEqualResult\", \"contents\": jsaddle_values.get(d.contents[0]) === jsaddle_values.get(d.contents[1])}" <> "\n\
+ \ break;\n\
+ \ case \"PropertyNames\":\n\
+ \ var result = [];\n\
+ \ for (name in jsaddle_values.get(d.contents)) { result.push(name); }\n\
+ \ " <> send "{\"tag\": \"PropertyNamesResult\", \"contents\": result}" <> "\n\
+ \ break;\n\
+ \ case \"Sync\":\n\
+ \ " <> send "{\"tag\": \"SyncResult\", \"contents\": []}" <> "\n\
+ \ break;\n\
+ \ default:\n\
+ \ " <> send "{\"tag\": \"ProtocolError\", \"contents\": e.data}" <> "\n\
+ \ }\n\
+ \ }\n\
+ \ catch (err) {\n\
+ \ var n = ++jsaddle_index;\n\
+ \ jsaddle_values.set(n, err);\n\
+ \ " <> send "{\"tag\": \"ThrowJSValue\", \"contents\": n}" <> "\n\
+ \ }\n\
+ \ };\n\
+ \ if(batch[2]) {\n\
+ \ window.requestAnimationFrame(processBatch);\n\
+ \ }\n\
+ \ else {\n\
+ \ processBatch(window.performance ? window.performance.now() : null);\n\
+ \ }\n\
+ \"
+
+-- Use this to generate this string for embedding
+-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy
+jsaddleJs :: ByteString
+jsaddleJs = "\
+ \if(typeof global !== \"undefined\") {\n\
+ \ global.window = global;\n\
+ \ global.WebSocket = require('ws');\n\
+ \}\n\
+ \\n\
+ \var connect = function() {\n\
+ \ var wsaddress =\n\
+ \ typeof window.location === \"undefined\"\n\
+ \ ? \"ws://localhost:3709/\"\n\
+ \ : window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\");\n\
+ \\n\
+ \ var ws = new WebSocket(wsaddress);\n\
+ \\n\
+ \ ws.onopen = function(e) {\n\
+ \ " <> initState <> "\
+ \\n\
+ \ ws.onmessage = function(e) {\n\
+ \ var batch = JSON.parse(e.data);\n\
+ \\n\
+ \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));") <> "\
+ \ };\n\
+ \ };\n\
+ \ ws.onerror = function() {\n\
+ \ setTimeout(connect, 1000);\n\
+ \ };\n\
+ \}\n\
+ \\n\
+ \connect();\n\
+ \"
diff --git a/src/Language/Javascript/JSaddle/Test.hs b/src/Language/Javascript/JSaddle/Test.hs
deleted file mode 100644
--- a/src/Language/Javascript/JSaddle/Test.hs
+++ /dev/null
@@ -1,84 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE LambdaCase #-}
------------------------------------------------------------------------------
---
--- Module : TestJSC
--- Copyright : (c) Hamish Mackenzie
--- License : MIT
---
--- Maintainer : Hamish Mackenzie
---
--- |
---
------------------------------------------------------------------------------
-
-module Language.Javascript.JSaddle.Test (
- testJSaddle
- , listWindowProperties
-) where
-
-import Control.Applicative
-import Prelude hiding((!!), catch)
-import Control.Monad.Trans.Reader (runReaderT)
-import Language.Javascript.JSaddle
-import qualified Data.Text as T
-import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad (forever, forM)
-import Control.Lens.Getter ((^.))
-import Data.Monoid ((<>))
-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)
-
-context :: MVar JSContextRef
-context = unsafePerformIO newEmptyMVar
-{-# NOINLINE context #-}
-
-server :: MVar ThreadId
-server = unsafePerformIO newEmptyMVar
-{-# NOINLINE server #-}
-
-startServer :: IO ()
-startServer =
- tryTakeMVar server >>= maybe (forkIO $
- run 3709 $ do
- liftIO $ tryTakeMVar context
- liftIO . putMVar context =<< askJSM
- liftIO . forever $ threadDelay 1000000
- ) return >>= putMVar server
-
--- >>> testJSaddle $ ((global ^. js "console" . js "log") # ["Hello"])
-testJSaddle :: ToJSVal val => JSM val -> IO ()
-testJSaddle f = do
- startServer
- c <- takeMVar context
- runReaderT (unJSM $ (f >>= valToText >>= liftIO . putStrLn . T.unpack)
- `catch` \ (JSException e) -> valToText e >>= liftIO . putStrLn . T.unpack) c
- putMVar context c
-
-debugLog :: String -> IO ()
-debugLog _ = return ()
-
-listWindowProperties :: IO ()
-listWindowProperties = testJSaddle $ T.pack . show <$> do
- window <- jsg ("window" :: Text)
- names <- propertyNames window
- forM names $ \name -> do
- v <- window ^. js name >>= valToText
- return (strToText name, v)
- `catch`
- \(JSException e) -> do
- msg <- valToText e
- return (strToText name, T.pack " error " <> msg)
-
-
-
-
-
-
-
-
-
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
@@ -70,8 +70,6 @@
, instanceOf
) where
-import Control.Applicative
-import Prelude hiding (catch)
import Language.Javascript.JSaddle.Types
(Object(..), JSString(..), JSVal(..))
#ifdef ghcjs_HOST_OS
@@ -87,7 +85,7 @@
import Language.Javascript.JSaddle.Native
(wrapJSString, withJSVal, withObject, withJSString,
withToJSVal)
-import Language.Javascript.JSaddle.WebSockets
+import Language.Javascript.JSaddle.Run
(Command(..), AsyncCommand(..), Result(..), sendCommand,
sendLazyCommand)
#endif
@@ -165,8 +163,8 @@
(JSVal 1) -> return False -- undefined
(JSVal 2) -> return False -- false
(JSVal 3) -> return True -- true
- val ->
- withJSVal val $ \rval -> do
+ v ->
+ withJSVal v $ \rval -> do
ValueToBoolResult result <- sendCommand (ValueToBool rval)
return result
#endif
@@ -570,6 +568,7 @@
DeRefValResult (-1) s -> return $ ValNumber (read (T.unpack s))
DeRefValResult (-2) s -> return $ ValString s
DeRefValResult ref _ -> return $ ValObject (Object (JSVal ref))
+ _ -> error "Unexpected result dereferencing JSaddle value"
#endif
-- | Make a JavaScript value out of a 'JSValue' ADT.
diff --git a/src/Language/Javascript/JSaddle/WebSockets.hs b/src/Language/Javascript/JSaddle/WebSockets.hs
deleted file mode 100644
--- a/src/Language/Javascript/JSaddle/WebSockets.hs
+++ /dev/null
@@ -1,238 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# 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 (
- -- * Running JSM over WebSockets
- run
- , syncPoint
- , syncAfter
- , waitForAnimationFrame
- , nextAnimationFrame
-#ifndef ghcjs_HOST_OS
- , jsaddleOr
- -- * Functions used to implement JSaddle over WebSockets
- , AsyncCommand(..)
- , Command(..)
- , Result(..)
- , sendCommand
- , sendLazyCommand
- , sendAsyncCommand
-#endif
-) where
-
-#ifdef ghcjs_HOST_OS
-import Language.Javascript.JSaddle.Types (JSM)
-import qualified JavaScript.Web.AnimationFrame as GHCJS
- (waitForAnimationFrame)
-#else
-import Control.Exception (throwIO)
-import Control.Monad (void, forever)
-import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.Trans.Reader (ask, runReaderT)
-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 Data.Time.Clock (getCurrentTime,diffUTCTime)
-
-import Network.Wai (Application)
-import Network.Wai.Handler.Warp
- (defaultSettings, setTimeout, setPort, runSettings)
-import Network.Wai.Application.Static
- (ssIndices, staticApp)
-import Network.WebSockets
- (ConnectionOptions(..), sendTextData, receiveDataMessage,
- acceptRequest, defaultConnectionOptions, ServerApp)
-import qualified Network.WebSockets as WS (DataMessage(..))
-import Network.Wai.Handler.WebSockets (websocketsOr)
-
-import WaiAppStatic.Storage.Embedded (mkSettings)
-import WaiAppStatic.Types (unsafeToPiece)
-
-import Language.Javascript.JSaddle.Types
- (Command(..), AsyncCommand(..), Result(..), JSContextRef(..), JSVal(..),
- Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
-import Language.Javascript.JSaddle.Exception (JSException(..))
-import Language.Javascript.JSaddle.Native (wrapJSVal)
-import Language.Javascript.JSaddle.WebSockets.Files (mkEmbedded)
-#endif
-
--- | Run the given 'JSM' action as the main entry point. Either directly
--- in GHCJS or as a Warp server on the given port on GHC.
-run :: Int -> JSM () -> IO ()
-#ifdef ghcjs_HOST_OS
-run _port = id
-#else
-run port f =
- runSettings (setPort port (setTimeout 3600 defaultSettings)) $
- jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp
-#endif
-
--- | Forces execution of pending asyncronous code
-syncPoint :: JSM ()
-#ifdef ghcjs_HOST_OS
-syncPoint = return ()
-#else
-syncPoint = void $ sendCommand Sync
-#endif
-
--- | Forces execution of pending asyncronous code after performing `f`
-syncAfter :: JSM a -> JSM a
-#ifdef ghcjs_HOST_OS
-syncAfter = id
-#else
-syncAfter f = do
- result <- f
- syncPoint
- return result
-#endif
-
--- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
--- On GHC it will delay the execution of the current batch of asynchronous
--- command when they are sent to JavaScript. It will not delay the Haskell
--- code execution. The time returned will be based on the Haskell clock
--- (not the JavaScript clock).
-waitForAnimationFrame :: JSM Double
-#ifdef ghcjs_HOST_OS
-waitForAnimationFrame = GHCJS.waitForAnimationFrame
-#else
-waitForAnimationFrame = do
- -- We can't get the timestamp from requestAnimationFrame so this will have to do
- start <- startTime <$> JSM ask
- now <- liftIO getCurrentTime
- void $ sendLazyCommand SyncWithAnimationFrame
- return $ realToFrac (diffUTCTime now start)
-#endif
-
--- | Tries to executes the given code in the next animation frame callback.
--- Avoid synchronous opperations where possible.
-nextAnimationFrame :: (Double -> JSM a) -> JSM a
-nextAnimationFrame f = do
- t <- waitForAnimationFrame
- syncAfter (f t)
-
-#ifndef ghcjs_HOST_OS
-sendCommand :: Command -> JSM Result
-sendCommand cmd = do
- s <- doSendCommand <$> JSM ask
- liftIO $ s cmd
-
-sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
-sendLazyCommand cmd = do
- nextRefTVar <- nextRef <$> JSM ask
- n <- liftIO . atomically $ do
- n <- subtract 1 <$> readTVar nextRefTVar
- writeTVar nextRefTVar n
- return n
- s <- doSendAsyncCommand <$> JSM ask
- liftIO $ s (cmd $ JSValueForSend n)
- wrapJSVal (JSValueReceived n)
-
-sendAsyncCommand :: AsyncCommand -> JSM ()
-sendAsyncCommand cmd = do
- s <- doSendAsyncCommand <$> JSM ask
- liftIO $ s cmd
-
-jsaddleOr :: ConnectionOptions -> JSM () -> Application -> Application
-jsaddleOr opts entryPoint = websocketsOr opts wsApp
- where
- wsApp :: ServerApp
- wsApp pending_conn = do
- startTime <- getCurrentTime
- conn <- acceptRequest pending_conn
- recvChan <- newTChanIO
- commandChan <- newTChanIO
- callbacks <- newTVarIO M.empty
- nextRef <- newTVarIO 0
- let ctx = JSContextRef {
- startTime = startTime
- , 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) <- runReaderT (unJSM $ wrapJSVal f) ctx
- this' <- runReaderT (unJSM $ wrapJSVal this) ctx
- args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
- (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
- Nothing -> liftIO $ putStrLn "Callback called after it was freed"
- Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
- Just m -> atomically $ writeTChan recvChan m
- _ -> error "jsaddle WebSocket unexpected binary data"
- forkIO . forever $ 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 ()
- runReaderT (unJSM entryPoint) ctx
-
- readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, Maybe (MVar Result))
- readBatch chan = do
- first <- atomically $ readTChan chan -- We want at least one command to send
- loop first []
- where
- loop (Left asyncCmd@(SyncWithAnimationFrame _)) asyncCmds =
- atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (asyncCmd:asyncCmds)
- loop (Right (cmd, resultMVar)) asyncCmds =
- return (Batch (reverse asyncCmds) cmd False, Just resultMVar)
- loop (Left asyncCmd) asyncCmds' = do
- let asyncCmds = asyncCmd:asyncCmds'
- atomically (tryReadTChan chan) >>= \case
- Nothing -> return (Batch (reverse asyncCmds) Sync False, Nothing)
- Just cmd -> loop cmd asyncCmds
- -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
- loopAnimation (Right (cmd, resultMVar)) asyncCmds =
- return (Batch (reverse asyncCmds) cmd True, Just resultMVar)
- loopAnimation (Left asyncCmd) asyncCmds =
- atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (asyncCmd: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"]}
-
-#endif
diff --git a/src/Language/Javascript/JSaddle/WebSockets/Files.hs b/src/Language/Javascript/JSaddle/WebSockets/Files.hs
deleted file mode 100644
--- a/src/Language/Javascript/JSaddle/WebSockets/Files.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-{-# 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
deleted file mode 100644
--- a/tests/DocTest.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-{-# 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 = do
-#ifdef ghcjs_HOST_OS
- putStrLn "TODO find a way to run doctest tests with GHCJS"
-#else
- hSetBuffering stdout LineBuffering
- hSetBuffering stderr LineBuffering
- 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=time-" ++ VERSION_time,
- "-package=containers-" ++ VERSION_containers,
- "-package=process-" ++ VERSION_process,
- "-package=filepath-" ++ VERSION_filepath,
- "-package=ref-tf-" ++ VERSION_ref_tf,
- "-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