903c374...master · jsaddle

.travis.yml+40−24

since splitsnapshots

unifiedsplit

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

1−sudo: required

1+language: nix

2−services:

2+nix: 2.2.2

3− - docker

4

3

5−cache:

4+jobs:

6− directories:

5+ include:

7− - .cabal

6+ - stage: Build

8− - .ghc

7+ env: OS=linux GHCVER=ghc865

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

9

24

10−env:

25+install:

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

26+- sudo mkdir -p /etc/nix

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

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

13− - CABALVER=1.24 GHCVER=8.0.2 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

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

17−

18−before_install:

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

20

29

21script:

30script:

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

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

23− sh -x -c "

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

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

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

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

34+- |

26− ./travis/build.sh"

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+

27notifications:

44notifications:

28 irc:

45 irc:

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

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

30− skip_join: true

31− email: true

47+ email: true

README.md+34−14

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

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

14import Control.Lens ((^.))

15import Language.Javascript.JSaddle

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

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

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

17

18

18main = run 3709 $ do

19main = run 3709 $ do

19 doc <- jsg "document"

20 doc <- jsg "document"

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

79 appendChild newParagraph text

80 appendChild newParagraph text

80 appendChild body (Just newParagraph)

81 appendChild body (Just newParagraph)

81 return ()

82 return ()

82−

83+

83 -- Make an exit button

84 -- Make an exit button

84 exitMVar <- liftIO newEmptyMVar

85 exitMVar <- liftIO newEmptyMVar

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

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

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

102

103

103## How does it work on GHC

104## How does it work on GHC

104

105

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

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

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.

107+

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.

107

119

108−### Why use WebSockets?

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

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

109

122

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

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

126+WebKitGTK. With the newer WebKit2 interface this level of access 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).

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

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

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

128+

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.

114

131

115### JSVal

132### JSVal

116

133

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

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

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

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

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

122

139

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

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

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

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

125lazy execution of the JSaddle code.

142lazy execution of the JSaddle code.

126

143

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

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

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

129

146

130### JSStrings

147### JSStrings

131

148

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`.

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`.

133

150

134### Lazy Execution

151### Lazy Execution

135

152

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

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.

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.

162

179

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

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

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

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

165

182

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

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

167

184

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

196at the point the exception is thrown.

213at the point the exception is thrown.

197

214

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

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

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

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

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

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

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

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

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

219There 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+3−35

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

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

2−

3packages:

1packages:

4 jsaddle/

2 jsaddle/

5 jsaddle-warp/

3 jsaddle-warp/

6 jsaddle-wkwebview/

4 jsaddle-wkwebview/

7−-- jsaddle-webkitgtk/

8 jsaddle-webkit2gtk/

5 jsaddle-webkit2gtk/

9 jsaddle-clib/

6 jsaddle-clib/

10

7

11−package gi-atk

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

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

9+

13−package gi-cairo

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

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.nixdeleted−8

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

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.nixdeleted−9

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

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+4−3

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

1name: jsaddle-clib

2−version: 0.9.0.0

2+version: 0.9.8.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

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

21 Language.Javascript.JSaddle.CLib

22 Language.Javascript.JSaddle.CLib.Internal

23 build-depends:

24− aeson >=0.8.0.2 && <1.3,

24+ aeson >=0.8.0.2 && <1.6,

25 base <5,

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

26 bytestring >=0.10.6.0 && <0.11,

27 bytestring >=0.10.6.0 && <0.11,

27 jsaddle >= 0.9.0.0 && <0.10,

28 jsaddle >= 0.9.0.0 && <0.10,

28 data-default,

29 data-default,

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

32 Include-dirs: cbits/include

33 Include-dirs: cbits/include

33 Includes: jsaddle.h

34 Includes: jsaddle.h

34 Install-includes: jsaddle.h

35 Install-includes: jsaddle.h

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

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

36 if impl(ghcjs)

37 if impl(ghcjs)

37 hs-source-dirs: src-ghcjs

38 hs-source-dirs: src-ghcjs

38 else

39 else

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

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

8 , appConfigToAppCallbacks

9 ) where

10

11+import Prelude ()

12+import Prelude.Compat

13+

11import Control.Monad (void)

14import Control.Monad (void)

12import Control.Concurrent (forkIO)

15import Control.Concurrent (forkIO)

13

16

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

16import Data.ByteString.Char8 (unpack)

19import Data.ByteString.Char8 (unpack)

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

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

18import Data.Default (def, Default)

21import Data.Default (def, Default)

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

20import Data.Text (Text)

22import Data.Text (Text)

21import qualified Data.Text.Encoding as T

23import qualified Data.Text.Encoding as T

22

24

jsaddle-warp/default.nixdeleted−25

@@ -1,25 +0,0 @@

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

2−, doctest, filepath, foreign-store, ghc-prim, http-types, jsaddle

3−, lens, network, primitive, process, QuickCheck, ref-tf, stdenv

4−, stm, text, time, transformers, uuid, uuid-types, wai

5−, wai-websockets, warp, webdriver, websockets

6−}:

7−mkDerivation {

8− pname = "jsaddle-warp";

9− version = "0.9.1.0";

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

11− libraryHaskellDepends = [

12− aeson base bytestring containers foreign-store http-types jsaddle

13− stm text time transformers uuid uuid-types wai wai-websockets warp

14− websockets

15− ];

16− testHaskellDepends = [

17− aeson base bytestring containers deepseq doctest filepath ghc-prim

18− http-types jsaddle lens network primitive process QuickCheck ref-tf

19− stm text time transformers wai wai-websockets warp webdriver

20− websockets

21− ];

22− testTarget = "--test-option=${jsaddle.src}";

23− description = "Interface for JavaScript that works with GHCJS and GHC";

24− license = stdenv.lib.licenses.mit;

25−}

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

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

1name: jsaddle-warp

2−version: 0.9.2.0

2+version: 0.9.8.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 JavaScipt helper.

13+ drive a small JavaScript helper.

14category: Web, Javascript

15author: Hamish Mackenzie

16

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

24 if !impl(ghcjs -any)

25 exposed-modules:

26 Language.Javascript.JSaddle.WebSockets

27+ other-modules:

28+ Language.Javascript.JSaddle.WebSockets.Compat

27 build-depends:

29 build-depends:

28− aeson >=0.8.0.2 && <1.3,

30+ aeson >=0.8.0.2 && <1.6,

29 bytestring >=0.10.6.0 && <0.11,

31 bytestring >=0.10.6.0 && <0.11,

30− containers >=0.5.6.2 && <0.6,

32+ containers >=0.5.6.2 && <0.7,

31 foreign-store >=0.2 && <0.3,

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

32− http-types >=0.8.6 && <0.10,

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

33− jsaddle >=0.9.2.0 && <0.10,

35+ jsaddle >=0.9.4.0 && <0.10,

34− stm >=2.4.4 && <2.5,

36+ stm >=2.4.4 && <2.6,

35 text >=1.2.1.3 && <1.3,

37 text >=1.2.1.3 && <1.3,

36− time >=1.5.0.1 && <1.8,

38+ time >=1.5.0.1 && <1.11,

37 transformers >=0.4.2.0 && <0.6,

39 transformers >=0.4.2.0 && <0.6,

38− uuid >=1.3.13 && <1.4,

39− uuid-types >=1.0.3 && <1.1,

40 wai >=3.0.3.0 && <3.3,

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

42− warp >=3.1.2 && <3.3,

42+ warp >=3.1.2 && <3.4,

43− websockets >=0.9.5.0 && <0.11

43+ websockets >=0.9.5.0 && <0.13

44 exposed-modules:

45 Language.Javascript.JSaddle.Warp

46 build-depends:

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

59 bytestring -any,

60 containers -any,

61 deepseq -any,

62− doctest >=0.10.1 && <0.12,

62+ doctest >=0.10.1 && <0.19,

63+ exceptions -any,

63 filepath >=1.4.0.0 && <1.5,

64 filepath >=1.4.0.0 && <1.5,

65+ foreign-store -any,

64 ghc-prim -any,

66 ghc-prim -any,

65 http-types -any,

67 http-types -any,

66 jsaddle -any,

68 jsaddle -any,

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

69 network -any,

71 network -any,

70 ref-tf -any,

72 ref-tf -any,

71 primitive -any,

73 primitive -any,

72− process >=1.2.3.0 && <1.5,

74+ process >=1.2.3.0 && <1.7,

75+ random -any,

73 stm -any,

76 stm -any,

74 text -any,

77 text -any,

75 time -any,

78 time -any,

76 transformers -any,

79 transformers -any,

80+ unliftio-core -any,

77 wai -any,

81 wai -any,

78 wai-websockets -any,

82 wai-websockets -any,

79 warp -any,

83 warp -any,

80− webdriver >=0.8.4 && <0.9,

84+ webdriver >=0.8.4 && <0.10,

81 websockets -any

85 websockets -any

82 type: exitcode-stdio-1.0

86 type: exitcode-stdio-1.0

83 main-is: DocTest.hs

87 main-is: DocTest.hs

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

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

17 , listWindowProperties

18) where

19

20−import Control.Applicative

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

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

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

21+import Control.Applicative

23−import Language.Javascript.JSaddle

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

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 ((^.))

28−import Data.Monoid ((<>))

29import Control.Concurrent.MVar

23import Control.Concurrent.MVar

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

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

31−import System.IO.Unsafe (unsafePerformIO)

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

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

26+import Control.Monad (forever, forM)

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

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

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

33import Data.Text (Text)

30import Data.Text (Text)

31+import qualified Data.Text as T

32+import Language.Javascript.JSaddle

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

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

34+import System.IO.Unsafe (unsafePerformIO)

35+import System.Timeout (timeout)

35

36

36context :: MVar JSContextRef

37context :: MVar JSContextRef

37context = unsafePerformIO newEmptyMVar

38context = unsafePerformIO newEmptyMVar

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

52

53

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

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

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

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

55−testJSaddle f = do

56+testJSaddle f = timeout 10000000 (do

56 startServer

57 startServer

57 c <- takeMVar context

58 c <- takeMVar context

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

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

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

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

60− putMVar context c

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

61

62

62debugLog :: String -> IO ()

63debugLog :: String -> IO ()

63debugLog _ = return ()

64debugLog _ = return ()

jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs+148−74

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

19 jsaddleOr

20 , jsaddleApp

21 , jsaddleWithAppOr

22+ , jsaddleAppWithJs

23+ , jsaddleAppWithJsOr

22 , jsaddleAppPartial

24 , jsaddleAppPartial

25+ , jsaddleJs

26+ , jsaddleJs'

23 , debug

27 , debug

28+ , debugOr

24 , debugWrapper

29 , debugWrapper

25) where

30) where

26

31

27−import Control.Monad (when, join, void, forever)

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

28import Control.Concurrent (killThread, forkIO, threadDelay)

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

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

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

30

35

@@ -37,12 +42,12 @@ import Network.Wai

37import Network.WebSockets

42import Network.WebSockets

38 (defaultConnectionOptions, ConnectionOptions(..), sendTextData,

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

39 receiveDataMessage, acceptRequest, ServerApp, sendPing)

44 receiveDataMessage, acceptRequest, ServerApp, sendPing)

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

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

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

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

42

47

43import Language.Javascript.JSaddle.Types (JSM(..), JSContextRef(..))

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

44import qualified Network.Wai as W

49import qualified Network.Wai as W

45− (responseLBS, requestMethod, pathInfo)

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

46import qualified Data.Text as T (pack)

51import qualified Data.Text as T (pack)

47import qualified Network.HTTP.Types as H

52import qualified Network.HTTP.Types as H

48 (status403, status200)

53 (status403, status200)

@@ -53,45 +58,59 @@ import Language.Javascript.JSaddle.Debug

53import Data.Maybe (fromMaybe)

58import Data.Maybe (fromMaybe)

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

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

55import Data.IORef

60import Data.IORef

