96b2abe...master · jsaddle

.travis.yml+40−24

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

1−sudo: required

2−services:

3− - docker

1+language: nix

2+nix: 2.2.2

43

5−cache:

6− directories:

7− - .cabal

8− - .ghc

4+jobs:

5+ include:

6+ - stage: Build

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

924

10−env:

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

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

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

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

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

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

17−

18−before_install:

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

25+install:

26+- sudo mkdir -p /etc/nix

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

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

2029

2130script:

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

23− sh -x -c "

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

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

26− ./travis/build.sh"

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

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

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

34+- |

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

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

37+ fi

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

39+- |

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

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

42+ fi

43+

2744notifications:

2845 irc:

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

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

1414import Control.Lens ((^.))

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

1718

1819main = run 3709 $ do

1920 doc <- jsg "document"

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

7980 appendChild newParagraph text

8081 appendChild body (Just newParagraph)

8182 return ()

82−

83+

8384 -- Make an exit button

8485 exitMVar <- liftIO newEmptyMVar

8586 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

102103

103104## How does it work on GHC

104105

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−[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.

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

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.

107119

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.

109122

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

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

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

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

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

124+

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

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

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

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.

114131

115132### JSVal

116133

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

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

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

122139

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

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

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

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

125142lazy execution of the JSaddle code.

126143

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

129146

130147### JSStrings

131148

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

133150

134151### Lazy Execution

135152

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

161178It 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.

162179

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

165182

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

167184

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

196213at the point the exception is thrown.

197214

198215When 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.

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

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

202219There 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−

31packages:

42 jsaddle/

53 jsaddle-warp/

64 jsaddle-wkwebview/

7−-- jsaddle-webkitgtk/

85 jsaddle-webkit2gtk/

96 jsaddle-clib/

107

11−package gi-atk

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

13−package gi-cairo

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

15−package gi-gdk

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

17−package gi-gdkpixbuf

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

19−package gi-gio

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

21−package gi-glib

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

23−package gi-gobject

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

25−package gi-gtk

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

27−package gi-gtk-hs

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

29−package gi-gtkosxapplication

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

31−package gi-gtksource

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

33−package gi-javascriptcore

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

35−package gi-pango

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

37−package gi-soup

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

39−package gi-webkit

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

41−package gi-webkit2

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

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

9+

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

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

11name: jsaddle-clib

2−version: 0.9.0.0

2+version: 0.9.8.0

33cabal-version: >=1.10

44build-type: Simple

55license: MIT

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

2121 Language.Javascript.JSaddle.CLib

2222 Language.Javascript.JSaddle.CLib.Internal

2323 build-depends:

24− aeson >=0.8.0.2 && <1.3,

24+ aeson >=0.8.0.2 && <1.6,

2525 base <5,

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

2627 bytestring >=0.10.6.0 && <0.11,

2728 jsaddle >= 0.9.0.0 && <0.10,

2829 data-default,

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

3233 Include-dirs: cbits/include

3334 Includes: jsaddle.h

3435 Install-includes: jsaddle.h

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

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

3637 if impl(ghcjs)

3738 hs-source-dirs: src-ghcjs

3839 else

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

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

88 , appConfigToAppCallbacks

99 ) where

1010

11+import Prelude ()

12+import Prelude.Compat

13+

1114import Control.Monad (void)

1215import Control.Concurrent (forkIO)

1316

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

1619import Data.ByteString.Char8 (unpack)

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

1821import Data.Default (def, Default)

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

2022import Data.Text (Text)

2123import qualified Data.Text.Encoding as T

2224

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.2.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 @@

11name: jsaddle-warp

2−version: 0.9.2.0

2+version: 0.9.8.0

33cabal-version: >=1.10

44build-type: Simple

55license: MIT

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

1010 This package provides an EDSL for calling JavaScript that

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

1212 the application is run using Warp and WebSockets to

13− drive a small JavaScipt helper.

13+ drive a small JavaScript helper.

1414category: Web, Javascript

1515author: Hamish Mackenzie

1616

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

2424 if !impl(ghcjs -any)

2525 exposed-modules:

2626 Language.Javascript.JSaddle.WebSockets

27+ other-modules:

28+ Language.Javascript.JSaddle.WebSockets.Compat

2729 build-depends:

28− aeson >=0.8.0.2 && <1.3,

30+ aeson >=0.8.0.2 && <1.6,

2931 bytestring >=0.10.6.0 && <0.11,

30− containers >=0.5.6.2 && <0.6,

32+ containers >=0.5.6.2 && <0.7,

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

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

33− jsaddle >=0.9.2.0 && <0.10,

34− stm >=2.4.4 && <2.5,

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

35+ jsaddle >=0.9.4.0 && <0.10,

36+ stm >=2.4.4 && <2.6,

3537 text >=1.2.1.3 && <1.3,

36− time >=1.5.0.1 && <1.8,

38+ time >=1.5.0.1 && <1.11,

3739 transformers >=0.4.2.0 && <0.6,

38− uuid >=1.3.13 && <1.4,

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

4040 wai >=3.0.3.0 && <3.3,

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

42− warp >=3.1.2 && <3.3,

43− websockets >=0.9.5.0 && <0.11

42+ warp >=3.1.2 && <3.4,

43+ websockets >=0.9.5.0 && <0.13

4444 exposed-modules:

4545 Language.Javascript.JSaddle.Warp

4646 build-depends:

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

5959 bytestring -any,

6060 containers -any,

6161 deepseq -any,

62− doctest >=0.10.1 && <0.12,

62+ doctest >=0.10.1 && <0.19,

63+ exceptions -any,

6364 filepath >=1.4.0.0 && <1.5,

65+ foreign-store -any,

6466 ghc-prim -any,

6567 http-types -any,

6668 jsaddle -any,

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

6971 network -any,

7072 ref-tf -any,

7173 primitive -any,

72− process >=1.2.3.0 && <1.5,

74+ process >=1.2.3.0 && <1.7,

75+ random -any,

7376 stm -any,

7477 text -any,

7578 time -any,

7679 transformers -any,

80+ unliftio-core -any,

7781 wai -any,

7882 wai-websockets -any,

7983 warp -any,

80− webdriver >=0.8.4 && <0.9,

84+ webdriver >=0.8.4 && <0.10,

8185 websockets -any

8286 type: exitcode-stdio-1.0

8387 main-is: DocTest.hs

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

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

1717 , listWindowProperties

1818) where

1919

20−import Control.Applicative

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

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

23−import Language.Javascript.JSaddle

24−import qualified Data.Text as T

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

26−import Control.Monad (forever, forM)

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

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

21+import Control.Applicative

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

2923import Control.Concurrent.MVar

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

31−import System.IO.Unsafe (unsafePerformIO)

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

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

26+import Control.Monad (forever, forM)

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

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

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

3330import Data.Text (Text)

31+import qualified Data.Text as T

32+import Language.Javascript.JSaddle

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

34+import System.IO.Unsafe (unsafePerformIO)

35+import System.Timeout (timeout)

3536

3637context :: MVar JSContextRef

3738context = unsafePerformIO newEmptyMVar

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

5253

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

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

55−testJSaddle f = do

56+testJSaddle f = timeout 10000000 (do

5657 startServer

5758 c <- takeMVar context

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

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

60− putMVar context c

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

6162

6263debugLog :: String -> IO ()

6364debugLog _ = return ()

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

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

1919 jsaddleOr

2020 , jsaddleApp

2121 , jsaddleWithAppOr

22+ , jsaddleAppWithJs

23+ , jsaddleAppWithJsOr

2224 , jsaddleAppPartial

25+ , jsaddleJs

26+ , jsaddleJs'

2327 , debug

28+ , debugOr

2429 , debugWrapper

2530) where

2631

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

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

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

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

3035

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

3742import Network.WebSockets

3843 (defaultConnectionOptions, ConnectionOptions(..), sendTextData,

3944 receiveDataMessage, acceptRequest, ServerApp, sendPing)

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

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

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

4247

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

4449import qualified Network.Wai as W

45− (responseLBS, requestMethod, pathInfo)

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

4651import qualified Data.Text as T (pack)

4752import qualified Network.HTTP.Types as H

4853 (status403, status200)

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

5358import Data.Maybe (fromMaybe)

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

5560import Data.IORef

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

