56022c3 · jsaddle · git.iko.soy

git.iko.soy/jsaddle

on master help sign in

Lazy evaluation and batching of commands.

56022c3Hamish Mackenzie10 years ago

data/jsaddle.js+82−88

compare with master

unifiedsplit

@@ -36,102 +36,96 @@ var connect = function() {

36 case "SetPropertyAtIndex":

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

38 break;

39+ case "EvaluateScript":

40+ var n = d.contents[1];

41+ jsaddle_values.set(n, eval(d.contents[0]));

42+ break;

43+ case "StringToValue":

44+ var n = d.contents[1];

45+ jsaddle_values.set(n, d.contents[0]);

46+ break;

47+ case "GetPropertyByName":

48+ var n = d.contents[2];

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

50+ break;

51+ case "GetPropertyAtIndex":

52+ var n = d.contents[2];

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

54+ break;

55+ case "NumberToValue":

56+ var n = d.contents[1];

57+ jsaddle_values.set(n, d.contents[0]);

58+ break;

59+ case "NewEmptyObject":

60+ var n = d.contents;

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

62+ break;

63+ case "NewCallback":

64+ var nFunction = d.contents;

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

66+ var nThis = ++jsaddle_index;

67+ jsaddle_values.set(nThis, this);

68+ var args = [];

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

70+ var nArg = ++jsaddle_index;

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

72+ args[i] = nArg;

73+ }

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

75+ });

76+ break;

77+ case "CallAsFunction":

78+ var n = d.contents[3];

79+ jsaddle_values.set(n,

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

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

82+ break;

83+ case "CallAsConstructor":

84+ var n = d.contents[2];

85+ var r;

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

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

88+ switch(a.length) {

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

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

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

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

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

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

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

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

97+ default:

98+ var ret;

99+ var temp = function() {

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

101+ };

102+ temp.prototype = f.prototype;

103+ var i = new temp();

104+ if(ret instanceof Object)

105+ r = ret;

106+ else {

107+ i.constructor = f;

108+ r = i;

109+ }

110+ }

111+ jsaddle_values.set(n, r);

112+ break;

113+ case "NewArray":

114+ var n = d.contents[1];

115+ jsaddle_values.set(n, d.contents[0].map(function(v){return jsaddle_values.get(v);}));

116+ break;

117+ default:

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

119+ return;

39 }

120 }

40 }

121 }

41 var d = batch[1];

122 var d = batch[1];