56− (writeIORef, IORef, readIORef, newIORef, atomicModifyIORef')

61+ (readIORef, newIORef, atomicModifyIORef')

57import Data.ByteString.Lazy (ByteString)

62import Data.ByteString.Lazy (ByteString)

58−import Data.UUID.Types (toText)

63+import qualified Data.ByteString.Lazy as LBS

64+ (toStrict, stripPrefix)

59import Control.Concurrent.MVar

65import Control.Concurrent.MVar

60− (tryPutMVar, modifyMVar_, putMVar, takeMVar, readMVar, newMVar,

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

61− newEmptyMVar, modifyMVar)

67+ readMVar, newMVar, newEmptyMVar, modifyMVar)

62import Network.Wai.Handler.Warp

68import Network.Wai.Handler.Warp

63 (defaultSettings, setTimeout, setPort, runSettings)

69 (defaultSettings, setTimeout, setPort, runSettings)

64−import Foreign.Store (newStore, readStore, lookupStore)

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

65import Language.Javascript.JSaddle (askJSM)

71import Language.Javascript.JSaddle (askJSM)

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

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

67

73

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

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

76+

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

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

69jsaddleOr opts entryPoint otherApp = do

78jsaddleOr opts entryPoint otherApp = do

70 syncHandlers <- newIORef M.empty

79 syncHandlers <- newIORef M.empty

80+ asyncHandlers <- newIORef M.empty

71 let wsApp :: ServerApp

81 let wsApp :: ServerApp

72 wsApp pending_conn = do

82 wsApp pending_conn = do

73 conn <- acceptRequest pending_conn

83 conn <- acceptRequest pending_conn

84+ initMsg <- receiveDataMessage conn

85+ case getTextMessageByteString initMsg of

86+ Just "" -> do

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

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

75− syncKey <- toText . contextId <$> askJSM

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

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

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

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

77− liftIO $ sendTextData conn (encode syncKey)

91+ liftIO $ sendTextData conn (encode syncKey)

78− entryPoint

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

79− _ <- forkIO . forever $

99+ forever $

80− receiveDataMessage conn >>= \case

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

81− (WS.Text t) ->

101+ Just t ->

82− case decode t of

102+ case decode t of

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

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

84− Just r -> processResult r

104+ Just r -> processResult r

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

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

86− start

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

87− waitTillClosed conn

88

107

89 -- Based on Network.WebSocket.forkPingThread

108 -- Based on Network.WebSocket.forkPingThread

90 waitTillClosed conn = ignore `handle` go 1

109 waitTillClosed conn = ignore `handle` go 1

91 where

110 where

92 go :: Int -> IO ()

111 go :: Int -> IO ()

93 go i = do

112 go i = do

94− threadDelay (1 * 1000 * 1000)

113+ threadDelay (10 * 1000 * 1000)

95 sendPing conn (T.pack $ show i)

114 sendPing conn (T.pack $ show i)

96 go (i + 1)

115 go (i + 1)

97

116

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

111 Just handler -> do

130 Just handler -> do

112 next <- encode <$> handler result

131 next <- encode <$> handler result

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

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

114− _ -> otherApp req sendResponse

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

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

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

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

137+ _ -> resp

115 return $ websocketsOr opts wsApp syncHandler

138 return $ websocketsOr opts wsApp syncHandler

116

139

117

140

118jsaddleApp :: Application

141jsaddleApp :: Application

142+jsaddleApp = jsaddleAppWithJs $ jsaddleJs False

143+

144+jsaddleAppWithJs :: ByteString -> Application

119−jsaddleApp req sendResponse =

145+jsaddleAppWithJs js req sendResponse =

120− fromMaybe

146+ jsaddleAppWithJsOr js

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

147+ (\_ _ -> 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)

122− (jsaddleAppPartial req sendResponse)

153+ (jsaddleAppPartialWithJs js req sendResponse)

123

154

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

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

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

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

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

127 (jsaddleAppPartial req sendResponse))

158 (jsaddleAppPartial req sendResponse))

128

159

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

160jsaddleAppPartial :: 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)

130−jsaddleAppPartial req sendResponse = case (W.requestMethod req, W.pathInfo req) of

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

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

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

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

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

133 _ -> Nothing

170 _ -> Nothing

134

171

172+jsaddleJs :: Bool -> ByteString

173+jsaddleJs = jsaddleJs' Nothing

174+

135-- Use this to generate this string for embedding

175-- Use this to generate this string for embedding

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

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

137−jsaddleJs :: ByteString

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

138−jsaddleJs = "\

178+jsaddleJs' jsaddleUri refreshOnLoad = "\

139− \if(typeof global !== \"undefined\") {\n\

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

140 \ global.window = global;\n\

180 \ global.window = global;\n\

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

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

142 \}\n\

182 \}\n\

143 \\n\

183 \\n\

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

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

185+ \ var wsaddress = "

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

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

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

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

189+ <> ";\n\

146 \\n\

190 \\n\

147− \ var ws = new WebSocket(wsaddress);\n\

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

148 \ var syncKey = \"\";\n\

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

149 \\n\

193 \\n\

150− \ ws.onopen = function(e) {\n\

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

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

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

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

151 \ " <> initState <> "\n\

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

152− \ var inXhrSend = false;\n\

153 \\n\

199 \\n\

154− \ ws.onmessage = function(e) {\n\

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

155− \ if(inXhrSend) return;\n\

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

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

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

203+ \ asyncBatch = batch;\n\

204+ \ return;\n\

205+ \ }\n\

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

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

158 \ syncKey = batch;\n\

207 \ 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

159− \ var xhr = new XMLHttpRequest();\n\

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

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

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

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

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

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

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

163− \ setTimeout(function(){window.location.reload();}, 500);\n\

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

164− \ };\n\

221+ \ };\n\

165− \ xhr.send();\n\

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

223+ else "") <>

166− \ return;\n\

224+ " return;\n\

167 \ }\n\

225 \ }\n\

168 \\n\

226 \\n\

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

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

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

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

171− \ inXhrSend = true;\n\

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

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

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

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

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

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

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

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

176− \ inXhrSend = false;\n\

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

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

178 \ };\n\

234 \ };\n\

179 \ };\n\

235 \ };\n\

180− \ ws.onerror = function() {\n\

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

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

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

182 \ };\n\

238 \ };\n\

183 \}\n\

239 \}\n\

@@ -191,26 +247,35 @@ jsaddleJs = "\

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

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

192debug :: Int -> JSM () -> IO ()

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

193debug port f = do

249debug port f = do

194− debugWrapper $ \refreshMiddleware registerContext ->

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

195 runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<

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

196− jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (refreshMiddleware jsaddleApp)

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

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

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

198

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+

199debugWrapper :: (Middleware -> JSM () -> IO ()) -> IO ()

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

200debugWrapper run = do

268debugWrapper run = do

201 reloadMVar <- newEmptyMVar

269 reloadMVar <- newEmptyMVar

202 reloadDoneMVars <- newMVar []

270 reloadDoneMVars <- newMVar []

203 contexts <- newMVar []

271 contexts <- newMVar []

204− let refreshMiddleware :: Middleware

272+ let refresh sendResponse = do

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

206− ("POST", ["reload", _syncKey]) -> do

207− reloadDone <- newEmptyMVar

273+ reloadDone <- newEmptyMVar

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

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

209− readMVar reloadMVar

275+ readMVar reloadMVar

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

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

211− putMVar reloadDone ()

277+ putMVar reloadDone ()

212− return r

278+ return r

213− _ -> otherApp req sendResponse

214 start :: Int -> IO (IO Int)

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

215 start expectedConnections = do

280 start expectedConnections = do

216 serverDone <- newEmptyMVar

281 serverDone <- newEmptyMVar

@@ -222,7 +287,7 @@ debugWrapper run = do

222 addContext

287 addContext

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

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

224 thread <- forkIO $

289 thread <- forkIO $

225− finally (run refreshMiddleware registerContext)

290+ finally (run (refreshMiddleware refresh) registerContext)

226 (putMVar serverDone ())

291 (putMVar serverDone ())

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

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

228 when (expectedConnections /= 0) $ takeMVar ready

293 when (expectedConnections /= 0) $ takeMVar ready

@@ -231,15 +296,24 @@ debugWrapper run = do

231 ctxs <- takeMVar contexts

296 ctxs <- takeMVar contexts

232 mapM_ removeContext ctxs

297 mapM_ removeContext ctxs

233 takeMVar reloadDoneMVars >>= mapM_ takeMVar

298 takeMVar reloadDoneMVars >>= mapM_ takeMVar

299+ tryTakeMVar serverDone >>= \case

300+ Nothing -> do

234− killThread thread

301+ killThread thread

235− takeMVar serverDone

302+ takeMVar serverDone

303+ Just _ -> return ()

236 return $ length ctxs

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

237− lookupStore shutdown_0 >>= \case

310+ lookupStore storeId >>= \case

238 Nothing -> do

311 Nothing -> do

239− shutdownRef <- newIORef =<< start 0

312+ restartMVar <- newMVar start

240− void $ newStore shutdownRef

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

314+ void $ writeStore (Store storeId) restartMVar

241 Just shutdownStore -> do

315 Just shutdownStore -> do

242− shutdownRef :: IORef (IO Int) <- readStore shutdownStore

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

243− expectedConnections <- join (readIORef shutdownRef)

317+ void $ tryTakeMVar restartMVar

244− writeIORef shutdownRef =<< start expectedConnections

318+ putMVar restartMVar start

245− where shutdown_0 = 0

319+ where storeId = 354

jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets/Compat.hsnew file+29

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

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+20−7

@@ -11,18 +11,17 @@ 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 (forkIO)

14+import Control.Concurrent

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

15import Control.Monad (void)

16import Control.Monad (void)

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

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

17import Data.Monoid ((<>))

18import Data.Monoid ((<>))

18import System.Environment (getArgs)

19import System.Environment (getArgs)

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

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

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

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

22

21

23main :: IO ()

22main :: IO ()

24main = do

23main = do

25− putStrLn "Hello"

24+ putStrLn "Testing JSaddle"

26 jsaddlePath <- getArgs >>= \case

25 jsaddlePath <- getArgs >>= \case

27 [arg] -> return arg

26 [arg] -> return arg

28 _ -> do

27 _ -> do

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

30 exitFailure

29 exitFailure

31 hSetBuffering stdout LineBuffering

30 hSetBuffering stdout LineBuffering

32 hSetBuffering stderr LineBuffering

31 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"

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

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

39− runSession defaultConfig $ do

40+ threadDelay 5000000

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

41+ putStrLn "Running Tests"

42+ done <- newEmptyMVar

43+ forkIO $ do

41 liftIO $ doctest [

44 liftIO $ doctest [

42 "-hide-all-packages",

45 "-hide-all-packages",

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

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

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

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

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

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

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

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

66 "-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,

64 "-i" <> "src",

71 "-i" <> "src",

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

106 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

99 closeSession

112 closeSession

jsaddle-webkit2gtk/default.nixdeleted−16

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

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+10−9

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

1name: jsaddle-webkit2gtk

2−version: 0.9.0.0

2+version: 0.9.8.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

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

26 base <5

27 if !impl(ghcjs -any)

28 build-depends:

29− aeson >=0.8.0.2 && <1.3,

29+ aeson >=0.8.0.2 && <1.6,

30 base <5,

31 bytestring >=0.10.6.0 && <0.11,

32 directory >=1.0.0.2 && <1.4,

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

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

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

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

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

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

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

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

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

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

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

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

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

39− jsaddle >=0.9.0.0 && <0.10,

40+ jsaddle >=0.9.4.0 && <0.10,

40 text >=1.2.1.3 && <1.3,

41 text >=1.2.1.3 && <1.3,

41 webkit2gtk3-javascriptcore >=0.14.0.0 && <0.15

42 webkit2gtk3-javascriptcore >=0.14.0.0 && <0.15

42 if !os(windows)

43 if !os(windows)

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

@@ -43,29 +43,24 @@ 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)

47import qualified Data.Text as T (pack)

46import qualified Data.Text as T (pack)

48−import Data.Text.Foreign (fromPtr)

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

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

50

48

51−import Foreign.Ptr (castPtr, nullPtr)

52−

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

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

54import Data.GI.Base.Signals

50import Data.GI.Base.Signals

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

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

56 SignalHandlerId)

52 SignalHandlerId)

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

58

53

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

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

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

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

61import GI.Gtk

56import GI.Gtk

62 (windowSetPosition, windowSetDefaultSize, windowNew,

57 (windowSetPosition, windowSetDefaultSize, windowNew,

63− scrolledWindowNew, noAdjustment, containerAdd,

58+ scrolledWindowNew, Adjustment, containerAdd,

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

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

65 widgetGetToplevel, widgetShowAll, onWidgetDestroy,

60 widgetGetToplevel, widgetShowAll, onWidgetDestroy,

66 mainQuit)

61 mainQuit)

67−import GI.Gio (noCancellable)

62+import GI.Gio (Cancellable)

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

63+import GI.JavaScriptCore (valueToString)

69import GI.WebKit2

64import GI.WebKit2