61+ (readIORef, newIORef, atomicModifyIORef')

5762import Data.ByteString.Lazy (ByteString)

58−import Data.UUID.Types (toText)

63+import qualified Data.ByteString.Lazy as LBS

64+ (toStrict, stripPrefix)

5965import Control.Concurrent.MVar

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

61− newEmptyMVar, modifyMVar)

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

67+ readMVar, newMVar, newEmptyMVar, modifyMVar)

6268import Network.Wai.Handler.Warp

6369 (defaultSettings, setTimeout, setPort, runSettings)

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

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

6571import Language.Javascript.JSaddle (askJSM)

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

6773

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

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

76+

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

6978jsaddleOr opts entryPoint otherApp = do

7079 syncHandlers <- newIORef M.empty

80+ asyncHandlers <- newIORef M.empty

7181 let wsApp :: ServerApp

7282 wsApp pending_conn = do

7383 conn <- acceptRequest pending_conn

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

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

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

77− liftIO $ sendTextData conn (encode syncKey)

78− entryPoint

79− _ <- forkIO . forever $

80− receiveDataMessage conn >>= \case

81− (WS.Text t) ->

82− case decode t of

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

84− Just r -> processResult r

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

86− start

87− waitTillClosed conn

84+ initMsg <- receiveDataMessage conn

85+ case getTextMessageByteString initMsg of

86+ Just "" -> do

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

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

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

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

91+ liftIO $ sendTextData conn (encode syncKey)

92+ entryPoint

93+ start

94+ waitTillClosed conn

95+ Just syncKey ->

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

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

98+ Just processResult ->

99+ forever $

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

101+ Just t ->

102+ case decode t of

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

104+ Just r -> processResult r

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

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

88107

89108 -- Based on Network.WebSocket.forkPingThread

90109 waitTillClosed conn = ignore `handle` go 1

91110 where

92111 go :: Int -> IO ()

93112 go i = do

94− threadDelay (1 * 1000 * 1000)

113+ threadDelay (10 * 1000 * 1000)

95114 sendPing conn (T.pack $ show i)

96115 go (i + 1)

97116

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

111130 Just handler -> do

112131 next <- encode <$> handler result

113132 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

115138 return $ websocketsOr opts wsApp syncHandler

116139

117140

118141jsaddleApp :: Application

119−jsaddleApp req sendResponse =

120− fromMaybe

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

122− (jsaddleAppPartial req sendResponse)

142+jsaddleApp = jsaddleAppWithJs $ jsaddleJs False

143+

144+jsaddleAppWithJs :: ByteString -> Application

145+jsaddleAppWithJs js req sendResponse =

146+ jsaddleAppWithJsOr js

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)

153+ (jsaddleAppPartialWithJs js req sendResponse)

123154

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

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

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

127158 (jsaddleAppPartial req sendResponse))

128159

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

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

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

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

161+jsaddleAppPartial = jsaddleAppPartialWithJs $ jsaddleJs False

162+

163+indexResponse :: Response

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

165+

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

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

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

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

133170 _ -> Nothing

134171

172+jsaddleJs :: Bool -> ByteString

173+jsaddleJs = jsaddleJs' Nothing

174+

135175-- Use this to generate this string for embedding

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

137−jsaddleJs :: ByteString

138−jsaddleJs = "\

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

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

178+jsaddleJs' jsaddleUri refreshOnLoad = "\

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

140180 \ global.window = global;\n\

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

142182 \}\n\

143183 \\n\

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

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

185+ \ var wsaddress = "

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\

146190 \\n\

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

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

148192 \ var syncKey = \"\";\n\

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

151198 \ " <> initState <> "\n\

152− \ var inXhrSend = false;\n\

153199 \\n\

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

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

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

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

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

203+ \ asyncBatch = batch;\n\

204+ \ return;\n\

205+ \ }\n\

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

158207 \ syncKey = batch;\n\

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

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

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

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

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

164− \ };\n\

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

166− \ return;\n\

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

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

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

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

212+ \ initialResults = null;\n\

213+ \ ws = ws1;\n\

214+ \ }\n" <>

215+ (if refreshOnLoad

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

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

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

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

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

221+ \ };\n\

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

223+ else "") <>

224+ " return;\n\

167225 \ }\n\

168226 \\n\

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

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

171− \ inXhrSend = true;\n\

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

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

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

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

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

176− \ inXhrSend = false;\n\

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

178234 \ };\n\

179235 \ };\n\

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

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

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

182238 \ };\n\

183239 \}\n\

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

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

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

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

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

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

198261

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+

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

200268debugWrapper run = do

201269 reloadMVar <- newEmptyMVar

202270 reloadDoneMVars <- newMVar []

203271 contexts <- newMVar []

204− let refreshMiddleware :: Middleware

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

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

207− reloadDone <- newEmptyMVar

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

209− readMVar reloadMVar

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

211− putMVar reloadDone ()

212− return r

213− _ -> otherApp req sendResponse

272+ let refresh sendResponse = do

273+ reloadDone <- newEmptyMVar

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

275+ readMVar reloadMVar

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

277+ putMVar reloadDone ()

278+ return r

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

215280 start expectedConnections = do

216281 serverDone <- newEmptyMVar

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

222287 addContext

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

224289 thread <- forkIO $

225− finally (run refreshMiddleware registerContext)

290+ finally (run (refreshMiddleware refresh) registerContext)

226291 (putMVar serverDone ())

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

228293 when (expectedConnections /= 0) $ takeMVar ready

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

231296 ctxs <- takeMVar contexts

232297 mapM_ removeContext ctxs

233298 takeMVar reloadDoneMVars >>= mapM_ takeMVar

234− killThread thread

235− takeMVar serverDone

299+ tryTakeMVar serverDone >>= \case

300+ Nothing -> do

301+ killThread thread

302+ takeMVar serverDone

303+ Just _ -> return ()

236304 return $ length ctxs

237− lookupStore shutdown_0 >>= \case

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

306+ restarter mvar stop = do

307+ start' <- takeMVar mvar

308+ n <- stop

309+ start' n >>= restarter mvar

310+ lookupStore storeId >>= \case

238311 Nothing -> do

239− shutdownRef <- newIORef =<< start 0

240− void $ newStore shutdownRef

312+ restartMVar <- newMVar start

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

314+ void $ writeStore (Store storeId) restartMVar

241315 Just shutdownStore -> do

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

243− expectedConnections <- join (readIORef shutdownRef)

244− writeIORef shutdownRef =<< start expectedConnections

245− where shutdown_0 = 0

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

317+ void $ tryTakeMVar restartMVar

318+ putMVar restartMVar start

319+ where storeId = 354

jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets/Compat.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)

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

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

1313import System.Process (readProcess, system)

14−import Control.Concurrent (forkIO)

14+import Control.Concurrent

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

1516import Control.Monad (void)

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

1718import Data.Monoid ((<>))

1819import System.Environment (getArgs)

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

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

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

2221

2322main :: IO ()

2423main = do

25− putStrLn "Hello"

24+ putStrLn "Testing JSaddle"

2625 jsaddlePath <- getArgs >>= \case

2726 [arg] -> return arg

2827 _ -> do

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

3029 exitFailure

3130 hSetBuffering stdout LineBuffering

3231 hSetBuffering stderr LineBuffering

32+ putStrLn "Checking for phantomjs"

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

3434 ExitSuccess -> return ()

3535 e -> do

3636 putStrLn "phantomjs not found"

3737 exitWith e

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

39− runSession defaultConfig $ do

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

38+ putStrLn "Starting phantomjs"

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

40+ threadDelay 5000000

41+ putStrLn "Running Tests"

42+ done <- newEmptyMVar

43+ forkIO $ do