42 switch (d.tag) {

123 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":

124 case "ValueToString":

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

125 var val = jsaddle_values.get(d.contents);

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

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

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

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

52 break;

128 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":

129 case "ValueToBool":

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

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

137 break;

131 break;

@@ -172,7 +166,7 @@ var connect = function() {

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

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

173 break;

167 break;

174 case "Sync":

168 case "Sync":

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

169+ ws.send(JSON.stringify({"tag": "SyncResult", "contents": []}));

176 break;

170 break;

177 default:

171 default:

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

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

src/Language/Javascript/JSaddle/Evaluate.hs+3−5

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

20 eval

21) where

23−import Language.Javascript.JSaddle.Types (JSVal)

23+import Language.Javascript.JSaddle.Types (Result(..), JSVal)

24#ifdef ghcjs_HOST_OS

25import GHCJS.Types (nullRef)

26import GHCJS.Marshal.Pure (pFromJSVal)

@@ -29,7 +29,7 @@ import Language.Javascript.JSaddle.Types (JSString)

29import Language.Javascript.JSaddle.Native

30 (wrapJSVal, withJSString)

31import Language.Javascript.JSaddle.WebSockets

32− (Command(..), Result(..), sendCommand)

32+ (AsyncCommand(..), Result(..), sendLazyCommand)

33#endif

34import Language.Javascript.JSaddle.Classes

35 (ToJSString(..))

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

58#else

59eval script = do

60 let rscript = toJSString script

61− withJSString rscript $ \script' -> do

61+ withJSString rscript $ sendLazyCommand . EvaluateScript

62− EvaluateScriptResult result <- sendCommand $ EvaluateScript script'

63− wrapJSVal result

64#endif

62#endif

src/Language/Javascript/JSaddle/Object.hs+10−20

@@ -108,10 +108,9 @@ import Control.Monad (liftM)

108import Data.Coerce (coerce)

109#else

110import Language.Javascript.JSaddle.Native

111− (wrapJSVal, wrapJSString, withJSVals,

111+ (wrapJSString, withJSVals, withObject)

112− withObject)

113import Language.Javascript.JSaddle.WebSockets

112import Language.Javascript.JSaddle.WebSockets

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

113+ (Command(..), AsyncCommand(..), Result(..), sendCommand, sendLazyCommand)

115#endif

114#endif

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

115import Language.Javascript.JSaddle.Value (valToObject)

117import Language.Javascript.JSaddle.Classes

116import Language.Javascript.JSaddle.Classes

@@ -128,7 +127,7 @@ import Data.Text (Text)

128-- $setup

127-- $setup

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

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

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

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

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

130+-- >>> import Language.Javascript.JSaddle.Value (val, valToText, JSNull(..), deRefVal)

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

131-- >>> import Language.Javascript.JSaddle.String (strToText)

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

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

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

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

@@ -269,7 +268,7 @@ jsgf name = global # name

269--

268--

270-- > jsg0 name = jsgf name ()

269-- > jsg0 name = jsgf name ()

271--

270--

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

271+-- >>> testJSaddle $ jsg0 "globalFunc" >>= valToText

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

272-- TypeError:...undefine...

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

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

275jsg0 name = jsgf name ()

274jsg0 name = jsgf name ()

@@ -404,9 +403,7 @@ obj :: JSM Object

404#ifdef ghcjs_HOST_OS

403#ifdef ghcjs_HOST_OS

405obj = liftIO Object.create

404obj = liftIO Object.create

406#else

405#else

407−obj = do

406+obj = Object <$> sendLazyCommand NewEmptyObject

408− NewEmptyObjectResult result <- sendCommand NewEmptyObject

409− Object <$> wrapJSVal result

410#endif

407#endif

411

408

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

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

@@ -414,7 +411,7 @@ obj = do

414--

411--

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

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

416-- undefined

413-- undefined

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

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

418-- Hello

415-- Hello

419-- undefined

416-- undefined

420fun :: JSCallAsFunction -> JSCallAsFunction

417fun :: JSCallAsFunction -> JSCallAsFunction

@@ -442,8 +439,7 @@ foreign import javascript unsafe "$r = function () { $1(this, arguments); }"

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

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

443#else

440#else

444function f = do

441function f = do

445− NewCallbackResult result <- sendCommand NewCallback

442+ obj <- Object <$> sendLazyCommand NewCallback

446− obj <- Object <$> wrapJSVal result

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

443 asks addCallback >>= \add -> liftIO $ add obj f

448 return $ Function () obj

444 return $ Function () obj

449#endif

445#endif

@@ -488,9 +484,7 @@ array args = do

488#else

484#else

489array args = do

485array args = do

490 rargs <- makeArgs args

486 rargs <- makeArgs args

491− withJSVals rargs $ \rargs' -> do

487+ withJSVals rargs $ \rargs' -> Object <$> sendLazyCommand (NewArray rargs')

492− NewArrayResult result <- sendCommand $ NewArray rargs'

493− Object <$> wrapJSVal result

494#endif

488#endif

495

489

496-- Make an array out of various lists

490-- Make an array out of various lists

@@ -570,9 +564,7 @@ objCallAsFunction f this args = do

570 rargs <- makeArgs args

564 rargs <- makeArgs args

571 withObject f $ \rfunction ->

565 withObject f $ \rfunction ->

572 withObject this $ \rthis ->

566 withObject this $ \rthis ->

573− withJSVals rargs $ \rargs' -> do

574− CallAsFunctionResult result <- sendCommand $ CallAsFunction rfunction rthis rargs'

567+ withJSVals rargs $ sendLazyCommand . CallAsFunction rfunction rthis

575− wrapJSVal result

576#endif

568#endif

577

569

578-- | Call a JavaScript object as a constructor. Consider using 'new'.

570-- | Call a JavaScript object as a constructor. Consider using 'new'.

@@ -620,9 +612,7 @@ foreign import javascript unsafe "\

620objCallAsConstructor f args = do

612objCallAsConstructor f args = do

621 rargs <- makeArgs args