70 (scriptDialogPromptSetText, scriptDialogPromptGetDefaultText,

65 (scriptDialogPromptSetText, scriptDialogPromptGetDefaultText,

71 scriptDialogGetMessage, scriptDialogGetDialogType,

66 scriptDialogGetMessage, scriptDialogGetDialogType,

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

74 setSettingsEnableJavascript, webViewNewWithUserContentManager,

69 setSettingsEnableJavascript, webViewNewWithUserContentManager,

75 userContentManagerNew,

70 userContentManagerNew,

76 userContentManagerRegisterScriptMessageHandler,

71 userContentManagerRegisterScriptMessageHandler,

77− javascriptResultGetValue, javascriptResultGetGlobalContext,

72+ javascriptResultGetJsValue,

78 webViewGetUserContentManager,

73 webViewGetUserContentManager,

79 mk_UserContentManagerScriptMessageReceivedCallback,

74 mk_UserContentManagerScriptMessageReceivedCallback,

80 wrap_UserContentManagerScriptMessageReceivedCallback,

75 wrap_UserContentManagerScriptMessageReceivedCallback,

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

83 onWebViewLoadChanged, setSettingsEnableDeveloperExtras,

78 onWebViewLoadChanged, setSettingsEnableDeveloperExtras,

84 webViewSetSettings, webViewGetSettings, ScriptDialogType(..))

79 webViewSetSettings, webViewGetSettings, ScriptDialogType(..))

85

80

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−

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

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

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

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

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

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

96

84

85+noAdjustment :: Maybe Adjustment

86+noAdjustment = Nothing

87+

88+noCancellable :: Maybe Cancellable

89+noCancellable = Nothing

90+

97quitWebView :: WebView -> IO ()

91quitWebView :: WebView -> IO ()

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

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

99 widgetDestroy w

93 widgetDestroy w

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

109postGUIAsync action =

103postGUIAsync action =

110 void . idleAdd PRIORITY_DEFAULT $ action >> return False

104 void . idleAdd PRIORITY_DEFAULT $ action >> return False

111

105

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−

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

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

128run main = do

107run main = do

129 _ <- Gtk.init Nothing

108 _ <- Gtk.init Nothing

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

148 void . onWebViewLoadChanged webView $ \case

127 void . onWebViewLoadChanged webView $ \case

149 LoadEventFinished -> runInWebView main webView

128 LoadEventFinished -> runInWebView main webView

150 _ -> return ()

129 _ -> return ()

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

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

152 installQuitHandler webView

131 installQuitHandler webView

153 Gtk.main

132 Gtk.main

154

133

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

172 let cb' = wrap_UserContentManagerScriptMessageReceivedCallback cb

151 let cb' = wrap_UserContentManagerScriptMessageReceivedCallback cb

173 cb'' <- mk_UserContentManagerScriptMessageReceivedCallback cb'

152 cb'' <- mk_UserContentManagerScriptMessageReceivedCallback cb'

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

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

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

155+ Nothing

156+#endif

175

157

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

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

177addJSaddleHandler webView processResult syncResults = do

159addJSaddleHandler webView processResult syncResults = do

178 manager <- webViewGetUserContentManager webView

160 manager <- webViewGetUserContentManager webView

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

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

180− ctx <- javascriptResultGetGlobalContext result

162+ arg <- javascriptResultGetJsValue result

181− arg <- javascriptResultGetValue result

163+ bs <- encodeUtf8 <$> valueToString arg

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

183− withJSValueRef arg $ \argRef ->

184− encodeUtf8 <$> valueToText ctxRef argRef

185 mapM_ processResult (decode (fromStrict bs))

164 mapM_ processResult (decode (fromStrict bs))

186 _ <- onWebViewScriptDialog webView $ \dialog ->

165 _ <- onWebViewScriptDialog webView $ \dialog ->

187 scriptDialogGetDialogType dialog >>= \case

166 scriptDialogGetDialogType dialog >>= \case

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

206 , initState

185 , initState

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

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

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

187 , 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

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

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

212 , "};\n"

189 , "};\n"

213 , "})()"

190 , "})()"

214 ]

191 ]

jsaddle-webkitgtk/default.nixdeleted−16

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

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+57−2

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

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);

5extern void callWithWebView(WKWebView *, HsStablePtr);

8extern void callWithWebView(WKWebView *, HsStablePtr);

6

9

7@interface AppDelegate : NSObject <NSApplicationDelegate>

10@interface AppDelegate : NSObject <NSApplicationDelegate>

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

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

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

12@end

15@end

13

16

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+

14@implementation AppDelegate

23@implementation AppDelegate

15

24

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

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

@@ -31,18 +40,39 @@ extern void callWithWebView(WKWebView *, HsStablePtr);

31 return self;

40 return self;

32}

41}

33

42

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

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

45+ return b ? YES : NO;

46+}

47+

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

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

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

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

50+ if (global_developerExtrasEnabled) {

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

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

52+ }

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

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

38 [_window setContentView:webView];

54 [_window setContentView:webView];

39 callWithWebView(webView, _handler);

55 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);

40}

69}

41

70

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

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

43 [_window orderFrontRegardless];

72 [_window orderFrontRegardless];

44 [_window center];

73 [_window center];

45 [NSApp activateIgnoringOtherApps:YES];

74 [NSApp activateIgnoringOtherApps:YES];

75+ callIO(global_didFinishLaunchingWithOptions);

46}

76}

47

77

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

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

@@ -51,8 +81,33 @@ extern void callWithWebView(WKWebView *, HsStablePtr);

51

81

52@end

82@end

53

83

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

84+void runInWKWebView(HsStablePtr handler,

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) {

55 @autoreleasepool {

105 @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;

56 NSApplication *application = [NSApplication sharedApplication];

111 NSApplication *application = [NSApplication sharedApplication];

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

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

58 [application setDelegate:appDelegate];

113 [application setDelegate:appDelegate];

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

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

5

6extern void callIO(HsStablePtr);

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

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

8

9

9@interface AppDelegate ()

10@interface AppDelegate ()

10

11

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

20HsStablePtr global_applicationWillTerminate = 0;

21HsStablePtr global_applicationWillTerminate = 0;

21HsStablePtr global_applicationSignificantTimeChange = 0;

22HsStablePtr global_applicationSignificantTimeChange = 0;

22HsStablePtr global_applicationUniversalLink = 0;

23HsStablePtr global_applicationUniversalLink = 0;

24+HsStablePtr global_applicationDidReceiveRemoteNotification = 0;

23uint64_t global_requestAuthorizationWithOptions = 0;

25uint64_t global_requestAuthorizationWithOptions = 0;

24uint64_t global_requestAuthorizationOptionBadge = 0;

26uint64_t global_requestAuthorizationOptionBadge = 0;

25uint64_t global_requestAuthorizationOptionSound = 0;

27uint64_t global_requestAuthorizationOptionSound = 0;

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

109 callWithCString([deviceTokenString UTF8String], global_didRegisterForRemoteNotificationsWithDeviceToken);

111 callWithCString([deviceTokenString UTF8String], global_didRegisterForRemoteNotificationsWithDeviceToken);

110}

112}

111

113

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+

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

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

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

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

114 NSString *errorString = [error localizedDescription];

133 NSString *errorString = [error localizedDescription];

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

143 HsStablePtr hs_applicationWillTerminate,

162 HsStablePtr hs_applicationWillTerminate,

144 HsStablePtr hs_applicationSignificantTimeChange,

163 HsStablePtr hs_applicationSignificantTimeChange,

145 HsStablePtr hs_applicationUniversalLink,

164 HsStablePtr hs_applicationUniversalLink,

165+ HsStablePtr hs_applicationDidReceiveRemoteNotification,

146 const uint64_t hs_requestAuthorizationWithOptions,

166 const uint64_t hs_requestAuthorizationWithOptions,

147 const uint64_t hs_requestAuthorizationOptionBadge,

167 const uint64_t hs_requestAuthorizationOptionBadge,

148 const uint64_t hs_requestAuthorizationOptionSound,

168 const uint64_t hs_requestAuthorizationOptionSound,

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

150 const uint64_t hs_requestAuthorizationOptionCarPlay,

170 const uint64_t hs_requestAuthorizationOptionCarPlay,

151 const uint64_t hs_registerForRemoteNotifications,

171 const uint64_t hs_registerForRemoteNotifications,

152 HsStablePtr hs_didRegisterForRemoteNotificationsWithDeviceToken,

172 HsStablePtr hs_didRegisterForRemoteNotificationsWithDeviceToken,

153− HsStablePtr hs_didFailToRegisterForRemoteNotificationsWithError) {

173+ HsStablePtr hs_didFailToRegisterForRemoteNotificationsWithError,

174+ const uint64_t hs_developerExtrasEnabled) {

154 @autoreleasepool {

175 @autoreleasepool {

155 globalHandler = handler;

176 globalHandler = handler;

156 global_willFinishLaunchingWithOptions = hs_willFinishLaunchingWithOptions;

177 global_willFinishLaunchingWithOptions = hs_willFinishLaunchingWithOptions;

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

162 global_applicationWillTerminate = hs_applicationWillTerminate;

183 global_applicationWillTerminate = hs_applicationWillTerminate;

163 global_applicationSignificantTimeChange = hs_applicationSignificantTimeChange;

184 global_applicationSignificantTimeChange = hs_applicationSignificantTimeChange;

164 global_applicationUniversalLink = hs_applicationUniversalLink;

185 global_applicationUniversalLink = hs_applicationUniversalLink;

186+ global_applicationDidReceiveRemoteNotification = hs_applicationDidReceiveRemoteNotification;

165 global_requestAuthorizationWithOptions = hs_requestAuthorizationWithOptions;

187 global_requestAuthorizationWithOptions = hs_requestAuthorizationWithOptions;

166 global_requestAuthorizationOptionBadge = hs_requestAuthorizationOptionBadge;

188 global_requestAuthorizationOptionBadge = hs_requestAuthorizationOptionBadge;

167 global_requestAuthorizationOptionSound = hs_requestAuthorizationOptionSound;

189 global_requestAuthorizationOptionSound = hs_requestAuthorizationOptionSound;

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

@@ -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,6 +74,9 @@ 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

77 webView.navigationDelegate = handler;

80 webView.navigationDelegate = handler;

78 webView.UIDelegate = handler;

81 webView.UIDelegate = handler;

79}

82}

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

92 handler.completionHandler = NULL;

95 handler.completionHandler = NULL;

93}

96}

94

97

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

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

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

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

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

97− dispatch_async(dispatch_get_main_queue(), ^{

101+ dispatch_async(dispatch_get_main_queue(), ^{

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

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

99 });

103 });

100}

104}

101

105

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

118 }

122 }

119 }

123 }

120}

124}

121−

122−

123−

jsaddle-wkwebview/default.nix+14−20

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

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

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

2−, buildPackages

2+self: super:

3−}:

3+let

4−

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

5−mkDerivation {

5+ inherit (pkgs) lib;

6− pname = "jsaddle-wkwebview";

6+in

7− version = "0.9.0.0";

7+with pkgs.haskell.lib;

8− src = ./.;

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

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

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

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

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

11− ++ (with buildPackages; [

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

12− darwin.libobjc

13− darwin.apple_sdk.libs.xpc

14− darwin.apple_sdk.frameworks.Foundation

15− darwin.apple_sdk.frameworks.Cocoa

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

16− darwin.apple_sdk.frameworks.WebKit

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

17− ]);

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

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

20−}

14+})

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

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

1name: jsaddle-wkwebview

2−version: 0.9.0.0

2+version: 0.9.8.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

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

25library

26 exposed-modules:

27 Language.Javascript.JSaddle.WKWebView

28− Language.Javascript.JSaddle.WKWebView.Internal

29 build-depends:

28 build-depends:

30− aeson >=0.8.0.2 && <1.3,

31− base <5,

29+ base <5

32− bytestring >=0.10.6.0 && <0.11,

33− jsaddle >= 0.9.0.0 && <0.10,

34− data-default,

35− containers

36 default-language: Haskell2010

30 default-language: Haskell2010

37 hs-source-dirs: src

31 hs-source-dirs: src

38− frameworks: Foundation, WebKit

39 ghc-options: -ferror-spans -Wall

32 ghc-options: -ferror-spans -Wall

40− c-sources:

33+ if os(linux)

41− cbits/WKWebView.m

34+ buildable: False

42 if impl(ghcjs)

35 if impl(ghcjs)

43 hs-source-dirs: src-ghcjs

36 hs-source-dirs: src-ghcjs

44 else

37 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

45 hs-source-dirs: src-ghc

49 hs-source-dirs: src-ghc

50+ c-sources:

51+ cbits/WKWebView.m

52+ cc-options: -Wno-everything

46 if os(ios)

53 if os(ios)

47 frameworks: UIKit, UserNotifications

54 frameworks: UIKit, UserNotifications

48 if flag(include-app-delegate)