4144 liftIO $ doctest [

4245 "-hide-all-packages",

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

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

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

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

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

6471 "-i" <> "src",

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

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

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

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

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

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

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

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

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

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

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

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

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

98106 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

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

11name: jsaddle-webkit2gtk

2−version: 0.9.0.0

2+version: 0.9.8.0

33cabal-version: >=1.10

44build-type: Simple

55license: MIT

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

2626 base <5

2727 if !impl(ghcjs -any)

2828 build-depends:

29− aeson >=0.8.0.2 && <1.3,

29+ aeson >=0.8.0.2 && <1.6,

3030 base <5,

3131 bytestring >=0.10.6.0 && <0.11,

3232 directory >=1.0.0.2 && <1.4,

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

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

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

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

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

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

39− jsaddle >=0.9.0.0 && <0.10,

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

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

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

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

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

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

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

40+ jsaddle >=0.9.4.0 && <0.10,

4041 text >=1.2.1.3 && <1.3,

4142 webkit2gtk3-javascriptcore >=0.14.0.0 && <0.15

4243 if !os(windows)

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

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

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

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

4545import Data.Aeson (encode, decode)

46−import Data.Text (Text)

4746import qualified Data.Text as T (pack)

48−import Data.Text.Foreign (fromPtr)

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

5048

51−import Foreign.Ptr (castPtr, nullPtr)

52−

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

5450import Data.GI.Base.Signals

5551 (connectSignalFunPtr, SignalConnectMode(..), SignalConnectMode,

5652 SignalHandlerId)

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

5853

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

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

6156import GI.Gtk

6257 (windowSetPosition, windowSetDefaultSize, windowNew,

63− scrolledWindowNew, noAdjustment, containerAdd,

58+ scrolledWindowNew, Adjustment, containerAdd,

6459 WindowType(..), WindowPosition(..), widgetDestroy,

6560 widgetGetToplevel, widgetShowAll, onWidgetDestroy,

6661 mainQuit)

67−import GI.Gio (noCancellable)

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

62+import GI.Gio (Cancellable)

63+import GI.JavaScriptCore (valueToString)

6964import GI.WebKit2

7065 (scriptDialogPromptSetText, scriptDialogPromptGetDefaultText,

7166 scriptDialogGetMessage, scriptDialogGetDialogType,

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

7469 setSettingsEnableJavascript, webViewNewWithUserContentManager,

7570 userContentManagerNew,

7671 userContentManagerRegisterScriptMessageHandler,

77− javascriptResultGetValue, javascriptResultGetGlobalContext,

72+ javascriptResultGetJsValue,

7873 webViewGetUserContentManager,

7974 mk_UserContentManagerScriptMessageReceivedCallback,

8075 wrap_UserContentManagerScriptMessageReceivedCallback,

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

8378 onWebViewLoadChanged, setSettingsEnableDeveloperExtras,

8479 webViewSetSettings, webViewGetSettings, ScriptDialogType(..))

8580

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−

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

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

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

9684

85+noAdjustment :: Maybe Adjustment

86+noAdjustment = Nothing

87+

88+noCancellable :: Maybe Cancellable

89+noCancellable = Nothing

90+

9791quitWebView :: WebView -> IO ()

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

9993 widgetDestroy w

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

109103postGUIAsync action =

110104 void . idleAdd PRIORITY_DEFAULT $ action >> return False

111105

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−

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

128107run main = do

129108 _ <- Gtk.init Nothing

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

148127 void . onWebViewLoadChanged webView $ \case

149128 LoadEventFinished -> runInWebView main webView

150129 _ -> return ()

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

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

152131 installQuitHandler webView

153132 Gtk.main

154133

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

172151 let cb' = wrap_UserContentManagerScriptMessageReceivedCallback cb

173152 cb'' <- mk_UserContentManagerScriptMessageReceivedCallback cb'

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

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

155+ Nothing

156+#endif

175157

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

177159addJSaddleHandler webView processResult syncResults = do

178160 manager <- webViewGetUserContentManager webView

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

180− ctx <- javascriptResultGetGlobalContext result

181− arg <- javascriptResultGetValue result

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

183− withJSValueRef arg $ \argRef ->

184− encodeUtf8 <$> valueToText ctxRef argRef

162+ arg <- javascriptResultGetJsValue result

163+ bs <- encodeUtf8 <$> valueToString arg

185164 mapM_ processResult (decode (fromStrict bs))

186165 _ <- onWebViewScriptDialog webView $ \dialog ->

187166 scriptDialogGetDialogType dialog >>= \case

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

206185 , initState

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

208187 , 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 <> ")))"))

212189 , "};\n"

213190 , "})()"

214191 ]

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

22#import <Cocoa/Cocoa.h>

33#import <WebKit/WebKit.h>

44

5+extern void callIO(HsStablePtr);

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

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

58extern void callWithWebView(WKWebView *, HsStablePtr);

69

710@interface AppDelegate : NSObject <NSApplicationDelegate>

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

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

1215@end

1316

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+

1423@implementation AppDelegate

1524

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

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

3140 return self;

3241}

3342

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

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

45+ return b ? YES : NO;

46+}

47+

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

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

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

50+ if (global_developerExtrasEnabled) {

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

52+ }

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

3854 [_window setContentView:webView];

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

4069}

4170

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

4372 [_window orderFrontRegardless];

4473 [_window center];

4574 [NSApp activateIgnoringOtherApps:YES];

75+ callIO(global_didFinishLaunchingWithOptions);

4676}

4777

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

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

5181

5282@end

5383

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

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

56111 NSApplication *application = [NSApplication sharedApplication];

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

58113 [application setDelegate:appDelegate];

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

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

55

66extern void callIO(HsStablePtr);

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

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

89

910@interface AppDelegate ()

1011

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

2021HsStablePtr global_applicationWillTerminate = 0;

2122HsStablePtr global_applicationSignificantTimeChange = 0;

2223HsStablePtr global_applicationUniversalLink = 0;

24+HsStablePtr global_applicationDidReceiveRemoteNotification = 0;

2325uint64_t global_requestAuthorizationWithOptions = 0;

2426uint64_t global_requestAuthorizationOptionBadge = 0;

2527uint64_t global_requestAuthorizationOptionSound = 0;

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

109111 callWithCString([deviceTokenString UTF8String], global_didRegisterForRemoteNotificationsWithDeviceToken);

110112}

111113

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+

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

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

114133 NSString *errorString = [error localizedDescription];

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

143162 HsStablePtr hs_applicationWillTerminate,

144163 HsStablePtr hs_applicationSignificantTimeChange,

145164 HsStablePtr hs_applicationUniversalLink,

165+ HsStablePtr hs_applicationDidReceiveRemoteNotification,

146166 const uint64_t hs_requestAuthorizationWithOptions,

147167 const uint64_t hs_requestAuthorizationOptionBadge,

148168 const uint64_t hs_requestAuthorizationOptionSound,

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

150170 const uint64_t hs_requestAuthorizationOptionCarPlay,

151171 const uint64_t hs_registerForRemoteNotifications,

152172 HsStablePtr hs_didRegisterForRemoteNotificationsWithDeviceToken,

153− HsStablePtr hs_didFailToRegisterForRemoteNotificationsWithError) {

173+ HsStablePtr hs_didFailToRegisterForRemoteNotificationsWithError,

174+ const uint64_t hs_developerExtrasEnabled) {

154175 @autoreleasepool {

155176 globalHandler = handler;

156177 global_willFinishLaunchingWithOptions = hs_willFinishLaunchingWithOptions;

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

162183 global_applicationWillTerminate = hs_applicationWillTerminate;

163184 global_applicationSignificantTimeChange = hs_applicationSignificantTimeChange;

164185 global_applicationUniversalLink = hs_applicationUniversalLink;

186+ global_applicationDidReceiveRemoteNotification = hs_applicationDidReceiveRemoteNotification;

165187 global_requestAuthorizationWithOptions = hs_requestAuthorizationWithOptions;

166188 global_requestAuthorizationOptionBadge = hs_requestAuthorizationOptionBadge;

167189 global_requestAuthorizationOptionSound = hs_requestAuthorizationOptionSound;

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

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

6161

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

6363 if(openApp(url))

64− decisionHandler(WKNavigationActionPolicyCancel);

65− else

66− decisionHandler(WKNavigationActionPolicyAllow);

64+ decisionHandler(WKNavigationActionPolicyCancel);

65+ else

66+ decisionHandler(WKNavigationActionPolicyAllow);

6767 }

6868 else

6969 decisionHandler(WKNavigationActionPolicyAllow);

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

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

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

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

77+#ifdef USE_UIKIT

78+ webView.scrollView.bounces = NO;

79+#endif

7780 webView.navigationDelegate = handler;

7881 webView.UIDelegate = handler;

7982}

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

9295 handler.completionHandler = NULL;

9396}

9497

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

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

97− dispatch_async(dispatch_get_main_queue(), ^{

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

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

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

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

101+ dispatch_async(dispatch_get_main_queue(), ^{

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

99103 });

100104}

101105

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

118122 }

119123 }

120124}

121−

122−

123−

jsaddle-wkwebview/default.nix+14−21

