58fa55d · jsaddle · git.iko.soy

git.iko.soy/jsaddle

on master help sign in

Initial working jsaddle over websockets

58fa55dHamish Mackenzie10 years ago

cabal.project+2

compare with master

unifiedsplit

@@ -33,3 +33,5 @@ package gi-soup

33 flags: -overloaded-methods -overloaded-signals -overloaded-properties

34package gi-webkit

35 flags: -overloaded-methods -overloaded-signals -overloaded-properties

36+package gi-webkit2

37+ flags: -overloaded-methods -overloaded-signals -overloaded-properties

data/index.htmlnew file+9

@@ -0,0 +1,9 @@

1+<!DOCTYPE html>

2+<html>

3+<head>

4+<title>JSaddle</title>

5+</head>

6+<body>

7+</body>

8+<script src="jsaddle.js"></script>

9+</html>

data/jsaddle.jsnew file+193

@@ -0,0 +1,193 @@

1+if(typeof global !== "undefined") {

2+ global.window = global;

3+ global.WebSocket = require('ws');

4+}

6+var connect = function() {

7+ var wsaddress =

8+ typeof window.location === "undefined"

9+ ? "ws://localhost:3709/"

10+ : window.location.protocol.replace('http', 'ws')+"//"+window.location.hostname+(window.location.port?(":"+window.location.port):"");

11+

12+ var ws = new WebSocket(wsaddress);

13+

14+ ws.onopen = function(e) {

15+ var jsaddle_values = new Map();

16+ jsaddle_values.set(0, null);

17+ jsaddle_values.set(1, undefined);

18+ jsaddle_values.set(2, false);

19+ jsaddle_values.set(3, true);

20+ jsaddle_values.set(4, window);

21+ var jsaddle_index = 100;

22+

23+ ws.onmessage = function(e) {

24+ try {

25+ var batch = JSON.parse(e.data);

26+ var nAsyncLength = batch[0].length;

27+ for (var nAsync = 0; nAsync != nAsyncLength; nAsync++) {

28+ var d = batch[0][nAsync];

29+ switch (d.tag) {

30+ case "FreeRef":

31+ jsaddle_values.delete(d.contents);

32+ break;

33+ case "SetPropertyByName":

34+ jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]);

35+ break;

36+ case "SetPropertyAtIndex":

37+ jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]);

38+ break;

39+ }

40+ }

41+ var d = batch[1];

42+ switch (d.tag) {

43+ case "EvaluateScript":

44+ var n = ++jsaddle_index;

45+ jsaddle_values.set(n, eval(d.contents));

46+ ws.send(JSON.stringify({"tag": "EvaluateScriptResult", "contents": n}));

47+ break;

48+ case "ValueToString":

49+ var val = jsaddle_values.get(d.contents);

50+ var s = val === null ? "null" : val === undefined ? "undefined" : val.toString();

51+ ws.send(JSON.stringify({"tag": "ValueToStringResult", "contents": s}));

52+ break;

53+ case "StringToValue":

54+ var n = ++jsaddle_index;

55+ jsaddle_values.set(n, d.contents);

56+ ws.send(JSON.stringify({"tag": "StringToValueResult", "contents": n}));

57+ break;

58+ case "GetPropertyByName":

59+ var n = ++jsaddle_index;

60+ jsaddle_values.set(n, jsaddle_values.get(d.contents[0])[d.contents[1]]);

61+ ws.send(JSON.stringify({"tag": "GetPropertyByNameResult", "contents": n}));

62+ break;

63+ case "GetPropertyAtIndex":

64+ var n = ++jsaddle_index;

65+ jsaddle_values.set(n, jsaddle_values.get(d.contents[0])[d.contents[1]]);

66+ ws.send(JSON.stringify({"tag": "GetPropertyAtIndexResult", "contents": n}));

67+ break;

68+ case "NumberToValue":

69+ var n = ++jsaddle_index;

70+ jsaddle_values.set(n, d.contents);

71+ ws.send(JSON.stringify({"tag": "NumberToValueResult", "contents": n}));

72+ break;

73+ case "NewEmptyObject":

74+ var n = ++jsaddle_index;

75+ jsaddle_values.set(n, {});

76+ ws.send(JSON.stringify({"tag": "NewEmptyObjectResult", "contents": n}));

77+ break;

78+ case "NewCallback":

79+ var nFunction = ++jsaddle_index;

80+ jsaddle_values.set(nFunction, function() {

81+ var nThis = ++jsaddle_index;

82+ jsaddle_values.set(nThis, this);

83+ var args = [];

84+ for (var i = 0; i != arguments.length; i++) {

85+ var nArg = ++jsaddle_index;

86+ jsaddle_values.set(nArg, arguments[i]);

87+ args[i] = nArg;

88+ }

89+ ws.send(JSON.stringify({"tag": "Callback", "contents": [nFunction, nThis, args]})); });

90+ ws.send(JSON.stringify({"tag": "NewCallbackResult", "contents": nFunction}));

91+ break;

92+ case "CallAsFunction":

93+ var n = ++jsaddle_index;

94+ jsaddle_values.set(n,

95+ jsaddle_values.get(d.contents[0]).apply(jsaddle_values.get(d.contents[1]),

96+ d.contents[2].map(function(arg){return jsaddle_values.get(arg);})));

97+ ws.send(JSON.stringify({"tag": "CallAsFunctionResult", "contents": n}));

98+ break;

99+ case "CallAsConstructor":

100+ var n = ++jsaddle_index;

101+ var r;

102+ var f = jsaddle_values.get(d.contents[0]);

103+ var a = d.contents[1].map(function(arg){return jsaddle_values.get(arg);});

104+ switch(a.length) {

105+ case 0 : r = new f(); break;

106+ case 1 : r = new f(a[0]); break;

107+ case 2 : r = new f(a[0],a[1]); break;

108+ case 3 : r = new f(a[0],a[1],a[2]); break;

109+ case 4 : r = new f(a[0],a[1],a[2],a[3]); break;

110+ case 5 : r = new f(a[0],a[1],a[2],a[3],a[4]); break;

111+ case 6 : r = new f(a[0],a[1],a[2],a[3],a[4],a[5]); break;

112+ case 7 : r = new f(a[0],a[1],a[2],a[3],a[4],a[5],a[6]); break;

113+ default:

114+ var ret;

115+ var temp = function() {

116+ ret = f.apply(this, a);

117+ };

118+ temp.prototype = f.prototype;

119+ var i = new temp();

120+ if(ret instanceof Object)

121+ r = ret;

122+ else {

123+ i.constructor = f;

124+ r = i;

125+ }

126+ }

127+ jsaddle_values.set(n, r);

128+ ws.send(JSON.stringify({"tag": "CallAsConstructorResult", "contents": n}));

129+ break;

130+ case "NewArray":

131+ var n = ++jsaddle_index;

132+ jsaddle_values.set(n, d.contents.map(function(v){return jsaddle_values.get(v);}));

133+ ws.send(JSON.stringify({"tag": "NewArrayResult", "contents": n}));

134+ break;

135+ case "ValueToBool":

136+ ws.send(JSON.stringify({"tag": "ValueToBoolResult", "contents": jsaddle_values.get(d.contents) ? true : false}));

137+ break;

138+ case "ValueToNumber":

139+ ws.send(JSON.stringify({"tag": "ValueToNumberResult", "contents": Number(jsaddle_values.get(d.contents))}));

140+ break;

141+ case "ValueToJSON":

142+ var s = jsaddle_values.get(d.contents) === undefined ? "" : JSON.stringify(jsaddle_values.get(d.contents));

143+ ws.send(JSON.stringify({"tag": "ValueToJSONResult", "contents": s}));

144+ break;

145+ case "DeRefVal":

146+ var n = d.contents;

147+ var v = jsaddle_values.get(n);

148+ var c = (v === null ) ? [0, ""] :

149+ (v === undefined ) ? [1, ""] :

150+ (v === false ) ? [2, ""] :

151+ (v === true ) ? [3, ""] :

152+ (typeof v === "number") ? [-1, v.toString()] :

153+ (typeof v === "string") ? [-2, v]

154+ : [n, ""];

155+ ws.send(JSON.stringify({"tag": "DeRefValResult", "contents": c}));

156+ break;

157+ case "IsNull":

158+ ws.send(JSON.stringify({"tag": "IsNullResult", "contents": jsaddle_values.get(d.contents) === null}));

159+ break;

160+ case "IsUndefined":

161+ ws.send(JSON.stringify({"tag": "IsUndefinedResult", "contents": jsaddle_values.get(d.contents) === undefined}));

162+ break;

163+ case "InstanceOf":

164+ ws.send(JSON.stringify({"tag": "InstanceOfResult", "contents": jsaddle_values.get(d.contents[0]) instanceof jsaddle_values.get(d.contents[1])}));

165+ break;

166+ case "StrictEqual":

167+ ws.send(JSON.stringify({"tag": "StrictEqualResult", "contents": jsaddle_values.get(d.contents[0]) === jsaddle_values.get(d.contents[1])}));

168+ break;

169+ case "PropertyNames":

170+ var result = [];

171+ for (name in jsaddle_values.get(d.contents)) { result.push(name); }

172+ ws.send(JSON.stringify({"tag": "PropertyNamesResult", "contents": result}));

173+ break;

174+ case "Sync":

175+ ws.send(JSON.stringify({"tag": "SyncResult"}));

176+ break;

177+ default:

178+ ws.send(JSON.stringify({"tag": "ProtocolError", "contents": e.data}));

179+ }

180+ }

181+ catch (err) {

182+ var n = ++jsaddle_index;

183+ jsaddle_values.set(n, err);

184+ ws.send(JSON.stringify({"tag": "ThrowJSValue", "contents": n}));

185+ }

186+ };

187+ };

188+ ws.onerror = function() {

189+ setTimeout(connect, 1000);

190+ };

191+}

192+

193+connect();

jsaddle.cabal+31−20

@@ -1,5 +1,5 @@

1name: jsaddle

2−version: 0.4.0.5

2+version: 0.5.0.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

@@ -25,9 +25,18 @@ library

25 ghcjs-prim -any

26 else

27 build-depends:

28− websockets >=0.9.7.0 && <0.10,

28+ aeson >=1.0.0.0 && <1.1,

29+ bytestring >=0.10.8.1 && <0.11,

30+ containers >=0.5.7.1 && <0.6,

31+ filepath >=1.4.1.0 && <1.5,

32+ http-types >=0.9.1 && <0.10,

33+ process >=1.4.2.0 && <1.5,

34+ stm >=2.4.4.1 && <2.5,

29 wai >=3.2.1.1 && <3.3,

35 wai >=3.2.1.1 && <3.3,

