master..6c28fa8 · jsaddle

.travis.yml+24−40

since splitsnapshots

unifiedsplit

@@ -1,47 +1,31 @@

1−language: nix

1+sudo: required

2−nix: 2.2.2

2+services:

3+ - docker

3

4

4−jobs:

5+cache:

5− include:

6+ directories:

6− - stage: Build

7+ - .cabal

7− env: OS=linux GHCVER=ghc865

8+ - .ghc

8− - stage: Build

9− env: OS=linux GHCVER=ghc881

10− - env: OS=macos GHCVER=ghc865

11− os: osx

12− # Fix OSX, see https://travis-ci.community/t/cannot-use-nix-support-on-osx/2927

13− language: generic

14− before_install:

15− - curl https://nixos.org/nix/install | sh

16− - source /Users/travis/.nix-profile/etc/profile.d/nix.sh

17− - env: OS=macos GHCVER=ghc881

18− os: osx

19− # Fix OSX, see https://travis-ci.community/t/cannot-use-nix-support-on-osx/2927

20− language: generic

21− before_install:

22− - curl https://nixos.org/nix/install | sh

23− - source /Users/travis/.nix-profile/etc/profile.d/nix.sh

24

9

25−install:

10+env:

26−- sudo mkdir -p /etc/nix

11+# - CABALVER=1.24 GHCVER=7.10.3 OSVER=xenial

27−- echo "substituters = https://cache.nixos.org https://hydra.iohk.io" | sudo tee -a /etc/nix/nix.conf > /dev/null

12+ - CABALVER=1.24 GHCVER=8.0.1 OSVER=xenial

28−- echo "trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=" | sudo tee -a /etc/nix/nix.conf > /dev/null

13+ - CABALVER=1.24 GHCVER=8.0.2 OSVER=xenial

14+ - CABALVER=1.24 GHCVER=7.10.3 OSVER=trusty

15+ - CABALVER=1.24 GHCVER=8.0.1 OSVER=trusty

16+ - CABALVER=1.24 GHCVER=8.0.2 OSVER=trusty

29

17

30−script:

18+before_install:

31−- nix-build --argstr haskellCompiler $GHCVER -A hsPkgs.jsaddle.components.library

19+ - docker build -t ghc -f travis/$OSVER.Dockerfile travis

32−- nix-build --argstr haskellCompiler $GHCVER -A hsPkgs.jsaddle-warp.components.library

33−- nix-build --argstr haskellCompiler $GHCVER -A hsPkgs.jsaddle-clib.components.library

34−- |

35− if [ "$OS" == "macos" ]; then

36− nix-build --argstr haskellCompiler $GHCVER -A hsPkgs.jsaddle-wkwebview.components.library

37− fi

38−# TODO try to find how to get working webkitgtk with nix on macOS

39−- |

40− if [ "$OS" != "macos" ]; then

41− nix-build --argstr haskellCompiler $GHCVER -A hsPkgs.jsaddle-webkit2gtk.components.library

42− fi

43

20

21+script:

22+ - docker run -v `pwd`:/build ghc

23+ sh -x -c "

24+ apt-get install -y cabal-install-$CABALVER ghc-$GHCVER &&

25+ export PATH=\$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/alex/3.1.7/bin:/opt/happy/1.19.5/bin:\$PATH &&

26+ ./travis/build.sh"

44notifications:

27notifications:

45 irc:

28 irc:

46 channels: "irc.freenode.net#ghcjs"

29 channels: "irc.freenode.net#ghcjs"

30+ skip_join: true

47− email: true

31+ email: true

README.md+14−34

@@ -13,8 +13,7 @@ import Control.Monad.IO.Class (MonadIO(..))

13import Control.Concurrent.MVar (takeMVar, putMVar, newEmptyMVar)

14import Control.Lens ((^.))

15import Language.Javascript.JSaddle

16− (jsg, js, js1, jss, fun, valToNumber, syncPoint)

16+ (run, jsg, js, js1, jss, fun, valToNumber, syncPoint)

17−import Language.Javascript.JSaddle.Warp (run)

18

17

19main = run 3709 $ do

18main = run 3709 $ do

20 doc <- jsg "document"

19 doc <- jsg "document"

@@ -80,7 +79,7 @@ main = run 3708 $ do

80 appendChild newParagraph text

79 appendChild newParagraph text

81 appendChild body (Just newParagraph)

80 appendChild body (Just newParagraph)

82 return ()

81 return ()

83−

82+

84 -- Make an exit button

83 -- Make an exit button

85 exitMVar <- liftIO newEmptyMVar

84 exitMVar <- liftIO newEmptyMVar

86 Just exit <- createElement doc (Just "span")

85 Just exit <- createElement doc (Just "span")

@@ -103,31 +102,15 @@ When compiled with GHC this code will run a Warp web server you can connect to a

103

102

104## How does it work on GHC

103## How does it work on GHC

105

104

106−There are a number of different JSaddle runners to choose from

105+As of version 0.5 it runs a small warp server that provides [index.html](https://github.com/ghcjs/jsaddle/blob/master/data/index.html) and

107−

106+[jsaddle.js](https://github.com/ghcjs/jsaddle/blob/master/data/jsaddle.js). The [jsaddle.js](https://github.com/ghcjs/jsaddle/blob/master/data/jsaddle.js) code connects to the server using WebSockets and processes JSON commands from the server and sends the result back over the same WebSocket.

108−* [jsaddle-warp](https://hackage.haskell.org/package/jsaddle-warp) - runs JSaddle in a warp server with a web browser connected to it.

109−* [jsaddle-webkit2gtk](https://hackage.haskell.org/package/jsaddle-webkit2gtk) - runs JSaddle in a WebKitGTK window.

110−* [jsaddle-wkwebview](https://hackage.haskell.org/package/jsaddle-wkwebview) - runs JSaddle in a WKWebView on iOS or macOS.

111−* [jsaddle-clib](https://hackage.haskell.org/package/jsaddle-clib) - C interface used to run JSaddle on Android using JNI.

112−

113−In all of these cases a web control or browser of some sort is used. An

114−[HTML file](./jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs#L24)

115−and a [small JavaScript command interpreter](./jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs#L340)

116−are loaded into it. Then the native GHC compiled JSaddle code runs. In order to interact with the browser

117−it sends commands to the JavaScript command interpreter. The mechanism for sending the commands differs

118−for the different runners, but they are always combined into batches and encoded in JSON.

119

107

120−Haskell callbacks from JavaScript are supported by sending JSON back from the command interpreter. These can be synchronous (blocking the

108+### Why use WebSockets?

121−JavaScript thread until the Haskell callback completes) or asynchronous.

122

109

123−### Why use a JavaScript command interpreter?

124−

125−Older versions of JSaddle relied on the WebKit1 interface to WebKitGTK and JavaScriptCore that is only supported in older versions of

126−WebKitGTK. With the newer WebKit2 interface this level of access is only available to WebKit Extensions.

110+Older versions relied on WebKitGTK and JavaScriptCore, but in WekKit2 the interface JSaddle used is only available to WebKit Extensions

111+so most of the benefits of this interface are lost (extensions are not in the same process as Gtk and RPC would have been needed).

127−The general advice for people migrating from WebKit1 to WebKit2 seems to be to use JavaScript.

112+The general advice for people migrating from WebKit1 to WebKit2 seems to be to use JavaScript. There is an interface in WebKit2

128−

113+to send JavaScript code from the host application, but it does not seem to provide any advantages over the WebSockets approach.

129−As a bonus we have been able to support a number of different platforms with the JavaScript command interpreter and it should

130−be easy to support more in the future.

131

114

132### JSVal

115### JSVal

133

116

@@ -137,8 +120,8 @@ The first five keys `[0..4]` are

137these values. Both the Haskell code and `jsaddle.js` can allocate new `JSVal` keys. The Haskell code allocates negative

120these values. Both the Haskell code and `jsaddle.js` can allocate new `JSVal` keys. The Haskell code allocates negative

138keys and `jsaddle.js` allocates positive keys to avoid clashing.

121keys and `jsaddle.js` allocates positive keys to avoid clashing.

139

122

140−The haskell code will not know the value to go with the key, but it will include it in commands to the server

123+The haskell code will not know the value of the to go with the key, but it will include it in commands to the server

141−that are sort of "hey call this function and put the result in the map with this key"). This allows for the

124+that are sort of "hey call this function and and put the result in the map with this key"). This allows for the

142lazy execution of the JSaddle code.

125lazy execution of the JSaddle code.

143

126

144A finalizer is added on the Haskell code and an asynchronous `FreeJSVal` command is automatically sent to `jsaddle.js`

127A finalizer is added on the Haskell code and an asynchronous `FreeJSVal` command is automatically sent to `jsaddle.js`

@@ -146,7 +129,7 @@ when the JSVal is no longer reachable. The `jsaddle.js` code then deletes the k

146

129

147### JSStrings

130### JSStrings

148

131

149−These are haskell `Text` type and so reside on the native side of the WebSocket. If you want to avoid transferring large string values over the WebSocket use `toJSVal` to convert it to a `JSVal`.

132+These are haskell `Text` type and so reside on the native side of the WebSocket. If you want to make avoid transferring large string values over the WebSocket use `toJSVal` to conevt it to a `JSVal`.

150

133

151### Lazy Execution

134### Lazy Execution

152

135

@@ -178,7 +161,7 @@ force all the pending asynchronous commands to be executed.

178It uses a handful of JS FFI calls to execute JavaScript functions indirectly. This indirection will be small compared to the overhead of the WebSockets approach (used when JSaddle is compiled with GHC), but it will be significant compared to hand crafted JS FFI calls.

161It uses a handful of JS FFI calls to execute JavaScript functions indirectly. This indirection will be small compared to the overhead of the WebSockets approach (used when JSaddle is compiled with GHC), but it will be significant compared to hand crafted JS FFI calls.

179

162

180For the best performance you may want to write both JS FFI and JSaddle wrappers

163For the best performance you may want to write both JS FFI and JSaddle wrappers

181−for your JavaScript code. This is the approach taken by `ghcjs-dom`.

164+For your JavaScript code. This is the approach taken by recent versions of `ghcjs-dom`.

182

165

183For instance here is `getElementById` from the `ghcjs-dom-jsffi` (used by `ghcjs-dom` when compiled with GHCJS)

166For instance here is `getElementById` from the `ghcjs-dom-jsffi` (used by `ghcjs-dom` when compiled with GHCJS)

184

167

@@ -213,10 +196,7 @@ JSaddle does not support exceptions well. When compiled with GHCJS an exception

213at the point the exception is thrown.

196at the point the exception is thrown.

214

197

215When using GHC the Haskell executions will probably continue for a while before the exception is received at all by the Haskell code

198When using GHC the Haskell executions will probably continue for a while before the exception is received at all by the Haskell code

216−(because the lazy execution of the JS code). The exception will be thrown when the next synchronous command is executed.

199+(because the lazy execution of the JS code). The exception will be thrown when the the next synchronous command is executed.

217When it reaches the synchronous command a haskell type JSException will be thrown (this may not be the thread that initiated the

200When it reaches the synchronous command a haskell type JSException will be thrown (this may not be the thread that initiated the

218command that caused the exception). You can use `syncPoint` and `syncAfter` to force the exception to be thrown.

201command that caused the exception). You can use `syncPoint` and `syncAfter` to force the exception to be thrown.

219There are `JSM` versions of `catch` and `bracket` that also include a `syncPoint` call.

202There are `JSM` versions of `catch` and `bracket` that also include a `syncPoint` call.

220−

221−## Building with Stack

222−The `jsaddle-webkit2gtk` runner can be difficult to build with stack. See [this issue](https://github.com/ghcjs/jsaddle/issues/38#issuecomment-331392995) if you get stuck.

cabal.project+35−3

@@ -1,10 +1,42 @@

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

2+

1packages:

3packages:

2 jsaddle/

4 jsaddle/

3 jsaddle-warp/

5 jsaddle-warp/

4 jsaddle-wkwebview/

6 jsaddle-wkwebview/

7+-- jsaddle-webkitgtk/

5 jsaddle-webkit2gtk/

8 jsaddle-webkit2gtk/

6 jsaddle-clib/

9 jsaddle-clib/

7

10

8−constraints: haskell-gi-overloading == 0.0

11+package gi-atk

9−

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

10−allow-newer: websockets:random, splitmix:time, *:time, *:unix, *:process, stm:base

13+package gi-cairo

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

15+package gi-gdk

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

17+package gi-gdkpixbuf

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

19+package gi-gio

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

21+package gi-glib

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

23+package gi-gobject

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

25+package gi-gtk

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

27+package gi-gtk-hs

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

29+package gi-gtkosxapplication

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

31+package gi-gtksource

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

33+package gi-javascriptcore

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

35+package gi-pango

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

37+package gi-soup

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

39+package gi-webkit

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

41+package gi-webkit2

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

default.nixnew file+8

@@ -0,0 +1,8 @@

1+haskellPackages: {

2+ jsaddle = haskellPackages.callPackage ./jsaddle {};

3+ jsaddle-warp = haskellPackages.callPackage ./jsaddle-warp {};

4+ jsaddle-wkwebview = haskellPackages.callPackage ./jsaddle-wkwebview {};

5+ jsaddle-webkit2gtk = haskellPackages.callPackage ./jsaddle-webkit2gtk {};

6+ jsaddle-webkitgtk = haskellPackages.callPackage ./jsaddle-webkitgtk {};

7+ jsaddle-clib = haskellPackages.callPackage ./jsaddle-clib {};

8+}

jsaddle-clib/default.nixnew file+9

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

1+{ mkDerivation, aeson, base, bytestring, data-default, jsaddle, stdenv, text }:

2+mkDerivation {

3+ pname = "jsaddle-clib";

4+ version = "0.9.0.0";

5+ src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;

6+ libraryHaskellDepends = [ aeson base bytestring data-default jsaddle text ];

7+ description = "Interface for JavaScript that works with GHCJS and GHC";

8+ license = stdenv.lib.licenses.mit;

9+}

jsaddle-clib/jsaddle-clib.cabal+3−4

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

1name: jsaddle-clib

2−version: 0.9.8.0

2+version: 0.9.0.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

@@ -21,9 +21,8 @@ library

21 Language.Javascript.JSaddle.CLib

22 Language.Javascript.JSaddle.CLib.Internal

23 build-depends:

24− aeson >=0.8.0.2 && <1.6,

24+ aeson >=0.8.0.2 && <1.3,

25 base <5,

26− base-compat >=0.9.0 && <0.12,

27 bytestring >=0.10.6.0 && <0.11,

26 bytestring >=0.10.6.0 && <0.11,

28 jsaddle >= 0.9.0.0 && <0.10,

27 jsaddle >= 0.9.0.0 && <0.10,

29 data-default,

28 data-default,

@@ -33,7 +32,7 @@ library

33 Include-dirs: cbits/include

32 Include-dirs: cbits/include

34 Includes: jsaddle.h

33 Includes: jsaddle.h

35 Install-includes: jsaddle.h

34 Install-includes: jsaddle.h

36− ghc-options: -ferror-spans -Wall

35+ ghc-options: -ferror-spans -Wall -Werror

37 if impl(ghcjs)

36 if impl(ghcjs)

38 hs-source-dirs: src-ghcjs

37 hs-source-dirs: src-ghcjs

39 else

38 else

jsaddle-clib/src-ghc/Language/Javascript/JSaddle/CLib.hs+1−3

@@ -8,9 +8,6 @@ module Language.Javascript.JSaddle.CLib

8 , appConfigToAppCallbacks

9 ) where

10

11−import Prelude ()

12−import Prelude.Compat

13−

14import Control.Monad (void)

11import Control.Monad (void)

15import Control.Concurrent (forkIO)

12import Control.Concurrent (forkIO)

16

13

@@ -19,6 +16,7 @@ import Data.ByteString (useAsCString, packCString)

19import Data.ByteString.Char8 (unpack)

16import Data.ByteString.Char8 (unpack)

20import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)

17import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)

21import Data.Default (def, Default)

18import Data.Default (def, Default)

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

22import Data.Text (Text)

20import Data.Text (Text)

23import qualified Data.Text.Encoding as T

21import qualified Data.Text.Encoding as T

24

22

jsaddle-warp/default.nixnew file+26

@@ -0,0 +1,26 @@

1+{ mkDerivation, aeson, base, bytestring, containers, deepseq

2+, doctest, filepath, ghc-prim, http-types, jsaddle, lens, primitive

3+, process, QuickCheck, ref-tf, stdenv, stm, text, time

4+, transformers, wai, wai-websockets, warp, websockets, osx_sdk

5+, darwin, webdriver, phantomjs, ghc

6+}:

7+mkDerivation {

8+ pname = "jsaddle-warp";

9+ version = "0.9.0.0";

10+ src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;

11+ libraryHaskellDepends = [

12+ aeson base containers http-types jsaddle stm text time transformers

13+ wai wai-websockets warp websockets

14+ ] ++ (if ghc.isGhcjs or false then [

15+ ] else if stdenv.isDarwin then [

16+# osx_sdk darwin.libobjc darwin.apple_sdk.libs.xpc

17+ ] else [

18+ ]);

19+ testHaskellDepends = [

20+ base bytestring deepseq doctest filepath ghc-prim jsaddle lens

21+ primitive process QuickCheck ref-tf webdriver phantomjs

22+ ];

23+ testTarget = "--test-option=${jsaddle.src}";

24+ description = "Interface for JavaScript that works with GHCJS and GHC";

25+ license = stdenv.lib.licenses.mit;

26+}

jsaddle-warp/jsaddle-warp.cabal+15−20

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

1name: jsaddle-warp

2−version: 0.9.8.0

2+version: 0.9.1.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

@@ -10,7 +10,7 @@ description:

10 This package provides an EDSL for calling JavaScript that

11 can be used both from GHCJS and GHC. When using GHC

12 the application is run using Warp and WebSockets to

13− drive a small JavaScript helper.

13+ drive a small JavaScipt helper.

14category: Web, Javascript

15author: Hamish Mackenzie

16

@@ -24,23 +24,22 @@ library

24 if !impl(ghcjs -any)

25 exposed-modules:

26 Language.Javascript.JSaddle.WebSockets

27− other-modules:

28− Language.Javascript.JSaddle.WebSockets.Compat

29 build-depends:

27 build-depends:

30− aeson >=0.8.0.2 && <1.6,

28+ aeson >=0.8.0.2 && <1.3,

31 bytestring >=0.10.6.0 && <0.11,

29 bytestring >=0.10.6.0 && <0.11,

32− containers >=0.5.6.2 && <0.7,

30+ containers >=0.5.6.2 && <0.6,

33− foreign-store >=0.2 && <0.3,

34− http-types >=0.8.6 && <0.13,

31+ http-types >=0.8.6 && <0.10,

35− jsaddle >=0.9.4.0 && <0.10,

32+ jsaddle >=0.9.0.0 && <0.10,

36− stm >=2.4.4 && <2.6,

33+ stm >=2.4.4 && <2.5,

37 text >=1.2.1.3 && <1.3,

34 text >=1.2.1.3 && <1.3,

38− time >=1.5.0.1 && <1.11,

35+ time >=1.5.0.1 && <1.8,

39 transformers >=0.4.2.0 && <0.6,

36 transformers >=0.4.2.0 && <0.6,

37+ uuid >=1.3.13 && <1.4,

38+ uuid-types >=1.0.3 && <1.1,

40 wai >=3.0.3.0 && <3.3,

39 wai >=3.0.3.0 && <3.3,

41 wai-websockets >=3.0.0.6 && <3.1,

40 wai-websockets >=3.0.0.6 && <3.1,

42− warp >=3.1.2 && <3.4,

41+ warp >=3.1.2 && <3.3,

43− websockets >=0.9.5.0 && <0.13

42+ websockets >=0.9.5.0 && <0.11

44 exposed-modules:

43 exposed-modules:

45 Language.Javascript.JSaddle.Warp

44 Language.Javascript.JSaddle.Warp

46 build-depends:

45 build-depends:

@@ -59,10 +58,8 @@ test-suite test-tool

59 bytestring -any,

58 bytestring -any,

60 containers -any,

59 containers -any,

61 deepseq -any,

60 deepseq -any,

62− doctest >=0.10.1 && <0.19,

61+ doctest >=0.10.1 && <0.12,

63− exceptions -any,

64 filepath >=1.4.0.0 && <1.5,

62 filepath >=1.4.0.0 && <1.5,

65− foreign-store -any,

66 ghc-prim -any,

63 ghc-prim -any,

67 http-types -any,

64 http-types -any,

68 jsaddle -any,

65 jsaddle -any,

@@ -71,17 +68,15 @@ test-suite test-tool

71 network -any,

68 network -any,

72 ref-tf -any,

69 ref-tf -any,

73 primitive -any,

70 primitive -any,

74− process >=1.2.3.0 && <1.7,

71+ process >=1.2.3.0 && <1.5,

75− random -any,

76 stm -any,

72 stm -any,

77 text -any,

73 text -any,

78 time -any,

74 time -any,

79 transformers -any,

75 transformers -any,

80− unliftio-core -any,

81 wai -any,

76 wai -any,

82 wai-websockets -any,

77 wai-websockets -any,

83 warp -any,

78 warp -any,

84− webdriver >=0.8.4 && <0.10,

79+ webdriver >=0.8.4 && <0.9,

85 websockets -any

80 websockets -any

86 type: exitcode-stdio-1.0

81 type: exitcode-stdio-1.0

87 main-is: DocTest.hs

82 main-is: DocTest.hs

jsaddle-warp/src/Language/Javascript/JSaddle/Test.hs+12−13

@@ -17,22 +17,21 @@ module Language.Javascript.JSaddle.Test (

17 , listWindowProperties

18) where

19

20−import Prelude hiding((!!), catch)

21import Control.Applicative

20import Control.Applicative

22−import Control.Concurrent (threadDelay, forkIO, ThreadId)

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

23−import Control.Concurrent.MVar

24− (tryTakeMVar, putMVar, takeMVar, newEmptyMVar, MVar)

25−import Control.Lens.Getter ((^.))

26−import Control.Monad (forever, forM)

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

28import Control.Monad.Trans.Reader (runReaderT)

22import Control.Monad.Trans.Reader (runReaderT)

23+import Language.Javascript.JSaddle

24+import qualified Data.Text as T

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

26+import Control.Monad (forever, forM)

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

29import Data.Monoid ((<>))

28import Data.Monoid ((<>))

29+import Control.Concurrent.MVar

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

31+import System.IO.Unsafe (unsafePerformIO)

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

30import Data.Text (Text)

33import Data.Text (Text)

31−import qualified Data.Text as T

32−import Language.Javascript.JSaddle

33import Language.Javascript.JSaddle.Warp (run)

34import Language.Javascript.JSaddle.Warp (run)

34−import System.IO.Unsafe (unsafePerformIO)

35−import System.Timeout (timeout)

36

35

37context :: MVar JSContextRef

36context :: MVar JSContextRef

38context = unsafePerformIO newEmptyMVar

37context = unsafePerformIO newEmptyMVar

@@ -53,12 +52,12 @@ startServer =

53

52

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

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

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

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

56−testJSaddle f = timeout 10000000 (do

55+testJSaddle f = do

57 startServer

56 startServer

58 c <- takeMVar context

57 c <- takeMVar context

59 runReaderT (unJSM $ (f >>= valToText >>= liftIO . putStrLn . T.unpack)

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

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

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

61− putMVar context c) >>= maybe (putStrLn "testJSaddle timed out") return

60+ putMVar context c

62

61

63debugLog :: String -> IO ()

62debugLog :: String -> IO ()

64debugLog _ = return ()

63debugLog _ = return ()

jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs+50−207

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

1{-# LANGUAGE LambdaCase #-}

2{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−{-# LANGUAGE RecursiveDo #-}

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

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

6--

4--

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

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

@@ -19,98 +17,66 @@ module Language.Javascript.JSaddle.WebSockets (

19 jsaddleOr

17 jsaddleOr

20 , jsaddleApp

18 , jsaddleApp

21 , jsaddleWithAppOr

19 , jsaddleWithAppOr

22− , jsaddleAppWithJs

23− , jsaddleAppWithJsOr

24 , jsaddleAppPartial

20 , jsaddleAppPartial

25− , jsaddleJs

26− , jsaddleJs'

27− , debug

28− , debugOr

29− , debugWrapper

30) where

21) where

31

22

32−import Control.Monad (when, void, forever)

23+import Control.Monad (forever)

33−import Control.Concurrent (killThread, forkIO, threadDelay)

24+import Control.Concurrent (forkIO, threadDelay)

34−import Control.Exception (handle, AsyncException, throwIO, fromException, finally)

25+import Control.Exception (handle, AsyncException, throwIO, fromException)

35

26

36import Data.Monoid ((<>))

27import Data.Monoid ((<>))

37import Data.Aeson (encode, decode)

28import Data.Aeson (encode, decode)

38

29

39import Network.Wai

30import Network.Wai

40− (Middleware, lazyRequestBody, Application, Request, Response,

31+ (requestBody, Application, Request, Response, ResponseReceived)

41− ResponseReceived)

42import Network.WebSockets

32import Network.WebSockets

43− (defaultConnectionOptions, ConnectionOptions(..), sendTextData,

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

44− receiveDataMessage, acceptRequest, ServerApp, sendPing)

34+ acceptRequest, ServerApp, sendPing)

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

45import Network.Wai.Handler.WebSockets (websocketsOr)

36import Network.Wai.Handler.WebSockets (websocketsOr)

46−import Network.HTTP.Types (Status(..))

47

37

48−import Language.Javascript.JSaddle.Types (JSM(..), JSContextRef(..))

38+import Language.Javascript.JSaddle.Types (JSM(..))

49import qualified Network.Wai as W

39import qualified Network.Wai as W

50− (responseLBS, requestMethod, pathInfo, modifyResponse, responseStatus)

40+ (responseLBS, requestMethod, pathInfo)

51import qualified Data.Text as T (pack)

41import qualified Data.Text as T (pack)

52import qualified Network.HTTP.Types as H

42import qualified Network.HTTP.Types as H

53 (status403, status200)

43 (status403, status200)

54−import Language.Javascript.JSaddle.Run (syncPoint, runJavaScript)

44+import Language.Javascript.JSaddle.Run (runJavaScript)

55import Language.Javascript.JSaddle.Run.Files (indexHtml, runBatch, ghcjsHelpers, initState)

45import Language.Javascript.JSaddle.Run.Files (indexHtml, runBatch, ghcjsHelpers, initState)

56−import Language.Javascript.JSaddle.Debug

57− (removeContext, addContext)

58import Data.Maybe (fromMaybe)

46import Data.Maybe (fromMaybe)

59import qualified Data.Map as M (empty, insert, lookup)

47import qualified Data.Map as M (empty, insert, lookup)

60−import Data.IORef

61− (readIORef, newIORef, atomicModifyIORef')

48+import Data.IORef (readIORef, newIORef, atomicModifyIORef')

62−import Data.ByteString.Lazy (ByteString)

49+import Data.ByteString.Lazy (fromStrict, ByteString)

63−import qualified Data.ByteString.Lazy as LBS

50+import Data.Text (Text)

64− (toStrict, stripPrefix)

51+import Data.UUID.Types (toText)

65−import Control.Concurrent.MVar

52+import Data.UUID.V4 (nextRandom)

66− (tryTakeMVar, MVar, tryPutMVar, modifyMVar_, putMVar, takeMVar,

67− readMVar, newMVar, newEmptyMVar, modifyMVar)

68−import Network.Wai.Handler.Warp

69− (defaultSettings, setTimeout, setPort, runSettings)

70−import Foreign.Store (readStore, lookupStore, writeStore, Store(..))

71−import Language.Javascript.JSaddle (askJSM)

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

73−

74−import Language.Javascript.JSaddle.WebSockets.Compat (getTextMessageByteString)

75−import qualified Data.Text.Encoding as T (decodeUtf8)

76

53

77jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application

54jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application

78jsaddleOr opts entryPoint otherApp = do

55jsaddleOr opts entryPoint otherApp = do

79 syncHandlers <- newIORef M.empty

56 syncHandlers <- newIORef M.empty

80− asyncHandlers <- newIORef M.empty

81 let wsApp :: ServerApp

57 let wsApp :: ServerApp

82 wsApp pending_conn = do

58 wsApp pending_conn = do

83 conn <- acceptRequest pending_conn

59 conn <- acceptRequest pending_conn

84− initMsg <- receiveDataMessage conn

85− case getTextMessageByteString initMsg of

86− Just "" -> do

87− rec (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) $ do

60+ (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) entryPoint

88− syncKey <- T.pack . show . contextId <$> askJSM

89− liftIO $ atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))

90− liftIO $ atomicModifyIORef' asyncHandlers (\m -> (M.insert syncKey processResult m, ()))

91− liftIO $ sendTextData conn (encode syncKey)

92− entryPoint

93− start

94− waitTillClosed conn

95− Just syncKey ->

96− M.lookup (T.decodeUtf8 $ LBS.toStrict syncKey) <$> readIORef syncHandlers >>= \case

97− Nothing -> error "jsaddle missing sync message handler"

98− Just processResult ->

99− forever $

61+ _ <- forkIO . forever $

100− receiveDataMessage conn >>= \msg -> case getTextMessageByteString msg of

62+ receiveDataMessage conn >>= \case

101− Just t ->

63+ (WS.Text t) ->

102− case decode t of

64+ case decode t of

103− Nothing -> error $ "jsaddle Results decode failed : " <> show t

65+ Nothing -> error $ "jsaddle Results decode failed : " <> show t

104− Just r -> processResult r

66+ Just r -> processResult r

105− _ -> error "jsaddle WebSocket unexpected binary data"

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

106− _ -> error "jsaddle WebSocket unexpected binary data"

68+ syncKey <- toText <$> nextRandom

69+ atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))

70+ sendTextData conn (encode syncKey)

71+ start

72+ waitTillClosed conn

107

73

108 -- Based on Network.WebSocket.forkPingThread

74 -- Based on Network.WebSocket.forkPingThread

109 waitTillClosed conn = ignore `handle` go 1

75 waitTillClosed conn = ignore `handle` go 1

110 where

76 where

111 go :: Int -> IO ()

77 go :: Int -> IO ()

112 go i = do

78 go i = do

113− threadDelay (10 * 1000 * 1000)

79+ threadDelay (1 * 1000 * 1000)

114 sendPing conn (T.pack $ show i)

80 sendPing conn (T.pack $ show i)

115 go (i + 1)

81 go (i + 1)

116

82

@@ -121,8 +87,8 @@ jsaddleOr opts entryPoint otherApp = do

121 syncHandler :: Application

87 syncHandler :: Application

122 syncHandler req sendResponse = case (W.requestMethod req, W.pathInfo req) of

88 syncHandler req sendResponse = case (W.requestMethod req, W.pathInfo req) of

123 ("POST", ["sync", syncKey]) -> do

89 ("POST", ["sync", syncKey]) -> do

124− body <- lazyRequestBody req

90+ body <- requestBody req

125− case decode body of

91+ case decode $ fromStrict body of

126 Nothing -> error $ "jsaddle sync message decode failed : " <> show body

92 Nothing -> error $ "jsaddle sync message decode failed : " <> show body

127 Just result ->

93 Just result ->

128 M.lookup syncKey <$> readIORef syncHandlers >>= \case

94 M.lookup syncKey <$> readIORef syncHandlers >>= \case

@@ -130,27 +96,15 @@ jsaddleOr opts entryPoint otherApp = do

130 Just handler -> do

96 Just handler -> do

131 next <- encode <$> handler result

97 next <- encode <$> handler result

132 sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] next

98 sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] next

133− (method, _) -> (catch404 otherApp) req sendResponse

99+ _ -> otherApp req sendResponse

134− where catch404 = W.modifyResponse $ \resp ->

135− case (method, W.responseStatus resp) of

136− ("GET", Status 404 _) -> indexResponse

137− _ -> resp

138 return $ websocketsOr opts wsApp syncHandler

100 return $ websocketsOr opts wsApp syncHandler

139

101

140

102

141jsaddleApp :: Application

103jsaddleApp :: Application

142−jsaddleApp = jsaddleAppWithJs $ jsaddleJs False

143−

144−jsaddleAppWithJs :: ByteString -> Application

145−jsaddleAppWithJs js req sendResponse =

104+jsaddleApp req sendResponse =

146− jsaddleAppWithJsOr js

105+ fromMaybe

147− (\_ _ -> sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")

106+ (sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")

148− req sendResponse

149−

150−jsaddleAppWithJsOr :: ByteString -> Application -> Application

151−jsaddleAppWithJsOr js otherApp req sendResponse =

152− fromMaybe (otherApp req sendResponse)

153− (jsaddleAppPartialWithJs js req sendResponse)

107+ (jsaddleAppPartial req sendResponse)

154

108

155jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application

109jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application

156jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->

110jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->

@@ -158,82 +112,46 @@ jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sen

158 (jsaddleAppPartial req sendResponse))

112 (jsaddleAppPartial req sendResponse))

159

113

160jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)

114jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)