@@ -1,21 +1,14 @@

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

2−, buildPackages, hostPlatform

3−}:

4−

5−mkDerivation {

6− pname = "jsaddle-wkwebview";

7− version = "0.9.0.0";

8− src = ./.;

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

10− libraryDarwinFrameworkDepends = with buildPackages; if hostPlatform.useiOSCross or false then [

11− (assert osx_sdk != null; osx_sdk)

12− ] else [

13− darwin.libobjc

14− darwin.apple_sdk.libs.xpc

15− darwin.apple_sdk.frameworks.Foundation

16− darwin.apple_sdk.frameworks.Cocoa

17− darwin.apple_sdk.frameworks.WebKit

18− ];

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

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

21−}

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

2+self: super:

3+let

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

5+ inherit (pkgs) lib;

6+in

7+with pkgs.haskell.lib;

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

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

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

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

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

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

14+})

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

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

11name: jsaddle-wkwebview

2−version: 0.9.0.0

2+version: 0.9.8.0

33cabal-version: >=1.10

44build-type: Simple

55license: MIT

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

2525library

2626 exposed-modules:

2727 Language.Javascript.JSaddle.WKWebView

28− Language.Javascript.JSaddle.WKWebView.Internal

2928 build-depends:

30− aeson >=0.8.0.2 && <1.3,

31− base <5,

32− bytestring >=0.10.6.0 && <0.11,

33− jsaddle >= 0.9.0.0 && <0.10,

34− data-default,

35− containers

29+ base <5

3630 default-language: Haskell2010

3731 hs-source-dirs: src

38− frameworks: Foundation, WebKit

3932 ghc-options: -ferror-spans -Wall

40− c-sources:

41− cbits/WKWebView.m

33+ if os(linux)

34+ buildable: False

4235 if impl(ghcjs)

4336 hs-source-dirs: src-ghcjs

4437 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

4549 hs-source-dirs: src-ghc

50+ c-sources:

51+ cbits/WKWebView.m

52+ cc-options: -Wno-everything

4653 if os(ios)

4754 frameworks: UIKit, UserNotifications

4855 if flag(include-app-delegate)

4956 c-sources:

5057 cbits-uikit/AppDelegate.m

5158 cbits-uikit/ViewController.m

59+ cpp-options: -DUSE_UIKIT

5260 else

5361 frameworks: Cocoa

5462 if flag(include-app-delegate)

5563 c-sources:

5664 cbits-cocoa/AppDelegate.m

65+ cpp-options: -DUSE_COCOA

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

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

11module Language.Javascript.JSaddle.WKWebView

22 ( jsaddleMain

3+ , jsaddleMainHTMLWithBaseURL

34 , jsaddleMainFile

45 , WKWebView(..)

56 , run

7+ , run'

68 , runWithAppConfig

9+ , runHTMLWithBaseURL

710 , runFile

811 , mainBundleResourcePath

12+ , ApplicationState (..)

913 , AppDelegateConfig (..)

1014 , AppDelegateNotificationConfig (..)

1115 , AuthorizationOption (..)

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

1721import qualified Data.Set as Set

1822import Data.Word

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

2126import System.Environment (getProgName)

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

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

2329import Foreign.StablePtr (StablePtr, newStablePtr)

2430import Language.Javascript.JSaddle (JSM)

2531

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

3541 -> StablePtr (IO ()) -- applicationWillTerminate

3642 -> StablePtr (IO ()) -- applicationSignificantTimeChange

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

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

3845 -> Word64 -- whether to run requestAuthorizationWithOptions

3946 -> Word64 -- Ask for Badge authorization

4047 -> Word64 -- Ask for Sound authorization

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

4350 -> Word64 -- registerForRemoteNotifications

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

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

53+ -> Word64 -- developerExtrasEnabled

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

4655 -> IO ()

4756

4857data AppDelegateConfig = AppDelegateConfig

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

5564 , _appDelegateConfig_applicationWillTerminate :: IO ()

5665 , _appDelegateConfig_applicationSignificantTimeChange :: IO ()

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

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

5986 }

6087

6188instance Default AppDelegateConfig where

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

6996 , _appDelegateConfig_applicationWillTerminate = return ()

7097 , _appDelegateConfig_applicationSignificantTimeChange = return ()

7198 , _appDelegateConfig_applicationUniversalLink = \_ -> return ()

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

72100 , _appDelegateConfig_appDelegateNotificationConfig = def

101+ , _appDelegateConfig_developerExtrasEnabled = True

102+ , _appDelegateConfig_applicationOpenFile = \_ -> return False

73103 }

74104

75105data AuthorizationOption = AuthorizationOption_Badge

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

78108 | AuthorizationOption_CarPlay

79109 deriving (Show, Read, Eq, Ord)

80110

111+data ApplicationState = ApplicationState_Active

112+ | ApplicationState_Inactive

113+ | ApplicationState_Background

114+ | ApplicationState_Unknown CInt

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

116+

81117data AppDelegateNotificationConfig = AppDelegateNotificationConfig