36+ wai-app-static >=3.1.6.1 && <3.2,

30− wai-websockets >=3.0.1.1 && <3.1

37+ wai-websockets >=3.0.1.1 && <3.1,

38+ warp >=3.2.8 && <3.3,

39+ websockets >=0.9.7.0 && <0.10

31 exposed-modules:

40 exposed-modules:

32 Language.Javascript.JSaddle

41 Language.Javascript.JSaddle

33 Language.Javascript.JSaddle.Arguments

42 Language.Javascript.JSaddle.Arguments

@@ -40,42 +49,44 @@ library

40 Language.Javascript.JSaddle.Properties

49 Language.Javascript.JSaddle.Properties

41 Language.Javascript.JSaddle.String

50 Language.Javascript.JSaddle.String

42 Language.Javascript.JSaddle.Value

51 Language.Javascript.JSaddle.Value

52+ Language.Javascript.JSaddle.Test

43 Language.Javascript.JSaddle.Types

53 Language.Javascript.JSaddle.Types

54+ Language.Javascript.JSaddle.WebSockets

55+ Language.Javascript.JSaddle.WebSockets.Files

56+ Paths_jsaddle

44 build-depends:

57 build-depends:

45− template-haskell -any,

46 base <5,

58 base <5,

47 lens >=3.8.5 && <4.15,

59 lens >=3.8.5 && <4.15,

60+ primitive >=0.6.1.0 && <0.7,

61+ template-haskell -any,

48 text >=0.11.2.3 && <1.3,

62 text >=0.11.2.3 && <1.3,

49− transformers >=0.3.0.0 && <0.6,

63+ transformers >=0.3.0.0 && <0.6

50− primitive >=0.6.1.0 && <0.7

51 default-language: Haskell2010

64 default-language: Haskell2010

52 hs-source-dirs: src

65 hs-source-dirs: src

53− other-modules:

54− Language.Javascript.JSaddle.WebSockets

55 ghc-options: -ferror-spans

66 ghc-options: -ferror-spans

57test-suite test-tool

68test-suite test-tool

59 if impl(ghcjs -any)

70 if impl(ghcjs -any)

60 buildable: False

71 buildable: False

61− else

62− build-depends:

63− haskell-gi-base >=0.17 && <0.19,

64− gi-glib >=2.0.2 && <2.1,

65− gi-gtk >=3.0.2 && <3.1,

66− gi-webkit >=3.0.2 && <3.1,

67− gi-javascriptcore >=3.0.2 && <3.1,

68− webkitgtk3-javascriptcore >=0.14.0.0 && <0.15,

69− warp >=3.2.8 && <3.3

70 type: exitcode-stdio-1.0

72 type: exitcode-stdio-1.0

71 main-is: DocTest.hs

73 main-is: DocTest.hs

72 build-depends:

74 build-depends:

73 QuickCheck -any,

75 QuickCheck -any,

74 base -any,

76 base -any,

77+ bytestring >=0.10.8.1 && <0.11,

75 doctest -any,

78 doctest -any,

76− vector >=0.11.0.0 && <0.12,

79+ filepath >=1.4.1.0 && <1.5,

80+ http-types >=0.9.1 && <0.10,

81+ jsaddle -any,

82+ process >=1.4.2.0 && <1.5,

77 text >=0.11.2.3 && <1.3,

83 text >=0.11.2.3 && <1.3,

78− jsaddle -any

84+ vector >=0.11.0.0 && <0.12,

85+ wai >=3.2.1.1 && <3.3,

86+ wai-app-static >=3.1.6.1 && <3.2,

87+ wai-websockets >=3.0.1.1 && <3.1,

88+ warp >=3.2.8 && <3.3,

89+ websockets >=0.9.7.0 && <0.10

79 default-language: Haskell2010

90 default-language: Haskell2010

80 hs-source-dirs: tests

91 hs-source-dirs: tests

81− ghc-options: -ferror-spans

92+ ghc-options: -ferror-spans -threaded

src/Language/Javascript/JSaddle/Classes.hs+1−1

@@ -30,7 +30,7 @@ class ToJSVal a where

31-- | Anything that can be used to make a JavaScript string reference

32class ToJSVal a => ToJSString a where

33− toJSString :: a -> JSM JSString

33+ toJSString :: a -> JSString

35-- | Anything that can be used to make a JavaScript object reference

36class MakeObject this where

src/Language/Javascript/JSaddle/Evaluate.hs+1−1

@@ -57,7 +57,7 @@ foreign import javascript unsafe "$r = eval($1);"

57 js_eval :: JSString -> IO JSVal

58#else

59eval script = do

60− rscript <- toJSString script

60+ let rscript = toJSString script

61 withJSString rscript $ \script' -> do

62 EvaluateScriptResult result <- sendCommand $ EvaluateScript script'

63 wrapJSVal result

src/Language/Javascript/JSaddle/Exception.hs+4−5

@@ -16,15 +16,14 @@ module Language.Javascript.JSaddle.Exception (

16-- , rethrow

17) where

19−import qualified Control.Exception as E (throwIO, Exception)

19+import qualified Control.Exception as E (Exception)

20−import Language.Javascript.JSaddle.Types

20+import Language.Javascript.JSaddle.Types (JSVal)

21− (MutableJSArray, JSVal)

22import Data.Typeable (Typeable)

21import Data.Typeable (Typeable)

23−import Language.Javascript.JSaddle.Monad (JSM)

24−import Control.Monad.IO.Class (MonadIO(..))

26newtype JSException = JSException JSVal deriving (Typeable)

23newtype JSException = JSException JSVal deriving (Typeable)

25+-- | JavaScript exception

26+-- >>>

28instance Show JSException where show _ = "JSException"

27instance Show JSException where show _ = "JSException"

29instance E.Exception JSException

28instance E.Exception JSException

src/Language/Javascript/JSaddle/Monad.hs+4−62

@@ -1,4 +1,3 @@

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE PatternSynonyms #-}

1{-# LANGUAGE PatternSynonyms #-}

3-----------------------------------------------------------------------------

2-----------------------------------------------------------------------------

4--

3--

@@ -17,52 +16,19 @@ module Language.Javascript.JSaddle.Monad (

17 JSM

16 JSM

18 , JSContextRef

17 , JSContextRef

20− -- * Running JSaddle given a DOM Window

19+ -- * Running JSaddle given a JSContextRef

21 , runJSaddle

20 , runJSaddle

23 -- * Exception Handling

22 -- * Exception Handling

24 , catch

23 , catch

25 , bracket

24 , bracket

26−

27− -- * GUI thread support

28− , postGUIAsyncJS

29− , postGUISyncJS

30) where

25) where

32import Prelude hiding (catch, read)

27import Prelude hiding (catch, read)

33import Control.Monad.Trans.Reader (runReaderT, ask, ReaderT(..))

28import Control.Monad.Trans.Reader (runReaderT, ask, ReaderT(..))

34−import Language.Javascript.JSaddle.Types

35− (JSM, JSVal, MutableJSArray, JSContextRef(..))

36import Control.Monad.IO.Class (MonadIO(..))

29import Control.Monad.IO.Class (MonadIO(..))

37−#ifdef ghcjs_HOST_OS

38−import GHCJS.Types (isUndefined, isNull)

39−import qualified JavaScript.Array as Array (create, read)

40−#else

41−import Network.WebSockets (Connection)

42−import Language.Javascript.JSaddle.Native (wrapJSVal)

43−#endif

44import qualified Control.Exception as E (Exception, catch, bracket)

30import qualified Control.Exception as E (Exception, catch, bracket)

45−import Control.Concurrent.MVar (takeMVar, putMVar, newEmptyMVar)

31+import Language.Javascript.JSaddle.Types (JSM, JSContextRef(..))

46−import Control.Monad (void)

47−import Control.Concurrent (forkIO)

48−

49−#ifndef ghcjs_HOST_OS

50−-- | Post an action to be run in the main GUI thread.

51−--

52−-- The current thread blocks until the action completes and the result is

53−-- returned.

54−--

55−postGUISync :: IO a -> IO a

56−postGUISync = id

57−

58−-- | Post an action to be run in the main GUI thread.

59−--

60−-- The current thread continues and does not wait for the result of the

61−-- action.

62−--

63−postGUIAsync :: IO () -> IO ()

64−postGUIAsync = void . forkIO

65−#endif

67-- | Wrapped version of 'E.catch' that runs in a MonadIO that works

33-- | Wrapped version of 'E.catch' that runs in a MonadIO that works

68-- a bit better with 'JSM'

34-- a bit better with 'JSM'

@@ -108,30 +74,6 @@ catchval f catcher = do

108#endif

74#endif

109-}

75-}

110

111−#ifdef ghcjs_HOST_OS

112−runJSaddle :: MonadIO m => w -> JSM a -> m a

77+runJSaddle :: MonadIO m => JSContextRef -> JSM a -> m a

113−runJSaddle _ f = liftIO $ runReaderT f ()

114−#else

115−runJSaddle :: MonadIO m => Connection -> JSM a -> m a

116−runJSaddle connection f = liftIO $

117− runReaderT f (JSContextRef connection)

118−#endif

119−

120−postGUIAsyncJS :: JSM () -> JSM ()

121−#ifdef ghcjs_HOST_OS

122−postGUIAsyncJS = id

123−#else

124−postGUIAsyncJS f = do

125− r <- ask

126− liftIO . postGUIAsync $ runReaderT f r

127−#endif

128−

129−postGUISyncJS :: JSM a -> JSM a

130−#ifdef ghcjs_HOST_OS

131−postGUISyncJS = id

132−#else

133−postGUISyncJS f = do

134− r <- ask

135− liftIO . postGUISync $ runReaderT f r

78+runJSaddle context f = liftIO $ runReaderT f context

136−#endif

137

src/Language/Javascript/JSaddle/Native.hs+7−11

@@ -27,9 +27,9 @@ module Language.Javascript.JSaddle.Native (

27import Control.Monad.Trans.Reader (ask)

28import Control.Monad.IO.Class (MonadIO, MonadIO(..))

29import Language.Javascript.JSaddle.Types

30+ (JSContextRef(..), AsyncCommand(..), JSM, JSString(..),

30− (JSM, JSString(..), Object(..), JSVal(..), JSValueReceived(..),

31+ Object(..), JSVal(..), JSValueReceived(..), JSValueForSend(..),

31− JSValueForSend(..), JSStringReceived(..), JSStringForSend(..),

32+ JSStringReceived(..), JSStringForSend(..), JSObjectForSend(..))

32− JSObjectForSend(..))

33import Language.Javascript.JSaddle.Classes (ToJSVal(..))

34import System.Mem.Weak (addFinalizer)

35import Control.Monad.Primitive (touch)

@@ -39,17 +39,13 @@ wrapJSVal :: JSValueReceived -> JSM JSVal

39wrapJSVal (JSValueReceived ref) = do

40 -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)