613 rargs <- makeArgs args

622 withObject f $ \rfunction ->

614 withObject f $ \rfunction ->

623− withJSVals rargs $ \rargs' -> do

624− CallAsConstructorResult result <- sendCommand $ CallAsConstructor rfunction rargs'

615+ withJSVals rargs $ sendLazyCommand . CallAsConstructor rfunction

625− wrapJSVal result

626#endif

616#endif

627

617

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

618-- >>> testJSaddle $ strictEqual nullObject (eval "null")

src/Language/Javascript/JSaddle/Properties.hs+3−7

@@ -39,7 +39,7 @@ import Language.Javascript.JSaddle.Types (JSString)

39import Language.Javascript.JSaddle.Native

40 (wrapJSVal, withObject, withJSString, withToJSVal)

41import Language.Javascript.JSaddle.WebSockets

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

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

43#endif

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

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

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

59objGetPropertyByName this name = do

60 let name' = toJSString name

61 withObject this $ \rthis ->

62− withJSString name' $ \rname -> do

62+ withJSString name' $ sendLazyCommand . GetPropertyByName rthis

63− GetPropertyByNameResult result <- sendCommand $ GetPropertyByName rthis rname

64− wrapJSVal result

65#endif

63#endif

67-- | Get a property value given the object and the index of the property.

65-- | Get a property value given the object and the index of the property.

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

74 js_tryIndex :: Index -> Object -> MutableJSArray -> IO JSVal

72 js_tryIndex :: Index -> Object -> MutableJSArray -> IO JSVal

75#else

73#else

76objGetPropertyAtIndex this index =

74objGetPropertyAtIndex this index =

77− withObject this $ \rthis -> do

75+ withObject this $ \rthis -> sendLazyCommand $ GetPropertyAtIndex rthis index

78− GetPropertyAtIndexResult result <- sendCommand $ GetPropertyAtIndex rthis index

79− wrapJSVal result

80#endif

76#endif

82-- | Set a property value given the object and the name of the property.

78-- | Set a property value given the object and the name of the property.

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

@@ -45,20 +45,23 @@ import JavaScript.Array (MutableJSArray)

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

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

47#else

48+import Data.Int (Int64)

48import Data.Text (Text)

49import Data.Text (Text)

49import Data.Aeson

50import Data.Aeson

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

51 (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..))

51import GHC.Generics (Generic)

52import GHC.Generics (Generic)

53+import Control.Concurrent.STM.TVar (TVar)

52#endif

54#endif

54#ifdef ghcjs_HOST_OS

56#ifdef ghcjs_HOST_OS

55type JSContextRef = ()

57type JSContextRef = ()

56type Index = Int

58type Index = Int

57#else

59#else

60+type JSRef = Int64

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

61+newtype JSValueReceived = JSValueReceived JSRef deriving(Show, ToJSON, FromJSON)

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

62+newtype JSValueForSend = JSValueForSend JSRef deriving(Show, ToJSON, FromJSON)

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

63+newtype JSVal = JSVal JSRef deriving(Show, ToJSON, FromJSON)

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

64+newtype MutableJSArray = MutableJSArray JSRef deriving(Show, ToJSON, FromJSON)

62type Index = Int

65type Index = Int

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

66newtype JSObjectForSend = JSObjectForSend JSValueForSend deriving(Show, ToJSON, FromJSON)

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

67newtype Object = Object JSVal deriving(Show, ToJSON, FromJSON)

@@ -70,6 +73,16 @@ newtype Nullable a = Nullable a

70data AsyncCommand = FreeRef JSValueForSend

73data AsyncCommand = FreeRef JSValueForSend

71 | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend

74 | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend

72 | SetPropertyAtIndex JSObjectForSend Index JSValueForSend

75 | SetPropertyAtIndex JSObjectForSend Index JSValueForSend

76+ | StringToValue JSStringForSend JSValueForSend

77+ | NumberToValue Double JSValueForSend

78+ | GetPropertyByName JSObjectForSend JSStringForSend JSValueForSend

79+ | GetPropertyAtIndex JSObjectForSend Index JSValueForSend

80+ | CallAsFunction JSObjectForSend JSObjectForSend [JSValueForSend] JSValueForSend