55 if flag(include-app-delegate)

49 c-sources:

56 c-sources:

50 cbits-uikit/AppDelegate.m

57 cbits-uikit/AppDelegate.m

51 cbits-uikit/ViewController.m

58 cbits-uikit/ViewController.m

59+ cpp-options: -DUSE_UIKIT

52 else

60 else

53 frameworks: Cocoa

61 frameworks: Cocoa

54 if flag(include-app-delegate)

62 if flag(include-app-delegate)

55 c-sources:

63 c-sources:

56 cbits-cocoa/AppDelegate.m

64 cbits-cocoa/AppDelegate.m

65+ cpp-options: -DUSE_COCOA

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

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

1module Language.Javascript.JSaddle.WKWebView

2 ( jsaddleMain

3+ , jsaddleMainHTMLWithBaseURL

3 , jsaddleMainFile

4 , jsaddleMainFile

4 , WKWebView(..)

5 , WKWebView(..)

5 , run

6 , run

7+ , run'

6 , runWithAppConfig

8 , runWithAppConfig

9+ , runHTMLWithBaseURL

7 , runFile

10 , runFile

8 , mainBundleResourcePath

11 , mainBundleResourcePath

12+ , ApplicationState (..)

9 , AppDelegateConfig (..)

13 , AppDelegateConfig (..)

10 , AppDelegateNotificationConfig (..)

14 , AppDelegateNotificationConfig (..)

11 , AuthorizationOption (..)

15 , AuthorizationOption (..)

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

17import qualified Data.Set as Set

21import qualified Data.Set as Set

18import Data.Word

22import Data.Word

19import Foreign.Marshal.Utils (fromBool)

23import Foreign.Marshal.Utils (fromBool)

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

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

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

21import System.Environment (getProgName)

26import System.Environment (getProgName)

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

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

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

23import Foreign.StablePtr (StablePtr, newStablePtr)

29import Foreign.StablePtr (StablePtr, newStablePtr)

24import Language.Javascript.JSaddle (JSM)

30import Language.Javascript.JSaddle (JSM)

25

31

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

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

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

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

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

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

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

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

38 -> Word64 -- whether to run requestAuthorizationWithOptions

45 -> Word64 -- whether to run requestAuthorizationWithOptions

39 -> Word64 -- Ask for Badge authorization

46 -> Word64 -- Ask for Badge authorization

40 -> Word64 -- Ask for Sound authorization

47 -> Word64 -- Ask for Sound authorization

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

43 -> Word64 -- registerForRemoteNotifications

50 -> Word64 -- registerForRemoteNotifications

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

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

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

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

53+ -> Word64 -- developerExtrasEnabled

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

46 -> IO ()

55 -> IO ()

47

56

48data AppDelegateConfig = AppDelegateConfig

57data AppDelegateConfig = AppDelegateConfig

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

55 , _appDelegateConfig_applicationWillTerminate :: IO ()

64 , _appDelegateConfig_applicationWillTerminate :: IO ()

56 , _appDelegateConfig_applicationSignificantTimeChange :: IO ()

65 , _appDelegateConfig_applicationSignificantTimeChange :: IO ()

57 , _appDelegateConfig_applicationUniversalLink :: CString -> IO ()

66 , _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

58 , _appDelegateConfig_appDelegateNotificationConfig :: AppDelegateNotificationConfig

76 , _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.

59 }

86 }

60

87

61instance Default AppDelegateConfig where

88instance Default AppDelegateConfig where

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

69 , _appDelegateConfig_applicationWillTerminate = return ()

96 , _appDelegateConfig_applicationWillTerminate = return ()

70 , _appDelegateConfig_applicationSignificantTimeChange = return ()

97 , _appDelegateConfig_applicationSignificantTimeChange = return ()

71 , _appDelegateConfig_applicationUniversalLink = \_ -> return ()

98 , _appDelegateConfig_applicationUniversalLink = \_ -> return ()

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

72 , _appDelegateConfig_appDelegateNotificationConfig = def

100 , _appDelegateConfig_appDelegateNotificationConfig = def

101+ , _appDelegateConfig_developerExtrasEnabled = True

102+ , _appDelegateConfig_applicationOpenFile = \_ -> return False

73 }

103 }

74

104

75data AuthorizationOption = AuthorizationOption_Badge

105data AuthorizationOption = AuthorizationOption_Badge

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

78 | AuthorizationOption_CarPlay

108 | AuthorizationOption_CarPlay

79 deriving (Show, Read, Eq, Ord)

109 deriving (Show, Read, Eq, Ord)

80

110

111+data ApplicationState = ApplicationState_Active

112+ | ApplicationState_Inactive

113+ | ApplicationState_Background

114+ | ApplicationState_Unknown CInt

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

116+

81data AppDelegateNotificationConfig = AppDelegateNotificationConfig

117data AppDelegateNotificationConfig = AppDelegateNotificationConfig

82 { _appDelegateNotificationConfig_requestAuthorizationWithOptions :: Maybe (Set AuthorizationOption)

118 { _appDelegateNotificationConfig_requestAuthorizationWithOptions :: Maybe (Set AuthorizationOption)

83 , _appDelegateNotificationConfig_registerForRemoteNotifications :: Bool

119 , _appDelegateNotificationConfig_registerForRemoteNotifications :: Bool

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

96

132

97-- | Run JSaddle in a WKWebView

133-- | Run JSaddle in a WKWebView

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

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

99−run = run' Nothing def

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

100

136

101-- | Run JSaddle in a WKWebView

137-- | Run JSaddle in a WKWebView

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

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

103−runWithAppConfig = run' Nothing

139+runWithAppConfig cfg = run' cfg . jsaddleMain

104

140

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

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

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

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

143+runFile

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

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

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

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

109− -> AppDelegateConfig

146+ -> AppDelegateConfig

110− -> JSM ()

147+ -> JSM ()

111− -> IO ()

148+ -> IO ()

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

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

113−

150+

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

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

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

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+

115− -> AppDelegateConfig

162+run' :: AppDelegateConfig

116− -> JSM ()

163+ -> (WKWebView -> IO ())

117 -> IO ()

164 -> IO ()

118−run' mUrl cfg f = do

165+run' cfg main = do

119− handler <- case mUrl of

166+ handler <- newStablePtr main

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

121− Nothing -> newStablePtr (jsaddleMain f)

122 progName <- getProgName

167 progName <- getProgName

123

168

124 -- AppDelegate callbacks

169 -- AppDelegate callbacks

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

131 applicationWillTerminate <- newStablePtr $ _appDelegateConfig_applicationWillTerminate cfg

176 applicationWillTerminate <- newStablePtr $ _appDelegateConfig_applicationWillTerminate cfg

132 applicationSignificantTimeChange <- newStablePtr $ _appDelegateConfig_applicationSignificantTimeChange cfg

177 applicationSignificantTimeChange <- newStablePtr $ _appDelegateConfig_applicationSignificantTimeChange cfg

133 applicationUniversalLink <- newStablePtr $ _appDelegateConfig_applicationUniversalLink cfg

178 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

134

187

135 -- AppDelegate notification configuration

188 -- AppDelegate notification configuration

136 let ncfg = _appDelegateConfig_appDelegateNotificationConfig cfg

189 let ncfg = _appDelegateConfig_appDelegateNotificationConfig cfg

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

153 applicationWillTerminate

206 applicationWillTerminate

154 applicationSignificantTimeChange

207 applicationSignificantTimeChange

155 applicationUniversalLink

208 applicationUniversalLink

209+ applicationDidReceiveRemoteNotification

156 (fromBool requestAuthorizationWithOptions)

210 (fromBool requestAuthorizationWithOptions)

157 (fromBool $ Set.member AuthorizationOption_Badge authorizationOptions)

211 (fromBool $ Set.member AuthorizationOption_Badge authorizationOptions)

158 (fromBool $ Set.member AuthorizationOption_Sound authorizationOptions)

212 (fromBool $ Set.member AuthorizationOption_Sound authorizationOptions)

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

161 (fromBool registerForRemoteNotifications)

215 (fromBool registerForRemoteNotifications)

162 didRegisterForRemoteNotificationsWithDeviceToken

216 didRegisterForRemoteNotificationsWithDeviceToken

163 didFailToRegisterForRemoteNotificationsWithError

217 didFailToRegisterForRemoteNotificationsWithError

218+ (fromBool $ _appDelegateConfig_developerExtrasEnabled cfg)

219+ applicationOpenFile

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

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

1{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}

2module Language.Javascript.JSaddle.WKWebView.Internal

3 ( jsaddleMain

4+ , jsaddleMainHTMLWithBaseURL

4 , jsaddleMainFile

5 , jsaddleMainFile

5 , WKWebView(..)

6 , WKWebView(..)

6 , mainBundleResourcePath

7 , mainBundleResourcePath

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

15import qualified Data.ByteString as BS (ByteString)

16import qualified Data.ByteString as BS (ByteString)

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

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

17import Data.Aeson (encode, decode)

18import Data.Aeson (encode, decode)

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

20+import Data.Text.Encoding (encodeUtf8)

18

21

19import Foreign.C.String (CString)

22import Foreign.C.String (CString)

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

20import Foreign.Ptr (Ptr, nullPtr)

24import Foreign.Ptr (Ptr, nullPtr)

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

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

22

26

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

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

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

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

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

26

30

31+import System.Directory (getCurrentDirectory)

32+

27newtype WKWebView = WKWebView (Ptr WKWebView)

33newtype WKWebView = WKWebView (Ptr WKWebView)

28newtype JSaddleHandler = JSaddleHandler (Ptr JSaddleHandler)

34newtype JSaddleHandler = JSaddleHandler (Ptr JSaddleHandler)

29

35

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

42

50

43-- | Run JSaddle in WKWebView

51-- | Run JSaddle in WKWebView

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

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

45−jsaddleMain f webView =

53+jsaddleMain f webView = do

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 =

46 jsaddleMain' f webView $

66 jsaddleMain' f webView $

47− useAsCString (toStrict indexHtml) $ loadHTMLString webView

67+ useAsCString baseURL $ \url ->

68+ useAsCString initialHTML $ \html ->

69+ loadHTMLStringWithBaseURL webView html url

48

70

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

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

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

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

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

107 f <- deRefStablePtr fptr

129 f <- deRefStablePtr fptr

108 f c

130 f c

109

131

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+

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

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

111callIO ptr = do

143callIO ptr = do

112 f <- deRefStablePtr ptr

144 f <- deRefStablePtr ptr

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

140 if bs == nullPtr

172 if bs == nullPtr

141 then return Nothing

173 then return Nothing

142 else Just <$> packCString bs

174 else Just <$> packCString bs

143−

jsaddle/default.nixdeleted−18

@@ -1,18 +0,0 @@

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, uuid, uuid-types

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− uuid uuid-types

15− ];

16− description = "Interface for JavaScript that works with GHCJS and GHC";

17− license = stdenv.lib.licenses.mit;

18−}

jsaddle/jsaddle.cabal+18−17

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

1name: jsaddle

2−version: 0.9.2.1

2+version: 0.9.8.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 JavaScipt helper.

13+ drive a small JavaScript helper.

14category: Web, Javascript

15author: Hamish Mackenzie

16

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

36 else

37 build-depends:

38 attoparsec >=0.11 && <0.14,

39− containers >=0.5.6.2 && <0.6,

39+ containers >=0.5.6.2 && <0.7,

40 deepseq >=1.3 && < 1.5,

41 filepath >=1.4.0.0 && <1.5,

42 ghc-prim,

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

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

44− process >=1.2.3.0 && <1.5,

44+ process >=1.2.3.0 && <1.7,

45+ random >= 1.1 && < 1.3,

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

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

46 scientific >=0.3 && <0.4,

47 scientific >=0.3 && <0.4,

47− stm >=2.4.4 && <2.5,

48+ stm >=2.4.4 && <2.6,

48− time >=1.5.0.1 && <1.8,

49+ time >=1.5.0.1 && <1.11,

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

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

50− uuid >=1.3.13 && <1.4,

51− uuid-types >=1.0.3 && <1.1,

52− vector >=0.10 && <0.13

51+ vector >=0.10 && <0.13,

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

53 exposed-modules:

54 Data.JSString

55 Data.JSString.Internal

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

63 GHCJS.Prim

64 GHCJS.Prim.Internal

65 GHCJS.Types

66+ GHCJS.Concurrent

66 GHCJS.Foreign

67 GHCJS.Foreign

67 GHCJS.Foreign.Internal

68 GHCJS.Foreign.Internal

68 GHCJS.Internal.Types

69 GHCJS.Internal.Types

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

106 Language.Javascript.JSaddle.Value

107 Language.Javascript.JSaddle.Value

107 Language.Javascript.JSaddle.Types

108 Language.Javascript.JSaddle.Types

108 build-depends:

109 build-depends:

109− aeson >=0.8.0.2 && <1.3,

110+ aeson >=0.11.3.0 && <1.6,

110− base <5,

111+ base >=4.9 && <5,

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

111− base64-bytestring >=1.0.0.1 && <1.1,

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

112 bytestring >=0.10.6.0 && <0.11,

114 bytestring >=0.10.6.0 && <0.11,

115+ exceptions >=0.8 && <0.11,

113− lens >=3.8.5 && <4.16,

116+ lens >=3.8.5 && <5.1,

114− primitive >=0.6.1.0 && <0.7,

117+ primitive >=0.6.1.0 && <0.8,

115 text >=1.2.1.3 && <1.3,

118 text >=1.2.1.3 && <1.3,

116 transformers >=0.4.2.0 && <0.6

119 transformers >=0.4.2.0 && <0.6

117 default-language: Haskell2010

120 default-language: Haskell2010

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

121 cpp-options: -DCHECK_UNCHECKED

124 cpp-options: -DCHECK_UNCHECKED

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

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

123 cpp-options: -DJSADDLE_HAS_CALL_STACK

126 cpp-options: -DJSADDLE_HAS_CALL_STACK

124−

125−

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

@@ -38,10 +38,11 @@ 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)

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

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