41 let result = JSVal ref

42− when (ref >= 5) $

42+ when (ref >= 5) $ do

43+ ctx <- ask

43− liftIO . addFinalizer result $ return () -- TODO free value ref

44+ liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref

44 return result

45 return result

46wrapJSString :: MonadIO m => JSStringReceived -> m JSString

47wrapJSString :: MonadIO m => JSStringReceived -> m JSString

47−wrapJSString (JSStringReceived ref) = do

48+wrapJSString (JSStringReceived ref) = return $ JSString ref

48− -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)

49− let result = JSString ref

50− when (ref >= 5) $

51− liftIO . addFinalizer result $ return () -- TODO free string ref

52− return result

54withJSVal :: MonadIO m => JSVal -> (JSValueForSend -> m a) -> m a

50withJSVal :: MonadIO m => JSVal -> (JSValueForSend -> m a) -> m a

55withJSVal v@(JSVal ref) f =

51withJSVal v@(JSVal ref) f =

src/Language/Javascript/JSaddle/Object.hs+24−35

@@ -92,9 +92,10 @@ module Language.Javascript.JSaddle.Object (

92import Control.Applicative

93import Prelude hiding ((!!))

94import Language.Javascript.JSaddle.Types

95− (JSPropertyNameArray, JSString, Object(..),

95+ (JSString, Object(..),

96− JSVal(..), Index)

96+ JSVal(..), Index, JSCallAsFunction, JSContextRef(..))

97#ifdef ghcjs_HOST_OS

98+import Control.Monad.Trans.Reader (runReaderT)

98import GHCJS.Types (nullRef, jsval)

99import GHCJS.Types (nullRef, jsval)

99import GHCJS.Foreign.Callback

100import GHCJS.Foreign.Callback

100 (releaseCallback, syncCallback2, OnBlocked(..), Callback)

101 (releaseCallback, syncCallback2, OnBlocked(..), Callback)

@@ -112,27 +113,23 @@ import Language.Javascript.JSaddle.Native

112import Language.Javascript.JSaddle.WebSockets

113import Language.Javascript.JSaddle.WebSockets

113 (Command(..), Result(..), sendCommand)

114 (Command(..), Result(..), sendCommand)

114#endif

115#endif

115−import Language.Javascript.JSaddle.Value

116+import Language.Javascript.JSaddle.Value (valToObject)

116− (JSUndefined, valToObject)

117import Language.Javascript.JSaddle.Classes

118 (ToJSVal(..), ToJSString(..), MakeObject(..))

119import Language.Javascript.JSaddle.Arguments (MakeArgs(..))

120import Language.Javascript.JSaddle.Monad

121 (JSM)

122−import Control.Monad.Trans.Reader (runReaderT, ask)

122+import Control.Monad.Trans.Reader (asks)

123import Control.Monad.IO.Class (MonadIO(..))

124−import qualified Control.Exception as E (catch)

125−import Control.Exception (SomeException)

126−import Foreign.Storable (Storable(..))

127import Language.Javascript.JSaddle.Properties

124import Language.Javascript.JSaddle.Properties

128import Control.Lens (IndexPreservingGetter, to)

125import Control.Lens (IndexPreservingGetter, to)

129−import Language.Javascript.JSaddle.String (nullJSString)

130import Data.Text (Text)

126import Data.Text (Text)

131

127

132-- $setup

128-- $setup

133-- >>> import Language.Javascript.JSaddle.Test (testJSaddle)

129-- >>> import Language.Javascript.JSaddle.Test (testJSaddle)

134-- >>> import Language.Javascript.JSaddle.Evaluate (eval)

130-- >>> import Language.Javascript.JSaddle.Evaluate (eval)

135-- >>> import Language.Javascript.JSaddle.Value (val, valToText, JSNull(..))

131-- >>> import Language.Javascript.JSaddle.Value (val, valToText, JSNull(..))

132+-- >>> import Language.Javascript.JSaddle.String (strToText)

136-- >>> import Control.Lens.Operators ((^.))

133-- >>> import Control.Lens.Operators ((^.))

137-- >>> import qualified Data.Text as T (unpack)

134-- >>> import qualified Data.Text as T (unpack)

138

135

@@ -189,7 +186,7 @@ js name = to (!name)

189-- >>> testJSaddle $ eval "'Hello World'.length = 12"

186-- >>> testJSaddle $ eval "'Hello World'.length = 12"

190-- 12

187-- 12

191-- >>> testJSaddle $ val "Hello World" ^. jss "length" 12

188-- >>> testJSaddle $ val "Hello World" ^. jss "length" 12

192−-- 12

189+-- undefined

193jss :: (ToJSString name, ToJSVal val)

190jss :: (ToJSString name, ToJSVal val)

194 => name -- ^ Name of the property to find

191 => name -- ^ Name of the property to find

195 -> val

192 -> val

@@ -251,12 +248,8 @@ js5 name a0 a1 a2 a3 a4 = jsf name (a0, a1, a2, a3, a4)

251-- | Handy way to get and hold onto a reference top level javascript

248-- | Handy way to get and hold onto a reference top level javascript

252--

249--

253-- >>> testJSaddle $ eval "w = console; w.log('Hello World')"

250-- >>> testJSaddle $ eval "w = console; w.log('Hello World')"

254−-- ** Message: console message: @1: Hello World

255−-- <BLANKLINE>

256-- undefined

251-- undefined

257-- >>> testJSaddle $ do w <- jsg "console"; w ^. js1 "log" "Hello World"

252-- >>> testJSaddle $ do w <- jsg "console"; w ^. js1 "log" "Hello World"

258−-- ** Message: console message:...@0: Hello World

259−-- <BLANKLINE>

260-- undefined

253-- undefined

261jsg :: ToJSString a => a -> JSM JSVal

254jsg :: ToJSString a => a -> JSM JSVal

262jsg name = global ! name

255jsg name = global ! name

@@ -277,7 +270,7 @@ jsgf name = global # name

277-- > jsg0 name = jsgf name ()

270-- > jsg0 name = jsgf name ()

278--

271--

279-- >>> testJSaddle $ jsg0 "globalFunc"

272-- >>> testJSaddle $ jsg0 "globalFunc"

280−-- TypeError:...undefined...is not an objec...

273+-- TypeError:...undefine...

281jsg0 :: (ToJSString name) => name -> JSM JSVal

274jsg0 :: (ToJSString name) => name -> JSM JSVal

282jsg0 name = jsgf name ()

275jsg0 name = jsgf name ()

283

276

@@ -416,22 +409,10 @@ obj = do

416 Object <$> wrapJSVal result

409 Object <$> wrapJSVal result

417#endif

410#endif

418

411

419−-- | Type used for Haskell functions called from JavaScript.

420−type JSCallAsFunction = JSVal -- ^ Function object

421− -> JSVal -- ^ this

422− -> [JSVal] -- ^ Function arguments

423− -> JSM JSUndefined -- ^ Only 'JSUndefined' can be returned because

424− -- the function may need to be executed in a

425− -- different thread. If you need to get a

426− -- value out pass in a continuation function

427− -- as an argument and invoke it from haskell.

428−

429-- | Short hand @::JSCallAsFunction@ so a haskell function can be passed to

412-- | Short hand @::JSCallAsFunction@ so a haskell function can be passed to

430-- a to a JavaScipt one.

413-- a to a JavaScipt one.

431--

414--

432-- >>> testJSaddle $ eval "(function(f) {f('Hello');})(function (a) {console.log(a)})"

415-- >>> testJSaddle $ eval "(function(f) {f('Hello');})(function (a) {console.log(a)})"

433−-- ** Message: console message: @1: Hello

434−-- <BLANKLINE>

435-- undefined

416-- undefined

436-- >>> testJSaddle $ call (eval "(function(f) {f('Hello');})") global [fun $ \ _ _ args -> valToText (head args) >>= (liftIO . putStrLn . T.unpack) ]

417-- >>> testJSaddle $ call (eval "(function(f) {f('Hello');})") global [fun $ \ _ _ args -> valToText (head args) >>= (liftIO . putStrLn . T.unpack) ]

437-- Hello

418-- Hello

@@ -461,9 +442,10 @@ foreign import javascript unsafe "$r = function () { $1(this, arguments); }"

461 makeFunctionWithCallback :: Callback (JSVal -> JSVal -> IO ()) -> IO Object

442 makeFunctionWithCallback :: Callback (JSVal -> JSVal -> IO ()) -> IO Object

462#else

443#else

463function f = do

444function f = do

464− -- callback <- liftIO $ mkJSObjectCallAsFunctionCallback (wrap gctxt)

465 NewCallbackResult result <- sendCommand NewCallback

445 NewCallbackResult result <- sendCommand NewCallback

466− Function () . Object <$> wrapJSVal result

446+ obj <- Object <$> wrapJSVal result

447+ asks addCallback >>= \add -> liftIO $ add obj f

448+ return $ Function () obj

467#endif

449#endif

468

450

469freeFunction :: Function -> JSM ()

451freeFunction :: Function -> JSM ()

@@ -471,7 +453,7 @@ freeFunction :: Function -> JSM ()

471freeFunction (Function callback _) = liftIO $

453freeFunction (Function callback _) = liftIO $

472 releaseCallback callback

454 releaseCallback callback

473#else

455#else

474−freeFunction (Function callback obj) = return () -- TODO

456+freeFunction (Function callback obj) = asks freeCallback >>= \f -> liftIO $ f obj

475#endif

457#endif

476

458

477instance ToJSVal Function where

459instance ToJSVal Function where

@@ -546,10 +528,14 @@ global = js_window

546foreign import javascript unsafe "$r = window"

528foreign import javascript unsafe "$r = window"

547 js_window :: Object

529 js_window :: Object

548#else

530#else

549−global = Object (JSVal 5)

531+global = Object (JSVal 4)

550#endif

532#endif

551

533

552-- | Get a list containing the property names present on a given object

534-- | Get a list containing the property names present on a given object

535+-- >>> testJSaddle $ show . map strToText <$> propertyNames obj

536+-- []

537+-- >>> testJSaddle $ show . map strToText <$> propertyNames (eval "({x:1, y:2})")

538+-- ["x","y"]

553propertyNames :: MakeObject this => this -> JSM [JSString]

539propertyNames :: MakeObject this => this -> JSM [JSString]

554#ifdef ghcjs_HOST_OS

540#ifdef ghcjs_HOST_OS

555propertyNames this = makeObject this >>= liftIO . js_propertyNames >>= liftIO . (fmap (map pFromJSVal)) . Array.toListIO

541propertyNames this = makeObject this >>= liftIO . js_propertyNames >>= liftIO . (fmap (map pFromJSVal)) . Array.toListIO

@@ -613,16 +599,17 @@ foreign import javascript unsafe "\

613 case 6 : $r = new $1($2[0],$2[1],$2[2],$2[3],$2[4],$2[5]); break;\

599 case 6 : $r = new $1($2[0],$2[1],$2[2],$2[3],$2[4],$2[5]); break;\

614 case 7 : $r = new $1($2[0],$2[1],$2[2],$2[3],$2[4],$2[5],$2[6]); break;\

600 case 7 : $r = new $1($2[0],$2[1],$2[2],$2[3],$2[4],$2[5],$2[6]); break;\

615 default:\

601 default:\

616− var ret;\

617 var temp = function() {\

602 var temp = function() {\

618 ret = $1.apply(this, $2);\

603 ret = $1.apply(this, $2);\

619 };\

604 };\

620 temp.prototype = $1.prototype;\

605 temp.prototype = $1.prototype;\

621 var i = new temp();\

606 var i = new temp();\

622 if(ret instanceof Object)\

607 if(ret instanceof Object)\

623− return ret;\

608+ $r = ret;\

609+ else {\

624− i.constructor = $1;\

610+ i.constructor = $1;\

625− return i;\

611+ $r = i;\

612+ }\

626 }\