81+ | CallAsConstructor JSObjectForSend [JSValueForSend] JSValueForSend

82+ | NewEmptyObject JSValueForSend

83+ | NewCallback JSValueForSend

84+ | NewArray [JSValueForSend] JSValueForSend

85+ | EvaluateScript JSStringForSend JSValueForSend

73 deriving (Show, Generic)

86 deriving (Show, Generic)

75instance ToJSON AsyncCommand where

88instance ToJSON AsyncCommand where

@@ -84,19 +97,9 @@ data Command = DeRefVal JSValueForSend

84 | ValueToJSON JSValueForSend

97 | ValueToJSON JSValueForSend

85 | IsNull JSValueForSend

98 | IsNull JSValueForSend

86 | IsUndefined JSValueForSend

99 | IsUndefined JSValueForSend

87− | NumberToValue Double

88− | StringToValue JSStringForSend

89 | StrictEqual JSValueForSend JSValueForSend

100 | StrictEqual JSValueForSend JSValueForSend

90 | InstanceOf JSValueForSend JSObjectForSend

101 | 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

102 | PropertyNames JSObjectForSend

99− | EvaluateScript JSStringForSend

100 | Sync

103 | Sync

101 deriving (Show, Generic)

104 deriving (Show, Generic)

102

105

@@ -113,27 +116,17 @@ instance ToJSON Batch where

113

116

114instance FromJSON Batch

117instance FromJSON Batch

115

118

116−data Result = DeRefValResult Int Text

119+data Result = DeRefValResult JSRef Text

117 | ValueToBoolResult Bool

120 | ValueToBoolResult Bool

118 | ValueToNumberResult Double

121 | ValueToNumberResult Double

119 | ValueToStringResult JSStringReceived

122 | ValueToStringResult JSStringReceived

120 | ValueToJSONResult JSStringReceived

123 | ValueToJSONResult JSStringReceived

121 | IsNullResult Bool

124 | IsNullResult Bool

122 | IsUndefinedResult Bool

125 | IsUndefinedResult Bool

123− | NumberToValueResult JSValueReceived

124− | StringToValueResult JSValueReceived

125 | StrictEqualResult Bool

126 | StrictEqualResult Bool

126 | InstanceOfResult Bool

127 | 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]

128 | Callback JSValueReceived JSValueReceived [JSValueReceived]

134− | NewArrayResult JSValueReceived

135 | PropertyNamesResult [JSStringReceived]

129 | PropertyNamesResult [JSStringReceived]

136− | EvaluateScriptResult JSValueReceived

137 | ThrowJSValue JSValueReceived

130 | ThrowJSValue JSValueReceived

138 | ProtocolError Text

131 | ProtocolError Text

139 | SyncResult

132 | SyncResult

@@ -149,6 +142,7 @@ data JSContextRef = JSContextRef {

149 , doSendAsyncCommand :: AsyncCommand -> IO ()

142 , doSendAsyncCommand :: AsyncCommand -> IO ()

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

143 , addCallback :: Object -> JSCallAsFunction -> IO ()

151 , freeCallback :: Object -> IO ()

144 , freeCallback :: Object -> IO ()

145+ , nextRef :: TVar JSRef

152}

146}

153

147

154#endif

148#endif

src/Language/Javascript/JSaddle/Value.hs+5−7

@@ -87,7 +87,9 @@ import Language.Javascript.JSaddle.Exception (rethrow)

87import Language.Javascript.JSaddle.Native

88 (wrapJSString, withJSVal, withObject, withJSString,

89 withToJSVal, wrapJSVal)

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

90+import Language.Javascript.JSaddle.WebSockets

91+ (Command(..), AsyncCommand(..), Result(..), sendCommand,

92+ sendLazyCommand)

91#endif

93#endif

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

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

93import Data.Text (Text)

95import Data.Text (Text)

@@ -442,9 +444,7 @@ valMakeNumber :: Double -> JSM JSVal

442#ifdef ghcjs_HOST_OS

444#ifdef ghcjs_HOST_OS

443valMakeNumber n = liftIO $ GHCJS.toJSVal n

445valMakeNumber n = liftIO $ GHCJS.toJSVal n

444#else

446#else

445−valMakeNumber n = do