161−jsaddleAppPartial = jsaddleAppPartialWithJs $ jsaddleJs False

162−

163−indexResponse :: Response

164−indexResponse = W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml

165−

166−jsaddleAppPartialWithJs :: ByteString -> Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)

167−jsaddleAppPartialWithJs js req sendResponse = case (W.requestMethod req, W.pathInfo req) of

115+jsaddleAppPartial req sendResponse = case (W.requestMethod req, W.pathInfo req) of

168− ("GET", []) -> Just $ sendResponse indexResponse

116+ ("GET", []) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml

169− ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] js

117+ ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs

170 _ -> Nothing

118 _ -> Nothing

171

119

172−jsaddleJs :: Bool -> ByteString

173−jsaddleJs = jsaddleJs' Nothing

174−

175-- Use this to generate this string for embedding

120-- Use this to generate this string for embedding

176-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy

121-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy

177−jsaddleJs' :: Maybe ByteString -> Bool -> ByteString

122+jsaddleJs :: ByteString

178−jsaddleJs' jsaddleUri refreshOnLoad = "\

123+jsaddleJs = "\

179− \if(typeof global !== \"undefined\" && typeof require === \"function\") {\n\

124+ \if(typeof global !== \"undefined\") {\n\

180 \ global.window = global;\n\

125 \ global.window = global;\n\

181 \ global.WebSocket = require('ws');\n\

126 \ global.WebSocket = require('ws');\n\

182 \}\n\

127 \}\n\

183 \\n\

128 \\n\

184 \var connect = function() {\n\

129 \var connect = function() {\n\

185− \ var wsaddress = "

186− <> maybe "window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\")"

130+ \ var wsaddress = window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\");\n\

187− (\ s -> "\"ws" <> s <> "\"")

188− (jsaddleUri >>= LBS.stripPrefix "http")

189− <> ";\n\

190 \\n\

131 \\n\

191− \ var ws0 = new WebSocket(wsaddress);\n\

132+ \ var ws = new WebSocket(wsaddress);\n\

192 \ var syncKey = \"\";\n\

133 \ var syncKey = \"\";\n\

193 \\n\

134 \\n\

194− \ ws0.onopen = function(e) {\n\

135+ \ ws.onopen = function(e) {\n\

195− \ ws0.send(\"\");\n\

196− \ var initialResults = [];\n\

197− \ var ws = {send: function(m) {initialResults.push(m);}};\n\

198− \ " <> initState <> "\n\

136+ \ " <> initState <> "\

199 \\n\

137 \\n\

200− \ ws0.onmessage = function(e) {\n\

138+ \ ws.onmessage = function(e) {\n\

201 \ var batch = JSON.parse(e.data);\n\

139 \ var batch = JSON.parse(e.data);\n\

202− \ if(inCallback > 0) {\n\

203− \ asyncBatch = batch;\n\

204− \ return;\n\

205− \ }\n\

206 \ if(typeof batch === \"string\") {\n\

140 \ if(typeof batch === \"string\") {\n\

207 \ syncKey = batch;\n\

141 \ syncKey = batch;\n\

208− \ var ws1 = new WebSocket(wsaddress);\n\

209− \ ws1.onopen = function(e) {\n\

210− \ ws1.send(syncKey);\n\

211− \ initialResults.forEach(function(m){ ws1.send(m); });\n\

212− \ initialResults = null;\n\

213− \ ws = ws1;\n\

214− \ }\n" <>

215− (if refreshOnLoad

216− then " var xhr = new XMLHttpRequest();\n\

217− \ xhr.open('POST', '/reload/'+syncKey, true);\n\

218− \ xhr.onreadystatechange = function() {\n\

219− \ if(xhr.readyState === XMLHttpRequest.DONE && xhr.status === 200)\n\

220− \ setTimeout(function(){window.location.reload();}, 100);\n\

221− \ };\n\

222− \ xhr.send();\n"

223− else "") <>

224− " return;\n\

142+ \ return;\n\

225 \ }\n\

143 \ }\n\

226 \\n\

144 \\n\

227 \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));")

145 \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));")

228 (Just (\a -> "(function(){\n\

146 (Just (\a -> "(function(){\n\

229 \ var xhr = new XMLHttpRequest();\n\

147 \ var xhr = new XMLHttpRequest();\n\

230− \ xhr.open('POST', '" <> fromMaybe "" jsaddleUri <> "/sync/'+syncKey, false);\n\

148+ \ xhr.open('POST', '/sync/'+syncKey, false);\n\

231 \ xhr.setRequestHeader(\"Content-type\", \"application/json\");\n\

149 \ xhr.setRequestHeader(\"Content-type\", \"application/json\");\n\

232 \ xhr.send(JSON.stringify(" <> a <> "));\n\

150 \ xhr.send(JSON.stringify(" <> a <> "));\n\

233 \ return JSON.parse(xhr.response);})()")) <> "\

151 \ return JSON.parse(xhr.response);})()")) <> "\

234 \ };\n\

152 \ };\n\

235 \ };\n\

153 \ };\n\

236− \ ws0.onerror = function() {\n\

154+ \ ws.onerror = function() {\n\

237 \ setTimeout(connect, 1000);\n\

155 \ setTimeout(connect, 1000);\n\

238 \ };\n\

156 \ };\n\

239 \}\n\

157 \}\n\

@@ -242,78 +160,3 @@ jsaddleJs' jsaddleUri refreshOnLoad = "\

242 \connect();\n\

160 \connect();\n\

243 \"

161 \"

244

162

245−-- | Start or restart the server.

246−-- To run this as part of every :reload use

247−-- > :def! reload (const $ return "::reload\nLanguage.Javascript.JSaddle.Warp.debug 3708 SomeMainModule.someMainFunction")

248−debug :: Int -> JSM () -> IO ()

249−debug port f = do

250− debugWrapper $ \withRefresh registerContext ->

251− runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<

252− jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJs $ jsaddleJs True)

253− putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"

254−

255−debugOr :: Int -> JSM () -> Application -> IO ()

256−debugOr port f b = do

257− debugWrapper $ \withRefresh registerContext ->

258− runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<

259− jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJsOr (jsaddleJs True) b)

260− putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"

261−

262−refreshMiddleware :: ((Response -> IO ResponseReceived) -> IO ResponseReceived) -> Middleware

263−refreshMiddleware refresh otherApp req sendResponse = case (W.requestMethod req, W.pathInfo req) of

264− ("POST", ["reload", _syncKey]) -> refresh sendResponse

265− _ -> otherApp req sendResponse

266−

267−debugWrapper :: (Middleware -> JSM () -> IO ()) -> IO ()

268−debugWrapper run = do

269− reloadMVar <- newEmptyMVar

270− reloadDoneMVars <- newMVar []

271− contexts <- newMVar []

272− let refresh sendResponse = do

273− reloadDone <- newEmptyMVar

274− modifyMVar_ reloadDoneMVars (return . (reloadDone:))

275− readMVar reloadMVar

276− r <- sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] ("reload" :: ByteString)

277− putMVar reloadDone ()

278− return r

279− start :: Int -> IO (IO Int)

280− start expectedConnections = do

281− serverDone <- newEmptyMVar

282− ready <- newEmptyMVar

283− let registerContext :: JSM ()

284− registerContext = do

285− uuid <- contextId <$> askJSM

286− browsersConnected <- liftIO $ modifyMVar contexts (\ctxs -> return (uuid:ctxs, length ctxs + 1))

287− addContext

288− when (browsersConnected == expectedConnections) . void . liftIO $ tryPutMVar ready ()

289− thread <- forkIO $

290− finally (run (refreshMiddleware refresh) registerContext)

291− (putMVar serverDone ())

292− _ <- forkIO $ threadDelay 10000000 >> void (tryPutMVar ready ())

293− when (expectedConnections /= 0) $ takeMVar ready

294− return $ do

295− putMVar reloadMVar ()

296− ctxs <- takeMVar contexts

297− mapM_ removeContext ctxs

298− takeMVar reloadDoneMVars >>= mapM_ takeMVar

299− tryTakeMVar serverDone >>= \case

300− Nothing -> do

301− killThread thread

302− takeMVar serverDone

303− Just _ -> return ()

304− return $ length ctxs

305− restarter :: MVar (Int -> IO (IO Int)) -> IO Int -> IO ()

306− restarter mvar stop = do

307− start' <- takeMVar mvar

308− n <- stop

309− start' n >>= restarter mvar

310− lookupStore storeId >>= \case

311− Nothing -> do

312− restartMVar <- newMVar start

313− void . forkIO $ restarter restartMVar (return 0)

314− void $ writeStore (Store storeId) restartMVar

315− Just shutdownStore -> do

316− restartMVar :: MVar (Int -> IO (IO Int)) <- readStore shutdownStore

317− void $ tryTakeMVar restartMVar

318− putMVar restartMVar start

319− where storeId = 354

jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets/Compat.hsdeleted−29

@@ -1,29 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−-----------------------------------------------------------------------------

3−--

4−-- Module : Language.Javascript.JSaddle.WebSockets.Compat

5−-- Copyright : (c) Hamish Mackenzie

6−-- License : MIT

7−--

8−-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>

9−--

10−-- | This module is necessary to harmonize various versions of the websockets

11−-- package; we can't do this CPP inline in

12−-- Language.Javascript.JSaddle.WebSockets because that module uses multi-line

13−-- strings, which are incompatible with CPP

14−--

15−-----------------------------------------------------------------------------

16−module Language.Javascript.JSaddle.WebSockets.Compat where

17−

18−import Data.ByteString.Lazy (ByteString)

19−import qualified Network.WebSockets as WS (DataMessage(..))

20−

21−getTextMessageByteString :: WS.DataMessage -> Maybe ByteString

22−getTextMessageByteString msg = case msg of

23−#if MIN_VERSION_websockets(0,11,0)

24− (WS.Text t _) ->

25−#else

26− (WS.Text t) ->

27−#endif

28− Just t

29− _ -> Nothing

jsaddle-warp/tests/DocTest.hs+7−20

@@ -11,17 +11,18 @@ import System.IO (stderr, BufferMode(..), stdout, hSetBuffering)

11import System.FilePath ((</>))

12import System.Exit (exitFailure, exitWith, ExitCode(..))

13import System.Process (readProcess, system)

14−import Control.Concurrent

14+import Control.Concurrent (forkIO)

15− (takeMVar, newEmptyMVar, forkIO, threadDelay, putMVar)

16import Control.Monad (void)

15import Control.Monad (void)

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

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

18import Data.Monoid ((<>))

17import Data.Monoid ((<>))

19import System.Environment (getArgs)

18import System.Environment (getArgs)

19+import Language.Javascript.JSaddle.Run.Files (jsaddleJs)

20+import qualified Data.ByteString.Lazy.Char8 as BS (unpack)

20import Test.WebDriver (runSession, defaultConfig, openPage, closeSession)

21import Test.WebDriver (runSession, defaultConfig, openPage, closeSession)

21

22

22main :: IO ()

23main :: IO ()

23main = do

24main = do

24− putStrLn "Testing JSaddle"

25+ putStrLn "Hello"

25 jsaddlePath <- getArgs >>= \case

26 jsaddlePath <- getArgs >>= \case

26 [arg] -> return arg

27 [arg] -> return arg

27 _ -> do

28 _ -> do

@@ -29,18 +30,14 @@ main = do

29 exitFailure

30 exitFailure

30 hSetBuffering stdout LineBuffering

31 hSetBuffering stdout LineBuffering

31 hSetBuffering stderr LineBuffering

32 hSetBuffering stderr LineBuffering

32− putStrLn "Checking for phantomjs"

33 node <- system "phantomjs --version" >>= \case

34 ExitSuccess -> return ()

35 e -> do

36 putStrLn "phantomjs not found"

37 exitWith e

38− putStrLn "Starting phantomjs"

39− forkIO . void $ readProcess "phantomjs" ["--webdriver=4444"] "" >>= putStr

38+ forkIO . void $ readProcess "phantomjs" ["--webdriver=4444"] (BS.unpack jsaddleJs) >>= putStr

40− threadDelay 5000000

39+ runSession defaultConfig $ do

41− putStrLn "Running Tests"

40+ openPage "http://localhost:3709"

42− done <- newEmptyMVar

43− forkIO $ do