613 }\

627 }\

614 }\

628 catch(e) {\

615 catch(e) {\

@@ -638,6 +625,8 @@ objCallAsConstructor f args = do

638 wrapJSVal result

625 wrapJSVal result

639#endif

626#endif

640

627

628+-- >>> testJSaddle $ strictEqual nullObject (eval "null")

629+-- true

641nullObject :: Object

630nullObject :: Object

642#ifdef ghcjs_HOST_OS

631#ifdef ghcjs_HOST_OS

643nullObject = Object nullRef

632nullObject = Object nullRef

src/Language/Javascript/JSaddle/Properties.hs+4−6

@@ -32,16 +32,14 @@ module Language.Javascript.JSaddle.Properties (

32import Language.Javascript.JSaddle.Classes

33 (ToJSVal(..), ToJSString(..))

34import Language.Javascript.JSaddle.Monad (JSM)

35−import Language.Javascript.JSaddle.Types

35+import Language.Javascript.JSaddle.Types (Object(..), Index)

36− (MutableJSArray, Object(..), JSPropertyAttributes,

37− Index)

38#ifdef ghcjs_HOST_OS

36#ifdef ghcjs_HOST_OS

39import Language.Javascript.JSaddle.Types (JSString)

37import Language.Javascript.JSaddle.Types (JSString)

40#else

38#else

41import Language.Javascript.JSaddle.Native

39import Language.Javascript.JSaddle.Native

42 (wrapJSVal, withObject, withJSString, withToJSVal)

40 (wrapJSVal, withObject, withJSString, withToJSVal)

43import Language.Javascript.JSaddle.WebSockets

41import Language.Javascript.JSaddle.WebSockets

44− (Command(..), Result(..), sendCommand, sendAsyncCommand)

42+ (Command(..), AsyncCommand(..), Result(..), sendCommand, sendAsyncCommand)

45#endif

43#endif

46import Control.Monad.Trans.Reader (ask)

44import Control.Monad.Trans.Reader (ask)

47import Language.Javascript.JSaddle.Value (JSVal)

45import Language.Javascript.JSaddle.Value (JSVal)

@@ -59,7 +57,7 @@ foreign import javascript unsafe "try { $r=$2[$1] } catch(e) { $3[0] = e }"

59 js_tryGetProp :: JSString -> Object -> MutableJSArray -> IO JSVal

57 js_tryGetProp :: JSString -> Object -> MutableJSArray -> IO JSVal

60#else

58#else

61objGetPropertyByName this name = do

59objGetPropertyByName this name = do

62− name' <- toJSString name

60+ let name' = toJSString name

63 withObject this $ \rthis ->

61 withObject this $ \rthis ->

64 withJSString name' $ \rname -> do

62 withJSString name' $ \rname -> do

65 GetPropertyByNameResult result <- sendCommand $ GetPropertyByName rthis rname

63 GetPropertyByNameResult result <- sendCommand $ GetPropertyByName rthis rname

@@ -95,7 +93,7 @@ foreign import javascript unsafe "try { $2[$1]=$3 } catch(e) { $4[0] = e }"

95 js_trySetProp :: JSString -> Object -> JSVal -> MutableJSArray -> IO ()

93 js_trySetProp :: JSString -> Object -> JSVal -> MutableJSArray -> IO ()

96#else

94#else

97objSetPropertyByName this name val = do

95objSetPropertyByName this name val = do

98− name' <- toJSString name

96+ let name' = toJSString name

99 withObject this $ \rthis ->

97 withObject this $ \rthis ->

100 withJSString name' $ \rname ->

98 withJSString name' $ \rname ->

101 withToJSVal val $ \rval ->

99 withToJSVal val $ \rval ->

src/Language/Javascript/JSaddle/String.hs+6−22

@@ -20,7 +20,6 @@ module Language.Javascript.JSaddle.String (

20 -- * Data.Text helpers

21 , strToText

22 , textToStr

23− , nullJSString

24) where

23) where

26import Data.Text (Text)

25import Data.Text (Text)

@@ -29,37 +28,22 @@ import Language.Javascript.JSaddle.Types (JSString(..))

29import Data.JSString.Text (textFromJSString, textToJSString)

28import Data.JSString.Text (textFromJSString, textToJSString)

30import GHCJS.Marshal.Internal (PFromJSVal(..))

29import GHCJS.Marshal.Internal (PFromJSVal(..))

31import GHCJS.Types (nullRef)

30import GHCJS.Types (nullRef)

32−#else

33−import Language.Javascript.JSaddle.Native (wrapJSString, withJSString)

34−import Language.Javascript.JSaddle.WebSockets (Command(..), Result(..), sendCommand)

35−import Language.Javascript.JSaddle.Monad (JSM)

36#endif

31#endif

37import Language.Javascript.JSaddle.Classes (ToJSString(..))

32import Language.Javascript.JSaddle.Classes (ToJSString(..))

39-- | Convert a JavaScript string to a Haskell 'Text'

34-- | Convert a JavaScript string to a Haskell 'Text'

40−strToText :: JSString -> JSM Text

35+strToText :: JSString -> Text

41#ifdef ghcjs_HOST_OS

36#ifdef ghcjs_HOST_OS

42−strToText = return . textFromJSString

37+strToText = textFromJSString

43#else

38#else

44−strToText jsstring' = withJSString jsstring' $ \jsstring -> do

39+strToText (JSString text) = text

45− JSStringToTextResult text <- sendCommand (JSStringToText jsstring)

46− return text

47#endif

40#endif

49-- | Convert a Haskell 'Text' to a JavaScript string

42-- | Convert a Haskell 'Text' to a JavaScript string

50−textToStr :: Text -> JSM JSString

43+textToStr :: Text -> JSString

51−#ifdef ghcjs_HOST_OS

52−textToStr = return . textToJSString

53−#else

54−textToStr text = do

55− TextToJSStringResult str <- sendCommand (TextToJSString text)

56− wrapJSString str

57−#endif

58−

59−nullJSString :: JSString

60#ifdef ghcjs_HOST_OS

44#ifdef ghcjs_HOST_OS

61−nullJSString = pFromJSVal nullRef

45+textToStr = textToJSString

62#else

46#else

63−nullJSString = JSString 0

47+textToStr = JSString

64#endif

48#endif

src/Language/Javascript/JSaddle/Test.hs+36−128

@@ -1,5 +1,5 @@

1−{-# LANGUAGE RecordWildCards #-}

1+{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE PatternSynonyms #-}

2+{-# LANGUAGE LambdaCase #-}

3-----------------------------------------------------------------------------

4--

5-- Module : TestJSC

@@ -14,157 +14,65 @@

15module Language.Javascript.JSaddle.Test (

16 testJSaddle

17− , showJSaddle

18 , listWindowProperties

17 , listWindowProperties

19) where

18) where

21import Control.Applicative

20import Control.Applicative

22import Prelude hiding((!!), catch)

21import Prelude hiding((!!), catch)

23−import GI.Gtk

24− (Window, widgetDestroy, widgetShowAll,

25− mainQuit, containerAdd, scrolledWindowNew,

26− windowSetPosition, windowSetDefaultSize, windowNew)

27−import Control.Concurrent

28− (tryTakeMVar, forkIO, newMVar, putMVar, takeMVar, newEmptyMVar,

29− yield)

30−import GI.Gtk.Enums (WindowType(..), WindowPosition(..))

31−import GI.WebKit.Objects.WebView

32− (webViewGetMainFrame, webViewNew)

33−import System.IO.Unsafe (unsafePerformIO)

34−import Control.Monad.Trans.Reader (runReaderT)

22+import Control.Monad.Trans.Reader (ask, runReaderT)

35−import GI.WebKit.Objects.WebFrame

36− (webFrameGetGlobalContext)

37import Language.Javascript.JSaddle

23import Language.Javascript.JSaddle

38import qualified Data.Text as T

24import qualified Data.Text as T

39import Control.Monad.IO.Class (MonadIO(..))

25import Control.Monad.IO.Class (MonadIO(..))

40−import Control.Monad (forM, when)

26+import Control.Monad (forever, forM)

41import Control.Lens.Getter ((^.))

27import Control.Lens.Getter ((^.))

42import Data.Monoid ((<>))

28import Data.Monoid ((<>))

43−import Control.Concurrent.MVar (MVar)

29+import Control.Concurrent.MVar

44−import qualified GI.Gtk.Functions as Gtk (init, main)

30+ (tryTakeMVar, putMVar, takeMVar, newEmptyMVar, MVar)

45−import GI.GLib.Functions (timeoutAdd)

31+import System.IO.Unsafe (unsafePerformIO)

46−import GI.Gtk.Enums (WindowPosition(..))

32+import Control.Concurrent (threadDelay, forkIO, ThreadId)

47−import Data.GI.Base.Signals (on)

33+import Data.Text (Text)

48−import GI.GLib (idleAdd)

34+import Language.Javascript.JSaddle.WebSockets (run)

49−import GI.GLib.Constants(pattern PRIORITY_DEFAULT, pattern PRIORITY_LOW)

35+

50−import GI.Gtk.Objects.Widget (onWidgetDestroy)

36+context :: MVar JSContextRef

51−import GI.JavaScriptCore.Structs.GlobalContext (GlobalContext(..))

37+context = unsafePerformIO newEmptyMVar

52−import Foreign.ForeignPtr (withForeignPtr)

38+{-# NOINLINE context #-}

53−import Foreign.Ptr (castPtr)

39+

54−import GI.Gtk.Objects.Adjustment (Adjustment(..))

40+server :: MVar ThreadId

55−

56−-- | Post an action to be run in the main GUI thread.

57−--

58−-- The current thread blocks until the action completes and the result is

59−-- returned.

60−--

61−postGUISync :: IO a -> IO a

62−postGUISync action = do

63− resultVar <- newEmptyMVar

64− idleAdd PRIORITY_DEFAULT $ action >>= putMVar resultVar >> return False

65− takeMVar resultVar

66−

67−-- | Post an action to be run in the main GUI thread.

68−--

69−-- The current thread continues and does not wait for the result of the

70−-- action.

71−--

72−postGUIAsync :: IO () -> IO ()

73−postGUIAsync action = do

74− idleAdd PRIORITY_DEFAULT $ action >> return False

75− return ()

76−

77−data TestState = TestState { jsContext :: GlobalContext, window :: Window }

78−

79−state :: MVar (Maybe TestState)

80−state = unsafePerformIO $ newMVar Nothing

41+server = unsafePerformIO newEmptyMVar

81−{-# NOINLINE state #-}

42+{-# NOINLINE server #-}

82−

43+

83−done :: MVar ()

44+startServer :: IO ()

84−done = unsafePerformIO newEmptyMVar

45+startServer =

85−{-# NOINLINE done #-}

46+ tryTakeMVar server >>= maybe (forkIO $

47+ run 3709 $ do

48+ liftIO $ tryTakeMVar context

49+ liftIO . putMVar context =<< ask

50+ liftIO . forever $ threadDelay 1000000

51+ ) return >>= putMVar server

87-- >>> testJSaddle $ ((global ^. js "console" . js "log") # ["Hello"])

53-- >>> testJSaddle $ ((global ^. js "console" . js "log") # ["Hello"])

88testJSaddle :: ToJSVal val => JSM val -> IO ()

54testJSaddle :: ToJSVal val => JSM val -> IO ()

89−testJSaddle = testJSaddle' False

55+testJSaddle f = do

90−

56+ startServer

91−-- >>> showJSaddle $ eval "document.body.innerHTML = 'Test'"

57+ c <- takeMVar context

92−showJSaddle :: ToJSVal val => JSM val -> IO ()

58+ runReaderT ((f >>= valToText >>= liftIO . putStrLn . T.unpack)

93−showJSaddle = testJSaddle' True

59+ `catch` \ (JSException e) -> valToText e >>= liftIO . putStrLn . T.unpack) c

60+ putMVar context c

95debugLog :: String -> IO ()

62debugLog :: String -> IO ()

96debugLog _ = return ()

63debugLog _ = return ()

98−testJSaddle' :: ToJSVal val => Bool -> JSM val -> IO ()

99−testJSaddle' showWindow f = do

100− debugLog "taking done"

101− _ <- tryTakeMVar done

102− debugLog "taking state"

103− mbState <- takeMVar state

104− TestState {..} <- case mbState of

105− Nothing -> do

106− debugLog "newState"

107− newState <- newEmptyMVar

108− debugLog "fork"

109− _ <- forkIO $ do

110− debugLog "initGUI"

111− _ <- Gtk.init mempty

112− debugLog "windowNew"

113− window <- windowNew WindowTypeToplevel

114− debugLog "timeoutAdd"

115− _ <- timeoutAdd PRIORITY_LOW 10 $ yield >> return True

116− windowSetDefaultSize window 900 600

117− windowSetPosition window WindowPositionCenter

118− scrollWin <- scrolledWindowNew (Nothing :: Maybe Adjustment) (Nothing :: Maybe Adjustment)

119− webView <- webViewNew

120− window `containerAdd` scrollWin

121− scrollWin `containerAdd` webView

122− _ <- onWidgetDestroy window $ do

123− debugLog "onDestroy"

124− _ <- tryTakeMVar state

125− debugLog "put state"

126− putMVar state Nothing

127− debugLog "mainQuit"

128− mainQuit

129− debugLog "put done"

130− putMVar done ()

131− return ()

132− debugLog "get context"

133− jsContext <- webViewGetMainFrame webView >>= webFrameGetGlobalContext

134− debugLog "put initial state"

135− putMVar newState TestState {..}

136− debugLog "maybe show"

137− when showWindow $ widgetShowAll window

138− debugLog "mainGUI"

139− Gtk.main

140− debugLog "mainGUI exited"

141− takeMVar newState

142− Just s@TestState {..} -> do

143− debugLog "maybe show (2)"

144− when showWindow . postGUISync $ widgetShowAll window

145− return s

146− x <- postGUISync $ withContext jsContext $ runReaderT ((f >>= valToText >>= liftIO . putStrLn . T.unpack)

147− `catch` \ (JSException e) -> valToText e >>= liftIO . putStrLn . T.unpack)

148− debugLog "put state"

149− putMVar state $ Just TestState {..}

150− return x

151−

152−withContext :: GlobalContext -> (JSContextRef -> IO a) -> IO a

153−withContext (GlobalContext fptr) f = withForeignPtr fptr $ f . castPtr

154−

155listWindowProperties :: IO ()

65listWindowProperties :: IO ()

156listWindowProperties = testJSaddle $ T.pack . show <$> do

66listWindowProperties = testJSaddle $ T.pack . show <$> do

157− window <- jsg "window"

67+ window <- jsg ("window" :: Text)

158 names <- propertyNames window

68 names <- propertyNames window

159 forM names $ \name -> do

69 forM names $ \name -> do

160 v <- window ^. js name >>= valToText

70 v <- window ^. js name >>= valToText

161− n <- strToText name

162− return (n, v)

71+ return (strToText name, v)

163 `catch`

72 `catch`

164 \(JSException e) -> do

73 \(JSException e) -> do

165− n <- strToText name

166 msg <- valToText e

74 msg <- valToText e

167− return (n, T.pack " error " <> msg)

75+ return (strToText name, T.pack " error " <> msg)

168

169

170

src/Language/Javascript/JSaddle/Types.hs+116−19

@@ -1,5 +1,7 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE CPP #-}

2−{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+{-# LANGUAGE DeriveGeneric #-}

3-----------------------------------------------------------------------------

5-----------------------------------------------------------------------------

4--

6--

5-- Module : Language.Javascript.JSaddle.Properties

7-- Module : Language.Javascript.JSaddle.Properties

@@ -16,19 +18,22 @@ module Language.Javascript.JSaddle.Types (

16 JSVal(..)

18 JSVal(..)

17 , MutableJSArray(..)

19 , MutableJSArray(..)

18 , Object(..)

20 , Object(..)

19− , JSPropertyNameArray(..)

20− , JSPropertyAttributes(..)

21 , JSContextRef(..)

22 , JSString(..)

23 , Index

24 , Nullable(..)

25 , JSM

26+ , JSCallAsFunction

26#ifndef ghcjs_HOST_OS

27#ifndef ghcjs_HOST_OS

27 , JSValueReceived(..)

28 , JSValueReceived(..)

28 , JSValueForSend(..)

29 , JSValueForSend(..)

29 , JSStringReceived(..)

30 , JSStringReceived(..)

30 , JSStringForSend(..)

31 , JSStringForSend(..)

31 , JSObjectForSend(..)

32 , JSObjectForSend(..)

33+ , AsyncCommand(..)

34+ , Command(..)

35+ , Batch(..)

36+ , Result(..)

32#endif

37#endif

33) where

38) where

@@ -40,32 +45,124 @@ import JavaScript.Array (MutableJSArray)

40import Data.Word (Word(..))

45import Data.Word (Word(..))

41import GHCJS.Nullable (Nullable(..))

46import GHCJS.Nullable (Nullable(..))

42#else

47#else

43−import Network.WebSockets (Connection)

44import Data.Text (Text)

48import Data.Text (Text)

49+import Data.Aeson

50+ (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..))

51+import GHC.Generics (Generic)

45#endif

52#endif

47#ifdef ghcjs_HOST_OS

54#ifdef ghcjs_HOST_OS

48−newtype JSPropertyNameArray = JSPropertyNameArray { unJSPropertyNameArrayRef :: JSVal }

49−type JSPropertyAttributes = Word

50type JSContextRef = ()

55type JSContextRef = ()

51type Index = Int

56type Index = Int

52#else

57#else

53−newtype JSValueReceived = JSValueReceived Int

58+newtype JSValueReceived = JSValueReceived Int deriving(Show, ToJSON, FromJSON)

54−newtype JSValueForSend = JSValueForSend Int

59+newtype JSValueForSend = JSValueForSend Int deriving(Show, ToJSON, FromJSON)

55−newtype JSVal = JSVal Int

60+newtype JSVal = JSVal Int deriving(Show, ToJSON, FromJSON)

56−newtype MutableJSArray = MutableJSArray Int

61+newtype MutableJSArray = MutableJSArray Int deriving(Show, ToJSON, FromJSON)

57−newtype JSPropertyNameArray = JSPropertyNameArray Int

58−newtype JSPropertyAttributes = JSPropertyAttributes Word

59type Index = Int

62type Index = Int

60−newtype JSObjectForSend = JSObjectForSend JSValueForSend

63+newtype JSObjectForSend = JSObjectForSend JSValueForSend deriving(Show, ToJSON, FromJSON)

61−newtype Object = Object JSVal

64+newtype Object = Object JSVal deriving(Show, ToJSON, FromJSON)

62−newtype JSStringReceived = JSStringReceived Int

65+newtype JSStringReceived = JSStringReceived Text deriving(Show, ToJSON, FromJSON)

63−newtype JSStringForSend = JSStringForSend Int

66+newtype JSStringForSend = JSStringForSend Text deriving(Show, ToJSON, FromJSON)

64−newtype JSString = JSString Int

67+newtype JSString = JSString Text deriving(Show, ToJSON, FromJSON)

65newtype Nullable a = Nullable a

68newtype Nullable a = Nullable a

69+

70+data AsyncCommand = FreeRef JSValueForSend

71+ | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend

72+ | SetPropertyAtIndex JSObjectForSend Index JSValueForSend

73+ deriving (Show, Generic)

74+

75+instance ToJSON AsyncCommand where

76+ toEncoding = genericToEncoding defaultOptions

77+

78+instance FromJSON AsyncCommand

79+

80+data Command = DeRefVal JSValueForSend

81+ | ValueToBool JSValueForSend

82+ | ValueToNumber JSValueForSend

83+ | ValueToString JSValueForSend

84+ | ValueToJSON JSValueForSend

85+ | IsNull JSValueForSend

86+ | IsUndefined JSValueForSend

87+ | NumberToValue Double

88+ | StringToValue JSStringForSend

89+ | StrictEqual JSValueForSend JSValueForSend

90+ | InstanceOf JSValueForSend JSObjectForSend

91+ | GetPropertyByName JSObjectForSend JSStringForSend

92+ | GetPropertyAtIndex JSObjectForSend Index

93+ | CallAsFunction JSObjectForSend JSObjectForSend [JSValueForSend]

94+ | CallAsConstructor JSObjectForSend [JSValueForSend]

95+ | NewEmptyObject

96+ | NewCallback

97+ | NewArray [JSValueForSend]

98+ | PropertyNames JSObjectForSend

99+ | EvaluateScript JSStringForSend

100+ | Sync

101+ deriving (Show, Generic)

102+

103+instance ToJSON Command where

104+ toEncoding = genericToEncoding defaultOptions

105+

106+instance FromJSON Command

107+

108+data Batch = Batch [AsyncCommand] Command

109+ deriving (Show, Generic)

110+

111+instance ToJSON Batch where

112+ toEncoding = genericToEncoding defaultOptions

113+

114+instance FromJSON Batch

115+

116+data Result = DeRefValResult Int Text

117+ | ValueToBoolResult Bool

118+ | ValueToNumberResult Double

119+ | ValueToStringResult JSStringReceived

120+ | ValueToJSONResult JSStringReceived

121+ | IsNullResult Bool

122+ | IsUndefinedResult Bool

123+ | NumberToValueResult JSValueReceived

124+ | StringToValueResult JSValueReceived

125+ | StrictEqualResult Bool

126+ | InstanceOfResult Bool

127+ | GetPropertyByNameResult JSValueReceived

128+ | GetPropertyAtIndexResult JSValueReceived

129+ | CallAsFunctionResult JSValueReceived

130+ | CallAsConstructorResult JSValueReceived

131+ | NewEmptyObjectResult JSValueReceived

132+ | NewCallbackResult JSValueReceived

133+ | Callback JSValueReceived JSValueReceived [JSValueReceived]

134+ | NewArrayResult JSValueReceived

135+ | PropertyNamesResult [JSStringReceived]

136+ | EvaluateScriptResult JSValueReceived

137+ | ThrowJSValue JSValueReceived

138+ | ProtocolError Text

139+ | SyncResult

140+ deriving (Show, Generic)

141+

142+instance ToJSON Result where

143+ toEncoding = genericToEncoding defaultOptions

144+

145+instance FromJSON Result

146+

66−data JSContextRef = JSContextRef Connection

147+data JSContextRef = JSContextRef {

148+ doSendCommand :: Command -> IO Result

149+ , doSendAsyncCommand :: AsyncCommand -> IO ()

150+ , addCallback :: Object -> JSCallAsFunction -> IO ()

151+ , freeCallback :: Object -> IO ()

152+}

153+

67#endif

154#endif

155

156+-- | Type used for Haskell functions called from JavaScript.

157+type JSCallAsFunction = JSVal -- ^ Function object

158+ -> JSVal -- ^ this

159+ -> [JSVal] -- ^ Function arguments

160+ -> JSM () -- ^ Only () (aka 'JSUndefined') can be returned because

161+ -- the function may need to be executed in a

162+ -- different thread. If you need to get a

163+ -- value out pass in a continuation function

164+ -- as an argument and invoke it from haskell.

165+

69-- | The @JSM@ monad keeps track of the JavaScript context.

166-- | The @JSM@ monad keeps track of the JavaScript context.

70--

167--

71-- Given a @JSM@ function and a 'JSContextRef' you can run the

168-- Given a @JSM@ function and a 'JSContextRef' you can run the

src/Language/Javascript/JSaddle/Value.hs+58−35

@@ -61,7 +61,7 @@ module Language.Javascript.JSaddle.Value (

61 , maybeNullOrUndefined'

62 , valBool

63 , valMakeNumber

64− , valString

64+ , valMakeString

66 -- * Convert to and from JSValue

67 , deRefVal

@@ -90,8 +90,6 @@ import Language.Javascript.JSaddle.Native

90import Language.Javascript.JSaddle.WebSockets (Command(..), Result(..), sendCommand)

91#endif

92import Language.Javascript.JSaddle.Monad (JSM)

93−import Control.Monad.Trans.Reader (ask)

94−import Control.Monad.IO.Class (MonadIO(..))

95import Data.Text (Text)

93import Data.Text (Text)

96import qualified Data.Text as T (pack, unpack)

94import qualified Data.Text as T (pack, unpack)

97import Language.Javascript.JSaddle.Classes

95import Language.Javascript.JSaddle.Classes

@@ -105,7 +103,7 @@ import Data.Int (Int32, Int64)

105-- >>> import Language.Javascript.JSaddle.Test (testJSaddle)

103-- >>> import Language.Javascript.JSaddle.Test (testJSaddle)

106-- >>> import Language.Javascript.JSaddle.Monad (catch)

104-- >>> import Language.Javascript.JSaddle.Monad (catch)

107-- >>> import Language.Javascript.JSaddle.Exception (JSException(..))

105-- >>> import Language.Javascript.JSaddle.Exception (JSException(..))

108−-- >>> import Language.Javascript.JSaddle.Object (obj)

106+-- >>> import Language.Javascript.JSaddle.Object (obj, jsg)

109-- >>> import qualified Data.Text as T (pack)

107-- >>> import qualified Data.Text as T (pack)

110

108

111data JSNull = JSNull -- ^ Type that represents a value that can only be null.

109data JSNull = JSNull -- ^ Type that represents a value that can only be null.

@@ -204,21 +202,21 @@ valToNumber value =

204-- | Given a JavaScript value get its string value (as a JavaScript string).

202-- | Given a JavaScript value get its string value (as a JavaScript string).

205-- May throw JSException.

203-- May throw JSException.

206--

204--

207−-- >>> testJSaddle $ valToStr JSNull >>= strToText

205+-- >>> testJSaddle $ strToText <$> valToStr JSNull

208-- null

206-- null

209−-- >>> testJSaddle $ valToStr () >>= strToText

207+-- >>> testJSaddle $ strToText <$> valToStr ()

210-- undefined

208-- undefined

211−-- >>> testJSaddle $ valToStr True >>= strToText

209+-- >>> testJSaddle $ strToText <$> valToStr True

212-- true

210-- true

213−-- >>> testJSaddle $ valToStr False >>= strToText

211+-- >>> testJSaddle $ strToText <$> valToStr False

214-- false

212-- false

215−-- >>> testJSaddle $ valToStr (1.0 :: Double) >>= strToText

213+-- >>> testJSaddle $ strToText <$> valToStr (1.0 :: Double)

216-- 1

214-- 1

217−-- >>> testJSaddle $ valToStr (0.0 :: Double) >>= strToText

215+-- >>> testJSaddle $ strToText <$> valToStr (0.0 :: Double)

218-- 0

216-- 0

219−-- >>> testJSaddle $ valToStr "" >>= strToText

217+-- >>> testJSaddle $ strToText <$> valToStr ""

220-- <BLANKLINE>

218-- <BLANKLINE>

221−-- >>> testJSaddle $ valToStr "1" >>= strToText

219+-- >>> testJSaddle $ strToText <$> valToStr "1"

222-- 1

220-- 1

223valToStr :: ToJSVal value => value -> JSM JSString

221valToStr :: ToJSVal value => value -> JSM JSString

224#ifdef ghcjs_HOST_OS

222#ifdef ghcjs_HOST_OS

@@ -251,33 +249,33 @@ valToStr value =

251-- >>> testJSaddle $ show <$> valToText "1"

249-- >>> testJSaddle $ show <$> valToText "1"

252-- "1"

250-- "1"

253valToText :: ToJSVal value => value -> JSM Text

251valToText :: ToJSVal value => value -> JSM Text

254−valToText jsvar = valToStr jsvar >>= strToText

252+valToText jsvar = strToText <$> valToStr jsvar

255

253

256-- | Given a JavaScript value get a JSON string value.

254-- | Given a JavaScript value get a JSON string value.

257-- May throw JSException.

255-- May throw JSException.

258--

256--

259−-- >>> testJSaddle $ valToJSON 0 JSNull >>= strToText

257+-- >>> testJSaddle $ strToText <$> valToJSON JSNull

260-- null

258-- null

261−-- >>> testJSaddle $ valToJSON 0 () >>= strToText

259+-- >>> testJSaddle $ strToText <$> valToJSON ()

262-- <BLANKLINE>

260-- <BLANKLINE>

263−-- >>> testJSaddle $ valToJSON 0 True >>= strToText

261+-- >>> testJSaddle $ strToText <$> valToJSON True

264-- true

262-- true

265−-- >>> testJSaddle $ valToJSON 0 False >>= strToText

263+-- >>> testJSaddle $ strToText <$> valToJSON False

266-- false

264-- false

267−-- >>> testJSaddle $ valToJSON 0 (1.0 :: Double) >>= strToText

265+-- >>> testJSaddle $ strToText <$> valToJSON (1.0 :: Double)

268-- 1

266-- 1

269−-- >>> testJSaddle $ valToJSON 0 (0.0 :: Double) >>= strToText

267+-- >>> testJSaddle $ strToText <$> valToJSON (0.0 :: Double)

270-- 0

268-- 0

271−-- >>> testJSaddle $ valToJSON 0 "" >>= strToText

269+-- >>> testJSaddle $ strToText <$> valToJSON ""

272-- ""

270-- ""

273−-- >>> testJSaddle $ valToJSON 0 "1" >>= strToText

271+-- >>> testJSaddle $ strToText <$> valToJSON "1"

274-- "1"

272-- "1"

275−-- >>> testJSaddle $ obj >>= valToJSON 0 >>= strToText

273+-- >>> testJSaddle $ strToText <$> (obj >>= valToJSON)

276-- {}

274-- {}

277valToJSON :: ToJSVal value => value -> JSM JSString

275valToJSON :: ToJSVal value => value -> JSM JSString

278#ifdef ghcjs_HOST_OS

276#ifdef ghcjs_HOST_OS

279valToJSON value = jsrefToJSON <$> toJSVal value

277valToJSON value = jsrefToJSON <$> toJSVal value

280−foreign import javascript unsafe "$r = JSON.stringify($1);" jsrefToJSON :: JSVal -> JSString

278+foreign import javascript unsafe "$r = $1 === undefined ? "" : JSON.stringify($1);" jsrefToJSON :: JSVal -> JSString

281#else

279#else

282valToJSON value =

280valToJSON value =

283 withToJSVal value $ \rval -> do

281 withToJSVal value $ \rval -> do

@@ -289,9 +287,9 @@ valToJSON value =

289-- May throw JSException.

287-- May throw JSException.

290--

288--

291-- >>> testJSaddle $ (valToObject JSNull >>= valToText) `catch` \ (JSException e) -> valToText e

289-- >>> testJSaddle $ (valToObject JSNull >>= valToText) `catch` \ (JSException e) -> valToText e

292−-- TypeError:...null...is not an object

290+-- null

293-- >>> testJSaddle $ (valToObject () >>= valToText) `catch` \ (JSException e) -> valToText e

291-- >>> testJSaddle $ (valToObject () >>= valToText) `catch` \ (JSException e) -> valToText e

294−-- TypeError:...undefined...is not an object

292+-- undefined

295-- >>> testJSaddle $ valToObject True

293-- >>> testJSaddle $ valToObject True

296-- true

294-- true

297-- >>> testJSaddle $ valToObject False

295-- >>> testJSaddle $ valToObject False

@@ -356,9 +354,13 @@ valIsNull :: ToJSVal value => value -> JSM Bool

356#ifdef ghcjs_HOST_OS

354#ifdef ghcjs_HOST_OS

357valIsNull value = isNull <$> toJSVal value

355valIsNull value = isNull <$> toJSVal value

358#else

356#else

357+valIsNull value =

359−valIsNull value = toJSVal value >>= \case

358+ toJSVal value >>= \case

360− JSVal 0 -> return True

359+ JSVal 0 -> return True

360+ v ->

361+ withJSVal v $ \rval -> do

362+ IsNullResult result <- sendCommand $ IsNull rval

361− _ -> return False

363+ return result

362#endif

364#endif

363

365

364----------- undefined ---------------

366----------- undefined ---------------

@@ -389,7 +391,11 @@ valIsUndefined :: ToJSVal value => value -> JSM Bool

389valIsUndefined value = isUndefined <$> toJSVal value

391valIsUndefined value = isUndefined <$> toJSVal value

390#else

392#else

391valIsUndefined value = toJSVal value >>= \case

393valIsUndefined value = toJSVal value >>= \case

392− JSVal ref -> return $ ref == 1

394+ JSVal 1 -> return True

395+ v ->

396+ withJSVal v $ \rval -> do

397+ IsUndefinedResult result <- sendCommand $ IsUndefined rval

398+ return result

393#endif

399#endif

394

400

395-- | Convert a JSVal to a Maybe JSVal (converting null and undefined to Nothing)

401-- | Convert a JSVal to a Maybe JSVal (converting null and undefined to Nothing)

@@ -475,15 +481,18 @@ valMakeText :: Text -> JSM JSVal

475#ifdef ghcjs_HOST_OS

481#ifdef ghcjs_HOST_OS

476valMakeText = return . pToJSVal . textToJSString

482valMakeText = return . pToJSVal . textToJSString

477#else

483#else

478−valMakeText text = valString <$> textToStr text

484+valMakeText text = valMakeString (textToStr text)

479#endif

485#endif

480

486

481-- | Make a JavaScript string from `JSString`

487-- | Make a JavaScript string from `JSString`

482−valString :: JSString -> JSVal

488+valMakeString :: JSString -> JSM JSVal

483#ifdef ghcjs_HOST_OS

489#ifdef ghcjs_HOST_OS

484−valString = pToJSVal

490+valMakeString = return . pToJSVal

485#else

491#else

486−valString (JSString ref) = JSVal ref

492+valMakeString s =

493+ withJSString s $ \s' -> do

494+ StringToValueResult result <- sendCommand $ StringToValue s'

495+ wrapJSVal result

487#endif

496#endif

488

497

489-- | Makes a JavaScript string

498-- | Makes a JavaScript string

@@ -500,11 +509,11 @@ instance ToJSVal String where

500

509

501-- | Makes a JavaScript string

510-- | Makes a JavaScript string

502instance ToJSVal JSString where

511instance ToJSVal JSString where

503− toJSVal = return . valString

512+ toJSVal = valMakeString

504

513

505-- | If we already have a JSString we are fine

514-- | If we already have a JSString we are fine

506instance ToJSString JSString where

515instance ToJSString JSString where

507− toJSString = return

516+ toJSString = id

508

517

509instance ToJSString Text where

518instance ToJSString Text where

510 toJSString = textToStr

519 toJSString = textToStr

@@ -531,6 +540,8 @@ instance ToJSString String where

531-- >>> testJSaddle $ showJSValue <$> deRefVal "1"

540-- >>> testJSaddle $ showJSValue <$> deRefVal "1"

532-- "1"

541-- "1"

533-- >>> testJSaddle $ showJSValue <$> (valToObject True >>= deRefVal)

542-- >>> testJSaddle $ showJSValue <$> (valToObject True >>= deRefVal)

543+-- true

544+-- >>> testJSaddle $ showJSValue <$> (obj >>= deRefVal)

534-- object

545-- object

535deRefVal :: ToJSVal value => value -> JSM JSValue

546deRefVal :: ToJSVal value => value -> JSM JSValue

536#ifdef ghcjs_HOST_OS

547#ifdef ghcjs_HOST_OS

@@ -602,6 +613,15 @@ foreign import javascript unsafe

602 "$1===$2" jsvalueisstrictequal :: JSVal -> JSVal -> Bool

613 "$1===$2" jsvalueisstrictequal :: JSVal -> JSVal -> Bool

603#endif

614#endif

604

615

616+-- | Determine if two values are equal (JavaScripts ===)

617+-- >>> testJSaddle $ strictEqual True False

618+-- false

619+-- >>> testJSaddle $ strictEqual True True

620+-- true

621+-- >>> testJSaddle $ strictEqual "Hello" ()

622+-- false

623+-- >>> testJSaddle $ strictEqual "Hello" "Hello"

624+-- true

605strictEqual :: (ToJSVal a, ToJSVal b) => a -> b -> JSM Bool

625strictEqual :: (ToJSVal a, ToJSVal b) => a -> b -> JSM Bool

606strictEqual a b = do

626strictEqual a b = do

607 aval <- toJSVal a

627 aval <- toJSVal a

@@ -626,6 +646,9 @@ foreign import javascript unsafe "\

626 js_isInstanceOf :: JSVal -> Object -> MutableJSArray -> Bool

646 js_isInstanceOf :: JSVal -> Object -> MutableJSArray -> Bool

627#endif

647#endif

628

648

649+-- | Determine if two values are equal (JavaScripts ===)

650+-- >>> testJSaddle $ instanceOf obj (Object <$> jsg "Object")

651+-- true

629instanceOf :: (ToJSVal value, MakeObject constructor) => value -> constructor -> JSM Bool

652instanceOf :: (ToJSVal value, MakeObject constructor) => value -> constructor -> JSM Bool

630instanceOf value constructor = do

653instanceOf value constructor = do

631 v <- toJSVal value

654 v <- toJSVal value

src/Language/Javascript/JSaddle/WebSockets.hs+117−50

@@ -1,3 +1,6 @@

1+{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE OverloadedStrings #-}

1-----------------------------------------------------------------------------

4-----------------------------------------------------------------------------

2--

5--

3-- Module : Language.Javascript.JSaddle.WebSockets

6-- Module : Language.Javascript.JSaddle.WebSockets

@@ -11,63 +14,127 @@

11-----------------------------------------------------------------------------

14-----------------------------------------------------------------------------

13module Language.Javascript.JSaddle.WebSockets (

16module Language.Javascript.JSaddle.WebSockets (

17+ jsaddleOr

18+ , run

19+ , AsyncCommand(..)

14− Command(..)

20+ , Command(..)

15 , Result(..)

21 , Result(..)

16 , sendCommand

22 , sendCommand

17 , sendAsyncCommand

23 , sendAsyncCommand

18) where

24) where

20−import Data.Text (Text)

26+import Control.Exception (throwIO)

21−import Language.Javascript.JSaddle.Types

27+import Control.Monad (void, forever)

22− (JSStringReceived(..), JSStringForSend, JSValueForSend,

28+import Control.Monad.IO.Class (MonadIO(..))

23− JSValueReceived(..), JSObjectForSend, Index)

29+import Control.Monad.Trans.Reader (asks)

24−import Language.Javascript.JSaddle.Monad (JSM)

30+import Control.Monad.STM (STM, atomically)

31+import Control.Concurrent (forkIO)

32+import Control.Concurrent.STM.TChan

33+ (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)

34+import Control.Concurrent.STM.TVar

35+ (readTVarIO, modifyTVar, newTVarIO)

36+import Control.Concurrent.MVar

37+ (MVar, MVar, putMVar, takeMVar, newEmptyMVar)

38+

39+import Data.Monoid ((<>))

40+import qualified Data.Text as T (unpack)

41+import qualified Data.Map as M (lookup, delete, insert, empty)

42+import Data.Aeson (encode, decode)

26−data Command = JSStringToText JSStringForSend

44+import Network.Wai (Application)

27− | TextToJSString Text

45+import Network.WebSockets

28− | DeRefVal JSValueForSend

46+ (ConnectionOptions(..), sendTextData, receiveDataMessage,

29− | ValueToBool JSValueForSend

47+ acceptRequest, defaultConnectionOptions, ServerApp)

30− | ValueToNumber JSValueForSend

48+import qualified Network.WebSockets as WS (DataMessage(..))

31− | ValueToString JSValueForSend

49+import Network.Wai.Handler.WebSockets (websocketsOr)

32− | ValueToJSON JSValueForSend

50+

33− | NumberToValue Double

51+import Language.Javascript.JSaddle.Types

34− | StrictEqual JSValueForSend JSValueForSend

52+ (Command(..), AsyncCommand(..), Result(..), JSContextRef(..), JSVal(..),

35− | InstanceOf JSValueForSend JSObjectForSend

36− | GetPropertyByName JSObjectForSend JSStringForSend

37− | GetPropertyAtIndex JSObjectForSend Index

38− | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend

39− | SetPropertyAtIndex JSObjectForSend Index JSValueForSend

40− | CallAsFunction JSObjectForSend JSObjectForSend [JSValueForSend]

41− | CallAsConstructor JSObjectForSend [JSValueForSend]

42− | NewEmptyObject

43− | NewCallback

44− | NewArray [JSValueForSend]

45− | PropertyNames JSObjectForSend

46− | EvaluateScript JSStringForSend

47−data Result = JSStringToTextResult Text

48− | TextToJSStringResult JSStringReceived

49− | DeRefValResult Int Text

50− | ValueToBoolResult Bool

51− | ValueToNumberResult Double

52− | ValueToStringResult JSStringReceived

53− | ValueToJSONResult JSStringReceived

54− | NumberToValueResult JSValueReceived

53+ Object(..), JSValueReceived(..), JSM, Batch(..))

55− | StrictEqualResult Bool

54+import Language.Javascript.JSaddle.Exception (JSException(..))

56− | InstanceOfResult Bool

55+import Language.Javascript.JSaddle.Monad (runJSaddle)

57− | GetPropertyByNameResult JSValueReceived

56+import Language.Javascript.JSaddle.Native (wrapJSVal)

58− | GetPropertyAtIndexResult JSValueReceived

57+import Language.Javascript.JSaddle.WebSockets.Files (mkEmbedded)

59− | CallAsFunctionResult JSValueReceived

58+import Network.Wai.Handler.Warp

60− | CallAsConstructorResult JSValueReceived

59+ (defaultSettings, setTimeout, setPort, runSettings)

61− | NewEmptyObjectResult JSValueReceived

60+import Network.Wai.Application.Static

62− | NewCallbackResult JSValueReceived

61+ (ssIndices, staticApp)

63− | Callback JSValueReceived JSValueReceived [JSValueReceived]

62+import WaiAppStatic.Storage.Embedded (mkSettings)

64− | NewArrayResult JSValueReceived

63+import WaiAppStatic.Types (unsafeToPiece)

65− | PropertyNamesResult [JSStringReceived]

66− | EvaluateScriptResult JSValueReceived

68sendCommand :: Command -> JSM Result

65sendCommand :: Command -> JSM Result

69−sendCommand = undefined

66+sendCommand cmd = do

67+ s <- asks doSendCommand

68+ liftIO $ s cmd

69+

70+sendAsyncCommand :: AsyncCommand -> JSM ()

71+sendAsyncCommand cmd = do

72+ s <- asks doSendAsyncCommand

73+ liftIO $ s cmd

74+

75+jsaddleOr :: ConnectionOptions -> JSM () -> Application -> Application

76+jsaddleOr opts entryPoint = websocketsOr opts wsApp

77+ where

78+ wsApp :: ServerApp

79+ wsApp pending_conn = do

80+ conn <- acceptRequest pending_conn

81+ recvChan <- newTChanIO

82+ commandChan <- newTChanIO

83+ callbacks <- newTVarIO M.empty

84+ let ctx = JSContextRef {

85+ doSendCommand = \cmd -> do

86+ result <- newEmptyMVar

87+ atomically $ writeTChan commandChan (Right (cmd, result))

88+ takeMVar result >>= \case

89+ (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)

90+ result -> return result

91+ , doSendAsyncCommand = atomically . writeTChan commandChan . Left

92+ , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar callbacks (M.insert val cb)

93+ , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar callbacks (M.delete val)

94+ }

95+ forkIO . forever $

96+ receiveDataMessage conn >>= \case

97+ (WS.Text t) ->

98+ case decode t of

99+ Nothing -> error $ "jsaddle WebSocket decode failed : " <> show t

100+ Just (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err

101+ Just (Callback f this a) -> do

102+ f'@(JSVal fNumber) <- runJSaddle ctx $ wrapJSVal f

103+ this' <- runJSaddle ctx $ wrapJSVal this

104+ args <- runJSaddle ctx $ mapM wrapJSVal a

105+ (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case

106+ Nothing -> liftIO $ putStrLn "Callback called after it was freed"

107+ Just cb -> void . forkIO . runJSaddle ctx $ cb f' this' args

108+ Just m -> atomically $ writeTChan recvChan m

109+ _ -> error "jsaddle WebSocket unexpected binary data"

110+ forkIO . forever $ atomically (readBatch commandChan) >>= \case

111+ (batch, Just resultMVar) -> do

112+ sendTextData conn $ encode batch

113+ atomically (readTChan recvChan) >>= putMVar resultMVar

114+ (batch, Nothing) -> do

115+ sendTextData conn $ encode batch

116+ SyncResult <- atomically $ readTChan recvChan

117+ return ()

118+

119+ runJSaddle ctx entryPoint

120+

121+ readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> STM (Batch, Maybe (MVar Result))

122+ readBatch chan = do

123+ first <- readTChan chan -- We want at least one command to send

124+ loop first []

125+ where

126+ loop (Right (cmd, resultMVar)) asyncCmds =

127+ return (Batch (reverse asyncCmds) cmd, Just resultMVar)

128+ loop (Left asyncCmd) asyncCmds' = do

129+ let asyncCmds = asyncCmd:asyncCmds'

130+ tryReadTChan chan >>= \case

131+ Nothing -> return (Batch (reverse asyncCmds) Sync, Nothing)

132+ Just cmd -> loop cmd asyncCmds

133

71−sendAsyncCommand :: Command -> JSM ()

134+jsaddleApp :: Application

72−sendAsyncCommand = undefined

135+jsaddleApp = staticApp ($(mkSettings mkEmbedded)) {ssIndices = [unsafeToPiece "index.html"]}

136

137+run :: Int -> JSM () -> IO ()

138+run port f =

139+ runSettings (setPort port (setTimeout 3600 defaultSettings)) $

140+ jsaddleOr defaultConnectionOptions f jsaddleApp

src/Language/Javascript/JSaddle/WebSockets/Files.hsnew file+36

@@ -0,0 +1,36 @@

1+{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}

2+-----------------------------------------------------------------------------

3+--

4+-- Module : Language.Javascript.JSaddle.WebSockets.Files

5+-- Copyright : (c) Hamish Mackenzie

6+-- License : MIT

7+--

8+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@gmail.com>

9+--

10+-- |

11+--

12+-----------------------------------------------------------------------------

13+

14+module Language.Javascript.JSaddle.WebSockets.Files (

15+ mkEmbedded

16+) where

17+

18+import WaiAppStatic.Storage.Embedded

19+import qualified Data.ByteString.Lazy as BL

20+

21+mkEmbedded :: IO [EmbeddableEntry]

22+mkEmbedded = do

23+ indexFile <- BL.readFile "data/index.html"

24+ jsFile <- BL.readFile "data/jsaddle.js"

25+ let index = EmbeddableEntry {

26+ eLocation = "index.html"

27+ , eMimeType = "text/html"

28+ , eContent = Left ("", indexFile)

29+ }

30+ js = EmbeddableEntry {

31+ eLocation = "jsaddle.js"

32+ , eMimeType = "text/plain"

33+ , eContent = Left ("", jsFile)

34+ }

35+ return [index, js]

36+

tests/DocTest.hs+46−26

@@ -1,35 +1,55 @@

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE PatternSynonyms #-}

2module Main (

4module Main (

3 main

5 main

4) where

6) where

6import Test.DocTest

8import Test.DocTest

9+import System.FilePath ((</>))

10+import System.Process (system)

11+import Control.Concurrent (forkIO)

12+import Control.Monad (void)

13+import Data.Monoid ((<>))

14+import Paths_jsaddle (getDataDir)

15+

8main :: IO ()

17main :: IO ()

18+main = do

19+ dataDir <- getDataDir

20+ forkIO . void . system $ "node --harmony " <> dataDir </> "data/jsaddle.js"

9−main = doctest [

21+ doctest [

10− "-hide-all-packages",

22+ "-hide-all-packages",

11− "-package=webkitgtk3-javascriptcore-" ++ VERSION_webkitgtk3_javascriptcore,

12− "-package=template-haskell-" ++ VERSION_template_haskell,

23+ "-package=template-haskell-" ++ VERSION_template_haskell,

13− "-package=base-" ++ VERSION_base,

24+ "-package=base-" ++ VERSION_base,

14− "-package=lens-" ++ VERSION_lens,

25+ "-package=lens-" ++ VERSION_lens,

15− "-package=text-" ++ VERSION_text,

26+ "-package=text-" ++ VERSION_text,

27+ "-package=bytestring-" ++ VERSION_bytestring,

16− "-package=transformers-" ++ VERSION_transformers,

28+ "-package=transformers-" ++ VERSION_transformers,

17− "-package=haskell-gi-base-" ++ VERSION_haskell_gi_base,

29+ "-package=websockets-" ++ VERSION_websockets,

18− "-package=gi-glib-" ++ VERSION_gi_glib,

30+ "-package=primitive-" ++ VERSION_primitive,

19− "-package=gi-gtk-" ++ VERSION_gi_gtk,

31+ "-package=aeson-" ++ VERSION_aeson,

20− "-package=gi-webkit-" ++ VERSION_gi_webkit,

32+ "-package=websockets-" ++ VERSION_websockets,

21− "-package=gi-javascriptcore-" ++ VERSION_gi_javascriptcore,

33+ "-package=wai-" ++ VERSION_wai,

34+ "-package=wai-websockets-" ++ VERSION_wai_websockets,

35+ "-package=wai-app-static-" ++ VERSION_wai_app_static,

36+ "-package=warp-" ++ VERSION_warp,

37+ "-package=http-types-" ++ VERSION_http_types,

38+ "-package=stm-" ++ VERSION_stm,

39+ "-package=containers-" ++ VERSION_containers,

40+ "-package=process-" ++ VERSION_process,

41+ "-package=filepath-" ++ VERSION_filepath,

22− "-isrc",

42+ "-isrc",

23− "src/Language/Javascript/JSaddle/Arguments.hs",

43+ "src/Language/Javascript/JSaddle/Arguments.hs",

24− "src/Language/Javascript/JSaddle/Classes.hs",

44+ "src/Language/Javascript/JSaddle/Classes.hs",

25− "src/Language/Javascript/JSaddle/Evaluate.hs",

45+ "src/Language/Javascript/JSaddle/Evaluate.hs",

26− "src/Language/Javascript/JSaddle/Exception.hs",

46+ "src/Language/Javascript/JSaddle/Exception.hs",

27− "src/Language/Javascript/JSaddle/Monad.hs",

47+ "src/Language/Javascript/JSaddle/Monad.hs",

28− "src/Language/Javascript/JSaddle/Native.hs",

48+ "src/Language/Javascript/JSaddle/Native.hs",

29− "src/Language/Javascript/JSaddle/Object.hs",

49+ "src/Language/Javascript/JSaddle/Object.hs",

30− "src/Language/Javascript/JSaddle/Properties.hs",

50+ "src/Language/Javascript/JSaddle/Properties.hs",

31− "src/Language/Javascript/JSaddle/String.hs",

51+ "src/Language/Javascript/JSaddle/String.hs",

32− "src/Language/Javascript/JSaddle/Test.hs",

52+ "src/Language/Javascript/JSaddle/Test.hs",

33− "src/Language/Javascript/JSaddle/Types.hs",

53+ "src/Language/Javascript/JSaddle/Types.hs",

34− "src/Language/Javascript/JSaddle/Value.hs" ]

54+ "src/Language/Javascript/JSaddle/Value.hs" ]