447+valMakeNumber = sendLazyCommand . NumberToValue

446− NumberToValueResult result <- sendCommand (NumberToValue n)

447− wrapJSVal result

448#endif

449

450-- | Makes a JavaScript number

@@ -490,9 +490,7 @@ valMakeString :: JSString -> JSM JSVal

490valMakeString = return . pToJSVal

491#else

492valMakeString s =

493− withJSString s $ \s' -> do

493+ withJSString s $ sendLazyCommand . StringToValue

494− StringToValueResult result <- sendCommand $ StringToValue s'

495− wrapJSVal result

496#endif

494#endif

497

495

498-- | Makes a JavaScript string

496-- | Makes a JavaScript string

src/Language/Javascript/JSaddle/WebSockets.hs+16−2

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

20 , Command(..)

21 , Result(..)

22 , sendCommand

23+ , sendLazyCommand

23 , sendAsyncCommand

24 , sendAsyncCommand

24) where

25) where

@@ -32,7 +33,7 @@ import Control.Concurrent (forkIO)

32import Control.Concurrent.STM.TChan

33import Control.Concurrent.STM.TChan

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

34 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)

34import Control.Concurrent.STM.TVar

35import Control.Concurrent.STM.TVar

35− (readTVarIO, modifyTVar, newTVarIO)

36+ (writeTVar, readTVar, readTVarIO, modifyTVar, newTVarIO)

36import Control.Concurrent.MVar

37import Control.Concurrent.MVar

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

38 (MVar, MVar, putMVar, takeMVar, newEmptyMVar)

@@ -50,7 +51,7 @@ import Network.Wai.Handler.WebSockets (websocketsOr)

51import Language.Javascript.JSaddle.Types

52import Language.Javascript.JSaddle.Types

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

53 (Command(..), AsyncCommand(..), Result(..), JSContextRef(..), JSVal(..),

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

54+ Object(..), JSValueReceived(..), JSM, Batch(..), JSValueForSend(..))

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

55import Language.Javascript.JSaddle.Exception (JSException(..))

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

56import Language.Javascript.JSaddle.Monad (runJSaddle)

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

57import Language.Javascript.JSaddle.Native (wrapJSVal)

@@ -67,6 +68,17 @@ sendCommand cmd = do

67 s <- asks doSendCommand

68 s <- asks doSendCommand

68 liftIO $ s cmd

69 liftIO $ s cmd

71+sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal

72+sendLazyCommand cmd = do

73+ nextRefTVar <- asks nextRef

74+ n <- liftIO . atomically $ do

75+ n <- subtract 1 <$> readTVar nextRefTVar

76+ writeTVar nextRefTVar n

77+ return n

78+ s <- asks doSendAsyncCommand

79+ liftIO $ s (cmd $ JSValueForSend n)

80+ wrapJSVal (JSValueReceived n)

81+

70sendAsyncCommand :: AsyncCommand -> JSM ()

82sendAsyncCommand :: AsyncCommand -> JSM ()

71sendAsyncCommand cmd = do

83sendAsyncCommand cmd = do

72 s <- asks doSendAsyncCommand

84 s <- asks doSendAsyncCommand

@@ -81,6 +93,7 @@ jsaddleOr opts entryPoint = websocketsOr opts wsApp

81 recvChan <- newTChanIO

93 recvChan <- newTChanIO

82 commandChan <- newTChanIO

94 commandChan <- newTChanIO

83 callbacks <- newTVarIO M.empty

95 callbacks <- newTVarIO M.empty

96+ nextRef <- newTVarIO 0

84 let ctx = JSContextRef {

97 let ctx = JSContextRef {

85 doSendCommand = \cmd -> do

98 doSendCommand = \cmd -> do

86 result <- newEmptyMVar

99 result <- newEmptyMVar

@@ -91,6 +104,7 @@ jsaddleOr opts entryPoint = websocketsOr opts wsApp

91 , doSendAsyncCommand = atomically . writeTChan commandChan . Left

104 , doSendAsyncCommand = atomically . writeTChan commandChan . Left

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

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

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

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

107+ , nextRef = nextRef

94 }

108 }

95 forkIO . forever $

109 forkIO . forever $

96 receiveDataMessage conn >>= \case

110 receiveDataMessage conn >>= \case