82118 { _appDelegateNotificationConfig_requestAuthorizationWithOptions :: Maybe (Set AuthorizationOption)

83119 , _appDelegateNotificationConfig_registerForRemoteNotifications :: Bool

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

96132

97133-- | Run JSaddle in a WKWebView

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

99−run = run' Nothing def

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

100136

101137-- | Run JSaddle in a WKWebView

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

103−runWithAppConfig = run' Nothing

139+runWithAppConfig cfg = run' cfg . jsaddleMain

104140

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

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

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

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

109− -> AppDelegateConfig

110− -> JSM ()

111− -> IO ()

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

113−

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

115− -> AppDelegateConfig

116− -> JSM ()

143+runFile

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

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

146+ -> AppDelegateConfig

147+ -> JSM ()

148+ -> IO ()

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

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

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+

162+run' :: AppDelegateConfig

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

117164 -> IO ()

118−run' mUrl cfg f = do

119− handler <- case mUrl of

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

121− Nothing -> newStablePtr (jsaddleMain f)

165+run' cfg main = do

166+ handler <- newStablePtr main

122167 progName <- getProgName

123168

124169 -- AppDelegate callbacks

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

131176 applicationWillTerminate <- newStablePtr $ _appDelegateConfig_applicationWillTerminate cfg

132177 applicationSignificantTimeChange <- newStablePtr $ _appDelegateConfig_applicationSignificantTimeChange cfg

133178 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

134187

135188 -- AppDelegate notification configuration

136189 let ncfg = _appDelegateConfig_appDelegateNotificationConfig cfg

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

153206 applicationWillTerminate

154207 applicationSignificantTimeChange

155208 applicationUniversalLink

209+ applicationDidReceiveRemoteNotification

156210 (fromBool requestAuthorizationWithOptions)

157211 (fromBool $ Set.member AuthorizationOption_Badge authorizationOptions)

158212 (fromBool $ Set.member AuthorizationOption_Sound authorizationOptions)

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

161215 (fromBool registerForRemoteNotifications)

162216 didRegisterForRemoteNotificationsWithDeviceToken

163217 didFailToRegisterForRemoteNotificationsWithError

218+ (fromBool $ _appDelegateConfig_developerExtrasEnabled cfg)

219+ applicationOpenFile

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

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

11{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}

22module Language.Javascript.JSaddle.WKWebView.Internal

33 ( jsaddleMain

4+ , jsaddleMainHTMLWithBaseURL

45 , jsaddleMainFile

56 , WKWebView(..)

67 , mainBundleResourcePath

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

1516import qualified Data.ByteString as BS (ByteString)

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

1718import Data.Aeson (encode, decode)

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

20+import Data.Text.Encoding (encodeUtf8)

1821

1922import Foreign.C.String (CString)

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

2024import Foreign.Ptr (Ptr, nullPtr)

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

2226

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

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

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

2630

31+import System.Directory (getCurrentDirectory)

32+

2733newtype WKWebView = WKWebView (Ptr WKWebView)

2834newtype JSaddleHandler = JSaddleHandler (Ptr JSaddleHandler)

2935

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

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

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

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

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

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

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

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

3644foreign 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 ()

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

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

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

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

4250

4351-- | Run JSaddle in WKWebView

4452jsaddleMain :: 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 =

4666 jsaddleMain' f webView $

47− useAsCString (toStrict indexHtml) $ loadHTMLString webView

67+ useAsCString baseURL $ \url ->

68+ useAsCString initialHTML $ \html ->

69+ loadHTMLStringWithBaseURL webView html url

4870

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

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

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

107129 f <- deRefStablePtr fptr

108130 f c

109131

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+

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

111143callIO ptr = do

112144 f <- deRefStablePtr ptr

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

140172 if bs == nullPtr

141173 then return Nothing

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

11name: jsaddle

2−version: 0.9.2.1

2+version: 0.9.8.0

33cabal-version: >=1.10

44build-type: Simple

55license: MIT

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

1010 This package provides an EDSL for calling JavaScript that

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

1212 the application is run using Warp and WebSockets to

13− drive a small JavaScipt helper.

13+ drive a small JavaScript helper.

1414category: Web, Javascript

1515author: Hamish Mackenzie

1616

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

3636 else

3737 build-depends:

3838 attoparsec >=0.11 && <0.14,

39− containers >=0.5.6.2 && <0.6,

39+ containers >=0.5.6.2 && <0.7,

4040 deepseq >=1.3 && < 1.5,

4141 filepath >=1.4.0.0 && <1.5,

4242 ghc-prim,

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

44− process >=1.2.3.0 && <1.5,

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

44+ process >=1.2.3.0 && <1.7,

45+ random >= 1.1 && < 1.3,

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

4647 scientific >=0.3 && <0.4,

47− stm >=2.4.4 && <2.5,

48− time >=1.5.0.1 && <1.8,

48+ stm >=2.4.4 && <2.6,

49+ time >=1.5.0.1 && <1.11,

4950 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

5353 exposed-modules:

5454 Data.JSString

5555 Data.JSString.Internal

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

6363 GHCJS.Prim

6464 GHCJS.Prim.Internal

6565 GHCJS.Types

66+ GHCJS.Concurrent

6667 GHCJS.Foreign

6768 GHCJS.Foreign.Internal

6869 GHCJS.Internal.Types

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

106107 Language.Javascript.JSaddle.Value

107108 Language.Javascript.JSaddle.Types

108109 build-depends:

109− aeson >=0.8.0.2 && <1.3,

110− base <5,

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

110+ aeson >=0.11.3.0 && <1.6,

111+ base >=4.9 && <5,

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

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

112114 bytestring >=0.10.6.0 && <0.11,

113− lens >=3.8.5 && <4.16,

114− primitive >=0.6.1.0 && <0.7,

115+ exceptions >=0.8 && <0.11,

116+ lens >=3.8.5 && <5.1,

117+ primitive >=0.6.1.0 && <0.8,

115118 text >=1.2.1.3 && <1.3,

116119 transformers >=0.4.2.0 && <0.6

117120 default-language: Haskell2010

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

121124 cpp-options: -DCHECK_UNCHECKED

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

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

3838import Data.Data (Data)

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

4040import Data.Typeable (Typeable)

41+import Data.Semigroup (Semigroup)

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

4243

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

4546

4647instance NFData JSString where rnf !_ = ()

4748

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

2727 (valueToBool)

2828import Data.Typeable (Typeable)

2929import GHCJS.Prim (isNull, isUndefined)

30+import System.IO.Unsafe (unsafePerformIO)

31+import Data.IORef (newIORef)

3032

3133jsTrue :: JSVal

32−jsTrue = JSVal 3

33−{-# INLINE jsTrue #-}

34+jsTrue = JSVal . unsafePerformIO $ newIORef 3

35+{-# NOINLINE jsTrue #-}

3436

3537jsFalse :: JSVal

36−jsFalse = JSVal 2

37−{-# INLINE jsFalse #-}

38+jsFalse = JSVal . unsafePerformIO $ newIORef 2

39+{-# NOINLINE jsFalse #-}

3840

3941jsNull :: JSVal

40−jsNull = JSVal 0

41−{-# INLINE jsNull #-}

42+jsNull = JSVal . unsafePerformIO $ newIORef 0

43+{-# NOINLINE jsNull #-}

4244

4345toJSBool :: Bool -> JSVal

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

45−{-# INLINE toJSBool #-}

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

47+{-# NOINLINE toJSBool #-}

4648

4749jsUndefined :: JSVal

48−jsUndefined = JSVal 1

49−{-# INLINE jsUndefined #-}

50+jsUndefined = JSVal . unsafePerformIO $ newIORef 1

51+{-# NOINLINE jsUndefined #-}

5052

5153isTruthy :: JSVal -> GHCJSPure Bool

5254isTruthy = GHCJSPure . valueToBool

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

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

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

1818

1919import qualified GHC.Exception as Ex

20+import Data.IORef (newIORef, IORef)

21+import System.IO.Unsafe (unsafePerformIO)

2022

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

2224type JSValueRef = Int64

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

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

2628 argument or result.

2729-}

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

30+newtype JSVal = JSVal (IORef JSValueRef)

2931

3032instance NFData JSVal where

3133 rnf x = x `seq` ()

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

4951 return (JSException (unsafeCoerce ref) "")

5052

5153jsNull :: JSVal

52−jsNull = JSVal 0

53−{-# INLINE jsNull #-}

54+jsNull = JSVal . unsafePerformIO $ newIORef 0

55+{-# NOINLINE jsNull #-}

5456

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

5658 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

2727import GHC.Types

2828import GHC.Prim

2929import GHC.Ptr

30+import GHC.IORef

31+import GHC.IO.Unsafe (unsafePerformIO)

3032

3133import Control.DeepSeq

3234import Unsafe.Coerce

3335

34−type Ref# = Int64

36+type Ref# = IORef Int64

3537

3638mkRef :: Ref# -> JSVal

3739mkRef = JSVal

3840{-# INLINE mkRef #-}

3941

4042nullRef :: JSVal

41−nullRef = JSVal 0

42−{-# INLINE nullRef #-}

43+nullRef = JSVal . unsafePerformIO $ newIORef 0

44+{-# NOINLINE nullRef #-}

4345

4446--toPtr :: JSVal -> Ptr a

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

jsaddle/src-ghc/JavaScript/Array.hs+2−2

@@ -48,7 +48,7 @@ import Language.Javascript.JSaddle.Types

4848 (JSM, JSVal, SomeJSArray(..), JSArray,

4949 MutableJSArray, GHCJSPure(..))

5050import Control.Lens.Operators ((^.))

51−import Language.Javascript.JSaddle.Object (js2, js0, (##), js1, js)

51+import Language.Javascript.JSaddle.Object (js2, js0, (<##), js1, js)

5252import Language.Javascript.JSaddle.Value (valToNumber)

5353import JavaScript.Array.Internal (create, fromList, fromListIO, toList, toListIO, index, read, push)

5454

@@ -69,7 +69,7 @@ append (SomeJSArray x) (SomeJSArray y) = SomeJSArray <$> x ^. js1 "concat" y

6969{-# INLINE append #-}

7070

7171write :: Int -> JSVal -> MutableJSArray -> JSM ()

72−write n e (SomeJSArray x) = void $ (x ## n) e

72+write n e (SomeJSArray x) = void $ (x <## n) e

7373{-# INLINE write #-}

7474

7575pop :: MutableJSArray -> JSM JSVal

jsaddle/src/Language/Javascript/JSaddle.hs+5−5

@@ -9,7 +9,7 @@

99-- | This package provides an EDSL for calling JavaScript that

1010-- can be used both from GHCJS and GHC. When using GHC

1111-- the application is run using Warp and WebSockets to

12−-- drive a small JavaScipt helper.

12+-- drive a small JavaScript helper.

1313-----------------------------------------------------------------------------

1414

1515module Language.Javascript.JSaddle (

@@ -35,10 +35,10 @@ module Language.Javascript.JSaddle (

3535 --

3636 -- Where it makes sense code examples are given in two forms. One

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

3939

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

4242 -- convert a Haskell function in the JSM monad into a javascript

4343 -- value.

4444

@@ -52,8 +52,8 @@ module Language.Javascript.JSaddle (

5252 -- and the server will run the Haskell code. The JSaddle parts will

5353 -- be executed by sending commands back to the browser.

5454

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

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

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

56+ -- set out by the EDSL it is done asynchronously to the Haskell code.

5757 -- This improves the performance by reducing the number of round trips

5858 -- needed between the Haskell and JavaScript code.

5959

jsaddle/src/Language/Javascript/JSaddle/Debug.hs+4−4

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

2626import System.IO.Unsafe (unsafePerformIO)

2727import Data.Monoid ((<>))

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

29−import Data.UUID (UUID)

29+import Data.Int (Int64)

3030

3131contexts :: IORef [JSContextRef]

3232contexts = unsafePerformIO $ newIORef []

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

3737 ctx <- askJSM

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

3939

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

41−removeContext uuid =

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

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

41+removeContext cid =

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

4343

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

4545runOnAll f = liftIO (readIORef contexts) >>= mapM (runJSM f)

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

@@ -50,7 +50,7 @@ eval :: (ToJSString script)

5050 -> JSM JSVal

5151#ifdef ghcjs_HOST_OS

5252eval script = liftIO $ js_eval (toJSString script)

53−foreign import javascript unsafe "$r = eval($1);"

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

5454 js_eval :: JSString -> IO JSVal

5555#else

5656eval = evaluateScript . toJSString

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

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

3838 , bracket

3939) where

4040

41−import Prelude hiding (read)

4241#ifndef ghcjs_HOST_OS

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

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

4443#endif

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

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

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

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

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

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

4948

5049-- | Gets the JavaScript context from the monad

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

6665-- | Alternative version of 'runJSM'

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

6867runJSaddle = 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 #-}

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

25--

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

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

4548) where

4649

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

48−import Control.Monad.Primitive (touch)

4951

5052import Data.Aeson (Value)

5153

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

5759import Language.Javascript.JSaddle.Run

5860 (Command(..), Result(..), sendCommand,

5961 sendAsyncCommand, sendLazyCommand, wrapJSVal)

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

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

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

65+import GHC.Base (touch#)

6066

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

6268wrapJSString (JSStringReceived ref) = return $ JSString ref

6369

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

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

72+

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

6574withJSVal (JSVal ref) f = do

66− result <- f (JSValueForSend ref)

67− liftIO $ touch ref

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

76+ liftIO $ touchIORef ref

6877 return result

6978

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

7180withJSVals v f =

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

73− liftIO $ mapM_ touch v

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

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

7483 return result

7584

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

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

7887

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

80−withJSString v@(JSString ref) f =

81− do result <- f (JSStringForSend ref)

82− liftIO $ touch v

83− return result

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

8490

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

8692setPropertyByName name val this =

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

166172{-# INLINE deRefVal #-}

167173

168174valueToBool :: JSVal -> JSM Bool

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

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

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

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

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

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

175− return result

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

176+ 0 -> return False -- null

177+ 1 -> return False -- undefined

178+ 2 -> return False -- false

179+ 3 -> return True -- true

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

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

182+ return result

176183{-# INLINE valueToBool #-}

177184

178185valueToNumber :: JSVal -> JSM Double

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

201208{-# INLINE valueToJSONValue #-}

202209

203210isNull :: JSVal -> JSM Bool

204−isNull (JSVal 0) = return True

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

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

207− return result

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

212+ 0 -> return True -- null

213+ 1 -> return False -- undefined

214+ 2 -> return False -- false

215+ 3 -> return False -- true

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

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

218+ return result

208219{-# INLINE isNull #-}

209220

210221isUndefined :: JSVal -> JSM Bool

211−isUndefined (JSVal 1) = return True

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

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

214− return result

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

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

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

229+ return result

215230{-# INLINE isUndefined #-}

216231

217232strictEqual :: JSVal -> JSVal -> JSM Bool

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

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

3737 _ <- forkIO $ forever $

3838 readChan batches >>= \case

3939 Batch commands _ batchNumber ->

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

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

4141 Left _ -> Nothing

4242 Right command -> Just $

4343 case command of

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

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

119119 (newAsyncCallback, newSyncCallback, callAsFunction, callAsConstructor)

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

121121import Language.Javascript.JSaddle.Types

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

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

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

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

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

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

125126#endif

126127import JavaScript.Array.Internal (fromListIO)

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

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

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

132133import Language.Javascript.JSaddle.Properties

133134import Control.Lens (IndexPreservingGetter, to)

135+import Data.IORef (newIORef, readIORef)

136+import System.IO.Unsafe (unsafePerformIO)

134137

135138-- $setup

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

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

481484freeFunction (Function callback _) = liftIO $

482485 releaseCallback callback

483486#else

484−freeFunction (Function object) = do

485− free <- freeCallback <$> askJSM

486− liftIO $ free object

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

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

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

487497#endif

488498

489499instance ToJSVal Function where

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

516526 Object . coerce <$> fromListIO rargs

517527

518528-- | JavaScript's global object

519−global :: Object

520529#ifdef ghcjs_HOST_OS

521−global = js_window

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

523− js_window :: Object

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

531+ global :: Object

524532#else

525−global = Object (JSVal 4)

533+global :: Object

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

526535#endif

527536

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

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

547556objCallAsFunction f this args = do

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

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

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

552561#else

553562objCallAsFunction f this args = do

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

567576objCallAsConstructor f args = do

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

569578 liftIO $ js_new f rargs

570−foreign import javascript unsafe "\

579+foreign import javascript safe "\

571580 switch($2.length) {\

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

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

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

603612#ifdef ghcjs_HOST_OS

604613nullObject = Object nullRef

605614#else

606−nullObject = Object (JSVal 0)

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

607616#endif

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

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

3737) where

3838

3939#ifdef ghcjs_HOST_OS

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

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

4141import qualified JavaScript.Web.AnimationFrame as GHCJS

4242 (waitForAnimationFrame)

4343#else

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

5656

5757import System.IO.Unsafe (unsafeInterleaveIO)

5858import System.Mem.Weak (addFinalizer)

59+import System.Random

5960

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

6162import GHC.Conc (ThreadId(..))

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

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

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

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

66−import Data.UUID.V4 (nextRandom)

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

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

68+import Data.IORef

69+ (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)

6970

7071import Language.Javascript.JSaddle.Types

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

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

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

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

7579import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))

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

7792

7893-- | Enable (or disable) JSaddle logging

7994enableLogging :: Bool -> JSM ()

@@ -85,27 +100,6 @@ enableLogging v = do

85100 liftIO $ f v

86101#endif

87102

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−

109103-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.

110104-- On GHC it will delay the execution of the current batch of asynchronous

111105-- command when they are sent to JavaScript. It will not delay the Haskell

@@ -131,11 +125,6 @@ nextAnimationFrame f = do

131125 syncAfter (f t)

132126

133127#ifndef ghcjs_HOST_OS

134−sendCommand :: Command -> JSM Result

135−sendCommand cmd = do

136− s <- doSendCommand <$> JSM ask

137− liftIO $ s cmd

138−

139128sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal

140129sendLazyCommand cmd = do

141130 nextRefTVar <- nextRef <$> JSM ask

@@ -154,7 +143,7 @@ sendAsyncCommand cmd = do

154143

155144runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())

156145runJavaScript sendBatch entryPoint = do

157− contextId' <- nextRandom

146+ contextId' <- randomIO

158147 startTime' <- getCurrentTime

159148 recvMVar <- newEmptyMVar

160149 lastAsyncBatch <- newEmptyMVar

@@ -162,25 +151,32 @@ runJavaScript sendBatch entryPoint = do

162151 callbacks <- newTVarIO M.empty

163152 nextRef' <- newTVarIO 0

164153 finalizerThreads' <- newMVar S.empty

154+ animationFrameHandlers' <- newMVar []

165155 loggingEnabled <- newIORef False

156+ liveRefs' <- newMVar S.empty

166157 let ctx = JSContextRef {

167− contextId = contextId'

168− , startTime = startTime'

169− , doSendCommand = \cmd -> cmd `deepseq` do

170− result <- newEmptyMVar

171− atomically $ writeTChan commandChan (Right (cmd, result))

172− unsafeInterleaveIO $

173− takeMVar result >>= \case

174− (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)

175− r -> return r

176− , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)

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

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

179− , nextRef = nextRef'

180− , doEnableLogging = atomicWriteIORef loggingEnabled

181− , finalizerThreads = finalizerThreads'

182− }

183− let processResults :: Bool -> Results -> IO ()

158+ contextId = contextId'

159+ , startTime = startTime'

160+ , doSendCommand = \cmd -> cmd `deepseq` do

161+ result <- newEmptyMVar

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

163+ unsafeInterleaveIO $

164+ takeMVar result >>= \case

165+ (ThrowJSValue v) -> do

166+ jsval <- wrapJSVal' ctx v

167+ throwIO $ JSException jsval

168+ r -> return r

169+ , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)

170+ , addCallback = \(Object (JSVal ioref)) cb -> do

171+ val <- readIORef ioref

172+ atomically $ modifyTVar' callbacks (M.insert val cb)

173+ , nextRef = nextRef'

174+ , doEnableLogging = atomicWriteIORef loggingEnabled

175+ , finalizerThreads = finalizerThreads'

176+ , animationFrameHandlers = animationFrameHandlers'

177+ , liveRefs = liveRefs'

178+ }

179+ processResults :: Bool -> Results -> IO ()

184180 processResults syncCallbacks = \case

185181 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err

186182 (Callback n br (JSValueReceived fNumber) f this a) -> do

@@ -210,8 +206,8 @@ runJavaScript sendBatch entryPoint = do

210206 logInfo s =

211207 readIORef loggingEnabled >>= \case

212208 True -> do

213− currentBytesUsedStr <- getGCStatsEnabled >>= \case

214− True -> show . currentBytesUsed <$> getGCStats

209+ currentBytesUsedStr <- getRTSStatsEnabled >>= \case

210+ True -> show . currentBytesUsed <$> getRTSStats

215211 False -> return "??"

216212 cbCount <- M.size <$> readTVarIO callbacks

217213 putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "

@@ -224,14 +220,21 @@ runJavaScript sendBatch entryPoint = do

224220 putMVar lastAsyncBatch batch

225221 sendBatch batch

226222 takeResult recvMVar nBatch >>= \case

227− (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"

228− (_, Success results) | length results /= length resultMVars -> error "Unexpected number of jsaddle results"

229− | otherwise -> zipWithM_ putMVar resultMVars results

230− (_, Failure results exception) -> do

231− -- The exception will only be rethrown in Haskell if/when one of the

232− -- missing results (if any) is evaluated.

233− putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"

234− zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)

223+ (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"

224+ (_, Success callbacksToFree results)

225+ | length results /= length resultMVars -> error "Unexpected number of jsaddle results"

226+ | otherwise -> do

227+ zipWithM_ putMVar resultMVars results

228+ forM_ callbacksToFree $ \(JSValueReceived val) ->

229+ atomically (modifyTVar' callbacks (M.delete val))

230+ (_, Failure callbacksToFree results exception err) -> do

231+ -- The exception will only be rethrown in Haskell if/when one of the

232+ -- missing results (if any) is evaluated.

233+ putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"

234+ putStrLn err

235+ zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)

236+ forM_ callbacksToFree $ \(JSValueReceived val) ->

237+ atomically (modifyTVar' callbacks (M.delete val))

235238 return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)

236239 where

237240 numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m ()

@@ -274,17 +277,29 @@ addThreadFinalizer :: ThreadId -> IO () -> IO ()

274277addThreadFinalizer t@(ThreadId t#) (IO finalizer) =

275278 IO $ \s -> case mkWeak# t# t finalizer s of { (# s1, _ #) -> (# s1, () #) }

276279

280+

277281wrapJSVal :: JSValueReceived -> JSM JSVal

278−wrapJSVal (JSValueReceived ref) = do

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

280− let result = JSVal ref

281− when (ref >= 5 || ref < 0) $ do

282− ctx <- JSM ask

283− liftIO . addFinalizer ref $ do

282+wrapJSVal v = do

283+ ctx <- JSM ask

284+ liftIO $ wrapJSVal' ctx v

285+

286+wrapJSVal' :: JSContextRef -> JSValueReceived -> IO JSVal

287+wrapJSVal' ctx (JSValueReceived n) = do

288+ ref <- liftIO $ newIORef n

289+ when (n >= 5 || n < 0) $

290+#ifdef JSADDLE_CHECK_WRAPJSVAL

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

284299 ft <- takeMVar $ finalizerThreads ctx

285300 t <- myThreadId

286301 let tname = T.pack $ show t

287− doSendAsyncCommand ctx $ FreeRef tname $ JSValueForSend ref

302+ doSendAsyncCommand ctx $ FreeRef tname $ JSValueForSend n

288303 if tname `S.member` ft

289304 then putMVar (finalizerThreads ctx) ft

290305 else do

@@ -292,5 +307,5 @@ wrapJSVal (JSValueReceived ref) = do

292307 modifyMVar (finalizerThreads ctx) $ \s -> return (S.delete tname s, ())

293308 doSendAsyncCommand ctx $ FreeRefs tname

294309 putMVar (finalizerThreads ctx) =<< evaluate (S.insert tname ft)

295− return result

310+ return (JSVal ref)

296311#endif

jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+29−46

@@ -13,7 +13,6 @@

1313

1414module Language.Javascript.JSaddle.Run.Files (

1515 indexHtml

16− , jsaddleJs

1716 , initState

1817 , runBatch

1918 , ghcjsHelpers

@@ -31,7 +30,7 @@ indexHtml =

3130 \</head>\n\

3231 \<body>\n\

3332 \</body>\n\

34− \<script src=\"jsaddle.js\"></script>\n\

33+ \<script src=\"/jsaddle.js\"></script>\n\

3534 \</html>"

3635

3736initState :: ByteString

@@ -42,11 +41,12 @@ initState = "\

4241 \ jsaddle_values.set(1, undefined);\n\

4342 \ jsaddle_values.set(2, false);\n\

4443 \ jsaddle_values.set(3, true);\n\

45− \ jsaddle_values.set(4, window);\n\

44+ \ jsaddle_values.set(4, globalThis);\n\

4645 \ var jsaddle_index = 100;\n\

4746 \ var expectedBatch = 1;\n\

48− \ var lastResults = [0, {}];\n\

47+ \ var lastResults = [0, {\"tag\": \"Success\", \"contents\": [[], []]}];\n\

4948 \ var inCallback = 0;\n\

49+ \ var asyncBatch = null;\n\

5050 \"

5151

5252runBatch :: (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString

@@ -54,6 +54,7 @@ runBatch send sendSync = "\

5454 \ var runBatch = function(firstBatch, initialSyncDepth) {\n\

5555 \ var processBatch = function(timestamp) {\n\

5656 \ var batch = firstBatch;\n\

57+ \ var callbacksToFree = [];\n\

5758 \ var results = [];\n\

5859 \ inCallback++;\n\

5960 \ try {\n\

@@ -92,6 +93,10 @@ runBatch send sendSync = "\

9293 \ var n = d.contents[1];\n\

9394 \ jsaddle_values.set(n, d.contents[0]);\n\

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

95100 \ case \"GetPropertyByName\":\n\

96101 \ var n = d.contents[2];\n\

97102 \ jsaddle_values.set(n, jsaddle_values.get(d.contents[0])[d.contents[1]]);\n\

@@ -155,6 +160,9 @@ runBatch send sendSync = "\

155160 \ jsaddle_values.set(nFunction, func);\n\

156161 \ })();\n\

157162 \ break;\n\

163+ \ case \"FreeCallback\":\n\

164+ \ callbacksToFree.push(d.contents);\n\

165+ \ break;\n\

158166 \ case \"CallAsFunction\":\n\

159167 \ var n = d.contents[3];\n\

160168 \ jsaddle_values.set(n,\n\

@@ -239,7 +247,7 @@ runBatch send sendSync = "\

239247 \ (v === true ) ? [3, \"\"] :\n\

240248 \ (typeof v === \"number\") ? [-1, v.toString()] :\n\

241249 \ (typeof v === \"string\") ? [-2, v]\n\

242− \ : [n, \"\"];\n\

250+ \ : [-3, \"\"];\n\

243251 \ results.push({\"tag\": \"DeRefValResult\", \"contents\": c});\n\

244252 \ break;\n\

245253 \ case \"IsNull\":\n\

@@ -268,17 +276,18 @@ runBatch send sendSync = "\

268276 \ }\n\

269277 \ }\n\

270278 \ if(syncDepth <= 0) {\n\

271− \ lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": results}];\n\

279+ \ lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": [callbacksToFree, results]}];\n\

272280 \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> "\n\

273281 \ break;\n\

274282 \ } else {\n" <> (

275283 case sendSync of

276284 Just s ->

277− " lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": results}];\n\

285+ " lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": [callbacksToFree, results]}];\n\

278286 \ batch = " <> s "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> ";\n\

279− \ results = [];\n"

287+ \ results = [];\n\

288+ \ callbacksToFree = [];\n"

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

282291 \ break;\n"

283292 ) <>

284293 " }\n\

@@ -293,7 +302,8 @@ runBatch send sendSync = "\

293302 \ } else {\n\

294303 \ batch = " <> s "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> ";\n\

295304 \ }\n\

296− \ results = [];\n"

305+ \ results = [];\n\

306+ \ callbacksToFree = [];\n"

297307 Nothing ->

298308 " " <> send "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> "\n\

299309 \ break;\n"

@@ -305,7 +315,15 @@ runBatch send sendSync = "\

305315 \ catch (err) {\n\

306316 \ var n = ++jsaddle_index;\n\

307317 \ jsaddle_values.set(n, err);\n\

308− \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Failure\", \"contents\": [results, n]}]}" <> "\n\

318+ \ console.log(err);\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\

309327 \ }\n\

310328 \ inCallback--;\n\

311329 \ };\n\

@@ -319,41 +337,6 @@ runBatch send sendSync = "\

319337 \ runBatch(batch);\n\

320338 \"

321339

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−

357340ghcjsHelpers :: ByteString

358341ghcjsHelpers = "\

359342 \function h$isNumber(o) {\

jsaddle/src/Language/Javascript/JSaddle/Types.hs+75−17

@@ -58,8 +58,14 @@ module Language.Javascript.JSaddle.Types (

5858 -- * Debugging

5959 , JSadddleHasCallStack

6060

61− -- * JavaScript Context Commands

61+ -- * Sync JSM

62+ , syncPoint

63+ , syncAfter

64+

6265#ifndef ghcjs_HOST_OS

66+ , sendCommand

67+

68+ -- * JavaScript Context Commands

6369 , MutabilityType(..)

6470 , Mutable

6571 , Immutable

@@ -89,13 +95,14 @@ import GHCJS.Nullable (Nullable(..))

8995import GHCJS.Prim.Internal (JSVal(..), JSValueRef)

9096import Data.JSString.Internal.Type (JSString(..))

9197import Control.DeepSeq (NFData(..))

98+import Control.Monad.Catch (MonadThrow, MonadCatch(..), MonadMask(..))

9299import Control.Monad.Trans.Cont (ContT(..))

93100import Control.Monad.Trans.Error (Error(..), ErrorT(..))

94101import Control.Monad.Trans.Except (ExceptT(..))

95102import Control.Monad.Trans.Identity (IdentityT(..))

96103import Control.Monad.Trans.List (ListT(..))

97104import Control.Monad.Trans.Maybe (MaybeT(..))

98−import Control.Monad.Trans.Reader (ReaderT(..))

105+import Control.Monad.Trans.Reader (ReaderT(..), ask)

99106import Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))

100107import Control.Monad.Trans.RWS.Strict as Strict (RWST(..))

101108import Control.Monad.Trans.State.Lazy as Lazy (StateT(..))

@@ -107,15 +114,17 @@ import Control.Monad.Fix (MonadFix)

107114import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))

108115import Control.Concurrent.STM.TVar (TVar)

109116import Control.Concurrent.MVar (MVar)

117+import Data.Int (Int64)

110118import Data.Set (Set)

111119import Data.Text (Text)

112−import Data.UUID (UUID)

113120import Data.Time.Clock (UTCTime(..))

114121import Data.Typeable (Typeable)

115122import Data.Coerce (coerce, Coercible)

116123import Data.Aeson

117124 (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..), Value)

118125import GHC.Generics (Generic)

126+import Control.Monad.IO.Unlift (MonadUnliftIO)

127+import qualified Control.Monad.Fail as Fail

119128#endif

120129

121130#if MIN_VERSION_base(4,9,0) && defined(CHECK_UNCHECKED)

@@ -132,15 +141,16 @@ import GHC.Exts (Constraint)

132141type JSContextRef = ()

133142#else

134143data JSContextRef = JSContextRef {

135− contextId :: UUID

136− , startTime :: UTCTime

137− , doSendCommand :: Command -> IO Result

138− , doSendAsyncCommand :: AsyncCommand -> IO ()

139− , addCallback :: Object -> JSCallAsFunction -> IO ()

140− , freeCallback :: Object -> IO ()

141− , nextRef :: TVar JSValueRef

142− , doEnableLogging :: Bool -> IO ()

143− , finalizerThreads :: MVar (Set Text)

144+ contextId :: Int64

145+ , startTime :: UTCTime

146+ , doSendCommand :: Command -> IO Result

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

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

149+ , nextRef :: TVar JSValueRef

150+ , doEnableLogging :: Bool -> IO ()

151+ , finalizerThreads :: MVar (Set Text)

152+ , animationFrameHandlers :: MVar [Double -> JSM ()]

153+ , liveRefs :: MVar (Set Int64)

144154}

145155#endif

146156

@@ -156,9 +166,56 @@ data JSContextRef = JSContextRef {

156166type JSM = IO

157167#else

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

160211#endif

161212

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

162219

163220-- | Type we can give to functions that are pure when using ghcjs, but

164221-- live in JSM when using jsaddle.

@@ -208,7 +265,7 @@ type MonadJSM = MonadIO

208265class (Applicative m, MonadIO m) => MonadJSM m where

209266 liftJSM' :: JSM a -> m a

210267

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

212269 liftJSM' = lift . (liftJSM' :: MonadJSM m' => JSM a -> m' a)

213270 {-# INLINE liftJSM' #-}

214271

@@ -339,7 +396,7 @@ type MutableJSArray = SomeJSArray Mutable

339396type STJSArray s = SomeJSArray (STMutable s)

340397

341398-- | See 'JavaScript.Object.Internal.Object'

342−newtype Object = Object JSVal deriving(Show, ToJSON, FromJSON)

399+newtype Object = Object JSVal

343400

344401-- | See 'GHCJS.Nullable.Nullable'

345402newtype Nullable a = Nullable a

@@ -377,6 +434,7 @@ data AsyncCommand = FreeRef Text JSValueForSend

377434 | NewEmptyObject JSValueForSend

378435 | NewAsyncCallback JSValueForSend

379436 | NewSyncCallback JSValueForSend

437+ | FreeCallback JSValueForSend

380438 | NewArray [JSValueForSend] JSValueForSend

381439 | EvaluateScript JSStringForSend JSValueForSend

382440 | SyncWithAnimationFrame JSValueForSend

@@ -445,8 +503,8 @@ instance ToJSON Result where

445503

446504instance FromJSON Result

447505

448−data BatchResults = Success [Result]

449− | Failure [Result] JSValueReceived

506+data BatchResults = Success [JSValueReceived] [Result]

507+ | Failure [JSValueReceived] [Result] JSValueReceived String

450508 deriving (Show, Generic)

451509

452510instance ToJSON BatchResults where

jsaddle/src/Language/Javascript/JSaddle/Value.hs+5−3

@@ -618,15 +618,17 @@ foreign import javascript unsafe "$r = ($1 === undefined)?0:\

618618 (typeof $1===\"string\")?4:\

619619 (typeof $1===\"object\")?5:-1;" jsrefGetType :: JSVal -> Int

620620#else

621−deRefVal value = toJSVal value >>= N.deRefVal >>= \result -> return $

622− case result of

621+deRefVal value = do

622+ v <- toJSVal value

623+ result <- N.deRefVal v

624+ return $ case result of

623625 DeRefValResult 0 _ -> ValNull

624626 DeRefValResult 1 _ -> ValUndefined

625627 DeRefValResult 2 _ -> ValBool False

626628 DeRefValResult 3 _ -> ValBool True

627629 DeRefValResult (-1) s -> ValNumber (read (T.unpack s))

628630 DeRefValResult (-2) s -> ValString s

629− DeRefValResult ref _ -> ValObject (Object (JSVal ref))

631+ DeRefValResult (-3) _ -> ValObject (Object v)

630632 _ -> error "Unexpected result dereferencing JSaddle value"

631633#endif

632634

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`

66

77JSADDLE_WARP_VERSION=`head -n2 jsaddle-warp/jsaddle-warp.cabal | tail -n1 | sed 's/[^0-9.]//g'`

88

9−if [[ -d .cabal && -d .ghc ]]; then

10− cp -a .cabal .ghc /root

11−fi

12−

139cabal 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'

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

17−

18−# update the cache

19−rm -rf .cabal

20−cp -a /root/.cabal ./

21−rm -rf .ghc

22−cp -a /root/.ghc ./

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

2313