jsaddle 0.5.2.0 → 0.6.0.0
raw patch · 14 files changed
+469/−702 lines, 14 filesdep −QuickCheckdep −doctestdep −jsaddledep ~basedep ~lens
Dependencies removed: QuickCheck, doctest, jsaddle, vector, wai, wai-app-static, wai-websockets, warp, websockets
Dependency ranges changed: base, lens
Files
- data/index.html +0/−9
- data/jsaddle.js +0/−201
- jsaddle.cabal +6/−41
- src/Language/Javascript/JSaddle/Evaluate.hs +1/−1
- src/Language/Javascript/JSaddle/Monad.hs +2/−3
- src/Language/Javascript/JSaddle/Object.hs +6/−6
- src/Language/Javascript/JSaddle/Properties.hs +3/−4
- src/Language/Javascript/JSaddle/Run.hs +196/−0
- src/Language/Javascript/JSaddle/Run/Files.hs +251/−0
- src/Language/Javascript/JSaddle/Test.hs +0/−84
- src/Language/Javascript/JSaddle/Value.hs +4/−5
- src/Language/Javascript/JSaddle/WebSockets.hs +0/−238
- src/Language/Javascript/JSaddle/WebSockets/Files.hs +0/−36
- tests/DocTest.hs +0/−74
− data/index.html
@@ -1,9 +0,0 @@-<!DOCTYPE html>-<html>-<head>-<title>JSaddle</title>-</head>-<body>-</body>-<script src="jsaddle.js"></script>-</html>
− data/jsaddle.js
@@ -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();
jsaddle.cabal view
@@ -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
src/Language/Javascript/JSaddle/Evaluate.hs view
@@ -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
src/Language/Javascript/JSaddle/Monad.hs view
@@ -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
src/Language/Javascript/JSaddle/Object.hs view
@@ -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
src/Language/Javascript/JSaddle/Properties.hs view
@@ -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
+ src/Language/Javascript/JSaddle/Run.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+--+-- Module : Language.Javascript.JSaddle.Run+-- Copyright : (c) Hamish Mackenzie+-- License : MIT+--+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>+--+-- |+--+-----------------------------------------------------------------------------++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
+ src/Language/Javascript/JSaddle/Run/Files.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE 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.Run.Files (+ indexHtml+ , jsaddleJs+ , initState+ , runBatch+) where++import Data.ByteString.Lazy (ByteString)+import Data.Monoid ((<>))++indexHtml :: ByteString+indexHtml =+ "<!DOCTYPE html>\n\+ \<html>\n\+ \<head>\n\+ \<title>JSaddle</title>\n\+ \</head>\n\+ \<body>\n\+ \</body>\n\+ \<script src=\"jsaddle.js\"></script>\n\+ \</html>"++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\+ \"
− src/Language/Javascript/JSaddle/Test.hs
@@ -1,84 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}------------------------------------------------------------------------------------ Module : TestJSC--- Copyright : (c) Hamish Mackenzie--- License : MIT------ Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>------ |-----------------------------------------------------------------------------------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)---------
src/Language/Javascript/JSaddle/Value.hs view
@@ -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.
− src/Language/Javascript/JSaddle/WebSockets.hs
@@ -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 <Hamish.K.Mackenzie@googlemail.com>------ |-----------------------------------------------------------------------------------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
− src/Language/Javascript/JSaddle/WebSockets/Files.hs
@@ -1,36 +0,0 @@-{-# 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
@@ -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