44 liftIO $ doctest [

41 liftIO $ doctest [

45 "-hide-all-packages",

42 "-hide-all-packages",

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

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

@@ -64,10 +61,6 @@ main = do

64 "-package=ref-tf-" ++ VERSION_ref_tf,

61 "-package=ref-tf-" ++ VERSION_ref_tf,

65 "-package=deepseq-" ++ VERSION_deepseq,

62 "-package=deepseq-" ++ VERSION_deepseq,

66 "-package=ghc-prim-" ++ VERSION_ghc_prim,

63 "-package=ghc-prim-" ++ VERSION_ghc_prim,

67− "-package=exceptions-" ++ VERSION_exceptions,

68− "-package=unliftio-core-" ++ VERSION_unliftio_core,

69− "-package=random-" ++ VERSION_random,

70− "-package=foreign-store-" ++ VERSION_foreign_store,

71 "-i" <> "src",

64 "-i" <> "src",

72 "-i" <> "src-ghc",

65 "-i" <> "src-ghc",

73 "src/Language/Javascript/JSaddle/Test.hs",

66 "src/Language/Javascript/JSaddle/Test.hs",

@@ -90,7 +83,6 @@ main = do

90 jsaddlePath </> "src/Language/Javascript/JSaddle/Arguments.hs",

83 jsaddlePath </> "src/Language/Javascript/JSaddle/Arguments.hs",

91 jsaddlePath </> "src/Language/Javascript/JSaddle/Classes.hs",

84 jsaddlePath </> "src/Language/Javascript/JSaddle/Classes.hs",

92 jsaddlePath </> "src/Language/Javascript/JSaddle/Classes/Internal.hs",

85 jsaddlePath </> "src/Language/Javascript/JSaddle/Classes/Internal.hs",

93− jsaddlePath </> "src/Language/Javascript/JSaddle/Debug.hs",

94 jsaddlePath </> "src/Language/Javascript/JSaddle/Evaluate.hs",

86 jsaddlePath </> "src/Language/Javascript/JSaddle/Evaluate.hs",

95 jsaddlePath </> "src/Language/Javascript/JSaddle/Exception.hs",

87 jsaddlePath </> "src/Language/Javascript/JSaddle/Exception.hs",

96 jsaddlePath </> "src/Language/Javascript/JSaddle/Monad.hs",

88 jsaddlePath </> "src/Language/Javascript/JSaddle/Monad.hs",

@@ -104,9 +96,4 @@ main = do

104 jsaddlePath </> "src/Language/Javascript/JSaddle/String.hs",

96 jsaddlePath </> "src/Language/Javascript/JSaddle/String.hs",

105 jsaddlePath </> "src/Language/Javascript/JSaddle/Types.hs",

97 jsaddlePath </> "src/Language/Javascript/JSaddle/Types.hs",

106 jsaddlePath </> "src/Language/Javascript/JSaddle/Value.hs" ]

98 jsaddlePath </> "src/Language/Javascript/JSaddle/Value.hs" ]

107− putMVar done ()

108− threadDelay 5000000

109− runSession defaultConfig $ do

110− openPage "http://127.0.0.1:3709"

111− liftIO $ takeMVar done

112 closeSession

99 closeSession

jsaddle-webkit2gtk/default.nixnew file+16

@@ -0,0 +1,16 @@

1+{ mkDerivation, aeson, base, bytestring, directory, gi-gio, gi-glib

2+, gi-gtk, gi-javascriptcore, gi-webkit2, haskell-gi-base, jsaddle

3+, stdenv, text, unix, webkit2gtk3-javascriptcore

4+}:

5+mkDerivation {

6+ pname = "jsaddle-webkit2gtk";

7+ version = "0.9.0.0";

8+ src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;

9+ libraryHaskellDepends = [

10+ aeson base bytestring directory gi-gio gi-glib gi-gtk

11+ gi-javascriptcore gi-webkit2 haskell-gi-base jsaddle text unix

12+ webkit2gtk3-javascriptcore

13+ ];

14+ description = "Interface for JavaScript that works with GHCJS and GHC";

15+ license = stdenv.lib.licenses.mit;

16+}

jsaddle-webkit2gtk/jsaddle-webkit2gtk.cabal+9−10

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

1name: jsaddle-webkit2gtk

2−version: 0.9.8.0

2+version: 0.9.0.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

@@ -26,18 +26,17 @@ library

26 base <5

27 if !impl(ghcjs -any)

28 build-depends:

29− aeson >=0.8.0.2 && <1.6,

29+ aeson >=0.8.0.2 && <1.3,

30 base <5,

31 bytestring >=0.10.6.0 && <0.11,

32 directory >=1.0.0.2 && <1.4,

33− gi-glib >=2.0.14 && <2.1,

33+ gi-glib >=2.0.6 && <2.1,

34− gi-gio >=2.0.14 && <2.1,

34+ gi-gio >=2.0.6 && <2.1,

35− gi-gtk >=3.0.17 && <3.1,

35+ gi-gtk >=3.0.6 && <3.1,

36− gi-webkit2 >=4.0.14 && <4.1,

36+ gi-webkit2 >=4.0.6 && <4.1,

37− gi-javascriptcore >=4.0.14 && <4.1,

37+ gi-javascriptcore >=4.0.6 && <4.1,

38− haskell-gi-base >=0.20 && <0.26,

38+ haskell-gi-base >=0.20 && <0.21,

39− haskell-gi-overloading >=0.0 && < 2.0,

40− jsaddle >=0.9.4.0 && <0.10,

39+ jsaddle >=0.9.0.0 && <0.10,

41 text >=1.2.1.3 && <1.3,

40 text >=1.2.1.3 && <1.3,

42 webkit2gtk3-javascriptcore >=0.14.0.0 && <0.15

41 webkit2gtk3-javascriptcore >=0.14.0.0 && <0.15

43 if !os(windows)

42 if !os(windows)

jsaddle-webkit2gtk/src/Language/Javascript/JSaddle/WebKitGTK.hs+40−17

@@ -43,24 +43,29 @@ import Data.Monoid ((<>))

43import Data.ByteString.Lazy (toStrict, fromStrict)

44import qualified Data.ByteString.Lazy as LB (ByteString)

45import Data.Aeson (encode, decode)

46+import Data.Text (Text)

46import qualified Data.Text as T (pack)

47import qualified Data.Text as T (pack)

48+import Data.Text.Foreign (fromPtr)

47import Data.Text.Encoding (decodeUtf8, encodeUtf8)

49import Data.Text.Encoding (decodeUtf8, encodeUtf8)

48

50

51+import Foreign.Ptr (castPtr, nullPtr)

52+

49import Data.GI.Base.BasicTypes (GObject)

53import Data.GI.Base.BasicTypes (GObject)

50import Data.GI.Base.Signals

54import Data.GI.Base.Signals

51 (connectSignalFunPtr, SignalConnectMode(..), SignalConnectMode,

55 (connectSignalFunPtr, SignalConnectMode(..), SignalConnectMode,

52 SignalHandlerId)

56 SignalHandlerId)

57+import Data.GI.Base.ManagedPtr (withManagedPtr)

53

58

54import GI.GLib (timeoutAdd, idleAdd, pattern PRIORITY_HIGH, pattern PRIORITY_DEFAULT)

59import GI.GLib (timeoutAdd, idleAdd, pattern PRIORITY_HIGH, pattern PRIORITY_DEFAULT)

55import qualified GI.Gtk as Gtk (main, init)

60import qualified GI.Gtk as Gtk (main, init)

56import GI.Gtk

61import GI.Gtk

57 (windowSetPosition, windowSetDefaultSize, windowNew,

62 (windowSetPosition, windowSetDefaultSize, windowNew,

58− scrolledWindowNew, Adjustment, containerAdd,

63+ scrolledWindowNew, noAdjustment, containerAdd,

59 WindowType(..), WindowPosition(..), widgetDestroy,

64 WindowType(..), WindowPosition(..), widgetDestroy,

60 widgetGetToplevel, widgetShowAll, onWidgetDestroy,

65 widgetGetToplevel, widgetShowAll, onWidgetDestroy,

61 mainQuit)

66 mainQuit)

62−import GI.Gio (Cancellable)

67+import GI.Gio (noCancellable)

63−import GI.JavaScriptCore (valueToString)

68+import GI.JavaScriptCore (Value(..), GlobalContext(..))

64import GI.WebKit2

69import GI.WebKit2

65 (scriptDialogPromptSetText, scriptDialogPromptGetDefaultText,

70 (scriptDialogPromptSetText, scriptDialogPromptGetDefaultText,

66 scriptDialogGetMessage, scriptDialogGetDialogType,

71 scriptDialogGetMessage, scriptDialogGetDialogType,

@@ -69,7 +74,7 @@ import GI.WebKit2

69 setSettingsEnableJavascript, webViewNewWithUserContentManager,

74 setSettingsEnableJavascript, webViewNewWithUserContentManager,

70 userContentManagerNew,

75 userContentManagerNew,

71 userContentManagerRegisterScriptMessageHandler,

76 userContentManagerRegisterScriptMessageHandler,

72− javascriptResultGetJsValue,

77+ javascriptResultGetValue, javascriptResultGetGlobalContext,

73 webViewGetUserContentManager,

78 webViewGetUserContentManager,

74 mk_UserContentManagerScriptMessageReceivedCallback,

79 mk_UserContentManagerScriptMessageReceivedCallback,

75 wrap_UserContentManagerScriptMessageReceivedCallback,

80 wrap_UserContentManagerScriptMessageReceivedCallback,

@@ -78,16 +83,17 @@ import GI.WebKit2

78 onWebViewLoadChanged, setSettingsEnableDeveloperExtras,

83 onWebViewLoadChanged, setSettingsEnableDeveloperExtras,

79 webViewSetSettings, webViewGetSettings, ScriptDialogType(..))

84 webViewSetSettings, webViewGetSettings, ScriptDialogType(..))

80

85

86+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

87+ (JSValueRef, JSContextRef)

88+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

89+ (jsstringgetcharactersptr, jsstringgetlength, jsstringrelease)

90+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

91+ (jsvaluetostringcopy)

92+

81import Language.Javascript.JSaddle (JSM, Results, Batch)

93import Language.Javascript.JSaddle (JSM, Results, Batch)

82import Language.Javascript.JSaddle.Run (runJavaScript)

94import Language.Javascript.JSaddle.Run (runJavaScript)

83import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)

95import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)

84

96

85−noAdjustment :: Maybe Adjustment

86−noAdjustment = Nothing

87−

88−noCancellable :: Maybe Cancellable

89−noCancellable = Nothing

90−

91quitWebView :: WebView -> IO ()

97quitWebView :: WebView -> IO ()

92quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv --TODO: Shouldn't this be postGUISync?

98quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv --TODO: Shouldn't this be postGUISync?

93 widgetDestroy w

99 widgetDestroy w

@@ -103,6 +109,21 @@ postGUIAsync :: IO () -> IO ()

103postGUIAsync action =

109postGUIAsync action =

104 void . idleAdd PRIORITY_DEFAULT $ action >> return False

110 void . idleAdd PRIORITY_DEFAULT $ action >> return False

105

111

112+withJSContextRef :: GlobalContext -> (JSContextRef -> IO a) -> IO a

113+withJSContextRef (GlobalContext ctx) f = withManagedPtr ctx (f . castPtr)

114+

115+withJSValueRef :: Value -> (JSValueRef -> IO a) -> IO a

116+withJSValueRef (Value ptr) f = withManagedPtr ptr (f . castPtr)

117+

118+valueToText :: JSContextRef -> JSValueRef -> IO Text

119+valueToText ctxRef s = do

120+ jsstring <- jsvaluetostringcopy ctxRef s nullPtr

121+ l <- jsstringgetlength jsstring

122+ p <- jsstringgetcharactersptr jsstring

123+ result <- fromPtr (castPtr p) (fromIntegral l)

124+ jsstringrelease jsstring

125+ return result

126+

106run :: JSM () -> IO ()

127run :: JSM () -> IO ()

107run main = do

128run main = do

108 _ <- Gtk.init Nothing

129 _ <- Gtk.init Nothing

@@ -127,7 +148,7 @@ run main = do

127 void . onWebViewLoadChanged webView $ \case

148 void . onWebViewLoadChanged webView $ \case

128 LoadEventFinished -> runInWebView main webView

149 LoadEventFinished -> runInWebView main webView

129 _ -> return ()

150 _ -> return ()

130− webViewLoadHtml webView "" . Just $ "file://" <> T.pack pwd <> "/index.html"

151+ webViewLoadHtml webView "" . Just $ "file://" <> T.pack pwd <> "/"

131 installQuitHandler webView

152 installQuitHandler webView

132 Gtk.main

153 Gtk.main

133

154

@@ -151,16 +172,16 @@ connectUserContentManagerScriptMessageReceived obj cb after = liftIO $ do

151 let cb' = wrap_UserContentManagerScriptMessageReceivedCallback cb

172 let cb' = wrap_UserContentManagerScriptMessageReceivedCallback cb

152 cb'' <- mk_UserContentManagerScriptMessageReceivedCallback cb'

173 cb'' <- mk_UserContentManagerScriptMessageReceivedCallback cb'

153 connectSignalFunPtr obj "script-message-received::jsaddle" cb'' after

174 connectSignalFunPtr obj "script-message-received::jsaddle" cb'' after

154−#if MIN_VERSION_haskell_gi_base(0,23,0)

155− Nothing

156−#endif

157

175

158addJSaddleHandler :: WebView -> (Results -> IO ()) -> (Results -> IO Batch) -> IO ()

176addJSaddleHandler :: WebView -> (Results -> IO ()) -> (Results -> IO Batch) -> IO ()

159addJSaddleHandler webView processResult syncResults = do

177addJSaddleHandler webView processResult syncResults = do

160 manager <- webViewGetUserContentManager webView

178 manager <- webViewGetUserContentManager webView

161 _ <- onUserContentManagerScriptMessageReceived manager $ \result -> do

179 _ <- onUserContentManagerScriptMessageReceived manager $ \result -> do

162− arg <- javascriptResultGetJsValue result

180+ ctx <- javascriptResultGetGlobalContext result

163− bs <- encodeUtf8 <$> valueToString arg

181+ arg <- javascriptResultGetValue result

182+ bs <- withJSContextRef ctx $ \ctxRef ->

183+ withJSValueRef arg $ \argRef ->

184+ encodeUtf8 <$> valueToText ctxRef argRef

164 mapM_ processResult (decode (fromStrict bs))

185 mapM_ processResult (decode (fromStrict bs))

165 _ <- onWebViewScriptDialog webView $ \dialog ->

186 _ <- onWebViewScriptDialog webView $ \dialog ->

166 scriptDialogGetDialogType dialog >>= \case

187 scriptDialogGetDialogType dialog >>= \case

@@ -185,7 +206,9 @@ jsaddleJs = ghcjsHelpers <> mconcat

185 , initState

206 , initState

186 , "\nreturn function(batch) {\n"

207 , "\nreturn function(batch) {\n"

187 , runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));\n")

208 , runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));\n")

209+ Nothing

210+ -- TODO fix https://github.com/haskell-gi/haskell-gi/issues/97 then use

188− (Just (\a -> "JSON.parse(window.prompt(\"JSaddleSync\", JSON.stringify(" <> a <> ")))"))

211+ -- (Just (\a -> "JSON.parse(window.prompt(\"JSaddleSync\", JSON.stringify(" <> a <> ")))"))

189 , "};\n"

212 , "};\n"

190 , "})()"

213 , "})()"

191 ]

214 ]

jsaddle-webkitgtk/default.nixnew file+16

@@ -0,0 +1,16 @@

1+{ mkDerivation, aeson, base, bytestring, directory, gi-glib, gi-gtk

2+, gi-javascriptcore, gi-webkit, haskell-gi-base, jsaddle, stdenv

3+, text, unix, webkitgtk3-javascriptcore

4+}:

5+mkDerivation {

6+ pname = "jsaddle-webkitgtk";

7+ version = "0.9.0.0";

8+ src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;

9+ libraryHaskellDepends = [

10+ aeson base bytestring directory gi-glib gi-gtk gi-javascriptcore

11+ gi-webkit haskell-gi-base jsaddle text unix

12+ webkitgtk3-javascriptcore

13+ ];

14+ description = "Interface for JavaScript that works with GHCJS and GHC";

15+ license = stdenv.lib.licenses.mit;

16+}

jsaddle-wkwebview/cbits-cocoa/AppDelegate.m+2−57

@@ -2,9 +2,6 @@

2#import <Cocoa/Cocoa.h>

3#import <WebKit/WebKit.h>

4

5−extern void callIO(HsStablePtr);

6−extern bool callWithCStringReturningBool(const char * _Nonnull, HsStablePtr);

7−extern void callWithCString(const char * _Nonnull, HsStablePtr);

8extern void callWithWebView(WKWebView *, HsStablePtr);

5extern void callWithWebView(WKWebView *, HsStablePtr);

9

6

10@interface AppDelegate : NSObject <NSApplicationDelegate>

7@interface AppDelegate : NSObject <NSApplicationDelegate>

@@ -14,12 +11,6 @@ extern void callWithWebView(WKWebView *, HsStablePtr);

14- (instancetype)initApp:(HsStablePtr)handler progName:(NSString *)progName;

11- (instancetype)initApp:(HsStablePtr)handler progName:(NSString *)progName;

15@end

12@end

16

13

17−HsStablePtr global_willFinishLaunchingWithOptions = 0;

18−HsStablePtr global_didFinishLaunchingWithOptions = 0;

19−HsStablePtr global_applicationUniversalLink = 0;

20−HsStablePtr global_applicationOpenFile = 0;

21−uint64_t global_developerExtrasEnabled = 1;

22−

23@implementation AppDelegate

14@implementation AppDelegate

24

15

25- (void)applicationWillTerminate:(NSNotification *)aNotification {

16- (void)applicationWillTerminate:(NSNotification *)aNotification {

@@ -40,39 +31,18 @@ uint64_t global_developerExtrasEnabled = 1;

40 return self;

31 return self;

41}

32}

42

33

43−-(BOOL)application:(NSApplication *)sender openFile:(NSString *)filename {

44− bool b = callWithCStringReturningBool([filename UTF8String], global_applicationOpenFile);

45− return b ? YES : NO;

46−}

47−

48-(void)applicationWillFinishLaunching:(NSNotification *)notification {

34-(void)applicationWillFinishLaunching:(NSNotification *)notification {

49 WKWebViewConfiguration *theConfiguration = [[WKWebViewConfiguration alloc] init];

35 WKWebViewConfiguration *theConfiguration = [[WKWebViewConfiguration alloc] init];

50− if (global_developerExtrasEnabled) {

51− [theConfiguration.preferences setValue:@YES forKey:@"developerExtrasEnabled"];

36+ [theConfiguration.preferences setValue:@YES forKey:@"developerExtrasEnabled"];

52− }

53 WKWebView *webView = [[WKWebView alloc] initWithFrame: [_window.contentView frame] configuration:theConfiguration];

37 WKWebView *webView = [[WKWebView alloc] initWithFrame: [_window.contentView frame] configuration:theConfiguration];

54 [_window setContentView:webView];

38 [_window setContentView:webView];

55 callWithWebView(webView, _handler);

39 callWithWebView(webView, _handler);

56− callIO(global_willFinishLaunchingWithOptions);

57− // Listen to URL events

58− NSAppleEventManager *manager = [NSAppleEventManager sharedAppleEventManager];

59− [manager

60− setEventHandler:self

61− andSelector:@selector(applicationUniversalLink:)

62− forEventClass:kInternetEventClass

63− andEventID:kAEGetURL];

64−}

65−

66−- (void)applicationUniversalLink:(NSAppleEventDescriptor *)event {

67− NSString *url = [[event paramDescriptorForKeyword:keyDirectObject] stringValue];

68− callWithCString([url UTF8String], global_applicationUniversalLink);

69}

40}

70

41

71-(void)applicationDidFinishLaunching:(NSNotification *)notification {

42-(void)applicationDidFinishLaunching:(NSNotification *)notification {

72 [_window orderFrontRegardless];

43 [_window orderFrontRegardless];

73 [_window center];

44 [_window center];

74 [NSApp activateIgnoringOtherApps:YES];

45 [NSApp activateIgnoringOtherApps:YES];

75− callIO(global_didFinishLaunchingWithOptions);

76}

46}

77

47