42

43

43-- | A wrapper around a JavaScript string

44-- | A wrapper around a JavaScript string

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

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

45

46

46instance NFData JSString where rnf !_ = ()

47instance NFData JSString where rnf !_ = ()

47

48

jsaddle/src-ghc/GHCJS/Concurrent.hsnew file+22

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

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+12−10

@@ -27,26 +27,28 @@ 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)

30

32

31jsTrue :: JSVal

33jsTrue :: JSVal

32−jsTrue = JSVal 3

34+jsTrue = JSVal . unsafePerformIO $ newIORef 3

33−{-# INLINE jsTrue #-}

35+{-# NOINLINE jsTrue #-}

34

36

35jsFalse :: JSVal

37jsFalse :: JSVal

36−jsFalse = JSVal 2

38+jsFalse = JSVal . unsafePerformIO $ newIORef 2

37−{-# INLINE jsFalse #-}

39+{-# NOINLINE jsFalse #-}

38

40

39jsNull :: JSVal

41jsNull :: JSVal

40−jsNull = JSVal 0

42+jsNull = JSVal . unsafePerformIO $ newIORef 0

41−{-# INLINE jsNull #-}

43+{-# NOINLINE jsNull #-}

42

44

43toJSBool :: Bool -> JSVal

45toJSBool :: Bool -> JSVal

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

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

45−{-# INLINE toJSBool #-}

47+{-# NOINLINE toJSBool #-}

46

48

47jsUndefined :: JSVal

49jsUndefined :: JSVal

48−jsUndefined = JSVal 1

50+jsUndefined = JSVal . unsafePerformIO $ newIORef 1

49−{-# INLINE jsUndefined #-}

51+{-# NOINLINE jsUndefined #-}

50

52

51isTruthy :: JSVal -> GHCJSPure Bool

53isTruthy :: JSVal -> GHCJSPure Bool

52isTruthy = GHCJSPure . valueToBool

54isTruthy = GHCJSPure . valueToBool

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

@@ -17,6 +17,8 @@ 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)

20

22

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

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

22type JSValueRef = Int64

24type JSValueRef = Int64

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

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

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

26 argument or result.

28 argument or result.

27-}

29-}

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

30+newtype JSVal = JSVal (IORef JSValueRef)

29

31

30instance NFData JSVal where

32instance NFData JSVal where

31 rnf x = x `seq` ()

33 rnf x = x `seq` ()

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

49 return (JSException (unsafeCoerce ref) "")

51 return (JSException (unsafeCoerce ref) "")

50

52

51jsNull :: JSVal

53jsNull :: JSVal

52−jsNull = JSVal 0

54+jsNull = JSVal . unsafePerformIO $ newIORef 0

53−{-# INLINE jsNull #-}

55+{-# NOINLINE jsNull #-}

54

56

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

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

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

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

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

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

27import GHC.Types

28import GHC.Prim

29import GHC.Ptr

30+import GHC.IORef

31+import GHC.IO.Unsafe (unsafePerformIO)

30

32

31import Control.DeepSeq

33import Control.DeepSeq

32import Unsafe.Coerce

34import Unsafe.Coerce

33

35

34−type Ref# = Int64

36+type Ref# = IORef Int64

35

37

36mkRef :: Ref# -> JSVal

38mkRef :: Ref# -> JSVal

37mkRef = JSVal

39mkRef = JSVal

38{-# INLINE mkRef #-}

40{-# INLINE mkRef #-}

39

41

40nullRef :: JSVal

42nullRef :: JSVal

41−nullRef = JSVal 0

43+nullRef = JSVal . unsafePerformIO $ newIORef 0

42−{-# INLINE nullRef #-}

44+{-# NOINLINE nullRef #-}

43

45

44--toPtr :: JSVal -> Ptr a

46--toPtr :: JSVal -> Ptr a

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

47--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 JavaScipt helper.

12+-- drive a small JavaScript 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 demonstated.

38+ -- uses more of the JSaddle EDSL feature being demonstrated.

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 code JavaScript code is executed in the the strict order

55+ -- Although the JavaScript code is executed in the strict order

56− -- set out by the EDSL it done asynchonously to the Haskell code.

56+ -- set out by the EDSL it is done asynchronously 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.hs+4−4

@@ -26,7 +26,7 @@ import Data.IORef (readIORef, atomicModifyIORef', newIORef, IORef)

26import System.IO.Unsafe (unsafePerformIO)

27import Data.Monoid ((<>))

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

29−import Data.UUID (UUID)

29+import Data.Int (Int64)

30

31contexts :: IORef [JSContextRef]

32contexts = unsafePerformIO $ newIORef []

@@ -37,9 +37,9 @@ addContext = do

37 ctx <- askJSM

38 liftIO $ atomicModifyIORef' contexts $ \c -> (c <> [ctx], ())

39

40−removeContext :: MonadIO m => UUID -> m ()

40+removeContext :: MonadIO m => Int64 -> m ()

41−removeContext uuid =

41+removeContext cid =

42− liftIO $ atomicModifyIORef' contexts $ \c -> (filter ((/= uuid) . contextId) c, ())

42+ liftIO $ atomicModifyIORef' contexts $ \c -> (filter ((/= cid) . contextId) c, ())

43

44runOnAll :: MonadIO m => JSM a -> m [a]

45runOnAll 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 unsafe "$r = eval($1);"

53+foreign import javascript safe "$r = eval($1);"

54 js_eval :: JSString -> IO JSVal

55#else

56eval = evaluateScript . toJSString

jsaddle/src/Language/Javascript/JSaddle/Monad.hs+3−26

@@ -38,13 +38,12 @@ module Language.Javascript.JSaddle.Monad (

38 , bracket

39) where

40

41−import Prelude hiding (read)

42#ifndef ghcjs_HOST_OS

41#ifndef ghcjs_HOST_OS

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

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

44#endif

43#endif

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

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

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

45+import Control.Monad.Catch (catch, bracket)

47−import Language.Javascript.JSaddle.Types (JSM(..), MonadJSM, liftJSM, JSContextRef(..))

46+import Language.Javascript.JSaddle.Types (JSM(..), MonadJSM, liftJSM, JSContextRef)

48import Language.Javascript.JSaddle.Run (syncPoint, syncAfter, waitForAnimationFrame, nextAnimationFrame)

47import Language.Javascript.JSaddle.Run (syncPoint, syncAfter, waitForAnimationFrame, nextAnimationFrame)

49

48

50-- | Gets the JavaScript context from the monad

49-- | Gets the JavaScript context from the monad

@@ -66,25 +65,3 @@ runJSM f = liftIO . runReaderT (unJSM f)

66-- | Alternative version of 'runJSM'

65-- | Alternative version of 'runJSM'

67runJSaddle :: MonadIO m => JSContextRef -> JSM a -> m a

66runJSaddle :: MonadIO m => JSContextRef -> JSM a -> m a

68runJSaddle = flip runJSM

67runJSaddle = 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+39−24

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

1+{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE MagicHash #-}

3+{-# LANGUAGE UnboxedTuples #-}

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

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

2--

5--

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

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

@@ -45,7 +48,6 @@ module Language.Javascript.JSaddle.Native.Internal (

45) where

48) where

46

49

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

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

48−import Control.Monad.Primitive (touch)

49

51

50import Data.Aeson (Value)

52import Data.Aeson (Value)

51

53

@@ -57,30 +59,34 @@ import Language.Javascript.JSaddle.Monad (askJSM)

57import Language.Javascript.JSaddle.Run

59import Language.Javascript.JSaddle.Run

58 (Command(..), Result(..), sendCommand,

60 (Command(..), Result(..), sendCommand,

59 sendAsyncCommand, sendLazyCommand, wrapJSVal)

61 sendAsyncCommand, sendLazyCommand, wrapJSVal)

62+import GHC.IORef (IORef(..), readIORef)

63+import GHC.STRef (STRef(..))

64+import GHC.IO (IO(..))

65+import GHC.Base (touch#)

60

66

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

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

62wrapJSString (JSStringReceived ref) = return $ JSString ref

68wrapJSString (JSStringReceived ref) = return $ JSString ref

63

69

70+touchIORef :: IORef a -> IO ()

71+touchIORef (IORef (STRef r#)) = IO $ \s -> case touch# r# s of s' -> (# s', () #)

72+

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

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

65withJSVal (JSVal ref) f = do

74withJSVal (JSVal ref) f = do

66− result <- f (JSValueForSend ref)

75+ result <- (f . JSValueForSend) =<< liftIO (readIORef ref)

67− liftIO $ touch ref

76+ liftIO $ touchIORef ref

68 return result

77 return result

69

78

70withJSVals :: MonadIO m => [JSVal] -> ([JSValueForSend] -> m a) -> m a

79withJSVals :: MonadIO m => [JSVal] -> ([JSValueForSend] -> m a) -> m a

71withJSVals v f =

80withJSVals v f =

72− do result <- f (map (\(JSVal ref) -> JSValueForSend ref) v)

81+ do result <- f =<< mapM (\(JSVal ref) -> liftIO $ JSValueForSend <$> readIORef ref) v

73− liftIO $ mapM_ touch v

82+ liftIO $ mapM_ (\(JSVal ref) -> touchIORef ref) v

74 return result

83 return result

75

84

76withObject :: MonadIO m => Object -> (JSObjectForSend -> m a) -> m a

85withObject :: MonadIO m => Object -> (JSObjectForSend -> m a) -> m a

77withObject (Object o) f = withJSVal o (f . JSObjectForSend)

86withObject (Object o) f = withJSVal o (f . JSObjectForSend)

78

87

79withJSString :: MonadIO m => JSString -> (JSStringForSend -> m a) -> m a

88withJSString :: MonadIO m => JSString -> (JSStringForSend -> m a) -> m a

80−withJSString v@(JSString ref) f =

89+withJSString (JSString ref) f = f (JSStringForSend ref)

81− do result <- f (JSStringForSend ref)

82− liftIO $ touch v

83− return result

84

90

85setPropertyByName :: JSString -> JSVal -> Object -> JSM ()

91setPropertyByName :: JSString -> JSVal -> Object -> JSM ()

86setPropertyByName name val this =

92setPropertyByName name val this =

@@ -166,13 +172,14 @@ deRefVal value = withJSVal value $ sendCommand . DeRefVal

166{-# INLINE deRefVal #-}

172{-# INLINE deRefVal #-}

167

173

168valueToBool :: JSVal -> JSM Bool

174valueToBool :: JSVal -> JSM Bool

175+valueToBool v@(JSVal ref) = liftIO (readIORef ref) >>= \case

169−valueToBool (JSVal 0) = return False -- null

176+ 0 -> return False -- null

170−valueToBool (JSVal 1) = return False -- undefined

177+ 1 -> return False -- undefined

171−valueToBool (JSVal 2) = return False -- false

178+ 2 -> return False -- false

172−valueToBool (JSVal 3) = return True -- true

179+ 3 -> return True -- true

173−valueToBool v = withJSVal v $ \rval -> do

180+ _ -> withJSVal v $ \rval -> do

174− ~(ValueToBoolResult result) <- sendCommand (ValueToBool rval)

181+ ~(ValueToBoolResult result) <- sendCommand (ValueToBool rval)

175− return result

182+ return result

176{-# INLINE valueToBool #-}

183{-# INLINE valueToBool #-}

177

184

178valueToNumber :: JSVal -> JSM Double

185valueToNumber :: JSVal -> JSM Double

@@ -201,17 +208,25 @@ valueToJSONValue value = withJSVal value $ \rval -> do

201{-# INLINE valueToJSONValue #-}

208{-# INLINE valueToJSONValue #-}

202

209

203isNull :: JSVal -> JSM Bool

210isNull :: JSVal -> JSM Bool

211+isNull v@(JSVal ref) = liftIO (readIORef ref) >>= \case

204−isNull (JSVal 0) = return True

212+ 0 -> return True -- null

213+ 1 -> return False -- undefined

214+ 2 -> return False -- false

215+ 3 -> return False -- true

205−isNull v = withJSVal v $ \rval -> do

216+ _ -> withJSVal v $ \rval -> do

206− ~(IsNullResult result) <- sendCommand $ IsNull rval

217+ ~(IsNullResult result) <- sendCommand $ IsNull rval

207− return result

218+ return result

208{-# INLINE isNull #-}

219{-# INLINE isNull #-}

209

220

210isUndefined :: JSVal -> JSM Bool

221isUndefined :: JSVal -> JSM Bool

211−isUndefined (JSVal 1) = return True

222+isUndefined v@(JSVal ref) = liftIO (readIORef ref) >>= \case

223+ 0 -> return False -- null

224+ 1 -> return True -- undefined

225+ 2 -> return False -- false

226+ 3 -> return False -- true

212−isUndefined v = withJSVal v $ \rval -> do

227+ _ -> withJSVal v $ \rval -> do

213− ~(IsUndefinedResult result) <- sendCommand $ IsUndefined rval

228+ ~(IsUndefinedResult result) <- sendCommand $ IsUndefined rval

214− return result

229+ return result

215{-# INLINE isUndefined #-}

230{-# INLINE isUndefined #-}

216

231

217strictEqual :: JSVal -> JSVal -> JSM Bool

232strictEqual :: JSVal -> JSVal -> JSM Bool

jsaddle/src/Language/Javascript/JSaddle/Null.hs+1−1

@@ -37,7 +37,7 @@ run f = do

37 _ <- forkIO $ forever $

38 readChan batches >>= \case

39 Batch commands _ batchNumber ->

40− processResult $ BatchResults batchNumber . Success $ mapMaybe (\case

40+ processResult $ BatchResults batchNumber . Success [] $ mapMaybe (\case

41 Left _ -> Nothing

42 Right command -> Just $

43 case command of

jsaddle/src/Language/Javascript/JSaddle/Object.hs+22−13

@@ -119,9 +119,10 @@ import Language.Javascript.JSaddle.Native

119 (newAsyncCallback, newSyncCallback, callAsFunction, callAsConstructor)

120import Language.Javascript.JSaddle.Monad (askJSM, JSM)

121import Language.Javascript.JSaddle.Types

122− (JSString, Object(..), SomeJSArray(..),

122+ (JSValueForSend(..), AsyncCommand(..), JSString, Object(..),

123− JSVal(..), JSCallAsFunction, JSContextRef(..))

123+ SomeJSArray(..), JSVal(..), JSCallAsFunction, JSContextRef(..))

124import JavaScript.Object.Internal (create, listProps)

125+import Language.Javascript.JSaddle.Run (sendAsyncCommand)

125#endif

126#endif

126import JavaScript.Array.Internal (fromListIO)

127import JavaScript.Array.Internal (fromListIO)

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

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

@@ -131,6 +132,8 @@ import Language.Javascript.JSaddle.Arguments (MakeArgs(..))

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

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

132import Language.Javascript.JSaddle.Properties

133import Language.Javascript.JSaddle.Properties

133import Control.Lens (IndexPreservingGetter, to)

134import Control.Lens (IndexPreservingGetter, to)

135+import Data.IORef (newIORef, readIORef)

136+import System.IO.Unsafe (unsafePerformIO)

134

137

135-- $setup

138-- $setup

136-- >>> import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

139-- >>> import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

@@ -481,9 +484,16 @@ freeFunction :: Function -> JSM ()

481freeFunction (Function callback _) = liftIO $

484freeFunction (Function callback _) = liftIO $

482 releaseCallback callback

485 releaseCallback callback

483#else

486#else

484−freeFunction (Function object) = do

487+freeFunction (Function (Object (JSVal objectRef))) = do

485− free <- freeCallback <$> askJSM

488+ -- By now the callback should ideally have been removed from whatever

486− liftIO $ free object

489+ -- events it was added to.

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

487#endif

497#endif

488

498

489instance ToJSVal Function where

499instance ToJSVal Function where

@@ -516,13 +526,12 @@ array args = do

516 Object . coerce <$> fromListIO rargs

526 Object . coerce <$> fromListIO rargs

517

527

518-- | JavaScript's global object

528-- | JavaScript's global object

519−global :: Object

520#ifdef ghcjs_HOST_OS

529#ifdef ghcjs_HOST_OS

521−global = js_window

522−foreign import javascript unsafe "$r = window"

530+foreign import javascript unsafe "$r = globalThis"

523− js_window :: Object

531+ global :: Object

524#else

532#else

525−global = Object (JSVal 4)

533+global :: Object

534+global = Object . JSVal . unsafePerformIO $ newIORef 4

526#endif

535#endif

527

536

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

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

@@ -547,7 +556,7 @@ objCallAsFunction :: MakeArgs args

547objCallAsFunction f this args = do

556objCallAsFunction f this args = do

548 rargs <- makeArgs args >>= liftIO . Array.fromListIO

557 rargs <- makeArgs args >>= liftIO . Array.fromListIO

549 liftIO $ js_apply f this rargs

558 liftIO $ js_apply f this rargs

550−foreign import javascript unsafe "$r = $1.apply($2, $3)"

559+foreign import javascript safe "$r = $1.apply($2, $3)"

551 js_apply :: Object -> Object -> MutableJSArray -> IO JSVal

560 js_apply :: Object -> Object -> MutableJSArray -> IO JSVal

552#else

561#else

553objCallAsFunction f this args = do

562objCallAsFunction f this args = do

@@ -567,7 +576,7 @@ objCallAsConstructor :: MakeArgs args

567objCallAsConstructor f args = do

576objCallAsConstructor f args = do

568 rargs <- makeArgs args >>= liftIO . Array.fromListIO

577 rargs <- makeArgs args >>= liftIO . Array.fromListIO

569 liftIO $ js_new f rargs

578 liftIO $ js_new f rargs

570−foreign import javascript unsafe "\

579+foreign import javascript safe "\

571 switch($2.length) {\

580 switch($2.length) {\

572 case 0 : $r = new $1(); break;\

581 case 0 : $r = new $1(); break;\

573 case 1 : $r = new $1($2[0]); break;\

582 case 1 : $r = new $1($2[0]); break;\

@@ -603,5 +612,5 @@ nullObject :: Object

603#ifdef ghcjs_HOST_OS

612#ifdef ghcjs_HOST_OS

604nullObject = Object nullRef

613nullObject = Object nullRef

605#else

614#else

606−nullObject = Object (JSVal 0)

615+nullObject = Object . JSVal . unsafePerformIO $ newIORef 0

607#endif

616#endif

jsaddle/src/Language/Javascript/JSaddle/Run.hs+82−67

@@ -37,7 +37,7 @@ module Language.Javascript.JSaddle.Run (

37) where

38

39#ifdef ghcjs_HOST_OS

40−import Language.Javascript.JSaddle.Types (JSM)

40+import Language.Javascript.JSaddle.Types (JSM, syncPoint, syncAfter)

41import qualified JavaScript.Web.AnimationFrame as GHCJS

42 (waitForAnimationFrame)

43#else

@@ -56,6 +56,7 @@ import Control.Concurrent.MVar

56

57import System.IO.Unsafe (unsafeInterleaveIO)

58import System.Mem.Weak (addFinalizer)

59+import System.Random

59

60

60import GHC.Base (IO(..), mkWeak#)

61import GHC.Base (IO(..), mkWeak#)

61import GHC.Conc (ThreadId(..))

62import GHC.Conc (ThreadId(..))

@@ -63,17 +64,31 @@ import Data.Monoid ((<>))

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

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

64import qualified Data.Map as M (lookup, delete, insert, empty, size)

65import qualified Data.Map as M (lookup, delete, insert, empty, size)

65import qualified Data.Set as S (empty, member, insert, delete)

66import qualified Data.Set as S (empty, member, insert, delete)

66−import Data.UUID.V4 (nextRandom)

67import Data.Time.Clock (getCurrentTime,diffUTCTime)

68+import Data.IORef

68−import Data.IORef (newIORef, atomicWriteIORef, readIORef)

69+ (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)

69

70

70import Language.Javascript.JSaddle.Types

71import Language.Javascript.JSaddle.Types

71 (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),

72 (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),

72− Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))

73+ Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand)

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

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

74−import Control.DeepSeq (deepseq)

75+import Control.DeepSeq (force, deepseq)

76+#if MIN_VERSION_base(4,11,0)

77+import GHC.Stats (getRTSStatsEnabled, getRTSStats, RTSStats(..), gcdetails_live_bytes, gc)

78+#else

75import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))

79import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))

76#endif

80#endif

81+import Data.Foldable (forM_)

82+#endif

83+

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

77

92

78-- | Enable (or disable) JSaddle logging

93-- | Enable (or disable) JSaddle logging

79enableLogging :: Bool -> JSM ()

94enableLogging :: Bool -> JSM ()

@@ -85,27 +100,6 @@ enableLogging v = do

85 liftIO $ f v

100 liftIO $ f v

86#endif

101#endif

87

102

88−-- | Forces execution of pending asyncronous code

89−syncPoint :: JSM ()

90−#ifdef ghcjs_HOST_OS

91−syncPoint = return ()

92−#else

93−syncPoint = do

94− SyncResult <- sendCommand Sync

95− return ()

96−#endif

97−

98−-- | Forces execution of pending asyncronous code after performing `f`

99−syncAfter :: JSM a -> JSM a

100−#ifdef ghcjs_HOST_OS

101−syncAfter = id

102−#else

103−syncAfter f = do

104− result <- f

105− syncPoint

106− return result

107−#endif

108−

109-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.

103-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.

110-- On GHC it will delay the execution of the current batch of asynchronous

104-- On GHC it will delay the execution of the current batch of asynchronous

111-- command when they are sent to JavaScript. It will not delay the Haskell

105-- command when they are sent to JavaScript. It will not delay the Haskell

@@ -131,11 +125,6 @@ nextAnimationFrame f = do

131 syncAfter (f t)

125 syncAfter (f t)

132

126

133#ifndef ghcjs_HOST_OS

127#ifndef ghcjs_HOST_OS

134−sendCommand :: Command -> JSM Result

135−sendCommand cmd = do

136− s <- doSendCommand <$> JSM ask

137− liftIO $ s cmd

138−

139sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal

128sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal

140sendLazyCommand cmd = do

129sendLazyCommand cmd = do

141 nextRefTVar <- nextRef <$> JSM ask

130 nextRefTVar <- nextRef <$> JSM ask

@@ -154,7 +143,7 @@ sendAsyncCommand cmd = do

154

143

155runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())

144runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())

156runJavaScript sendBatch entryPoint = do

145runJavaScript sendBatch entryPoint = do

157− contextId' <- nextRandom

146+ contextId' <- randomIO

158 startTime' <- getCurrentTime

147 startTime' <- getCurrentTime

159 recvMVar <- newEmptyMVar

148 recvMVar <- newEmptyMVar

160 lastAsyncBatch <- newEmptyMVar

149 lastAsyncBatch <- newEmptyMVar

@@ -162,25 +151,32 @@ runJavaScript sendBatch entryPoint = do

162 callbacks <- newTVarIO M.empty

151 callbacks <- newTVarIO M.empty

163 nextRef' <- newTVarIO 0

152 nextRef' <- newTVarIO 0

164 finalizerThreads' <- newMVar S.empty

153 finalizerThreads' <- newMVar S.empty

154+ animationFrameHandlers' <- newMVar []

165 loggingEnabled <- newIORef False

155 loggingEnabled <- newIORef False

156+ liveRefs' <- newMVar S.empty

166 let ctx = JSContextRef {

157 let ctx = JSContextRef {

167− contextId = contextId'

158+ contextId = contextId'

168− , startTime = startTime'

159+ , startTime = startTime'

169− , doSendCommand = \cmd -> cmd `deepseq` do

160+ , doSendCommand = \cmd -> cmd `deepseq` do

170− result <- newEmptyMVar

161+ result <- newEmptyMVar

171− atomically $ writeTChan commandChan (Right (cmd, result))

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

172− unsafeInterleaveIO $

163+ unsafeInterleaveIO $

173− takeMVar result >>= \case

164+ takeMVar result >>= \case

165+ (ThrowJSValue v) -> do

166+ jsval <- wrapJSVal' ctx v

174− (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)

167+ throwIO $ JSException jsval

175− r -> return r

168+ r -> return r

176− , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)

169+ , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)

170+ , addCallback = \(Object (JSVal ioref)) cb -> do

171+ val <- readIORef ioref

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

172+ atomically $ modifyTVar' callbacks (M.insert val cb)

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

179− , nextRef = nextRef'

173+ , nextRef = nextRef'

180− , doEnableLogging = atomicWriteIORef loggingEnabled

174+ , doEnableLogging = atomicWriteIORef loggingEnabled

181− , finalizerThreads = finalizerThreads'

175+ , finalizerThreads = finalizerThreads'

176+ , animationFrameHandlers = animationFrameHandlers'

177+ , liveRefs = liveRefs'

182− }

178+ }

183− let processResults :: Bool -> Results -> IO ()

179+ processResults :: Bool -> Results -> IO ()

184 processResults syncCallbacks = \case

180 processResults syncCallbacks = \case

185 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err

181 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err

186 (Callback n br (JSValueReceived fNumber) f this a) -> do

182 (Callback n br (JSValueReceived fNumber) f this a) -> do

@@ -210,8 +206,8 @@ runJavaScript sendBatch entryPoint = do

210 logInfo s =

206 logInfo s =

211 readIORef loggingEnabled >>= \case

207 readIORef loggingEnabled >>= \case

212 True -> do

208 True -> do

213− currentBytesUsedStr <- getGCStatsEnabled >>= \case

209+ currentBytesUsedStr <- getRTSStatsEnabled >>= \case

214− True -> show . currentBytesUsed <$> getGCStats

210+ True -> show . currentBytesUsed <$> getRTSStats

215 False -> return "??"

211 False -> return "??"

216 cbCount <- M.size <$> readTVarIO callbacks

212 cbCount <- M.size <$> readTVarIO callbacks

217 putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "

213 putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "

@@ -224,14 +220,21 @@ runJavaScript sendBatch entryPoint = do

224 putMVar lastAsyncBatch batch

220 putMVar lastAsyncBatch batch

225 sendBatch batch

221 sendBatch batch

226 takeResult recvMVar nBatch >>= \case

222 takeResult recvMVar nBatch >>= \case

227− (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"

223+ (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"

224+ (_, Success callbacksToFree results)

228− (_, Success results) | length results /= length resultMVars -> error "Unexpected number of jsaddle results"

225+ | length results /= length resultMVars -> error "Unexpected number of jsaddle results"

226+ | otherwise -> do

229− | otherwise -> zipWithM_ putMVar resultMVars results

227+ zipWithM_ putMVar resultMVars results

228+ forM_ callbacksToFree $ \(JSValueReceived val) ->

229+ atomically (modifyTVar' callbacks (M.delete val))

230− (_, Failure results exception) -> do

230+ (_, Failure callbacksToFree results exception err) -> do

231− -- The exception will only be rethrown in Haskell if/when one of the

231+ -- The exception will only be rethrown in Haskell if/when one of the

232− -- missing results (if any) is evaluated.

232+ -- missing results (if any) is evaluated.

233− putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"

233+ putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"

234+ putStrLn err

234− zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)

235+ zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)

236+ forM_ callbacksToFree $ \(JSValueReceived val) ->

237+ atomically (modifyTVar' callbacks (M.delete val))

235 return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)

238 return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)

236 where

239 where

237 numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m ()

240 numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m ()

@@ -274,17 +277,29 @@ addThreadFinalizer :: ThreadId -> IO () -> IO ()

274addThreadFinalizer t@(ThreadId t#) (IO finalizer) =

277addThreadFinalizer t@(ThreadId t#) (IO finalizer) =

275 IO $ \s -> case mkWeak# t# t finalizer s of { (# s1, _ #) -> (# s1, () #) }

278 IO $ \s -> case mkWeak# t# t finalizer s of { (# s1, _ #) -> (# s1, () #) }

276

279

280+

277wrapJSVal :: JSValueReceived -> JSM JSVal

281wrapJSVal :: JSValueReceived -> JSM JSVal

278−wrapJSVal (JSValueReceived ref) = do

282+wrapJSVal v = do

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

283+ ctx <- JSM ask

280− let result = JSVal ref

284+ liftIO $ wrapJSVal' ctx v

285+

286+wrapJSVal' :: JSContextRef -> JSValueReceived -> IO JSVal

287+wrapJSVal' ctx (JSValueReceived n) = do

288+ ref <- liftIO $ newIORef n

281− when (ref >= 5 || ref < 0) $ do

289+ when (n >= 5 || n < 0) $

282− ctx <- JSM ask

290+#ifdef JSADDLE_CHECK_WRAPJSVAL

283− liftIO . addFinalizer ref $ do

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

284 ft <- takeMVar $ finalizerThreads ctx

299 ft <- takeMVar $ finalizerThreads ctx

285 t <- myThreadId

300 t <- myThreadId

286 let tname = T.pack $ show t

301 let tname = T.pack $ show t

287− doSendAsyncCommand ctx $ FreeRef tname $ JSValueForSend ref

302+ doSendAsyncCommand ctx $ FreeRef tname $ JSValueForSend n

288 if tname `S.member` ft

303 if tname `S.member` ft

289 then putMVar (finalizerThreads ctx) ft

304 then putMVar (finalizerThreads ctx) ft

290 else do

305 else do

@@ -292,5 +307,5 @@ wrapJSVal (JSValueReceived ref) = do

292 modifyMVar (finalizerThreads ctx) $ \s -> return (S.delete tname s, ())

307 modifyMVar (finalizerThreads ctx) $ \s -> return (S.delete tname s, ())

293 doSendAsyncCommand ctx $ FreeRefs tname

308 doSendAsyncCommand ctx $ FreeRefs tname

294 putMVar (finalizerThreads ctx) =<< evaluate (S.insert tname ft)

309 putMVar (finalizerThreads ctx) =<< evaluate (S.insert tname ft)

295− return result

310+ return (JSVal ref)

296#endif

311#endif

jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+29−46

@@ -13,7 +13,6 @@

13

14module Language.Javascript.JSaddle.Run.Files (

15 indexHtml

16− , jsaddleJs

17 , initState

16 , initState

18 , runBatch

17 , runBatch

19 , ghcjsHelpers

18 , ghcjsHelpers

@@ -31,7 +30,7 @@ indexHtml =

31 \</head>\n\

30 \</head>\n\

32 \<body>\n\

31 \<body>\n\

33 \</body>\n\

32 \</body>\n\

34− \<script src=\"jsaddle.js\"></script>\n\

33+ \<script src=\"/jsaddle.js\"></script>\n\

35 \</html>"

34 \</html>"

36

35

37initState :: ByteString

36initState :: ByteString

@@ -42,11 +41,12 @@ initState = "\

42 \ jsaddle_values.set(1, undefined);\n\

41 \ jsaddle_values.set(1, undefined);\n\

43 \ jsaddle_values.set(2, false);\n\

42 \ jsaddle_values.set(2, false);\n\

44 \ jsaddle_values.set(3, true);\n\

43 \ jsaddle_values.set(3, true);\n\

45− \ jsaddle_values.set(4, window);\n\

44+ \ jsaddle_values.set(4, globalThis);\n\

46 \ var jsaddle_index = 100;\n\

45 \ var jsaddle_index = 100;\n\

47 \ var expectedBatch = 1;\n\

46 \ var expectedBatch = 1;\n\

48− \ var lastResults = [0, {}];\n\

47+ \ var lastResults = [0, {\"tag\": \"Success\", \"contents\": [[], []]}];\n\

49 \ var inCallback = 0;\n\

48 \ var inCallback = 0;\n\

49+ \ var asyncBatch = null;\n\

50 \"

51

52runBatch :: (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString

@@ -54,6 +54,7 @@ runBatch send sendSync = "\

54 \ var runBatch = function(firstBatch, initialSyncDepth) {\n\

55 \ var processBatch = function(timestamp) {\n\

56 \ var batch = firstBatch;\n\

57+ \ var callbacksToFree = [];\n\

57 \ var results = [];\n\

58 \ var results = [];\n\

58 \ inCallback++;\n\

59 \ inCallback++;\n\

59 \ try {\n\

60 \ try {\n\

@@ -92,6 +93,10 @@ runBatch send sendSync = "\

92 \ var n = d.contents[1];\n\

93 \ var n = d.contents[1];\n\

93 \ jsaddle_values.set(n, d.contents[0]);\n\

94 \ jsaddle_values.set(n, d.contents[0]);\n\

94 \ break;\n\

95 \ 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\

95 \ case \"GetPropertyByName\":\n\

100 \ case \"GetPropertyByName\":\n\

96 \ var n = d.contents[2];\n\

101 \ var n = d.contents[2];\n\

97 \ jsaddle_values.set(n, jsaddle_values.get(d.contents[0])[d.contents[1]]);\n\

102 \ jsaddle_values.set(n, jsaddle_values.get(d.contents[0])[d.contents[1]]);\n\

@@ -155,6 +160,9 @@ runBatch send sendSync = "\

155 \ jsaddle_values.set(nFunction, func);\n\

160 \ jsaddle_values.set(nFunction, func);\n\

156 \ })();\n\

161 \ })();\n\

157 \ break;\n\

162 \ break;\n\

163+ \ case \"FreeCallback\":\n\

164+ \ callbacksToFree.push(d.contents);\n\

165+ \ break;\n\

158 \ case \"CallAsFunction\":\n\

166 \ case \"CallAsFunction\":\n\

159 \ var n = d.contents[3];\n\

167 \ var n = d.contents[3];\n\

160 \ jsaddle_values.set(n,\n\

168 \ jsaddle_values.set(n,\n\

@@ -239,7 +247,7 @@ runBatch send sendSync = "\

239 \ (v === true ) ? [3, \"\"] :\n\

247 \ (v === true ) ? [3, \"\"] :\n\

240 \ (typeof v === \"number\") ? [-1, v.toString()] :\n\

248 \ (typeof v === \"number\") ? [-1, v.toString()] :\n\

241 \ (typeof v === \"string\") ? [-2, v]\n\

249 \ (typeof v === \"string\") ? [-2, v]\n\

242− \ : [n, \"\"];\n\

250+ \ : [-3, \"\"];\n\

243 \ results.push({\"tag\": \"DeRefValResult\", \"contents\": c});\n\

251 \ results.push({\"tag\": \"DeRefValResult\", \"contents\": c});\n\

244 \ break;\n\

252 \ break;\n\

245 \ case \"IsNull\":\n\

253 \ case \"IsNull\":\n\

@@ -268,17 +276,18 @@ runBatch send sendSync = "\

268 \ }\n\

276 \ }\n\

269 \ }\n\

277 \ }\n\

270 \ if(syncDepth <= 0) {\n\

278 \ if(syncDepth <= 0) {\n\

271− \ lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": results}];\n\

279+ \ lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": [callbacksToFree, results]}];\n\

272 \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> "\n\

280 \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> "\n\

273 \ break;\n\

281 \ break;\n\

274 \ } else {\n" <> (

282 \ } else {\n" <> (

275 case sendSync of

283 case sendSync of

276 Just s ->

284 Just s ->

277− " lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": results}];\n\

285+ " lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": [callbacksToFree, results]}];\n\

278 \ batch = " <> s "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> ";\n\

286 \ batch = " <> s "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> ";\n\

279− \ results = [];\n"

287+ \ results = [];\n\

288+ \ callbacksToFree = [];\n"

280 Nothing ->

289 Nothing ->

281− " " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Success\", \"contents\": results}]}" <> "\n\

290+ " " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Success\", \"contents\": [callbacksToFree, results]}]}" <> "\n\

282 \ break;\n"

291 \ break;\n"

283 ) <>

292 ) <>

284 " }\n\

293 " }\n\

@@ -293,7 +302,8 @@ runBatch send sendSync = "\

293 \ } else {\n\

302 \ } else {\n\

294 \ batch = " <> s "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> ";\n\

303 \ batch = " <> s "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> ";\n\

295 \ }\n\

304 \ }\n\

296− \ results = [];\n"

305+ \ results = [];\n\

306+ \ callbacksToFree = [];\n"

297 Nothing ->

307 Nothing ->

298 " " <> send "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> "\n\

308 " " <> send "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> "\n\

299 \ break;\n"

309 \ break;\n"

@@ -305,7 +315,15 @@ runBatch send sendSync = "\

305 \ catch (err) {\n\

315 \ catch (err) {\n\

306 \ var n = ++jsaddle_index;\n\

316 \ var n = ++jsaddle_index;\n\

307 \ jsaddle_values.set(n, err);\n\

317 \ jsaddle_values.set(n, err);\n\

318+ \ console.log(err);\n\

308− \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Failure\", \"contents\": [results, n]}]}" <> "\n\

319+ \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Failure\", \"contents\": [callbacksToFree, results, n, String(err)]}]}" <> "\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\

309 \ }\n\

327 \ }\n\

310 \ inCallback--;\n\

328 \ inCallback--;\n\

311 \ };\n\

329 \ };\n\

@@ -319,41 +337,6 @@ runBatch send sendSync = "\

319 \ runBatch(batch);\n\

337 \ runBatch(batch);\n\

320 \"

338 \"

321

339

322−-- Use this to generate this string for embedding

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

324−jsaddleJs :: ByteString

325−jsaddleJs = "\

326− \if(typeof global !== \"undefined\") {\n\

327− \ global.window = global;\n\

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

329− \}\n\

330− \\n\

331− \var connect = function() {\n\

332− \ var wsaddress =\n\

333− \ typeof window.location === \"undefined\"\n\

334− \ ? \"ws://localhost:3709/\"\n\

335− \ : window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\");\n\

336− \\n\

337− \ var ws = new WebSocket(wsaddress);\n\

338− \\n\

339− \ ws.onopen = function(e) {\n\

340− \ " <> initState <> "\

341− \\n\

342− \ ws.onmessage = function(e) {\n\

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

344− \\n\

345− \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));") Nothing <> "\

346− \ };\n\

347− \ };\n\

348− \ ws.onerror = function() {\n\

349− \ setTimeout(connect, 1000);\n\

350− \ };\n\

351− \}\n\

352− \\n\

353− \ " <> ghcjsHelpers <> "\

354− \connect();\n\

355− \"

356−

357ghcjsHelpers :: ByteString

340ghcjsHelpers :: ByteString

358ghcjsHelpers = "\

341ghcjsHelpers = "\

359 \function h$isNumber(o) {\

342 \function h$isNumber(o) {\

jsaddle/src/Language/Javascript/JSaddle/Types.hs+75−17

@@ -58,8 +58,14 @@ module Language.Javascript.JSaddle.Types (

58 -- * Debugging

59 , JSadddleHasCallStack

60

61− -- * JavaScript Context Commands

61+ -- * Sync JSM

62+ , syncPoint

63+ , syncAfter

64+

62#ifndef ghcjs_HOST_OS

65#ifndef ghcjs_HOST_OS

66+ , sendCommand

67+

68+ -- * JavaScript Context Commands

63 , MutabilityType(..)

69 , MutabilityType(..)

64 , Mutable

70 , Mutable

65 , Immutable

71 , Immutable

@@ -89,13 +95,14 @@ import GHCJS.Nullable (Nullable(..))

89import GHCJS.Prim.Internal (JSVal(..), JSValueRef)

95import GHCJS.Prim.Internal (JSVal(..), JSValueRef)

90import Data.JSString.Internal.Type (JSString(..))

96import Data.JSString.Internal.Type (JSString(..))

91import Control.DeepSeq (NFData(..))

97import Control.DeepSeq (NFData(..))

98+import Control.Monad.Catch (MonadThrow, MonadCatch(..), MonadMask(..))

92import Control.Monad.Trans.Cont (ContT(..))

99import Control.Monad.Trans.Cont (ContT(..))

93import Control.Monad.Trans.Error (Error(..), ErrorT(..))

100import Control.Monad.Trans.Error (Error(..), ErrorT(..))

94import Control.Monad.Trans.Except (ExceptT(..))

101import Control.Monad.Trans.Except (ExceptT(..))

95import Control.Monad.Trans.Identity (IdentityT(..))

102import Control.Monad.Trans.Identity (IdentityT(..))

96import Control.Monad.Trans.List (ListT(..))

103import Control.Monad.Trans.List (ListT(..))

97import Control.Monad.Trans.Maybe (MaybeT(..))

104import Control.Monad.Trans.Maybe (MaybeT(..))

98−import Control.Monad.Trans.Reader (ReaderT(..))

105+import Control.Monad.Trans.Reader (ReaderT(..), ask)

99import Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))

106import Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))

100import Control.Monad.Trans.RWS.Strict as Strict (RWST(..))

107import Control.Monad.Trans.RWS.Strict as Strict (RWST(..))

101import Control.Monad.Trans.State.Lazy as Lazy (StateT(..))

108import Control.Monad.Trans.State.Lazy as Lazy (StateT(..))

@@ -107,15 +114,17 @@ import Control.Monad.Fix (MonadFix)

107import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))

114import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))

108import Control.Concurrent.STM.TVar (TVar)

115import Control.Concurrent.STM.TVar (TVar)

109import Control.Concurrent.MVar (MVar)

116import Control.Concurrent.MVar (MVar)

117+import Data.Int (Int64)

110import Data.Set (Set)

118import Data.Set (Set)

111import Data.Text (Text)

119import Data.Text (Text)

112−import Data.UUID (UUID)

113import Data.Time.Clock (UTCTime(..))

120import Data.Time.Clock (UTCTime(..))

114import Data.Typeable (Typeable)

121import Data.Typeable (Typeable)

115import Data.Coerce (coerce, Coercible)

122import Data.Coerce (coerce, Coercible)

116import Data.Aeson

123import Data.Aeson

117 (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..), Value)

124 (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..), Value)

118import GHC.Generics (Generic)

125import GHC.Generics (Generic)

126+import Control.Monad.IO.Unlift (MonadUnliftIO)

127+import qualified Control.Monad.Fail as Fail

119#endif

128#endif

120

129

121#if MIN_VERSION_base(4,9,0) && defined(CHECK_UNCHECKED)

130#if MIN_VERSION_base(4,9,0) && defined(CHECK_UNCHECKED)

@@ -132,15 +141,16 @@ import GHC.Exts (Constraint)

132type JSContextRef = ()

141type JSContextRef = ()

133#else

142#else

134data JSContextRef = JSContextRef {

143data JSContextRef = JSContextRef {

135− contextId :: UUID

144+ contextId :: Int64

136− , startTime :: UTCTime

145+ , startTime :: UTCTime

137− , doSendCommand :: Command -> IO Result

146+ , doSendCommand :: Command -> IO Result

138− , doSendAsyncCommand :: AsyncCommand -> IO ()

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

139− , addCallback :: Object -> JSCallAsFunction -> IO ()

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

140− , freeCallback :: Object -> IO ()

141− , nextRef :: TVar JSValueRef

149+ , nextRef :: TVar JSValueRef

142− , doEnableLogging :: Bool -> IO ()

150+ , doEnableLogging :: Bool -> IO ()

143− , finalizerThreads :: MVar (Set Text)

151+ , finalizerThreads :: MVar (Set Text)

152+ , animationFrameHandlers :: MVar [Double -> JSM ()]

153+ , liveRefs :: MVar (Set Int64)

144}

154}

145#endif

155#endif

146

156

@@ -156,9 +166,56 @@ data JSContextRef = JSContextRef {

156type JSM = IO

166type JSM = IO

157#else

167#else

158newtype JSM a = JSM { unJSM :: ReaderT JSContextRef IO a }

168newtype JSM a = JSM { unJSM :: ReaderT JSContextRef IO a }

159− deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

169+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadThrow, MonadUnliftIO, Fail.MonadFail)

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

189+

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

160#endif

211#endif

161

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

162

219

163-- | Type we can give to functions that are pure when using ghcjs, but

220-- | Type we can give to functions that are pure when using ghcjs, but

164-- live in JSM when using jsaddle.

221-- live in JSM when using jsaddle.

@@ -208,7 +265,7 @@ type MonadJSM = MonadIO

208class (Applicative m, MonadIO m) => MonadJSM m where

265class (Applicative m, MonadIO m) => MonadJSM m where

209 liftJSM' :: JSM a -> m a

266 liftJSM' :: JSM a -> m a

210

267

211− default liftJSM' :: (MonadJSM m', MonadTrans t) => JSM a' -> t m' a'

268+ default liftJSM' :: (MonadJSM m', MonadTrans t, m ~ t m') => JSM a -> m a

212 liftJSM' = lift . (liftJSM' :: MonadJSM m' => JSM a -> m' a)

269 liftJSM' = lift . (liftJSM' :: MonadJSM m' => JSM a -> m' a)

213 {-# INLINE liftJSM' #-}

270 {-# INLINE liftJSM' #-}

214

271

@@ -339,7 +396,7 @@ type MutableJSArray = SomeJSArray Mutable

339type STJSArray s = SomeJSArray (STMutable s)

396type STJSArray s = SomeJSArray (STMutable s)

340

397

341-- | See 'JavaScript.Object.Internal.Object'

398-- | See 'JavaScript.Object.Internal.Object'

342−newtype Object = Object JSVal deriving(Show, ToJSON, FromJSON)

399+newtype Object = Object JSVal

343

400

344-- | See 'GHCJS.Nullable.Nullable'

401-- | See 'GHCJS.Nullable.Nullable'

345newtype Nullable a = Nullable a

402newtype Nullable a = Nullable a

@@ -377,6 +434,7 @@ data AsyncCommand = FreeRef Text JSValueForSend

377 | NewEmptyObject JSValueForSend

434 | NewEmptyObject JSValueForSend

378 | NewAsyncCallback JSValueForSend

435 | NewAsyncCallback JSValueForSend

379 | NewSyncCallback JSValueForSend

436 | NewSyncCallback JSValueForSend

437+ | FreeCallback JSValueForSend

380 | NewArray [JSValueForSend] JSValueForSend

438 | NewArray [JSValueForSend] JSValueForSend

381 | EvaluateScript JSStringForSend JSValueForSend

439 | EvaluateScript JSStringForSend JSValueForSend

382 | SyncWithAnimationFrame JSValueForSend

440 | SyncWithAnimationFrame JSValueForSend

@@ -445,8 +503,8 @@ instance ToJSON Result where

445

503

446instance FromJSON Result

504instance FromJSON Result

447

505

448−data BatchResults = Success [Result]

506+data BatchResults = Success [JSValueReceived] [Result]

449− | Failure [Result] JSValueReceived

507+ | Failure [JSValueReceived] [Result] JSValueReceived String

450 deriving (Show, Generic)

508 deriving (Show, Generic)

451

509

452instance ToJSON BatchResults where

510instance ToJSON BatchResults where

jsaddle/src/Language/Javascript/JSaddle/Value.hs+5−3

@@ -618,15 +618,17 @@ 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 = toJSVal value >>= N.deRefVal >>= \result -> return $

621+deRefVal value = do

622+ v <- toJSVal value

623+ result <- N.deRefVal v

622− case result of

624+ return $ case result of

623 DeRefValResult 0 _ -> ValNull

625 DeRefValResult 0 _ -> ValNull

624 DeRefValResult 1 _ -> ValUndefined

626 DeRefValResult 1 _ -> ValUndefined

625 DeRefValResult 2 _ -> ValBool False

627 DeRefValResult 2 _ -> ValBool False

626 DeRefValResult 3 _ -> ValBool True

628 DeRefValResult 3 _ -> ValBool True

627 DeRefValResult (-1) s -> ValNumber (read (T.unpack s))

629 DeRefValResult (-1) s -> ValNumber (read (T.unpack s))

628 DeRefValResult (-2) s -> ValString s

630 DeRefValResult (-2) s -> ValString s

629− DeRefValResult ref _ -> ValObject (Object (JSVal ref))

631+ DeRefValResult (-3) _ -> ValObject (Object v)

630 _ -> error "Unexpected result dereferencing JSaddle value"

632 _ -> error "Unexpected result dereferencing JSaddle value"

631#endif

633#endif

632

634

nix/hix.nixnew file+8

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

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+2−12

@@ -6,18 +6,8 @@ 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−

13cabal update

9cabal update

14−cabal new-build --constraint='Cabal>=1.24.2.0' 'jsaddle-warp:lib:jsaddle-warp' 'jsaddle-warp:test:test-tool'

10+cabal new-build 'jsaddle-warp:lib:jsaddle-warp' 'jsaddle-warp:test:test-tool'

15cd jsaddle-warp

11cd jsaddle-warp

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

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

17−

18−# update the cache

19−rm -rf .cabal

20−cp -a /root/.cabal ./

21−rm -rf .ghc

22−cp -a /root/.ghc ./

23

13