78-(BOOL) applicationShouldTerminateAfterLastWindowClosed:(NSApplication *)app {

48-(BOOL) applicationShouldTerminateAfterLastWindowClosed:(NSApplication *)app {

@@ -81,33 +51,8 @@ uint64_t global_developerExtrasEnabled = 1;

81

51

82@end

52@end

83

53

84−void runInWKWebView(HsStablePtr handler,

54+void runInWKWebView(HsStablePtr handler, const char * _Nonnull progName) {

85− const char * _Nonnull progName,

86− HsStablePtr hs_willFinishLaunchingWithOptions,

87− HsStablePtr hs_didFinishLaunchingWithOptions,

88− HsStablePtr hs_applicationDidBecomeActive,

89− HsStablePtr hs_applicationWillResignActive,

90− HsStablePtr hs_applicationDidEnterBackground,

91− HsStablePtr hs_applicationWillEnterForeground,

92− HsStablePtr hs_applicationWillTerminate,

93− HsStablePtr hs_applicationSignificantTimeChange,

94− HsStablePtr hs_applicationUniversalLink,

95− const uint64_t hs_requestAuthorizationWithOptions,

96− const uint64_t hs_requestAuthorizationOptionBadge,

97− const uint64_t hs_requestAuthorizationOptionSound,

98− const uint64_t hs_requestAuthorizationOptionAlert,

99− const uint64_t hs_requestAuthorizationOptionCarPlay,

100− const uint64_t hs_registerForRemoteNotifications,

101− HsStablePtr hs_didRegisterForRemoteNotificationsWithDeviceToken,

102− HsStablePtr hs_didFailToRegisterForRemoteNotificationsWithError,

103− const uint64_t hs_developerExtrasEnabled,

104− HsStablePtr hs_applicationOpenFile) {

105 @autoreleasepool {

55 @autoreleasepool {

106− global_willFinishLaunchingWithOptions = hs_willFinishLaunchingWithOptions;

107− global_didFinishLaunchingWithOptions = hs_didFinishLaunchingWithOptions;

108− global_applicationUniversalLink = hs_applicationUniversalLink;

109− global_applicationOpenFile = hs_applicationOpenFile;

110− global_developerExtrasEnabled = hs_developerExtrasEnabled;

111 NSApplication *application = [NSApplication sharedApplication];

56 NSApplication *application = [NSApplication sharedApplication];

112 AppDelegate *appDelegate = [[AppDelegate alloc] initApp:handler progName:[NSString stringWithCString:progName encoding:NSUTF8StringEncoding]];

57 AppDelegate *appDelegate = [[AppDelegate alloc] initApp:handler progName:[NSString stringWithCString:progName encoding:NSUTF8StringEncoding]];

113 [application setDelegate:appDelegate];

58 [application setDelegate:appDelegate];

jsaddle-wkwebview/cbits-uikit/AppDelegate.m+1−23

@@ -5,7 +5,6 @@

5

6extern void callIO(HsStablePtr);

7extern void callWithCString(const char * _Nonnull, HsStablePtr);

8−extern void callWithCIntCString(int n, const char * _Nonnull, HsStablePtr);

9

8

10@interface AppDelegate ()

9@interface AppDelegate ()

11

10

@@ -21,7 +20,6 @@ HsStablePtr global_applicationWillEnterForeground = 0;

21HsStablePtr global_applicationWillTerminate = 0;

20HsStablePtr global_applicationWillTerminate = 0;

22HsStablePtr global_applicationSignificantTimeChange = 0;

21HsStablePtr global_applicationSignificantTimeChange = 0;

23HsStablePtr global_applicationUniversalLink = 0;

22HsStablePtr global_applicationUniversalLink = 0;

24−HsStablePtr global_applicationDidReceiveRemoteNotification = 0;

25uint64_t global_requestAuthorizationWithOptions = 0;

23uint64_t global_requestAuthorizationWithOptions = 0;

26uint64_t global_requestAuthorizationOptionBadge = 0;

24uint64_t global_requestAuthorizationOptionBadge = 0;

27uint64_t global_requestAuthorizationOptionSound = 0;

25uint64_t global_requestAuthorizationOptionSound = 0;

@@ -111,23 +109,6 @@ HsStablePtr global_didFailToRegisterForRemoteNotificationsWithError = 0;

111 callWithCString([deviceTokenString UTF8String], global_didRegisterForRemoteNotificationsWithDeviceToken);

109 callWithCString([deviceTokenString UTF8String], global_didRegisterForRemoteNotificationsWithDeviceToken);

112}

110}

113

111

114−- (void)application:(UIApplication *)application didReceiveRemoteNotification:(NSDictionary *)userInfo fetchCompletionHandler:(void (^)(UIBackgroundFetchResult result))completionHandler {

115− // Sent when the application receives remote notifications in the foreground or background

116− // TODO Allow a configurable CString -> IO () to be passed into AppDelegateConfig

117− if ([userInfo valueForKeyPath:@"aps.badge"] != nil) {

118− [UIApplication sharedApplication].applicationIconBadgeNumber=[[[userInfo objectForKey:@"aps"] objectForKey:@"badge"] intValue];

119− }

120− NSError *error;

121− NSData *jsonData = [NSJSONSerialization dataWithJSONObject:userInfo options:0 error:&error];

122− if (jsonData) {

123− NSString *jsonString = [[NSString alloc] initWithData:jsonData encoding:NSUTF8StringEncoding];

124− callWithCIntCString((int) application.applicationState, [jsonString UTF8String], global_applicationDidReceiveRemoteNotification);

125− } else {

126− NSLog(@"jsaddle-wkwebview didReceiveRemoteNotification handler: error while serialising push notification as JSON");

127− }

128− completionHandler(UIBackgroundFetchResultNewData);

129−}

130−

131- (void)application:(UIApplication *)application didFailToRegisterForRemoteNotificationsWithError:(NSError *)error {

112- (void)application:(UIApplication *)application didFailToRegisterForRemoteNotificationsWithError:(NSError *)error {

132 // Sent to the delegate when Apple Push Notification service cannot successfully complete the registration process.

113 // Sent to the delegate when Apple Push Notification service cannot successfully complete the registration process.

133 NSString *errorString = [error localizedDescription];

114 NSString *errorString = [error localizedDescription];

@@ -162,7 +143,6 @@ void runInWKWebView(HsStablePtr handler,

162 HsStablePtr hs_applicationWillTerminate,

143 HsStablePtr hs_applicationWillTerminate,

163 HsStablePtr hs_applicationSignificantTimeChange,

144 HsStablePtr hs_applicationSignificantTimeChange,

164 HsStablePtr hs_applicationUniversalLink,

145 HsStablePtr hs_applicationUniversalLink,

165− HsStablePtr hs_applicationDidReceiveRemoteNotification,

166 const uint64_t hs_requestAuthorizationWithOptions,

146 const uint64_t hs_requestAuthorizationWithOptions,

167 const uint64_t hs_requestAuthorizationOptionBadge,

147 const uint64_t hs_requestAuthorizationOptionBadge,

168 const uint64_t hs_requestAuthorizationOptionSound,

148 const uint64_t hs_requestAuthorizationOptionSound,

@@ -170,8 +150,7 @@ void runInWKWebView(HsStablePtr handler,

170 const uint64_t hs_requestAuthorizationOptionCarPlay,

150 const uint64_t hs_requestAuthorizationOptionCarPlay,

171 const uint64_t hs_registerForRemoteNotifications,

151 const uint64_t hs_registerForRemoteNotifications,

172 HsStablePtr hs_didRegisterForRemoteNotificationsWithDeviceToken,

152 HsStablePtr hs_didRegisterForRemoteNotificationsWithDeviceToken,

173− HsStablePtr hs_didFailToRegisterForRemoteNotificationsWithError,

153+ HsStablePtr hs_didFailToRegisterForRemoteNotificationsWithError) {

174− const uint64_t hs_developerExtrasEnabled) {

175 @autoreleasepool {

154 @autoreleasepool {

176 globalHandler = handler;

155 globalHandler = handler;

177 global_willFinishLaunchingWithOptions = hs_willFinishLaunchingWithOptions;

156 global_willFinishLaunchingWithOptions = hs_willFinishLaunchingWithOptions;

@@ -183,7 +162,6 @@ void runInWKWebView(HsStablePtr handler,

183 global_applicationWillTerminate = hs_applicationWillTerminate;

162 global_applicationWillTerminate = hs_applicationWillTerminate;

184 global_applicationSignificantTimeChange = hs_applicationSignificantTimeChange;

163 global_applicationSignificantTimeChange = hs_applicationSignificantTimeChange;

185 global_applicationUniversalLink = hs_applicationUniversalLink;

164 global_applicationUniversalLink = hs_applicationUniversalLink;

186− global_applicationDidReceiveRemoteNotification = hs_applicationDidReceiveRemoteNotification;

187 global_requestAuthorizationWithOptions = hs_requestAuthorizationWithOptions;

165 global_requestAuthorizationWithOptions = hs_requestAuthorizationWithOptions;

188 global_requestAuthorizationOptionBadge = hs_requestAuthorizationOptionBadge;

166 global_requestAuthorizationOptionBadge = hs_requestAuthorizationOptionBadge;

189 global_requestAuthorizationOptionSound = hs_requestAuthorizationOptionSound;

167 global_requestAuthorizationOptionSound = hs_requestAuthorizationOptionSound;

jsaddle-wkwebview/cbits/WKWebView.m+10−11

@@ -61,9 +61,9 @@ extern void jsaddleSyncResult(HsStablePtr, JSaddleHandler *, const char * _Nonnu

61

62 if(!navigationAction.targetFrame && ![url.scheme isEqualToString:@"file"]) {

63 if(openApp(url))

64− decisionHandler(WKNavigationActionPolicyCancel);

64+ decisionHandler(WKNavigationActionPolicyCancel);

65− else

65+ else

66− decisionHandler(WKNavigationActionPolicyAllow);

66+ decisionHandler(WKNavigationActionPolicyAllow);

67 }

68 else

69 decisionHandler(WKNavigationActionPolicyAllow);

@@ -74,9 +74,6 @@ extern void jsaddleSyncResult(HsStablePtr, JSaddleHandler *, const char * _Nonnu

74void addJSaddleHandler(WKWebView *webView, HsStablePtr startHandler, HsStablePtr resultHandler, HsStablePtr syncHandler) {

75 JSaddleHandler * handler = [[JSaddleHandler alloc] initHandler:startHandler resultHandler:resultHandler syncHandler:syncHandler];

76 [[[webView configuration] userContentController] addScriptMessageHandler:handler name:@"jsaddle"];

77−#ifdef USE_UIKIT

78− webView.scrollView.bounces = NO;

79−#endif

80 webView.navigationDelegate = handler;

77 webView.navigationDelegate = handler;

81 webView.UIDelegate = handler;

78 webView.UIDelegate = handler;

82}

79}

@@ -95,11 +92,10 @@ void completeSync(JSaddleHandler *handler, const char * _Nonnull s) {

95 handler.completionHandler = NULL;

92 handler.completionHandler = NULL;

96}

93}

97

94

98−void loadHTMLStringWithBaseURL(WKWebView *webView, const char * _Nonnull html, const char * _Nonnull url) {

95+void loadHTMLString(WKWebView *webView, const char * _Nonnull html) {

99− NSString *htmlString = [NSString stringWithCString:html encoding:NSUTF8StringEncoding];

96+ NSString *htmlString = [NSString stringWithCString:html encoding:NSUTF8StringEncoding];

100− NSURL *baseURL = [NSURL URLWithString:[[NSString alloc] initWithCString:url encoding:NSUTF8StringEncoding]];

101− dispatch_async(dispatch_get_main_queue(), ^{

97+ dispatch_async(dispatch_get_main_queue(), ^{

102− [webView loadHTMLString:htmlString baseURL:baseURL];

98+ [webView loadHTMLString:htmlString baseURL:NULL];

103 });

99 });

104}

100}

105

101

@@ -122,3 +118,6 @@ void loadBundleFile(WKWebView *webView, const char * _Nonnull file, const char *

122 }

118 }

123 }

119 }

124}

120}

121+

122+

123+

jsaddle-wkwebview/default.nix+20−14

@@ -1,14 +1,20 @@

1−{ filterSource ? (x: x) }:

1+{ mkDerivation, stdenv, aeson, base, bytestring, jsaddle, data-default

2−self: super:

2+, buildPackages

3−let

3+}:

4− pkgs = self.callPackage ({pkgs}: pkgs) {};

4+

5− inherit (pkgs) lib;

5+mkDerivation {

6−in

6+ pname = "jsaddle-wkwebview";

7−with pkgs.haskell.lib;

7+ version = "0.9.0.0";

8−overrideCabal (self.callCabal2nix "jsaddle-wkwebview" (filterSource ./.) {}) (drv: {

8+ src = ./.;

9− libraryFrameworkDepends = (drv.libraryFrameworkDepends or []) ++

9+ libraryHaskellDepends = [ aeson base bytestring jsaddle data-default ]

10− (if pkgs.stdenv.hostPlatform.useiOSPrebuilt then [

10+ # should use `librarySystemDepends` but it is not propagated

11− "${pkgs.buildPackages.darwin.xcode}/Contents/Developer/Platforms/${pkgs.stdenv.hostPlatform.xcodePlatform}.platform/Developer/SDKs/${pkgs.stdenv.hostPlatform.xcodePlatform}.sdk/System"

11+ ++ (with buildPackages; [

12+ darwin.libobjc

13+ darwin.apple_sdk.libs.xpc

14+ darwin.apple_sdk.frameworks.Foundation

12− ] else (with pkgs.buildPackages.darwin.apple_sdk.frameworks; [ Cocoa WebKit ]));

15+ darwin.apple_sdk.frameworks.Cocoa

13− buildDepends = lib.optional (!pkgs.stdenv.hostPlatform.useiOSPrebuilt) [ pkgs.buildPackages.darwin.cf-private ];

16+ darwin.apple_sdk.frameworks.WebKit

17+ ]);

18+ description = "Interface for JavaScript that works with GHCJS and GHC";

19+ license = stdenv.lib.licenses.mit;

14−})

20+}

jsaddle-wkwebview/jsaddle-wkwebview.cabal+11−20

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

1name: jsaddle-wkwebview

2−version: 0.9.8.0

2+version: 0.9.0.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

@@ -25,41 +25,32 @@ source-repository head

25library

26 exposed-modules:

27 Language.Javascript.JSaddle.WKWebView

28+ Language.Javascript.JSaddle.WKWebView.Internal

28 build-depends:

29 build-depends:

30+ aeson >=0.8.0.2 && <1.3,

29− base <5

31+ base <5,

32+ bytestring >=0.10.6.0 && <0.11,

33+ jsaddle >= 0.9.0.0 && <0.10,

34+ data-default,

35+ containers

30 default-language: Haskell2010

36 default-language: Haskell2010

31 hs-source-dirs: src

37 hs-source-dirs: src

38+ frameworks: Foundation, WebKit

32 ghc-options: -ferror-spans -Wall

39 ghc-options: -ferror-spans -Wall

33− if os(linux)

40+ c-sources:

34− buildable: False

41+ cbits/WKWebView.m

35 if impl(ghcjs)

42 if impl(ghcjs)

36 hs-source-dirs: src-ghcjs

43 hs-source-dirs: src-ghcjs

37 else

44 else

38− frameworks: Foundation, WebKit

39− build-depends:

40− aeson >=0.8.0.2 && <1.6,

41− bytestring >=0.10.6.0 && <0.11,

42− directory,

43− jsaddle >= 0.9.4.0 && <0.10,

44− text,

45− data-default,

46− containers

47− exposed-modules:

48− Language.Javascript.JSaddle.WKWebView.Internal

49 hs-source-dirs: src-ghc

45 hs-source-dirs: src-ghc

50− c-sources:

51− cbits/WKWebView.m

52− cc-options: -Wno-everything

53 if os(ios)

46 if os(ios)

54 frameworks: UIKit, UserNotifications

47 frameworks: UIKit, UserNotifications

55 if flag(include-app-delegate)

48 if flag(include-app-delegate)

56 c-sources:

49 c-sources:

57 cbits-uikit/AppDelegate.m

50 cbits-uikit/AppDelegate.m

58 cbits-uikit/ViewController.m

51 cbits-uikit/ViewController.m

59− cpp-options: -DUSE_UIKIT

60 else

52 else

61 frameworks: Cocoa

53 frameworks: Cocoa

62 if flag(include-app-delegate)

54 if flag(include-app-delegate)

63 c-sources:

55 c-sources:

64 cbits-cocoa/AppDelegate.m

56 cbits-cocoa/AppDelegate.m

65− cpp-options: -DUSE_COCOA

jsaddle-wkwebview/src-ghc/Language/Javascript/JSaddle/WKWebView.hs+17−73

@@ -1,15 +1,11 @@

1module Language.Javascript.JSaddle.WKWebView

2 ( jsaddleMain

3− , jsaddleMainHTMLWithBaseURL

4 , jsaddleMainFile

3 , jsaddleMainFile

5 , WKWebView(..)

4 , WKWebView(..)

6 , run

5 , run

7− , run'

8 , runWithAppConfig

6 , runWithAppConfig

9− , runHTMLWithBaseURL

10 , runFile

7 , runFile

11 , mainBundleResourcePath

8 , mainBundleResourcePath

12− , ApplicationState (..)

13 , AppDelegateConfig (..)

9 , AppDelegateConfig (..)

14 , AppDelegateNotificationConfig (..)

10 , AppDelegateNotificationConfig (..)

15 , AuthorizationOption (..)

11 , AuthorizationOption (..)

@@ -21,11 +17,9 @@ import Data.Set (Set)

21import qualified Data.Set as Set

17import qualified Data.Set as Set

22import Data.Word

18import Data.Word

23import Foreign.Marshal.Utils (fromBool)

19import Foreign.Marshal.Utils (fromBool)

24−import Language.Javascript.JSaddle.WKWebView.Internal

20+import Language.Javascript.JSaddle.WKWebView.Internal (jsaddleMain, jsaddleMainFile, WKWebView(..), mainBundleResourcePath)

25− (jsaddleMain, jsaddleMainHTMLWithBaseURL, jsaddleMainFile, WKWebView(..), mainBundleResourcePath)

26import System.Environment (getProgName)

21import System.Environment (getProgName)

27import Foreign.C.String (CString, withCString)

22import Foreign.C.String (CString, withCString)

28−import Foreign.C.Types (CBool, CInt)

29import Foreign.StablePtr (StablePtr, newStablePtr)

23import Foreign.StablePtr (StablePtr, newStablePtr)

30import Language.Javascript.JSaddle (JSM)

24import Language.Javascript.JSaddle (JSM)

31

25

@@ -41,7 +35,6 @@ foreign import ccall runInWKWebView

41 -> StablePtr (IO ()) -- applicationWillTerminate

35 -> StablePtr (IO ()) -- applicationWillTerminate

42 -> StablePtr (IO ()) -- applicationSignificantTimeChange

36 -> StablePtr (IO ()) -- applicationSignificantTimeChange

43 -> StablePtr (CString -> IO ()) -- applicationUniversalLink

37 -> StablePtr (CString -> IO ()) -- applicationUniversalLink

44− -> StablePtr (CInt -> CString -> IO ()) -- applicationDidReceiveRemoteNotification

45 -> Word64 -- whether to run requestAuthorizationWithOptions

38 -> Word64 -- whether to run requestAuthorizationWithOptions

46 -> Word64 -- Ask for Badge authorization

39 -> Word64 -- Ask for Badge authorization

47 -> Word64 -- Ask for Sound authorization

40 -> Word64 -- Ask for Sound authorization

@@ -50,8 +43,6 @@ foreign import ccall runInWKWebView

50 -> Word64 -- registerForRemoteNotifications

43 -> Word64 -- registerForRemoteNotifications

51 -> StablePtr (CString -> IO ()) -- didRegisterForRemoteNotificationsWithDeviceToken

44 -> StablePtr (CString -> IO ()) -- didRegisterForRemoteNotificationsWithDeviceToken

52 -> StablePtr (CString -> IO ()) -- didFailToRegisterForRemoteNotificationsWithError

45 -> StablePtr (CString -> IO ()) -- didFailToRegisterForRemoteNotificationsWithError

53− -> Word64 -- developerExtrasEnabled

54− -> StablePtr (CString -> IO CBool) -- applicationOpenFile

55 -> IO ()

46 -> IO ()

56

47

57data AppDelegateConfig = AppDelegateConfig

48data AppDelegateConfig = AppDelegateConfig

@@ -64,25 +55,7 @@ data AppDelegateConfig = AppDelegateConfig

64 , _appDelegateConfig_applicationWillTerminate :: IO ()

55 , _appDelegateConfig_applicationWillTerminate :: IO ()

65 , _appDelegateConfig_applicationSignificantTimeChange :: IO ()

56 , _appDelegateConfig_applicationSignificantTimeChange :: IO ()

66 , _appDelegateConfig_applicationUniversalLink :: CString -> IO ()

57 , _appDelegateConfig_applicationUniversalLink :: CString -> IO ()

67− -- ^ Called when the app is launched from a URL. 'CString' contains the URL.

68− --

69− -- The Core Foundation plist key CFBundleURLTypes controls which URL schemes

70− -- the app should respond to.

71− , _appDelegateConfig_applicationDidReceiveRemoteNotification :: ApplicationState -> CString -> IO ()

72− -- ^ Called when the application receives a remote notification.

73− -- 'ApplicationState' is the current state of the app.

74− -- The 'CString' JSON-encoded user info contained in the notification.

75− -- For more information see https://developer.apple.com/documentation/uikit/uiapplicationdelegate/1623117-application?language=objc

76 , _appDelegateConfig_appDelegateNotificationConfig :: AppDelegateNotificationConfig

58 , _appDelegateConfig_appDelegateNotificationConfig :: AppDelegateNotificationConfig

77− , _appDelegateConfig_developerExtrasEnabled :: Bool

78− -- ^ Allow devtools in the app. Defaults to 'True'

79− , _appDelegateConfig_applicationOpenFile :: CString -> IO Bool

80− -- ^ Called when the app is launched by opening a file. 'CString' contains

81− -- the file path. Return value is 'True' if the file was successfully

82− -- opened. Defaults to ignoring the file and returning 'False'.

83− --

84− -- The Core Foundation plist key CFBundleDocumentTypes controls which file

85− -- types should be associated with the app.

86 }

59 }

87

60

88instance Default AppDelegateConfig where

61instance Default AppDelegateConfig where

@@ -96,10 +69,7 @@ instance Default AppDelegateConfig where

96 , _appDelegateConfig_applicationWillTerminate = return ()

69 , _appDelegateConfig_applicationWillTerminate = return ()

97 , _appDelegateConfig_applicationSignificantTimeChange = return ()

70 , _appDelegateConfig_applicationSignificantTimeChange = return ()

98 , _appDelegateConfig_applicationUniversalLink = \_ -> return ()

71 , _appDelegateConfig_applicationUniversalLink = \_ -> return ()

99− , _appDelegateConfig_applicationDidReceiveRemoteNotification = \_ _ -> return ()

100 , _appDelegateConfig_appDelegateNotificationConfig = def

72 , _appDelegateConfig_appDelegateNotificationConfig = def

101− , _appDelegateConfig_developerExtrasEnabled = True

102− , _appDelegateConfig_applicationOpenFile = \_ -> return False

103 }

73 }

104

74

105data AuthorizationOption = AuthorizationOption_Badge

75data AuthorizationOption = AuthorizationOption_Badge

@@ -108,12 +78,6 @@ data AuthorizationOption = AuthorizationOption_Badge

108 | AuthorizationOption_CarPlay

78 | AuthorizationOption_CarPlay

109 deriving (Show, Read, Eq, Ord)

79 deriving (Show, Read, Eq, Ord)

110

80

111−data ApplicationState = ApplicationState_Active

112− | ApplicationState_Inactive

113− | ApplicationState_Background

114− | ApplicationState_Unknown CInt

115− deriving (Show, Read, Eq, Ord)

116−

117data AppDelegateNotificationConfig = AppDelegateNotificationConfig

81data AppDelegateNotificationConfig = AppDelegateNotificationConfig

118 { _appDelegateNotificationConfig_requestAuthorizationWithOptions :: Maybe (Set AuthorizationOption)

82 { _appDelegateNotificationConfig_requestAuthorizationWithOptions :: Maybe (Set AuthorizationOption)

119 , _appDelegateNotificationConfig_registerForRemoteNotifications :: Bool

83 , _appDelegateNotificationConfig_registerForRemoteNotifications :: Bool

@@ -132,38 +96,29 @@ instance Default AppDelegateNotificationConfig where

132

96

133-- | Run JSaddle in a WKWebView

97-- | Run JSaddle in a WKWebView

134run :: JSM () -> IO ()

98run :: JSM () -> IO ()

135−run f = run' def (jsaddleMain f)

99+run = run' Nothing def

136

100

137-- | Run JSaddle in a WKWebView

101-- | Run JSaddle in a WKWebView

138runWithAppConfig :: AppDelegateConfig -> JSM () -> IO ()

102runWithAppConfig :: AppDelegateConfig -> JSM () -> IO ()

139−runWithAppConfig cfg = run' cfg . jsaddleMain

103+runWithAppConfig = run' Nothing

140

104

141-- | Run JSaddle in a WKWebView first loading the specified file

105-- | Run JSaddle in a WKWebView first loading the specified file

142-- from the mainBundle (relative to the resourcePath).

106-- from the mainBundle (relative to the resourcePath).

143−runFile

144− :: ByteString -- ^ The file to navigate to.

107+runFile :: ByteString -- ^ The file to navigate to.

145− -> ByteString -- ^ The path to allow read access to.

108+ -> ByteString -- ^ The path to allow read access to.

146− -> AppDelegateConfig

109+ -> AppDelegateConfig

147− -> JSM ()

110+ -> JSM ()

148− -> IO ()

111+ -> IO ()

149−runFile url allowing cfg = run' cfg . jsaddleMainFile url allowing

112+runFile url allowing = run' $ Just (url, allowing)

150−

113+

151−-- | Run JSaddle in a WKWebView first loading the specified html

152−-- as though it came from the specified URL

153−-- (calls WKWebKit function loadHTMLString).

154−runHTMLWithBaseURL

155− :: ByteString -- ^ HTML to load.

114+run' :: Maybe (ByteString, ByteString)

156− -> ByteString -- ^ pretend it came from this URL.

157− -> AppDelegateConfig

158− -> JSM ()

159− -> IO ()

160−runHTMLWithBaseURL url allowing cfg = run' cfg . jsaddleMainHTMLWithBaseURL url allowing

161−

162−run' :: AppDelegateConfig

115+ -> AppDelegateConfig

163− -> (WKWebView -> IO ())

116+ -> JSM ()

164 -> IO ()

117 -> IO ()

165−run' cfg main = do

118+run' mUrl cfg f = do

166− handler <- newStablePtr main

119+ handler <- case mUrl of

120+ Just (url, allowing) -> newStablePtr (jsaddleMainFile url allowing f)

121+ Nothing -> newStablePtr (jsaddleMain f)

167 progName <- getProgName

122 progName <- getProgName

168

123

169 -- AppDelegate callbacks

124 -- AppDelegate callbacks

@@ -176,14 +131,6 @@ run' cfg main = do

176 applicationWillTerminate <- newStablePtr $ _appDelegateConfig_applicationWillTerminate cfg

131 applicationWillTerminate <- newStablePtr $ _appDelegateConfig_applicationWillTerminate cfg

177 applicationSignificantTimeChange <- newStablePtr $ _appDelegateConfig_applicationSignificantTimeChange cfg

132 applicationSignificantTimeChange <- newStablePtr $ _appDelegateConfig_applicationSignificantTimeChange cfg

178 applicationUniversalLink <- newStablePtr $ _appDelegateConfig_applicationUniversalLink cfg

133 applicationUniversalLink <- newStablePtr $ _appDelegateConfig_applicationUniversalLink cfg

179− applicationDidReceiveRemoteNotification <- newStablePtr $ \n s -> do

180− let appState = case n of

181− 0 -> ApplicationState_Active

182− 1 -> ApplicationState_Inactive

183− 2 -> ApplicationState_Background

184− _ -> ApplicationState_Unknown n

185− _appDelegateConfig_applicationDidReceiveRemoteNotification cfg appState s

186− applicationOpenFile <- newStablePtr $ fmap fromBool . _appDelegateConfig_applicationOpenFile cfg

187

134

188 -- AppDelegate notification configuration

135 -- AppDelegate notification configuration

189 let ncfg = _appDelegateConfig_appDelegateNotificationConfig cfg

136 let ncfg = _appDelegateConfig_appDelegateNotificationConfig cfg

@@ -206,7 +153,6 @@ run' cfg main = do

206 applicationWillTerminate

153 applicationWillTerminate

207 applicationSignificantTimeChange

154 applicationSignificantTimeChange

208 applicationUniversalLink

155 applicationUniversalLink

209− applicationDidReceiveRemoteNotification

210 (fromBool requestAuthorizationWithOptions)

156 (fromBool requestAuthorizationWithOptions)

211 (fromBool $ Set.member AuthorizationOption_Badge authorizationOptions)

157 (fromBool $ Set.member AuthorizationOption_Badge authorizationOptions)

212 (fromBool $ Set.member AuthorizationOption_Sound authorizationOptions)

158 (fromBool $ Set.member AuthorizationOption_Sound authorizationOptions)

@@ -215,5 +161,3 @@ run' cfg main = do

215 (fromBool registerForRemoteNotifications)

161 (fromBool registerForRemoteNotifications)

216 didRegisterForRemoteNotificationsWithDeviceToken

162 didRegisterForRemoteNotificationsWithDeviceToken

217 didFailToRegisterForRemoteNotificationsWithError

163 didFailToRegisterForRemoteNotificationsWithError

218− (fromBool $ _appDelegateConfig_developerExtrasEnabled cfg)

219− applicationOpenFile

jsaddle-wkwebview/src/Language/Javascript/JSaddle/WKWebView/Internal.hs+4−35

@@ -1,7 +1,6 @@

1{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}

2module Language.Javascript.JSaddle.WKWebView.Internal

3 ( jsaddleMain

4− , jsaddleMainHTMLWithBaseURL

5 , jsaddleMainFile

4 , jsaddleMainFile

6 , WKWebView(..)

5 , WKWebView(..)

7 , mainBundleResourcePath

6 , mainBundleResourcePath

@@ -16,11 +15,8 @@ import Data.ByteString (useAsCString, packCString)

16import qualified Data.ByteString as BS (ByteString)

15import qualified Data.ByteString as BS (ByteString)

17import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)

16import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)

18import Data.Aeson (encode, decode)

17import Data.Aeson (encode, decode)

19−import qualified Data.Text as T (pack)

20−import Data.Text.Encoding (encodeUtf8)

21

18

22import Foreign.C.String (CString)

19import Foreign.C.String (CString)

23−import Foreign.C.Types (CBool(..), CInt(..))

24import Foreign.Ptr (Ptr, nullPtr)

20import Foreign.Ptr (Ptr, nullPtr)

25import Foreign.StablePtr (StablePtr, newStablePtr, deRefStablePtr)

21import Foreign.StablePtr (StablePtr, newStablePtr, deRefStablePtr)

26

22

@@ -28,8 +24,6 @@ import Language.Javascript.JSaddle (Results, Batch, JSM)

28import Language.Javascript.JSaddle.Run (runJavaScript)

24import Language.Javascript.JSaddle.Run (runJavaScript)

29import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)

25import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)

30

26

31−import System.Directory (getCurrentDirectory)

32−

33newtype WKWebView = WKWebView (Ptr WKWebView)

27newtype WKWebView = WKWebView (Ptr WKWebView)

34newtype JSaddleHandler = JSaddleHandler (Ptr JSaddleHandler)

28newtype JSaddleHandler = JSaddleHandler (Ptr JSaddleHandler)

35

29

@@ -37,12 +31,10 @@ foreign export ccall jsaddleStart :: StablePtr (IO ()) -> IO ()

37foreign export ccall jsaddleResult :: StablePtr (Results -> IO ()) -> CString -> IO ()

31foreign export ccall jsaddleResult :: StablePtr (Results -> IO ()) -> CString -> IO ()

38foreign export ccall jsaddleSyncResult :: StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()

32foreign export ccall jsaddleSyncResult :: StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()

39foreign export ccall callWithWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()

33foreign export ccall callWithWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()

40−foreign export ccall callWithCIntCString :: CInt -> CString -> StablePtr (CInt -> CString -> IO ()) -> IO ()

41foreign export ccall callWithCString :: CString -> StablePtr (CString -> IO ()) -> IO ()

34foreign export ccall callWithCString :: CString -> StablePtr (CString -> IO ()) -> IO ()

42−foreign export ccall callWithCStringReturningBool :: CString -> StablePtr (CString -> IO CBool) -> IO CBool

43foreign export ccall callIO :: StablePtr (IO ()) -> IO ()

35foreign export ccall callIO :: StablePtr (IO ()) -> IO ()

44foreign import ccall addJSaddleHandler :: WKWebView -> StablePtr (IO ()) -> StablePtr (Results -> IO ()) -> StablePtr (Results -> IO Batch) -> IO ()

36foreign import ccall addJSaddleHandler :: WKWebView -> StablePtr (IO ()) -> StablePtr (Results -> IO ()) -> StablePtr (Results -> IO Batch) -> IO ()

45−foreign import ccall loadHTMLStringWithBaseURL :: WKWebView -> CString -> CString -> IO ()

37+foreign import ccall loadHTMLString :: WKWebView -> CString -> IO ()

46foreign import ccall loadBundleFile :: WKWebView -> CString -> CString -> IO ()

38foreign import ccall loadBundleFile :: WKWebView -> CString -> CString -> IO ()

47foreign import ccall evaluateJavaScript :: WKWebView -> CString -> IO ()

39foreign import ccall evaluateJavaScript :: WKWebView -> CString -> IO ()

48foreign import ccall completeSync :: JSaddleHandler -> CString -> IO ()

40foreign import ccall completeSync :: JSaddleHandler -> CString -> IO ()

@@ -50,23 +42,9 @@ foreign import ccall mainBundleResourcePathC :: IO CString

50

42

51-- | Run JSaddle in WKWebView

43-- | Run JSaddle in WKWebView

52jsaddleMain :: JSM () -> WKWebView -> IO ()

44jsaddleMain :: JSM () -> WKWebView -> IO ()

53−jsaddleMain f webView = do

45+jsaddleMain f webView =

54− pwd <- getCurrentDirectory

55− let baseURL = encodeUtf8 $ "file://" <> T.pack pwd <> "/index.html"

56− jsaddleMainHTMLWithBaseURL (toStrict indexHtml) baseURL f webView

57−

58−-- | Run JSaddle in WKWebView with initial html and base url

59−jsaddleMainHTMLWithBaseURL

60− :: BS.ByteString -- ^ HTML

61− -> BS.ByteString -- ^ Base URL

62− -> JSM ()

63− -> WKWebView

64− -> IO ()

65−jsaddleMainHTMLWithBaseURL initialHTML baseURL f webView =

66 jsaddleMain' f webView $

46 jsaddleMain' f webView $

67− useAsCString baseURL $ \url ->

47+ useAsCString (toStrict indexHtml) $ loadHTMLString webView

68− useAsCString initialHTML $ \html ->

69− loadHTMLStringWithBaseURL webView html url

70

48

71-- | Run JSaddle in a WKWebView first loading the specified file

49-- | Run JSaddle in a WKWebView first loading the specified file

72-- from the mainBundle (relative to the resourcePath).

50-- from the mainBundle (relative to the resourcePath).

@@ -129,16 +107,6 @@ callWithCString c fptr = do

129 f <- deRefStablePtr fptr

107 f <- deRefStablePtr fptr

130 f c

108 f c

131

109

132−callWithCIntCString :: CInt -> CString -> StablePtr (CInt -> CString -> IO ()) -> IO ()

133−callWithCIntCString n s fptr = do

134− f <- deRefStablePtr fptr

135− f n s

136−

137−callWithCStringReturningBool :: CString -> StablePtr (CString -> IO CBool) -> IO CBool

138−callWithCStringReturningBool c fptr = do

139− f <- deRefStablePtr fptr

140− f c

141−

142callIO :: StablePtr (IO ()) -> IO ()

110callIO :: StablePtr (IO ()) -> IO ()

143callIO ptr = do

111callIO ptr = do

144 f <- deRefStablePtr ptr

112 f <- deRefStablePtr ptr

@@ -172,3 +140,4 @@ mainBundleResourcePath = do

172 if bs == nullPtr

140 if bs == nullPtr

173 then return Nothing

141 then return Nothing

174 else Just <$> packCString bs

142 else Just <$> packCString bs

143+

jsaddle/default.nixnew file+17

@@ -0,0 +1,17 @@

1+{ mkDerivation, aeson, attoparsec, base, base64-bytestring

2+, bytestring, containers, deepseq, filepath, ghc-prim, http-types

3+, lens, primitive, process, ref-tf, scientific, stdenv, stm, text

4+, time, transformers, unordered-containers, vector

5+}:

6+mkDerivation {

7+ pname = "jsaddle";

8+ version = "0.9.0.0";

9+ src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;

10+ libraryHaskellDepends = [

11+ aeson attoparsec base base64-bytestring bytestring containers

12+ deepseq filepath ghc-prim http-types lens primitive process ref-tf

13+ scientific stm text time transformers unordered-containers vector

14+ ];

15+ description = "Interface for JavaScript that works with GHCJS and GHC";

16+ license = stdenv.lib.licenses.mit;

17+}

jsaddle/jsaddle.cabal+15−20

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

1name: jsaddle

2−version: 0.9.8.0

2+version: 0.9.0.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

@@ -10,7 +10,7 @@ description:

10 This package provides an EDSL for calling JavaScript that

11 can be used both from GHCJS and GHC. When using GHC

12 the application is run using Warp and WebSockets to

13− drive a small JavaScript helper.

13+ drive a small JavaScipt helper.

14category: Web, Javascript

15author: Hamish Mackenzie

16

@@ -36,20 +36,18 @@ library

36 else

37 build-depends:

38 attoparsec >=0.11 && <0.14,

39− containers >=0.5.6.2 && <0.7,

39+ containers >=0.5.6.2 && <0.6,

40 deepseq >=1.3 && < 1.5,

41 filepath >=1.4.0.0 && <1.5,

42 ghc-prim,

43− http-types >=0.8.6 && <0.13,

43+ http-types >=0.8.6 && <0.10,

44− process >=1.2.3.0 && <1.7,

44+ process >=1.2.3.0 && <1.5,

45− random >= 1.1 && < 1.3,

46 ref-tf >=0.4.0.1 && <0.5,

45 ref-tf >=0.4.0.1 && <0.5,

47 scientific >=0.3 && <0.4,

46 scientific >=0.3 && <0.4,

48− stm >=2.4.4 && <2.6,

47+ stm >=2.4.4 && <2.5,

49− time >=1.5.0.1 && <1.11,

48+ time >=1.5.0.1 && <1.8,

50 unordered-containers >=0.2 && <0.3,

49 unordered-containers >=0.2 && <0.3,

51− vector >=0.10 && <0.13,

50+ vector >=0.10 && <0.13

52− unliftio-core >=0.1 && < 0.3

53 exposed-modules:

51 exposed-modules:

54 Data.JSString

52 Data.JSString

55 Data.JSString.Internal

53 Data.JSString.Internal

@@ -63,7 +61,6 @@ library

63 GHCJS.Prim

61 GHCJS.Prim

64 GHCJS.Prim.Internal

62 GHCJS.Prim.Internal

65 GHCJS.Types

63 GHCJS.Types

66− GHCJS.Concurrent

67 GHCJS.Foreign

64 GHCJS.Foreign

68 GHCJS.Foreign.Internal

65 GHCJS.Foreign.Internal

69 GHCJS.Internal.Types

66 GHCJS.Internal.Types

@@ -84,10 +81,8 @@ library

84 JavaScript.Array.Internal

81 JavaScript.Array.Internal

85 JavaScript.Object

82 JavaScript.Object

86 JavaScript.Object.Internal

83 JavaScript.Object.Internal

87− Language.Javascript.JSaddle.Debug

88 Language.Javascript.JSaddle.Native

84 Language.Javascript.JSaddle.Native

89 Language.Javascript.JSaddle.Native.Internal

85 Language.Javascript.JSaddle.Native.Internal

90− Language.Javascript.JSaddle.Null

91 hs-source-dirs: src-ghc

86 hs-source-dirs: src-ghc

92 exposed-modules:

87 exposed-modules:

93 Language.Javascript.JSaddle

88 Language.Javascript.JSaddle

@@ -107,14 +102,12 @@ library

107 Language.Javascript.JSaddle.Value

102 Language.Javascript.JSaddle.Value

108 Language.Javascript.JSaddle.Types

103 Language.Javascript.JSaddle.Types

109 build-depends:

104 build-depends:

110− aeson >=0.11.3.0 && <1.6,

105+ aeson >=0.8.0.2 && <1.3,

111− base >=4.9 && <5,

106+ base <5,

112− base-compat >=0.9.0 && <0.12,

113− base64-bytestring >=1.0.0.1 && <1.2,

107+ base64-bytestring >=1.0.0.1 && <1.1,

114 bytestring >=0.10.6.0 && <0.11,

108 bytestring >=0.10.6.0 && <0.11,

115− exceptions >=0.8 && <0.11,

116− lens >=3.8.5 && <5.1,

109+ lens >=3.8.5 && <4.16,

117− primitive >=0.6.1.0 && <0.8,

110+ primitive >=0.6.1.0 && <0.7,

118 text >=1.2.1.3 && <1.3,

111 text >=1.2.1.3 && <1.3,

119 transformers >=0.4.2.0 && <0.6

112 transformers >=0.4.2.0 && <0.6

120 default-language: Haskell2010

113 default-language: Haskell2010

@@ -124,3 +117,5 @@ library

124 cpp-options: -DCHECK_UNCHECKED

117 cpp-options: -DCHECK_UNCHECKED

125 if flag(call-stacks) || flag(check-unchecked)

118 if flag(call-stacks) || flag(check-unchecked)

126 cpp-options: -DJSADDLE_HAS_CALL_STACK

119 cpp-options: -DJSADDLE_HAS_CALL_STACK

120+

121+

jsaddle/src-ghc/Data/JSString/Internal/Type.hs+1−2

@@ -38,11 +38,10 @@ import Data.Aeson (ToJSON(..), FromJSON(..))

38import Data.Data (Data)

39-- import Data.Text.Internal.Unsafe.Char (ord)

40import Data.Typeable (Typeable)

41−import Data.Semigroup (Semigroup)

42import GHC.Exts (Char(..), ord#, andI#, (/=#), isTrue#)

41import GHC.Exts (Char(..), ord#, andI#, (/=#), isTrue#)

43

42

44-- | A wrapper around a JavaScript string

43-- | A wrapper around a JavaScript string

45−newtype JSString = JSString Text deriving(Show, Read, IsString, Semigroup, Monoid, Ord, Eq, Data, ToJSON, FromJSON, Typeable)

44+newtype JSString = JSString Text deriving(Show, Read, IsString, Monoid, Ord, Eq, Data, ToJSON, FromJSON, Typeable)

46

45

47instance NFData JSString where rnf !_ = ()

46instance NFData JSString where rnf !_ = ()

48

47

jsaddle/src-ghc/GHCJS/Concurrent.hsdeleted−22

@@ -1,22 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2−

3−module GHCJS.Concurrent ( OnBlocked(..)

4− , WouldBlockException(..)

5− ) where

6−

7−import GHCJS.Prim

8−

9−import Data.Data

10−

11−{- |

12− The runtime tries to run synchronous threads to completion. Sometimes it's

13− not possible to continue running a thread, for example when the thread

14− tries to take an empty 'MVar'. The runtime can then either throw a

15− 'WouldBlockException', aborting the blocking action, or continue the

16− thread asynchronously.

17− -}

18−

19−data OnBlocked = ContinueAsync -- ^ continue the thread asynchronously if blocked

20− | ThrowWouldBlock -- ^ throw 'WouldBlockException' if blocked

21− deriving (Data, Typeable, Enum, Show, Eq, Ord)

22−

jsaddle/src-ghc/GHCJS/Foreign/Internal.hs+10−12

@@ -27,28 +27,26 @@ import Language.Javascript.JSaddle.Native.Internal

27 (valueToBool)

28import Data.Typeable (Typeable)

29import GHCJS.Prim (isNull, isUndefined)

30−import System.IO.Unsafe (unsafePerformIO)

31−import Data.IORef (newIORef)

32

30

33jsTrue :: JSVal

31jsTrue :: JSVal

34−jsTrue = JSVal . unsafePerformIO $ newIORef 3

32+jsTrue = JSVal 3

35−{-# NOINLINE jsTrue #-}

33+{-# INLINE jsTrue #-}

36

34

37jsFalse :: JSVal

35jsFalse :: JSVal

38−jsFalse = JSVal . unsafePerformIO $ newIORef 2

36+jsFalse = JSVal 2

39−{-# NOINLINE jsFalse #-}

37+{-# INLINE jsFalse #-}

40

38

41jsNull :: JSVal

39jsNull :: JSVal

42−jsNull = JSVal . unsafePerformIO $ newIORef 0

40+jsNull = JSVal 0

43−{-# NOINLINE jsNull #-}

41+{-# INLINE jsNull #-}

44

42

45toJSBool :: Bool -> JSVal

43toJSBool :: Bool -> JSVal

46−toJSBool b = JSVal . unsafePerformIO . newIORef $ if b then 3 else 2

44+toJSBool b = JSVal $ if b then 3 else 2

47−{-# NOINLINE toJSBool #-}

45+{-# INLINE toJSBool #-}

48

46

49jsUndefined :: JSVal

47jsUndefined :: JSVal

50−jsUndefined = JSVal . unsafePerformIO $ newIORef 1

48+jsUndefined = JSVal 1

51−{-# NOINLINE jsUndefined #-}

49+{-# INLINE jsUndefined #-}

52

50

53isTruthy :: JSVal -> GHCJSPure Bool

51isTruthy :: JSVal -> GHCJSPure Bool

54isTruthy = GHCJSPure . valueToBool

52isTruthy = GHCJSPure . valueToBool

jsaddle/src-ghc/GHCJS/Prim/Internal.hs+3−5

@@ -17,8 +17,6 @@ import Unsafe.Coerce (unsafeCoerce)

17import Data.Aeson (ToJSON(..), FromJSON(..))

18

19import qualified GHC.Exception as Ex

20−import Data.IORef (newIORef, IORef)

21−import System.IO.Unsafe (unsafePerformIO)

22

20

23-- A reference to a particular JavaScript value inside the JavaScript context

21-- A reference to a particular JavaScript value inside the JavaScript context

24type JSValueRef = Int64

22type JSValueRef = Int64

@@ -27,7 +25,7 @@ type JSValueRef = Int64

27 JSVal is a boxed type that can be used as FFI

25 JSVal is a boxed type that can be used as FFI

28 argument or result.

26 argument or result.

29-}

27-}

30−newtype JSVal = JSVal (IORef JSValueRef)

28+newtype JSVal = JSVal JSValueRef deriving(Show, ToJSON, FromJSON)

31

29

32instance NFData JSVal where

30instance NFData JSVal where

33 rnf x = x `seq` ()

31 rnf x = x `seq` ()

@@ -51,8 +49,8 @@ mkJSException ref =

51 return (JSException (unsafeCoerce ref) "")

49 return (JSException (unsafeCoerce ref) "")

52

50

53jsNull :: JSVal

51jsNull :: JSVal

54−jsNull = JSVal . unsafePerformIO $ newIORef 0

52+jsNull = JSVal 0

55−{-# NOINLINE jsNull #-}

53+{-# INLINE jsNull #-}

56

54

57{- | If a synchronous thread tries to do something that can only

55{- | If a synchronous thread tries to do something that can only

58 be done asynchronously, and the thread is set up to not

56 be done asynchronously, and the thread is set up to not

jsaddle/src-ghc/GHCJS/Types.hs+3−5

@@ -27,21 +27,19 @@ import GHC.Int

27import GHC.Types

28import GHC.Prim

29import GHC.Ptr

30−import GHC.IORef

31−import GHC.IO.Unsafe (unsafePerformIO)

32

30

33import Control.DeepSeq

31import Control.DeepSeq

34import Unsafe.Coerce

32import Unsafe.Coerce

35

33

36−type Ref# = IORef Int64

34+type Ref# = Int64

37

35

38mkRef :: Ref# -> JSVal

36mkRef :: Ref# -> JSVal

39mkRef = JSVal

37mkRef = JSVal

40{-# INLINE mkRef #-}

38{-# INLINE mkRef #-}

41

39

42nullRef :: JSVal

40nullRef :: JSVal

43−nullRef = JSVal . unsafePerformIO $ newIORef 0

41+nullRef = JSVal 0

44−{-# NOINLINE nullRef #-}

42+{-# INLINE nullRef #-}

45

43

46--toPtr :: JSVal -> Ptr a

44--toPtr :: JSVal -> Ptr a

47--toPtr (JSVal x) = unsafeCoerce (Ptr' x 0#)

45--toPtr (JSVal x) = unsafeCoerce (Ptr' x 0#)

jsaddle/src-ghc/JavaScript/Array.hs+2−2

@@ -48,7 +48,7 @@ import Language.Javascript.JSaddle.Types

48 (JSM, JSVal, SomeJSArray(..), JSArray,

49 MutableJSArray, GHCJSPure(..))

50import Control.Lens.Operators ((^.))

51−import Language.Javascript.JSaddle.Object (js2, js0, (<##), js1, js)

51+import Language.Javascript.JSaddle.Object (js2, js0, (##), js1, js)

52import Language.Javascript.JSaddle.Value (valToNumber)

53import JavaScript.Array.Internal (create, fromList, fromListIO, toList, toListIO, index, read, push)

54

@@ -69,7 +69,7 @@ append (SomeJSArray x) (SomeJSArray y) = SomeJSArray <$> x ^. js1 "concat" y

69{-# INLINE append #-}

70

71write :: Int -> JSVal -> MutableJSArray -> JSM ()

72−write n e (SomeJSArray x) = void $ (x <## n) e

72+write n e (SomeJSArray x) = void $ (x ## n) e

73{-# INLINE write #-}

74

75pop :: MutableJSArray -> JSM JSVal

jsaddle/src/Language/Javascript/JSaddle.hs+5−5

@@ -9,7 +9,7 @@

9-- | This package provides an EDSL for calling JavaScript that

10-- can be used both from GHCJS and GHC. When using GHC

11-- the application is run using Warp and WebSockets to

12−-- drive a small JavaScript helper.

12+-- drive a small JavaScipt helper.

13-----------------------------------------------------------------------------

14

15module Language.Javascript.JSaddle (

@@ -35,10 +35,10 @@ module Language.Javascript.JSaddle (

35 --

36 -- Where it makes sense code examples are given in two forms. One

37 -- that uses 'eval' to run a purely JavaScript version and one that

38− -- uses more of the JSaddle EDSL feature being demonstrated.

38+ -- uses more of the JSaddle EDSL feature being demonstated.

39

40 -- * Calling Haskell from JavaScript

41− -- | You can call back into Haskell from JavaScript using 'fun' to

41+ -- | You can call back into haskell from JavaScript using 'fun' to

42 -- convert a Haskell function in the JSM monad into a javascript

43 -- value.

44

@@ -52,8 +52,8 @@ module Language.Javascript.JSaddle (

52 -- and the server will run the Haskell code. The JSaddle parts will

53 -- be executed by sending commands back to the browser.

54

55− -- Although the JavaScript code is executed in the strict order

55+ -- Although the code JavaScript code is executed in the the strict order

56− -- set out by the EDSL it is done asynchronously to the Haskell code.

56+ -- set out by the EDSL it done asynchonously to the Haskell code.

57 -- This improves the performance by reducing the number of round trips

58 -- needed between the Haskell and JavaScript code.

59

jsaddle/src/Language/Javascript/JSaddle/Debug.hsdeleted−48

@@ -1,48 +0,0 @@

1−{-# LANGUAGE LambdaCase #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−-----------------------------------------------------------------------------

4−--

5−-- Module : Language.Javascript.JSaddle.WebSockets

6−-- Copyright : (c) Hamish Mackenzie

7−-- License : MIT

8−--

9−-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>

10−--

11−-- |

12−--

13−-----------------------------------------------------------------------------

14−

15−module Language.Javascript.JSaddle.Debug (

16− contexts

17− , addContext

18− , removeContext

19− , runOnAll

20− , runOnAll_

21−) where

22−

23−import Language.Javascript.JSaddle

24− (runJSM, askJSM, JSM, JSContextRef(..))

25−import Data.IORef (readIORef, atomicModifyIORef', newIORef, IORef)

26−import System.IO.Unsafe (unsafePerformIO)

27−import Data.Monoid ((<>))

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

29−import Data.Int (Int64)

30−

31−contexts :: IORef [JSContextRef]

32−contexts = unsafePerformIO $ newIORef []

33−{-# NOINLINE contexts #-}

34−

35−addContext :: JSM ()

36−addContext = do

37− ctx <- askJSM

38− liftIO $ atomicModifyIORef' contexts $ \c -> (c <> [ctx], ())

39−

40−removeContext :: MonadIO m => Int64 -> m ()

41−removeContext cid =

42− liftIO $ atomicModifyIORef' contexts $ \c -> (filter ((/= cid) . contextId) c, ())

43−

44−runOnAll :: MonadIO m => JSM a -> m [a]

45−runOnAll f = liftIO (readIORef contexts) >>= mapM (runJSM f)

46−

47−runOnAll_ :: MonadIO m => JSM a -> m ()

48−runOnAll_ f = liftIO (readIORef contexts) >>= mapM_ (runJSM f)

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

@@ -50,7 +50,7 @@ eval :: (ToJSString script)

50 -> JSM JSVal

51#ifdef ghcjs_HOST_OS

52eval script = liftIO $ js_eval (toJSString script)

53−foreign import javascript safe "$r = eval($1);"

53+foreign import javascript unsafe "$r = eval($1);"

54 js_eval :: JSString -> IO JSVal

55#else

56eval = evaluateScript . toJSString

jsaddle/src/Language/Javascript/JSaddle/Monad.hs+26−3

@@ -38,12 +38,13 @@ module Language.Javascript.JSaddle.Monad (

38 , bracket

39) where

40

41+import Prelude hiding (read)

41#ifndef ghcjs_HOST_OS

42#ifndef ghcjs_HOST_OS

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

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

43#endif

44#endif

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

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

45−import Control.Monad.Catch (catch, bracket)

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

46−import Language.Javascript.JSaddle.Types (JSM(..), MonadJSM, liftJSM, JSContextRef)

47+import Language.Javascript.JSaddle.Types (JSM(..), MonadJSM, liftJSM, JSContextRef(..))

47import Language.Javascript.JSaddle.Run (syncPoint, syncAfter, waitForAnimationFrame, nextAnimationFrame)

48import Language.Javascript.JSaddle.Run (syncPoint, syncAfter, waitForAnimationFrame, nextAnimationFrame)

48

49

49-- | Gets the JavaScript context from the monad

50-- | Gets the JavaScript context from the monad

@@ -65,3 +66,25 @@ runJSM f = liftIO . runReaderT (unJSM f)

65-- | Alternative version of 'runJSM'

66-- | Alternative version of 'runJSM'

66runJSaddle :: MonadIO m => JSContextRef -> JSM a -> m a

67runJSaddle :: MonadIO m => JSContextRef -> JSM a -> m a

67runJSaddle = flip runJSM

68runJSaddle = flip runJSM

69+

70+

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

72+-- a bit better with 'JSM'

73+catch :: E.Exception e

74+ => JSM b

75+ -> (e -> JSM b)

76+ -> JSM b

77+t `catch` c = do

78+ r <- askJSM

79+ liftIO (runJSM (syncAfter t) r `E.catch` \e -> runJSM (c e) r)

80+

81+-- | Wrapped version of 'E.bracket' that runs in a MonadIO that works

82+-- a bit better with 'JSM'

83+bracket :: JSM a -> (a -> JSM b) -> (a -> JSM c) -> JSM c

84+bracket aquire release f = do

85+ r <- askJSM

86+ liftIO $ E.bracket

87+ (runJSM (syncAfter aquire) r)

88+ (\x -> runJSM (syncAfter $ release x) r)

89+ (\x -> runJSM (syncAfter $ f x) r)

90+

jsaddle/src/Language/Javascript/JSaddle/Native/Internal.hs+25−40

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

1−{-# LANGUAGE LambdaCase #-}

2−{-# LANGUAGE MagicHash #-}

3−{-# LANGUAGE UnboxedTuples #-}

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

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

5--

2--

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

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

@@ -48,6 +45,7 @@ module Language.Javascript.JSaddle.Native.Internal (

48) where

45) where

49

46

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

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

48+import Control.Monad.Primitive (touch)

51

49

52import Data.Aeson (Value)

50import Data.Aeson (Value)

53

51

@@ -59,34 +57,30 @@ import Language.Javascript.JSaddle.Monad (askJSM)

59import Language.Javascript.JSaddle.Run

57import Language.Javascript.JSaddle.Run

60 (Command(..), Result(..), sendCommand,

58 (Command(..), Result(..), sendCommand,

61 sendAsyncCommand, sendLazyCommand, wrapJSVal)

59 sendAsyncCommand, sendLazyCommand, wrapJSVal)

62−import GHC.IORef (IORef(..), readIORef)

63−import GHC.STRef (STRef(..))

64−import GHC.IO (IO(..))

65−import GHC.Base (touch#)

66

60

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

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

68wrapJSString (JSStringReceived ref) = return $ JSString ref

62wrapJSString (JSStringReceived ref) = return $ JSString ref

69

63

70−touchIORef :: IORef a -> IO ()

71−touchIORef (IORef (STRef r#)) = IO $ \s -> case touch# r# s of s' -> (# s', () #)

72−

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

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

74−withJSVal (JSVal ref) f = do

65+withJSVal v@(JSVal ref) f =

75− result <- (f . JSValueForSend) =<< liftIO (readIORef ref)

66+ do result <- f (JSValueForSend ref)

76− liftIO $ touchIORef ref

67+ liftIO $ touch v

77 return result

68 return result

78

69

79withJSVals :: MonadIO m => [JSVal] -> ([JSValueForSend] -> m a) -> m a

70withJSVals :: MonadIO m => [JSVal] -> ([JSValueForSend] -> m a) -> m a

80withJSVals v f =

71withJSVals v f =

81− do result <- f =<< mapM (\(JSVal ref) -> liftIO $ JSValueForSend <$> readIORef ref) v

72+ do result <- f (map (\(JSVal ref) -> JSValueForSend ref) v)

82− liftIO $ mapM_ (\(JSVal ref) -> touchIORef ref) v

73+ liftIO $ mapM_ touch v

83 return result

74 return result

84

75

85withObject :: MonadIO m => Object -> (JSObjectForSend -> m a) -> m a

76withObject :: MonadIO m => Object -> (JSObjectForSend -> m a) -> m a

86withObject (Object o) f = withJSVal o (f . JSObjectForSend)

77withObject (Object o) f = withJSVal o (f . JSObjectForSend)

87

78

88withJSString :: MonadIO m => JSString -> (JSStringForSend -> m a) -> m a

79withJSString :: MonadIO m => JSString -> (JSStringForSend -> m a) -> m a

89−withJSString (JSString ref) f = f (JSStringForSend ref)

80+withJSString v@(JSString ref) f =

81+ do result <- f (JSStringForSend ref)

82+ liftIO $ touch v

83+ return result

90

84

91setPropertyByName :: JSString -> JSVal -> Object -> JSM ()

85setPropertyByName :: JSString -> JSVal -> Object -> JSM ()

92setPropertyByName name val this =

86setPropertyByName name val this =

@@ -172,14 +166,13 @@ deRefVal value = withJSVal value $ sendCommand . DeRefVal

172{-# INLINE deRefVal #-}

166{-# INLINE deRefVal #-}

173

167

174valueToBool :: JSVal -> JSM Bool

168valueToBool :: JSVal -> JSM Bool

175−valueToBool v@(JSVal ref) = liftIO (readIORef ref) >>= \case

176− 0 -> return False -- null

169+valueToBool (JSVal 0) = return False -- null

177− 1 -> return False -- undefined

170+valueToBool (JSVal 1) = return False -- undefined

178− 2 -> return False -- false

171+valueToBool (JSVal 2) = return False -- false

179− 3 -> return True -- true

172+valueToBool (JSVal 3) = return True -- true

180− _ -> withJSVal v $ \rval -> do

173+valueToBool v = withJSVal v $ \rval -> do

181− ~(ValueToBoolResult result) <- sendCommand (ValueToBool rval)

174+ ~(ValueToBoolResult result) <- sendCommand (ValueToBool rval)

182− return result

175+ return result

183{-# INLINE valueToBool #-}

176{-# INLINE valueToBool #-}

184

177

185valueToNumber :: JSVal -> JSM Double

178valueToNumber :: JSVal -> JSM Double

@@ -208,25 +201,17 @@ valueToJSONValue value = withJSVal value $ \rval -> do

208{-# INLINE valueToJSONValue #-}

201{-# INLINE valueToJSONValue #-}

209

202

210isNull :: JSVal -> JSM Bool

203isNull :: JSVal -> JSM Bool

211−isNull v@(JSVal ref) = liftIO (readIORef ref) >>= \case

212− 0 -> return True -- null

204+isNull (JSVal 0) = return True

213− 1 -> return False -- undefined

214− 2 -> return False -- false

215− 3 -> return False -- true

216− _ -> withJSVal v $ \rval -> do

205+isNull v = withJSVal v $ \rval -> do

217− ~(IsNullResult result) <- sendCommand $ IsNull rval

206+ ~(IsNullResult result) <- sendCommand $ IsNull rval

218− return result

207+ return result

219{-# INLINE isNull #-}

208{-# INLINE isNull #-}

220

209

221isUndefined :: JSVal -> JSM Bool

210isUndefined :: JSVal -> JSM Bool

222−isUndefined v@(JSVal ref) = liftIO (readIORef ref) >>= \case

211+isUndefined (JSVal 1) = return True

223− 0 -> return False -- null

224− 1 -> return True -- undefined

225− 2 -> return False -- false

226− 3 -> return False -- true

227− _ -> withJSVal v $ \rval -> do

212+isUndefined v = withJSVal v $ \rval -> do

228− ~(IsUndefinedResult result) <- sendCommand $ IsUndefined rval

213+ ~(IsUndefinedResult result) <- sendCommand $ IsUndefined rval

229− return result

214+ return result

230{-# INLINE isUndefined #-}

215{-# INLINE isUndefined #-}

231

216

232strictEqual :: JSVal -> JSVal -> JSM Bool

217strictEqual :: JSVal -> JSVal -> JSM Bool

jsaddle/src/Language/Javascript/JSaddle/Null.hsdeleted−56

@@ -1,56 +0,0 @@

1−{-# LANGUAGE LambdaCase #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−-----------------------------------------------------------------------------

4−--

5−-- Module : Language.Javascript.JSaddle.WebSockets

6−-- Copyright : (c) Hamish Mackenzie

7−-- License : MIT

8−--

9−-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>

10−--

11−-- |

12−--

13−-----------------------------------------------------------------------------

14−

15−module Language.Javascript.JSaddle.Null (

16− run

17−) where

18−

19−import Language.Javascript.JSaddle.Types

20− (BatchResults(..), JSM, JSStringReceived(..), Batch(..),

21− Results(..), Result(..), Command(..))

22−import Control.Concurrent.Chan (readChan, writeChan, newChan)

23−import Language.Javascript.JSaddle.Run (runJavaScript)

24−import Control.Concurrent (forkIO)

25−import Control.Monad (forever)

26−import Data.Aeson (Value(..))

27−import Data.Maybe (mapMaybe)

28−

29−-- | This is for performance testing JSaddle code that does not need to

30−-- to read anything back from the JavaScript context.

31−-- Anthing that does try to read will get JS null, 0 or "" back (depending

32−-- on how the value is read).

33−run :: JSM () -> IO ()

34−run f = do

35− batches <- newChan

36− (processResult, _processSyncResult, start) <- runJavaScript (writeChan batches) f

37− _ <- forkIO $ forever $

38− readChan batches >>= \case

39− Batch commands _ batchNumber ->

40− processResult $ BatchResults batchNumber . Success [] $ mapMaybe (\case

41− Left _ -> Nothing

42− Right command -> Just $

43− case command of

44− DeRefVal _ -> DeRefValResult 0 ""

45− ValueToBool _ -> ValueToBoolResult False

46− ValueToNumber _ -> ValueToNumberResult 0

47− ValueToString _ -> ValueToStringResult (JSStringReceived "")

48− ValueToJSON _ -> ValueToJSONResult (JSStringReceived "null")

49− ValueToJSONValue _ -> ValueToJSONValueResult Null

50− IsNull _ -> IsNullResult True

51− IsUndefined _ -> IsUndefinedResult False

52− StrictEqual _ _ -> StrictEqualResult False

53− InstanceOf _ _ -> InstanceOfResult False

54− PropertyNames _ -> PropertyNamesResult []

55− Sync -> SyncResult) commands

56− start

jsaddle/src/Language/Javascript/JSaddle/Object.hs+13−22

@@ -119,10 +119,9 @@ import Language.Javascript.JSaddle.Native

119 (newAsyncCallback, newSyncCallback, callAsFunction, callAsConstructor)

120import Language.Javascript.JSaddle.Monad (askJSM, JSM)

121import Language.Javascript.JSaddle.Types

122− (JSValueForSend(..), AsyncCommand(..), JSString, Object(..),

122+ (JSString, Object(..), SomeJSArray(..),

123− SomeJSArray(..), JSVal(..), JSCallAsFunction, JSContextRef(..))

123+ JSVal(..), JSCallAsFunction, JSContextRef(..))

124import JavaScript.Object.Internal (create, listProps)

125−import Language.Javascript.JSaddle.Run (sendAsyncCommand)

126#endif

125#endif

127import JavaScript.Array.Internal (fromListIO)

126import JavaScript.Array.Internal (fromListIO)

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

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

@@ -132,8 +131,6 @@ import Language.Javascript.JSaddle.Arguments (MakeArgs(..))

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

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

133import Language.Javascript.JSaddle.Properties

132import Language.Javascript.JSaddle.Properties

134import Control.Lens (IndexPreservingGetter, to)

133import Control.Lens (IndexPreservingGetter, to)

135−import Data.IORef (newIORef, readIORef)

136−import System.IO.Unsafe (unsafePerformIO)

137

134

138-- $setup

135-- $setup

139-- >>> import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

136-- >>> import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

@@ -484,16 +481,9 @@ freeFunction :: Function -> JSM ()

484freeFunction (Function callback _) = liftIO $

481freeFunction (Function callback _) = liftIO $

485 releaseCallback callback

482 releaseCallback callback

486#else

483#else

487−freeFunction (Function (Object (JSVal objectRef))) = do

484+freeFunction (Function object) = do

488− -- By now the callback should ideally have been removed from whatever

485+ free <- freeCallback <$> askJSM

489− -- events it was added to.

486+ liftIO $ free object

490− -- In case a call to the callback is still pending (perhaps just being sent

491− -- on the JS side) we use FreeCallback to queue the callback to be freed when

492− -- the next batch of results comes back fro JS.

493− -- We are not using withJSVal to keep JS value "alive" because FreeCallback

494− -- does not use the it.

495− n <- liftIO $ readIORef objectRef

496− sendAsyncCommand (FreeCallback (JSValueForSend n))

497#endif

487#endif

498

488

499instance ToJSVal Function where

489instance ToJSVal Function where

@@ -526,12 +516,13 @@ array args = do

526 Object . coerce <$> fromListIO rargs

516 Object . coerce <$> fromListIO rargs

527

517

528-- | JavaScript's global object

518-- | JavaScript's global object

519+global :: Object

529#ifdef ghcjs_HOST_OS

520#ifdef ghcjs_HOST_OS

521+global = js_window

530−foreign import javascript unsafe "$r = globalThis"

522+foreign import javascript unsafe "$r = window"

531− global :: Object

523+ js_window :: Object

532#else

524#else

533−global :: Object

525+global = Object (JSVal 4)

534−global = Object . JSVal . unsafePerformIO $ newIORef 4

535#endif

526#endif

536

527

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

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

@@ -556,7 +547,7 @@ objCallAsFunction :: MakeArgs args

556objCallAsFunction f this args = do

547objCallAsFunction f this args = do

557 rargs <- makeArgs args >>= liftIO . Array.fromListIO

548 rargs <- makeArgs args >>= liftIO . Array.fromListIO

558 liftIO $ js_apply f this rargs

549 liftIO $ js_apply f this rargs

559−foreign import javascript safe "$r = $1.apply($2, $3)"

550+foreign import javascript unsafe "$r = $1.apply($2, $3)"

560 js_apply :: Object -> Object -> MutableJSArray -> IO JSVal

551 js_apply :: Object -> Object -> MutableJSArray -> IO JSVal

561#else

552#else

562objCallAsFunction f this args = do

553objCallAsFunction f this args = do

@@ -576,7 +567,7 @@ objCallAsConstructor :: MakeArgs args

576objCallAsConstructor f args = do

567objCallAsConstructor f args = do

577 rargs <- makeArgs args >>= liftIO . Array.fromListIO

568 rargs <- makeArgs args >>= liftIO . Array.fromListIO

578 liftIO $ js_new f rargs

569 liftIO $ js_new f rargs

579−foreign import javascript safe "\

570+foreign import javascript unsafe "\

580 switch($2.length) {\

571 switch($2.length) {\

581 case 0 : $r = new $1(); break;\

572 case 0 : $r = new $1(); break;\

582 case 1 : $r = new $1($2[0]); break;\

573 case 1 : $r = new $1($2[0]); break;\

@@ -612,5 +603,5 @@ nullObject :: Object

612#ifdef ghcjs_HOST_OS

603#ifdef ghcjs_HOST_OS

613nullObject = Object nullRef

604nullObject = Object nullRef

614#else

605#else

615−nullObject = Object . JSVal . unsafePerformIO $ newIORef 0

606+nullObject = Object (JSVal 0)

616#endif

607#endif

jsaddle/src/Language/Javascript/JSaddle/Run.hs+74−111

@@ -2,8 +2,6 @@

2{-# LANGUAGE CPP #-}

3{-# LANGUAGE LambdaCase #-}

4{-# LANGUAGE OverloadedStrings #-}

5−{-# LANGUAGE MagicHash #-}

6−{-# LANGUAGE UnboxedTuples #-}

7-----------------------------------------------------------------------------

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

8--

6--

9-- Module : Language.Javascript.JSaddle.Run

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

@@ -37,59 +35,43 @@ module Language.Javascript.JSaddle.Run (

37) where

35) where

38

36

39#ifdef ghcjs_HOST_OS

37#ifdef ghcjs_HOST_OS

40−import Language.Javascript.JSaddle.Types (JSM, syncPoint, syncAfter)

38+import Language.Javascript.JSaddle.Types (JSM)

41import qualified JavaScript.Web.AnimationFrame as GHCJS

39import qualified JavaScript.Web.AnimationFrame as GHCJS

42 (waitForAnimationFrame)

40 (waitForAnimationFrame)

43#else

41#else

44−import Control.Exception (throwIO, evaluate)

42+import Control.Exception (throwIO)

45−import Control.Monad (void, when, zipWithM_)

43+import Control.Monad (void, when, forever, zipWithM_)

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

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

47import Control.Monad.Trans.Reader (ask, runReaderT)

45import Control.Monad.Trans.Reader (ask, runReaderT)

48import Control.Monad.STM (atomically)

46import Control.Monad.STM (atomically)

49−import Control.Concurrent (forkIO, myThreadId)

47+import Control.Concurrent (forkIO)

50import Control.Concurrent.STM.TChan

48import Control.Concurrent.STM.TChan

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

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

52import Control.Concurrent.STM.TVar

50import Control.Concurrent.STM.TVar

53 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)

51 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)

54import Control.Concurrent.MVar

52import Control.Concurrent.MVar

55− (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)

53+ (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar, readMVar)

56

54

57import System.IO.Unsafe (unsafeInterleaveIO)

55import System.IO.Unsafe (unsafeInterleaveIO)

58import System.Mem.Weak (addFinalizer)

56import System.Mem.Weak (addFinalizer)

59−import System.Random

60

57

61−import GHC.Base (IO(..), mkWeak#)

62−import GHC.Conc (ThreadId(..))

63import Data.Monoid ((<>))

58import Data.Monoid ((<>))

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

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

65import qualified Data.Map as M (lookup, delete, insert, empty, size)

60import qualified Data.Map as M (lookup, delete, insert, empty, size)

66−import qualified Data.Set as S (empty, member, insert, delete)

67import Data.Time.Clock (getCurrentTime,diffUTCTime)

61import Data.Time.Clock (getCurrentTime,diffUTCTime)

68−import Data.IORef

69− (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)

62+import Data.IORef (newIORef, atomicWriteIORef, readIORef)

70

63

71import Language.Javascript.JSaddle.Types

64import Language.Javascript.JSaddle.Types

72 (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),

65 (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),

73− Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand)

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

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

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

68+-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)

75−import Control.DeepSeq (force, deepseq)

69+import Control.DeepSeq (deepseq)

76−#if MIN_VERSION_base(4,11,0)

77−import GHC.Stats (getRTSStatsEnabled, getRTSStats, RTSStats(..), gcdetails_live_bytes, gc)

78−#else

79import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))

70import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))

80−#endif

71+import Data.Maybe (isJust)

81import Data.Foldable (forM_)

72import Data.Foldable (forM_)

82#endif

73#endif

83

74

84−#ifndef ghcjs_HOST_OS

85−#if MIN_VERSION_base(4,11,0)

86−currentBytesUsed = gcdetails_live_bytes . gc

87−#else

88−getRTSStatsEnabled = getGCStatsEnabled

89−getRTSStats = getGCStats

90−#endif

91−#endif

92−

93-- | Enable (or disable) JSaddle logging

75-- | Enable (or disable) JSaddle logging

94enableLogging :: Bool -> JSM ()

76enableLogging :: Bool -> JSM ()

95#ifdef ghcjs_HOST_OS

77#ifdef ghcjs_HOST_OS

@@ -100,6 +82,27 @@ enableLogging v = do

100 liftIO $ f v

82 liftIO $ f v

101#endif

83#endif

102

84

85+-- | Forces execution of pending asyncronous code

86+syncPoint :: JSM ()

87+#ifdef ghcjs_HOST_OS

88+syncPoint = return ()

89+#else

90+syncPoint = do

91+ SyncResult <- sendCommand Sync

92+ return ()

93+#endif

94+

95+-- | Forces execution of pending asyncronous code after performing `f`

96+syncAfter :: JSM a -> JSM a

97+#ifdef ghcjs_HOST_OS

98+syncAfter = id

99+#else

100+syncAfter f = do

101+ result <- f

102+ syncPoint

103+ return result

104+#endif

105+

103-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.

106-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.

104-- On GHC it will delay the execution of the current batch of asynchronous

107-- On GHC it will delay the execution of the current batch of asynchronous

105-- command when they are sent to JavaScript. It will not delay the Haskell

108-- command when they are sent to JavaScript. It will not delay the Haskell

@@ -125,12 +128,17 @@ nextAnimationFrame f = do

125 syncAfter (f t)

128 syncAfter (f t)

126

129

127#ifndef ghcjs_HOST_OS

130#ifndef ghcjs_HOST_OS

131+sendCommand :: Command -> JSM Result

132+sendCommand cmd = do

133+ s <- doSendCommand <$> JSM ask

134+ liftIO $ s cmd

135+

128sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal

136sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal

129sendLazyCommand cmd = do

137sendLazyCommand cmd = do

130 nextRefTVar <- nextRef <$> JSM ask

138 nextRefTVar <- nextRef <$> JSM ask

131 n <- liftIO . atomically $ do

139 n <- liftIO . atomically $ do

132 n <- subtract 1 <$> readTVar nextRefTVar

140 n <- subtract 1 <$> readTVar nextRefTVar

133− writeTVar nextRefTVar $! n

141+ writeTVar nextRefTVar n

134 return n

142 return n

135 s <- doSendAsyncCommand <$> JSM ask

143 s <- doSendAsyncCommand <$> JSM ask

136 liftIO $ s (cmd $ JSValueForSend n)

144 liftIO $ s (cmd $ JSValueForSend n)

@@ -143,45 +151,34 @@ sendAsyncCommand cmd = do

143

151

144runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())

152runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())

145runJavaScript sendBatch entryPoint = do

153runJavaScript sendBatch entryPoint = do

146− contextId' <- randomIO

147 startTime' <- getCurrentTime

154 startTime' <- getCurrentTime

148 recvMVar <- newEmptyMVar

155 recvMVar <- newEmptyMVar

149 lastAsyncBatch <- newEmptyMVar

156 lastAsyncBatch <- newEmptyMVar

150 commandChan <- newTChanIO

157 commandChan <- newTChanIO

151 callbacks <- newTVarIO M.empty

158 callbacks <- newTVarIO M.empty

152 nextRef' <- newTVarIO 0

159 nextRef' <- newTVarIO 0

153− finalizerThreads' <- newMVar S.empty

154− animationFrameHandlers' <- newMVar []

155 loggingEnabled <- newIORef False

160 loggingEnabled <- newIORef False

156− liveRefs' <- newMVar S.empty

157 let ctx = JSContextRef {

161 let ctx = JSContextRef {

158− contextId = contextId'

159− , startTime = startTime'

162+ startTime = startTime'

160− , doSendCommand = \cmd -> cmd `deepseq` do

163+ , doSendCommand = \cmd -> cmd `deepseq` do

161− result <- newEmptyMVar

164+ result <- newEmptyMVar

162− atomically $ writeTChan commandChan (Right (cmd, result))

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

163− unsafeInterleaveIO $

166+ unsafeInterleaveIO $

164− takeMVar result >>= \case

167+ takeMVar result >>= \case

165− (ThrowJSValue v) -> do

166− jsval <- wrapJSVal' ctx v

167− throwIO $ JSException jsval

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

168− r -> return r

169+ r -> return r

169− , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)

170+ , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)

170− , addCallback = \(Object (JSVal ioref)) cb -> do

171− val <- readIORef ioref

172− atomically $ modifyTVar' callbacks (M.insert val cb)

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

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

173− , nextRef = nextRef'

173+ , nextRef = nextRef'

174− , doEnableLogging = atomicWriteIORef loggingEnabled

174+ , doEnableLogging = atomicWriteIORef loggingEnabled

175− , finalizerThreads = finalizerThreads'

176− , animationFrameHandlers = animationFrameHandlers'

177− , liveRefs = liveRefs'

178− }

175+ }

179− processResults :: Bool -> Results -> IO ()

176+ let processResults :: Bool -> Results -> IO ()

180 processResults syncCallbacks = \case

177 processResults syncCallbacks = \case

181 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err

178 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err

182− (Callback n br (JSValueReceived fNumber) f this a) -> do

179+ (Callback n br f this a) -> do

183 putMVar recvMVar (n, br)

180 putMVar recvMVar (n, br)

184− f' <- runReaderT (unJSM $ wrapJSVal f) ctx

181+ f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx

185 this' <- runReaderT (unJSM $ wrapJSVal this) ctx

182 this' <- runReaderT (unJSM $ wrapJSVal this) ctx

186 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx

183 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx

187 logInfo (("Call " <> show fNumber <> " ") <>)

184 logInfo (("Call " <> show fNumber <> " ") <>)

@@ -206,11 +203,11 @@ runJavaScript sendBatch entryPoint = do

206 logInfo s =

203 logInfo s =

207 readIORef loggingEnabled >>= \case

204 readIORef loggingEnabled >>= \case

208 True -> do

205 True -> do

209− currentBytesUsedStr <- getRTSStatsEnabled >>= \case

206+ currentBytesUsedStr <- getGCStatsEnabled >>= \case

210− True -> show . currentBytesUsed <$> getRTSStats

207+ True -> show . currentBytesUsed <$> getGCStats

211 False -> return "??"

208 False -> return "??"

212 cbCount <- M.size <$> readTVarIO callbacks

209 cbCount <- M.size <$> readTVarIO callbacks

213− putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "

210+ putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount

214 False -> return ()

211 False -> return ()

215 _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->

212 _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->

216 readBatch nBatch commandChan >>= \case

213 readBatch nBatch commandChan >>= \case

@@ -220,26 +217,19 @@ runJavaScript sendBatch entryPoint = do

220 putMVar lastAsyncBatch batch

217 putMVar lastAsyncBatch batch

221 sendBatch batch

218 sendBatch batch

222 takeResult recvMVar nBatch >>= \case

219 takeResult recvMVar nBatch >>= \case

223− (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"

220+ (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"

224− (_, Success callbacksToFree results)

225− | length results /= length resultMVars -> error "Unexpected number of jsaddle results"

221+ (_, Success results) | length results /= length resultMVars -> error "Unexpected number of jsaddle results"

226− | otherwise -> do

227− zipWithM_ putMVar resultMVars results

222+ | otherwise -> zipWithM_ putMVar resultMVars results

228− forM_ callbacksToFree $ \(JSValueReceived val) ->

229− atomically (modifyTVar' callbacks (M.delete val))

230− (_, Failure callbacksToFree results exception err) -> do

223+ (_, Failure results exception) -> do

231− -- The exception will only be rethrown in Haskell if/when one of the

224+ -- The exception will only be rethrown in Haskell if/when one of the

232− -- missing results (if any) is evaluated.

225+ -- missing results (if any) is evaluated.

233− putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"

226+ putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"

234− putStrLn err

235− zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)

227+ zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)

236− forM_ callbacksToFree $ \(JSValueReceived val) ->

237− atomically (modifyTVar' callbacks (M.delete val))

238 return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)

228 return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)

239 where

229 where

240 numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m ()

230 numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m ()

241 numberForeverFromM_ !n f = do

231 numberForeverFromM_ !n f = do

242− _ <- f n

232+ f n

243 numberForeverFromM_ (succ n) f

233 numberForeverFromM_ (succ n) f

244 takeResult recvMVar nBatch =

234 takeResult recvMVar nBatch =

245 takeMVar recvMVar >>= \case

235 takeMVar recvMVar >>= \case

@@ -273,39 +263,12 @@ runJavaScript sendBatch entryPoint = do

273 loopAnimation (Left asyncCmd) (cmds, resultMVars) =

263 loopAnimation (Left asyncCmd) (cmds, resultMVars) =

274 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)

264 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)

275

265

276−addThreadFinalizer :: ThreadId -> IO () -> IO ()

277−addThreadFinalizer t@(ThreadId t#) (IO finalizer) =

278− IO $ \s -> case mkWeak# t# t finalizer s of { (# s1, _ #) -> (# s1, () #) }

279−

280−

281wrapJSVal :: JSValueReceived -> JSM JSVal

266wrapJSVal :: JSValueReceived -> JSM JSVal

282−wrapJSVal v = do

267+wrapJSVal (JSValueReceived ref) = do

283− ctx <- JSM ask

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

284− liftIO $ wrapJSVal' ctx v

269+ let result = JSVal ref

285−

286−wrapJSVal' :: JSContextRef -> JSValueReceived -> IO JSVal

287−wrapJSVal' ctx (JSValueReceived n) = do

288− ref <- liftIO $ newIORef n

289− when (n >= 5 || n < 0) $

270+ when (ref >= 5) $ do

290−#ifdef JSADDLE_CHECK_WRAPJSVAL

271+ ctx <- JSM ask

291− do lr <- takeMVar $ liveRefs ctx

292− if n `S.member` lr

293− then do

294− putStrLn $ "JS Value Ref " <> show n <> " already wrapped"

295− putMVar (liveRefs ctx) lr

296− else putMVar (liveRefs ctx) =<< evaluate (S.insert n lr)

297−#endif

298− void . mkWeakIORef ref $ do

299− ft <- takeMVar $ finalizerThreads ctx

300− t <- myThreadId

301− let tname = T.pack $ show t

302− doSendAsyncCommand ctx $ FreeRef tname $ JSValueForSend n

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

303− if tname `S.member` ft

304− then putMVar (finalizerThreads ctx) ft

305− else do

306− addThreadFinalizer t $ do

307− modifyMVar (finalizerThreads ctx) $ \s -> return (S.delete tname s, ())

308− doSendAsyncCommand ctx $ FreeRefs tname

309− putMVar (finalizerThreads ctx) =<< evaluate (S.insert tname ft)

310− return (JSVal ref)

273+ return result

311#endif

274#endif

jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+56−56

@@ -13,6 +13,7 @@

13

14module Language.Javascript.JSaddle.Run.Files (

15 indexHtml

16+ , jsaddleJs

16 , initState

17 , initState

17 , runBatch

18 , runBatch

18 , ghcjsHelpers

19 , ghcjsHelpers

@@ -30,23 +31,21 @@ indexHtml =

30 \</head>\n\

31 \</head>\n\

31 \<body>\n\

32 \<body>\n\

32 \</body>\n\

33 \</body>\n\

33− \<script src=\"/jsaddle.js\"></script>\n\

34+ \<script src=\"jsaddle.js\"></script>\n\

34 \</html>"

35 \</html>"

35

36

36initState :: ByteString

37initState :: ByteString

37initState = "\

38initState = "\

38 \ var jsaddle_values = new Map();\n\

39 \ var jsaddle_values = new Map();\n\

39− \ var jsaddle_free = new Map();\n\

40 \ jsaddle_values.set(0, null);\n\

41 \ jsaddle_values.set(1, undefined);\n\

42 \ jsaddle_values.set(2, false);\n\

43 \ jsaddle_values.set(3, true);\n\

44− \ jsaddle_values.set(4, globalThis);\n\

44+ \ jsaddle_values.set(4, window);\n\

45 \ var jsaddle_index = 100;\n\

46 \ var expectedBatch = 1;\n\

47− \ var lastResults = [0, {\"tag\": \"Success\", \"contents\": [[], []]}];\n\

47+ \ var lastResults = [0, {}];\n\

48 \ var inCallback = 0;\n\

49− \ var asyncBatch = null;\n\

50 \"

49 \"

51

50

52runBatch :: (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString

51runBatch :: (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString

@@ -54,7 +53,6 @@ runBatch send sendSync = "\

54 \ var runBatch = function(firstBatch, initialSyncDepth) {\n\

53 \ var runBatch = function(firstBatch, initialSyncDepth) {\n\

55 \ var processBatch = function(timestamp) {\n\

54 \ var processBatch = function(timestamp) {\n\

56 \ var batch = firstBatch;\n\

55 \ var batch = firstBatch;\n\

57− \ var callbacksToFree = [];\n\

58 \ var results = [];\n\

56 \ var results = [];\n\

59 \ inCallback++;\n\

57 \ inCallback++;\n\

60 \ try {\n\

58 \ try {\n\

@@ -69,15 +67,7 @@ runBatch send sendSync = "\

69 \ var d = cmd.Left;\n\

67 \ var d = cmd.Left;\n\

70 \ switch (d.tag) {\n\

68 \ switch (d.tag) {\n\

71 \ case \"FreeRef\":\n\

69 \ case \"FreeRef\":\n\

72− \ var refsToFree = jsaddle_free.get(d.contents[0]) || [];\n\

73− \ refsToFree.push(d.contents[1]);\n\

74− \ jsaddle_free.set(d.contents[0], refsToFree);\n\

75− \ break;\n\

76− \ case \"FreeRefs\":\n\

77− \ var refsToFree = jsaddle_free.get(d.contents) || [];\n\

78− \ for(var nRef = 0; nRef != refsToFree.length; nRef++)\n\

79− \ jsaddle_values.delete(refsToFree[nRef]);\n\

80− \ jsaddle_free.delete(d.contents);\n\

70+ \ jsaddle_values.delete(d.contents);\n\

81 \ break;\n\

71 \ break;\n\

82 \ case \"SetPropertyByName\":\n\

72 \ case \"SetPropertyByName\":\n\

83 \ jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]);\n\

73 \ jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]);\n\

@@ -93,10 +83,6 @@ runBatch send sendSync = "\

93 \ var n = d.contents[1];\n\

83 \ var n = d.contents[1];\n\

94 \ jsaddle_values.set(n, d.contents[0]);\n\

84 \ jsaddle_values.set(n, d.contents[0]);\n\

95 \ break;\n\

85 \ break;\n\

96− \ case \"JSONValueToValue\":\n\

97− \ var n = d.contents[1];\n\

98− \ jsaddle_values.set(n, d.contents[0]);\n\

99− \ break;\n\

100 \ case \"GetPropertyByName\":\n\

86 \ case \"GetPropertyByName\":\n\

101 \ var n = d.contents[2];\n\

87 \ var n = d.contents[2];\n\

102 \ jsaddle_values.set(n, jsaddle_values.get(d.contents[0])[d.contents[1]]);\n\

88 \ jsaddle_values.set(n, jsaddle_values.get(d.contents[0])[d.contents[1]]);\n\

@@ -116,9 +102,7 @@ runBatch send sendSync = "\

116 \ case \"NewAsyncCallback\":\n\

102 \ case \"NewAsyncCallback\":\n\

117 \ (function() {\n\

103 \ (function() {\n\

118 \ var nFunction = d.contents;\n\

104 \ var nFunction = d.contents;\n\

119− \ var func = function() {\n\

120− \ var nFunctionInFunc = ++jsaddle_index;\n\

121− \ jsaddle_values.set(nFunctionInFunc, func);\n\

105+ \ jsaddle_values.set(nFunction, function() {\n\

122 \ var nThis = ++jsaddle_index;\n\

106 \ var nThis = ++jsaddle_index;\n\

123 \ jsaddle_values.set(nThis, this);\n\

107 \ jsaddle_values.set(nThis, this);\n\

124 \ var args = [];\n\

108 \ var args = [];\n\

@@ -127,17 +111,13 @@ runBatch send sendSync = "\

127 \ jsaddle_values.set(nArg, arguments[i]);\n\

111 \ jsaddle_values.set(nArg, arguments[i]);\n\

128 \ args[i] = nArg;\n\

112 \ args[i] = nArg;\n\

129 \ }\n\

113 \ }\n\

130− \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n\

114+ \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n\

131− \ };\n\

132− \ jsaddle_values.set(nFunction, func);\n\

133− \ })();\n\

115+ \ })})();\n\

134 \ break;\n\

116 \ break;\n\

135 \ case \"NewSyncCallback\":\n\

117 \ case \"NewSyncCallback\":\n\

136 \ (function() {\n\

118 \ (function() {\n\

137 \ var nFunction = d.contents;\n\

119 \ var nFunction = d.contents;\n\

138− \ var func = function() {\n\

139− \ var nFunctionInFunc = ++jsaddle_index;\n\

140− \ jsaddle_values.set(nFunctionInFunc, func);\n\

120+ \ jsaddle_values.set(nFunction, function() {\n\

141 \ var nThis = ++jsaddle_index;\n\

121 \ var nThis = ++jsaddle_index;\n\

142 \ jsaddle_values.set(nThis, this);\n\

122 \ jsaddle_values.set(nThis, this);\n\

143 \ var args = [];\n\

123 \ var args = [];\n\

@@ -149,19 +129,14 @@ runBatch send sendSync = "\

149 case sendSync of

129 case sendSync of

150 Just s ->

130 Just s ->

151 " if(inCallback > 0) {\n\

131 " if(inCallback > 0) {\n\

152− \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n\

132+ \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n\

153 \ } else {\n\

133 \ } else {\n\

154− \ runBatch(" <> s "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> ", 1);\n\

134+ \ runBatch(" <> s "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> ", 1);\n\

155 \ }\n"

135 \ }\n"

156 Nothing ->

136 Nothing ->

157− " " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n"

137+ " " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n"

158 ) <>

138 ) <>

159− " };\n\

139+ " })})();\n\

160− \ jsaddle_values.set(nFunction, func);\n\

161− \ })();\n\

162− \ break;\n\

163− \ case \"FreeCallback\":\n\

164− \ callbacksToFree.push(d.contents);\n\

165 \ break;\n\

140 \ break;\n\

166 \ case \"CallAsFunction\":\n\

141 \ case \"CallAsFunction\":\n\

167 \ var n = d.contents[3];\n\

142 \ var n = d.contents[3];\n\

@@ -204,7 +179,7 @@ runBatch send sendSync = "\

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

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

205 \ break;\n\

180 \ break;\n\

206 \ case \"SyncWithAnimationFrame\":\n\

181 \ case \"SyncWithAnimationFrame\":\n\

207− \ var n = d.contents;\n\

182+ \ var n = d.contents[0];\n\

208 \ jsaddle_values.set(n, timestamp);\n\

183 \ jsaddle_values.set(n, timestamp);\n\

209 \ break;\n\

184 \ break;\n\

210 \ case \"StartSyncBlock\":\n\

185 \ case \"StartSyncBlock\":\n\

@@ -247,7 +222,7 @@ runBatch send sendSync = "\

247 \ (v === true ) ? [3, \"\"] :\n\

222 \ (v === true ) ? [3, \"\"] :\n\

248 \ (typeof v === \"number\") ? [-1, v.toString()] :\n\

223 \ (typeof v === \"number\") ? [-1, v.toString()] :\n\

249 \ (typeof v === \"string\") ? [-2, v]\n\

224 \ (typeof v === \"string\") ? [-2, v]\n\

250− \ : [-3, \"\"];\n\

225+ \ : [n, \"\"];\n\

251 \ results.push({\"tag\": \"DeRefValResult\", \"contents\": c});\n\

226 \ results.push({\"tag\": \"DeRefValResult\", \"contents\": c});\n\

252 \ break;\n\

227 \ break;\n\

253 \ case \"IsNull\":\n\

228 \ case \"IsNull\":\n\

@@ -276,18 +251,17 @@ runBatch send sendSync = "\

276 \ }\n\

251 \ }\n\

277 \ }\n\

252 \ }\n\

278 \ if(syncDepth <= 0) {\n\

253 \ if(syncDepth <= 0) {\n\

279− \ lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": [callbacksToFree, results]}];\n\

254+ \ lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": results}];\n\

280 \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> "\n\

255 \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> "\n\

281 \ break;\n\

256 \ break;\n\

282 \ } else {\n" <> (

257 \ } else {\n" <> (

283 case sendSync of

258 case sendSync of

284 Just s ->

259 Just s ->

285− " lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": [callbacksToFree, results]}];\n\

260+ " lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": results}];\n\

286 \ batch = " <> s "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> ";\n\

261 \ batch = " <> s "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> ";\n\

287− \ results = [];\n\

262+ \ results = [];\n"

288− \ callbacksToFree = [];\n"

289 Nothing ->

263 Nothing ->

290− " " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Success\", \"contents\": [callbacksToFree, results]}]}" <> "\n\

264+ " " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Success\", \"contents\": results}]}" <> "\n\

291 \ break;\n"

265 \ break;\n"

292 ) <>

266 ) <>

293 " }\n\

267 " }\n\

@@ -302,8 +276,7 @@ runBatch send sendSync = "\

302 \ } else {\n\

276 \ } else {\n\

303 \ batch = " <> s "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> ";\n\

277 \ batch = " <> s "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> ";\n\

304 \ }\n\

278 \ }\n\

305− \ results = [];\n\

279+ \ results = [];\n"

306− \ callbacksToFree = [];\n"

307 Nothing ->

280 Nothing ->

308 " " <> send "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> "\n\

281 " " <> send "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> "\n\

309 \ break;\n"

282 \ break;\n"

@@ -315,15 +288,7 @@ runBatch send sendSync = "\

315 \ catch (err) {\n\

288 \ catch (err) {\n\

316 \ var n = ++jsaddle_index;\n\

289 \ var n = ++jsaddle_index;\n\

317 \ jsaddle_values.set(n, err);\n\

290 \ jsaddle_values.set(n, err);\n\

318− \ console.log(err);\n\

319− \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Failure\", \"contents\": [callbacksToFree, results, n, String(err)]}]}" <> "\n\

291+ \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Failure\", \"contents\": [results, n]}]}" <> "\n\

320− \ }\n\

321− \ if(inCallback == 1) {\n\

322− \ while(asyncBatch !== null) {\n\

323− \ var b = asyncBatch;\n\

324− \ asyncBatch = null;\n\

325− \ if(b[2] == expectedBatch) runBatch(b);\n\

326− \ }\n\

327 \ }\n\

292 \ }\n\

328 \ inCallback--;\n\

293 \ inCallback--;\n\

329 \ };\n\

294 \ };\n\

@@ -337,6 +302,41 @@ runBatch send sendSync = "\

337 \ runBatch(batch);\n\

302 \ runBatch(batch);\n\

338 \"

303 \"

339

304

305+-- Use this to generate this string for embedding

306+-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy

307+jsaddleJs :: ByteString

308+jsaddleJs = "\

309+ \if(typeof global !== \"undefined\") {\n\

310+ \ global.window = global;\n\

311+ \ global.WebSocket = require('ws');\n\

312+ \}\n\

313+ \\n\

314+ \var connect = function() {\n\

315+ \ var wsaddress =\n\

316+ \ typeof window.location === \"undefined\"\n\

317+ \ ? \"ws://localhost:3709/\"\n\

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

319+ \\n\

320+ \ var ws = new WebSocket(wsaddress);\n\

321+ \\n\

322+ \ ws.onopen = function(e) {\n\

323+ \ " <> initState <> "\

324+ \\n\

325+ \ ws.onmessage = function(e) {\n\

326+ \ var batch = JSON.parse(e.data);\n\

327+ \\n\

328+ \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));") Nothing <> "\

329+ \ };\n\

330+ \ };\n\

331+ \ ws.onerror = function() {\n\

332+ \ setTimeout(connect, 1000);\n\

333+ \ };\n\

334+ \}\n\

335+ \\n\

336+ \ " <> ghcjsHelpers <> "\

337+ \connect();\n\

338+ \"

339+

340ghcjsHelpers :: ByteString

341ghcjsHelpers = "\

342 \function h$isNumber(o) {\

jsaddle/src/Language/Javascript/JSaddle/Types.hs+29−131

@@ -58,14 +58,8 @@ module Language.Javascript.JSaddle.Types (

58 -- * Debugging

59 , JSadddleHasCallStack

60

61− -- * Sync JSM

62− , syncPoint

63− , syncAfter

64−

65−#ifndef ghcjs_HOST_OS

66− , sendCommand

67−

68 -- * JavaScript Context Commands

61 -- * JavaScript Context Commands

62+#ifndef ghcjs_HOST_OS

69 , MutabilityType(..)

63 , MutabilityType(..)

70 , Mutable

64 , Mutable

71 , Immutable

65 , Immutable

@@ -95,14 +89,13 @@ import GHCJS.Nullable (Nullable(..))

95import GHCJS.Prim.Internal (JSVal(..), JSValueRef)

89import GHCJS.Prim.Internal (JSVal(..), JSValueRef)

96import Data.JSString.Internal.Type (JSString(..))

90import Data.JSString.Internal.Type (JSString(..))

97import Control.DeepSeq (NFData(..))

91import Control.DeepSeq (NFData(..))

98−import Control.Monad.Catch (MonadThrow, MonadCatch(..), MonadMask(..))

99import Control.Monad.Trans.Cont (ContT(..))

92import Control.Monad.Trans.Cont (ContT(..))

100import Control.Monad.Trans.Error (Error(..), ErrorT(..))

93import Control.Monad.Trans.Error (Error(..), ErrorT(..))

101import Control.Monad.Trans.Except (ExceptT(..))

94import Control.Monad.Trans.Except (ExceptT(..))

102import Control.Monad.Trans.Identity (IdentityT(..))

95import Control.Monad.Trans.Identity (IdentityT(..))

103import Control.Monad.Trans.List (ListT(..))

96import Control.Monad.Trans.List (ListT(..))

104import Control.Monad.Trans.Maybe (MaybeT(..))

97import Control.Monad.Trans.Maybe (MaybeT(..))

105−import Control.Monad.Trans.Reader (ReaderT(..), ask)

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

106import Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))

99import Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))

107import Control.Monad.Trans.RWS.Strict as Strict (RWST(..))

100import Control.Monad.Trans.RWS.Strict as Strict (RWST(..))

108import Control.Monad.Trans.State.Lazy as Lazy (StateT(..))

101import Control.Monad.Trans.State.Lazy as Lazy (StateT(..))

@@ -113,9 +106,6 @@ import Control.Monad.Trans.Class (MonadTrans(..))

113import Control.Monad.Fix (MonadFix)

106import Control.Monad.Fix (MonadFix)

114import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))

107import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))

115import Control.Concurrent.STM.TVar (TVar)

108import Control.Concurrent.STM.TVar (TVar)

116−import Control.Concurrent.MVar (MVar)

117−import Data.Int (Int64)

118−import Data.Set (Set)

119import Data.Text (Text)

109import Data.Text (Text)

120import Data.Time.Clock (UTCTime(..))

110import Data.Time.Clock (UTCTime(..))

121import Data.Typeable (Typeable)

111import Data.Typeable (Typeable)

@@ -123,8 +113,6 @@ import Data.Coerce (coerce, Coercible)

123import Data.Aeson

113import Data.Aeson

124 (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..), Value)

114 (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..), Value)

125import GHC.Generics (Generic)

115import GHC.Generics (Generic)

126−import Control.Monad.IO.Unlift (MonadUnliftIO)

127−import qualified Control.Monad.Fail as Fail

128#endif

116#endif

129

117

130#if MIN_VERSION_base(4,9,0) && defined(CHECK_UNCHECKED)

118#if MIN_VERSION_base(4,9,0) && defined(CHECK_UNCHECKED)

@@ -141,16 +129,13 @@ import GHC.Exts (Constraint)

141type JSContextRef = ()

129type JSContextRef = ()

142#else

130#else

143data JSContextRef = JSContextRef {

131data JSContextRef = JSContextRef {

144− contextId :: Int64

145− , startTime :: UTCTime

132+ startTime :: UTCTime

146− , doSendCommand :: Command -> IO Result

133+ , doSendCommand :: Command -> IO Result

147− , doSendAsyncCommand :: AsyncCommand -> IO ()

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

148− , addCallback :: Object -> JSCallAsFunction -> IO ()

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

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

149− , nextRef :: TVar JSValueRef

137+ , nextRef :: TVar JSValueRef

150− , doEnableLogging :: Bool -> IO ()

138+ , doEnableLogging :: Bool -> IO ()

151− , finalizerThreads :: MVar (Set Text)

152− , animationFrameHandlers :: MVar [Double -> JSM ()]

153− , liveRefs :: MVar (Set Int64)

154}

139}

155#endif

140#endif

156

141

@@ -166,56 +151,9 @@ data JSContextRef = JSContextRef {

166type JSM = IO

151type JSM = IO

167#else

152#else

168newtype JSM a = JSM { unJSM :: ReaderT JSContextRef IO a }

153newtype JSM a = JSM { unJSM :: ReaderT JSContextRef IO a }

169− deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadThrow, MonadUnliftIO, Fail.MonadFail)

154+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

170−

171−instance MonadCatch JSM where

172− t `catch` c = JSM (unJSM (syncAfter t) `catch` \e -> unJSM (c e))

173−

174−instance MonadMask JSM where

175− mask a = JSM $ mask $ \unmask -> unJSM (a $ q unmask)

176− where q :: (ReaderT JSContextRef IO a -> ReaderT JSContextRef IO a) -> JSM a -> JSM a

177− q unmask (JSM b) = syncAfter . JSM $ unmask b

178− uninterruptibleMask a =

179− JSM $ uninterruptibleMask $ \unmask -> unJSM (a $ q unmask)

180− where q :: (ReaderT JSContextRef IO a -> ReaderT JSContextRef IO a) -> JSM a -> JSM a

181− q unmask (JSM b) = syncAfter . JSM $ unmask b

182−#if MIN_VERSION_exceptions(0,9,0)

183− generalBracket acquire release use =

184− JSM $ generalBracket

185− (unJSM acquire)

186− (\resource exitCase -> unJSM $ release resource exitCase)

187− (unJSM . syncAfter . use)

188#endif

155#endif

189

156

190−#endif

191−

192−-- | Forces execution of pending asyncronous code

193−syncPoint :: JSM ()

194−#ifdef ghcjs_HOST_OS

195−syncPoint = return ()

196−#else

197−syncPoint = do

198− SyncResult <- sendCommand Sync

199− return ()

200−#endif

201−

202−-- | Forces execution of pending asyncronous code after performing `f`

203−syncAfter :: JSM a -> JSM a

204−#ifdef ghcjs_HOST_OS

205−syncAfter = id

206−#else

207−syncAfter f = do

208− result <- f

209− syncPoint

210− return result

211−#endif

212−

213−#ifndef ghcjs_HOST_OS

214−sendCommand :: Command -> JSM Result

215−sendCommand cmd = do

216− s <- doSendCommand <$> JSM ask

217− liftIO $ s cmd

218−#endif

219

157

220-- | Type we can give to functions that are pure when using ghcjs, but

158-- | Type we can give to functions that are pure when using ghcjs, but

221-- live in JSM when using jsaddle.

159-- live in JSM when using jsaddle.

@@ -265,7 +203,7 @@ type MonadJSM = MonadIO

265class (Applicative m, MonadIO m) => MonadJSM m where

203class (Applicative m, MonadIO m) => MonadJSM m where

266 liftJSM' :: JSM a -> m a

204 liftJSM' :: JSM a -> m a

267

205

268− default liftJSM' :: (MonadJSM m', MonadTrans t, m ~ t m') => JSM a -> m a

206+ default liftJSM' :: (MonadJSM m', MonadTrans t) => JSM a' -> t m' a'

269 liftJSM' = lift . (liftJSM' :: MonadJSM m' => JSM a -> m' a)

207 liftJSM' = lift . (liftJSM' :: MonadJSM m' => JSM a -> m' a)

270 {-# INLINE liftJSM' #-}

208 {-# INLINE liftJSM' #-}

271

209

@@ -273,57 +211,19 @@ instance MonadJSM JSM where

273 liftJSM' = id

211 liftJSM' = id

274 {-# INLINE liftJSM' #-}

212 {-# INLINE liftJSM' #-}

275

213

276−instance (MonadJSM m) => MonadJSM (ContT r m) where

214+instance (MonadJSM m) => MonadJSM (ContT r m)

277− liftJSM' = lift . liftJSM'

278− {-# INLINE liftJSM' #-}

279−

280−instance (Error e, MonadJSM m) => MonadJSM (ErrorT e m) where

215+instance (Error e, MonadJSM m) => MonadJSM (ErrorT e m)

281− liftJSM' = lift . liftJSM'

282− {-# INLINE liftJSM' #-}

283−

284−instance (MonadJSM m) => MonadJSM (ExceptT e m) where

216+instance (MonadJSM m) => MonadJSM (ExceptT e m)

285− liftJSM' = lift . liftJSM'

286− {-# INLINE liftJSM' #-}

287−

288−instance (MonadJSM m) => MonadJSM (IdentityT m) where

217+instance (MonadJSM m) => MonadJSM (IdentityT m)

289− liftJSM' = lift . liftJSM'

290− {-# INLINE liftJSM' #-}

291−

292−instance (MonadJSM m) => MonadJSM (ListT m) where

218+instance (MonadJSM m) => MonadJSM (ListT m)

293− liftJSM' = lift . liftJSM'

294− {-# INLINE liftJSM' #-}

295−

296−instance (MonadJSM m) => MonadJSM (MaybeT m) where

219+instance (MonadJSM m) => MonadJSM (MaybeT m)

297− liftJSM' = lift . liftJSM'

298− {-# INLINE liftJSM' #-}

299−

300−instance (MonadJSM m) => MonadJSM (ReaderT r m) where

220+instance (MonadJSM m) => MonadJSM (ReaderT r m)

301− liftJSM' = lift . liftJSM'

302− {-# INLINE liftJSM' #-}

303−

304−instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.RWST r w s m) where

221+instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.RWST r w s m)

305− liftJSM' = lift . liftJSM'

306− {-# INLINE liftJSM' #-}

307−

308−instance (Monoid w, MonadJSM m) => MonadJSM (Strict.RWST r w s m) where

222+instance (Monoid w, MonadJSM m) => MonadJSM (Strict.RWST r w s m)

309− liftJSM' = lift . liftJSM'

310− {-# INLINE liftJSM' #-}

311−

312−instance (MonadJSM m) => MonadJSM (Lazy.StateT s m) where

223+instance (MonadJSM m) => MonadJSM (Lazy.StateT s m)

313− liftJSM' = lift . liftJSM'

314− {-# INLINE liftJSM' #-}

315−

316−instance (MonadJSM m) => MonadJSM (Strict.StateT s m) where

224+instance (MonadJSM m) => MonadJSM (Strict.StateT s m)

317− liftJSM' = lift . liftJSM'

318− {-# INLINE liftJSM' #-}

319−

320−instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.WriterT w m) where

225+instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.WriterT w m)

321− liftJSM' = lift . liftJSM'

322− {-# INLINE liftJSM' #-}

323−

324−instance (Monoid w, MonadJSM m) => MonadJSM (Strict.WriterT w m) where

226+instance (Monoid w, MonadJSM m) => MonadJSM (Strict.WriterT w m)

325− liftJSM' = lift . liftJSM'

326− {-# INLINE liftJSM' #-}

327

227

328instance MonadRef JSM where

228instance MonadRef JSM where

329 type Ref JSM = Ref IO

229 type Ref JSM = Ref IO

@@ -396,7 +296,7 @@ type MutableJSArray = SomeJSArray Mutable

396type STJSArray s = SomeJSArray (STMutable s)

296type STJSArray s = SomeJSArray (STMutable s)

397

297

398-- | See 'JavaScript.Object.Internal.Object'

298-- | See 'JavaScript.Object.Internal.Object'

399−newtype Object = Object JSVal

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

400

300

401-- | See 'GHCJS.Nullable.Nullable'

301-- | See 'GHCJS.Nullable.Nullable'

402newtype Nullable a = Nullable a

302newtype Nullable a = Nullable a

@@ -420,8 +320,7 @@ newtype JSStringForSend = JSStringForSend Text deriving(Show, ToJSON, FromJSON,

420instance NFData JSStringForSend

320instance NFData JSStringForSend

421

321

422-- | Command sent to a JavaScript context for execution asynchronously

322-- | Command sent to a JavaScript context for execution asynchronously

423−data AsyncCommand = FreeRef Text JSValueForSend

323+data AsyncCommand = FreeRef JSValueForSend

424− | FreeRefs Text

425 | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend

324 | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend

426 | SetPropertyAtIndex JSObjectForSend Int JSValueForSend

325 | SetPropertyAtIndex JSObjectForSend Int JSValueForSend

427 | StringToValue JSStringForSend JSValueForSend

326 | StringToValue JSStringForSend JSValueForSend

@@ -434,7 +333,6 @@ data AsyncCommand = FreeRef Text JSValueForSend

434 | NewEmptyObject JSValueForSend

333 | NewEmptyObject JSValueForSend

435 | NewAsyncCallback JSValueForSend

334 | NewAsyncCallback JSValueForSend

436 | NewSyncCallback JSValueForSend

335 | NewSyncCallback JSValueForSend

437− | FreeCallback JSValueForSend

438 | NewArray [JSValueForSend] JSValueForSend

336 | NewArray [JSValueForSend] JSValueForSend

439 | EvaluateScript JSStringForSend JSValueForSend

337 | EvaluateScript JSStringForSend JSValueForSend

440 | SyncWithAnimationFrame JSValueForSend

338 | SyncWithAnimationFrame JSValueForSend

@@ -503,8 +401,8 @@ instance ToJSON Result where

503

401

504instance FromJSON Result

402instance FromJSON Result

505

403

506−data BatchResults = Success [JSValueReceived] [Result]

404+data BatchResults = Success [Result]

507− | Failure [JSValueReceived] [Result] JSValueReceived String

405+ | Failure [Result] JSValueReceived

508 deriving (Show, Generic)

406 deriving (Show, Generic)

509

407

510instance ToJSON BatchResults where

408instance ToJSON BatchResults where

@@ -514,7 +412,7 @@ instance FromJSON BatchResults

514

412

515data Results = BatchResults Int BatchResults

413data Results = BatchResults Int BatchResults

516 | Duplicate Int Int

414 | Duplicate Int Int

517− | Callback Int BatchResults JSValueReceived JSValueReceived JSValueReceived [JSValueReceived]

415+ | Callback Int BatchResults JSValueReceived JSValueReceived [JSValueReceived]

518 | ProtocolError Text

416 | ProtocolError Text

519 deriving (Show, Generic)

417 deriving (Show, Generic)

520

418

jsaddle/src/Language/Javascript/JSaddle/Value.hs+3−5

@@ -618,17 +618,15 @@ foreign import javascript unsafe "$r = ($1 === undefined)?0:\

618 (typeof $1===\"string\")?4:\

619 (typeof $1===\"object\")?5:-1;" jsrefGetType :: JSVal -> Int

620#else

621−deRefVal value = do

621+deRefVal value = toJSVal value >>= N.deRefVal >>= \result -> return $

622− v <- toJSVal value

623− result <- N.deRefVal v

624− return $ case result of

622+ case result of

625 DeRefValResult 0 _ -> ValNull

623 DeRefValResult 0 _ -> ValNull

626 DeRefValResult 1 _ -> ValUndefined

624 DeRefValResult 1 _ -> ValUndefined

627 DeRefValResult 2 _ -> ValBool False

625 DeRefValResult 2 _ -> ValBool False

628 DeRefValResult 3 _ -> ValBool True

626 DeRefValResult 3 _ -> ValBool True

629 DeRefValResult (-1) s -> ValNumber (read (T.unpack s))

627 DeRefValResult (-1) s -> ValNumber (read (T.unpack s))

630 DeRefValResult (-2) s -> ValString s

628 DeRefValResult (-2) s -> ValString s

631− DeRefValResult (-3) _ -> ValObject (Object v)

629+ DeRefValResult ref _ -> ValObject (Object (JSVal ref))

632 _ -> error "Unexpected result dereferencing JSaddle value"

630 _ -> error "Unexpected result dereferencing JSaddle value"

633#endif

631#endif

634

632

nix/hix.nixdeleted−8

@@ -1,8 +0,0 @@

1−{pkgs, ...}:

2−{ modules = [({pkgs, ...}: {

3− packages.webkit2gtk3-javascriptcore.components.library.doHaddock = false;

4− })];

5− shell.buildInputs = [ pkgs.nodejs ];

6− shell.tools.cabal = {};

7− shell.crossPlatforms = p: [ p.ghcjs ];

8−}

travis/build.sh+12−2

@@ -6,8 +6,18 @@ GHCVER=`ghc --numeric-version`

6

7JSADDLE_WARP_VERSION=`head -n2 jsaddle-warp/jsaddle-warp.cabal | tail -n1 | sed 's/[^0-9.]//g'`

8

9+if [[ -d .cabal && -d .ghc ]]; then

10+ cp -a .cabal .ghc /root

11+fi

12+

9cabal update

13cabal update

10−cabal new-build 'jsaddle-warp:lib:jsaddle-warp' 'jsaddle-warp:test:test-tool'

14+cabal new-build --constraint='Cabal>=1.24.2.0' 'jsaddle-warp:lib:jsaddle-warp' 'jsaddle-warp:test:test-tool'

11cd jsaddle-warp

15cd jsaddle-warp

12−GHC_PACKAGE_PATH=/opt/ghc/$GHCVER/lib/ghc-$GHCVER/package.conf.d:~/.cabal/store/ghc-$GHCVER/package.db:../dist-newstyle/packagedb/ghc-$GHCVER ../dist-newstyle/build/x86_64-linux/ghc-$GHCVER/jsaddle-warp-$JSADDLE_WARP_VERSION/t/test-tool/build/test-tool/test-tool ../jsaddle

16+GHC_PACKAGE_PATH=/opt/ghc/$GHCVER/lib/ghc-$GHCVER/package.conf.d:~/.cabal/store/ghc-$GHCVER/package.db:./dist-newstyle/packagedb/ghc-$GHCVER jsaddle_datadir=`pwd` ../dist-newstyle/build/jsaddle-warp-$JSADDLE_WARP_VERSION/build/test-tool/test-tool ../jsaddle-warp

17+

18+# update the cache

19+rm -rf .cabal

20+cp -a /root/.cabal ./

21+rm -rf .ghc

22+cp -a /root/.ghc ./

13

23