on master help sign in
87 files changed+6993−999
since splitsnapshots
unifiedsplit
.travis.yml+40−22 README.md+34−14 cabal.project+4−35 jsaddle-clib/LICENSE+21 jsaddle-clib/Setup.lhs+6 jsaddle-clib/cbits/include/jsaddle.h+24 jsaddle-clib/jsaddle-clib.cabal+40 jsaddle-clib/src-ghc/Language/Javascript/JSaddle/CLib.hs+157 jsaddle-clib/src-ghcjs/Language/Javascript/JSaddle/CLib.hs+7 jsaddle-clib/src/Language/Javascript/JSaddle/CLib/Internal.hsc+67 jsaddle-warp/jsaddle-warp.cabal+37−14 jsaddle-warp/src/Language/Javascript/JSaddle/Test.hs+13−12 jsaddle-warp/src/Language/Javascript/JSaddle/Warp.hs+3−4 jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs+287−40 jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets/Compat.hs+29 jsaddle-warp/tests/DocTest.hs+84−61 jsaddle-webkit2gtk/jsaddle-webkit2gtk.cabal+19−12 jsaddle-webkit2gtk/src/Language/Javascript/JSaddle/WebKit2GTK.hs → jsaddle-webkit2gtk/src/Language/Javascript/JSaddle/WebKitGTK.hs+72−55 jsaddle-webkitgtk/jsaddle-webkitgtk.cabal+8−5 jsaddle-webkitgtk/src/Language/Javascript/JSaddle/WebKitGTK.hs+30−11 jsaddle-wkwebview/cbits-cocoa/AppDelegate.m+126 jsaddle-wkwebview/cbits-uikit/AppDelegate.h+8 jsaddle-wkwebview/cbits-uikit/AppDelegate.m+207 jsaddle-wkwebview/cbits-uikit/ViewController.h+10 jsaddle-wkwebview/cbits-uikit/ViewController.m+40 jsaddle-wkwebview/cbits/WKWebView.m+79−10 jsaddle-wkwebview/default.nix+14 jsaddle-wkwebview/jsaddle-wkwebview.cabal+39−7 jsaddle-wkwebview/src-ghc/Language/Javascript/JSaddle/WKWebView.hs+219 jsaddle-wkwebview/src-ghcjs/Language/Javascript/JSaddle/WKWebView.hs+7 jsaddle-wkwebview/src/Language/Javascript/JSaddle/WKWebView.hs−76 jsaddle-wkwebview/src/Language/Javascript/JSaddle/WKWebView/Internal.hs+174 jsaddle/jsaddle.cabal+61−16 jsaddle/src-ghc/Data/JSString.hs+1404 jsaddle/src-ghc/Data/JSString/Internal.hs+1 jsaddle/src-ghc/Data/JSString/Internal/Fusion.hs+127 jsaddle/src-ghc/Data/JSString/Internal/Fusion/CaseMapping.hs+570 jsaddle/src-ghc/Data/JSString/Internal/Fusion/Common.hs+92 jsaddle/src-ghc/Data/JSString/Internal/Fusion/Types.hs+122 jsaddle/src-ghc/Data/JSString/Internal/Search.hs+11 jsaddle/src-ghc/Data/JSString/Internal/Type.hs+116 jsaddle/src-ghc/Data/JSString/Text.hs+52 jsaddle/src-ghc/GHCJS/Buffer.hs+117 jsaddle/src-ghc/GHCJS/Buffer/Types.hs+11 jsaddle/src-ghc/GHCJS/Concurrent.hs+22 jsaddle/src-ghc/GHCJS/Foreign.hs+64 jsaddle/src-ghc/GHCJS/Foreign/Internal.hs+67 jsaddle/src-ghc/GHCJS/Internal/Types.hs+16 jsaddle/src-ghc/GHCJS/Marshal.hs+37−36 jsaddle/src-ghc/GHCJS/Marshal/Internal.hs+66−32 jsaddle/src-ghc/GHCJS/Marshal/Pure.hs+5−6 jsaddle/src-ghc/GHCJS/Prim.hs+84 jsaddle/src-ghc/GHCJS/Prim/Internal.hs+68 jsaddle/src-ghc/GHCJS/Types.hs+60 jsaddle/src/Language/Javascript/JSaddle/Array.hs → jsaddle/src-ghc/JavaScript/Array.hs+36−23 jsaddle/src-ghc/JavaScript/Array/Internal.hs+33−20 jsaddle/src-ghc/JavaScript/Object.hs+10 jsaddle/src-ghc/JavaScript/Object/Internal.hs+26−22 jsaddle/src-ghc/JavaScript/TypedArray.hs+19 jsaddle/src-ghc/JavaScript/TypedArray/ArrayBuffer.hs+51 jsaddle/src-ghc/JavaScript/TypedArray/ArrayBuffer/Internal.hs+33 jsaddle/src-ghc/JavaScript/TypedArray/ArrayBuffer/Type.hs+6 jsaddle/src-ghc/JavaScript/TypedArray/DataView/Internal.hs+147 jsaddle/src-ghc/JavaScript/TypedArray/Immutable.hs+1 jsaddle/src-ghc/JavaScript/TypedArray/Internal.hs+344 jsaddle/src-ghc/JavaScript/TypedArray/Internal/Types.hs+121 jsaddle/src/Language/Javascript/JSaddle.hs+5−6 jsaddle/src/Language/Javascript/JSaddle/Debug.hs+48 jsaddle/src/Language/Javascript/JSaddle/Evaluate.hs+3−7 jsaddle/src/Language/Javascript/JSaddle/Exception.hs+6−1 jsaddle/src/Language/Javascript/JSaddle/Foreign.hs−99 jsaddle/src/Language/Javascript/JSaddle/Helper.hs+30 jsaddle/src/Language/Javascript/JSaddle/Monad.hs+3−26 jsaddle/src/Language/Javascript/JSaddle/Native.hs+1−6 jsaddle/src/Language/Javascript/JSaddle/Native/Internal.hs+212−23 jsaddle/src/Language/Javascript/JSaddle/Null.hs+56 jsaddle/src/Language/Javascript/JSaddle/Object.hs+54−28 jsaddle/src/Language/Javascript/JSaddle/Run.hs+174−64 jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+186−56 jsaddle/src/Language/Javascript/JSaddle/Types.hs+239−45 jsaddle/src/Language/Javascript/JSaddle/Value.hs+57−88 nix/hix.nix+8 travis/build.sh+2−13 travis/trusty.Dockerfile+1−1 travis/vivid.Dockerfile+1−1 travis/wily.Dockerfile+1−1 travis/xenial.Dockerfile+1−1
.travis.yml+40−22
@@ -1,29 +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=7.10.3 OSVER=trusty
14− - CABALVER=1.24 GHCVER=8.0.1 OSVER=trusty
15−
16−before_install:
17− - 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
1829
1930script:
20− - docker run -v `pwd`:/build ghc
21− sh -x -c "
22− apt-get install -y cabal-install-$CABALVER ghc-$GHCVER &&
23− 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 &&
24− ./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+
2544notifications:
2645 irc:
2746 channels: "irc.freenode.net#ghcjs"
28− skip_join: true
29− 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+4−35
@@ -1,41 +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/
6+ jsaddle-clib/
7+
8+constraints: haskell-gi-overloading == 0.0
99
10−package gi-atk
11− flags: -overloaded-methods -overloaded-signals -overloaded-properties
12−package gi-cairo
13− flags: -overloaded-methods -overloaded-signals -overloaded-properties
14−package gi-gdk
15− flags: -overloaded-methods -overloaded-signals -overloaded-properties
16−package gi-gdkpixbuf
17− flags: -overloaded-methods -overloaded-signals -overloaded-properties
18−package gi-gio
19− flags: -overloaded-methods -overloaded-signals -overloaded-properties
20−package gi-glib
21− flags: -overloaded-methods -overloaded-signals -overloaded-properties
22−package gi-gobject
23− flags: -overloaded-methods -overloaded-signals -overloaded-properties
24−package gi-gtk
25− flags: -overloaded-methods -overloaded-signals -overloaded-properties
26−package gi-gtk-hs
27− flags: -overloaded-methods -overloaded-signals -overloaded-properties
28−package gi-gtkosxapplication
29− flags: -overloaded-methods -overloaded-signals -overloaded-properties
30−package gi-gtksource
31− flags: -overloaded-methods -overloaded-signals -overloaded-properties
32−package gi-javascriptcore
33− flags: -overloaded-methods -overloaded-signals -overloaded-properties
34−package gi-pango
35− flags: -overloaded-methods -overloaded-signals -overloaded-properties
36−package gi-soup
37− flags: -overloaded-methods -overloaded-signals -overloaded-properties
38−package gi-webkit
39− flags: -overloaded-methods -overloaded-signals -overloaded-properties
40−package gi-webkit2
41− flags: -overloaded-methods -overloaded-signals -overloaded-properties
10+allow-newer: websockets:random, splitmix:time, *:time, *:unix, *:process, stm:base
jsaddle-clib/LICENSEnew file+21
@@ -0,0 +1,21 @@
1+Copyright (c) 2010-2012 Hamish Mackenzie, Victor Nazarov, Luite Stegeman
2+
3+Permission is hereby granted, free of charge, to any person obtaining
4+a copy of this software and associated documentation files (the
5+"Software"), to deal in the Software without restriction, including
6+without limitation the rights to use, copy, modify, merge, publish,
7+distribute, sublicense, and/or sell copies of the Software, and to
8+permit persons to whom the Software is furnished to do so, subject to
9+the following conditions:
10+
11+The above copyright notice and this permission notice shall be
12+included in all copies or substantial portions of the Software.
13+
14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
17+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
18+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
19+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
20+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21+
jsaddle-clib/Setup.lhsnew file+6
@@ -0,0 +1,6 @@
1+#!/usr/bin/runhaskell
2+> module Main where
3+> import Distribution.Simple
4+> main :: IO ()
5+> main = defaultMain
6+
jsaddle-clib/cbits/include/jsaddle.hnew file+24
@@ -0,0 +1,24 @@
1+#ifndef JSADDLE_H
2+#define JSADDLE_H
3+
4+typedef struct native_callbacks {
5+ void (* jsaddleStart) ();
6+ void (* jsaddleResult) (char *);
7+ char * (* jsaddleSyncResult) (char *);
8+ char * jsaddleJsData;
9+ char * jsaddleHtmlData;
10+} native_callbacks;
11+
12+typedef struct app_callbacks {
13+ void (* mainActivity_onCreate) ();
14+ void (* mainActivity_onStart) ();
15+ void (* mainActivity_onResume) ();
16+ void (* mainActivity_onPause) ();
17+ void (* mainActivity_onStop) ();
18+ void (* mainActivity_onDestroy) ();
19+ void (* mainActivity_onRestart) ();
20+ void (* mainActivity_onNewIntent) (char *, char *);
21+ void (* firebaseInstanceIdService_sendRegistrationToServer) (char *);
22+} app_callbacks;
23+
24+#endif
jsaddle-clib/jsaddle-clib.cabalnew file+40
@@ -0,0 +1,40 @@
1+name: jsaddle-clib
2+version: 0.9.8.0
3+cabal-version: >=1.10
4+build-type: Simple
5+license: MIT
6+license-file: LICENSE
7+maintainer: Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
8+synopsis: Interface for JavaScript that works with GHCJS and GHC
9+description:
10+ This package provides an EDSL for calling JavaScript that
11+ can be used both from GHCJS and GHC.
12+category: Web, Javascript
13+author: Hamish Mackenzie
14+
15+source-repository head
16+ type: git
17+ location: https://github.com/ghcjs/jsaddle
18+
19+library
20+ exposed-modules:
21+ Language.Javascript.JSaddle.CLib
22+ Language.Javascript.JSaddle.CLib.Internal
23+ build-depends:
24+ aeson >=0.8.0.2 && <1.6,
25+ base <5,
26+ base-compat >=0.9.0 && <0.12,
27+ bytestring >=0.10.6.0 && <0.11,
28+ jsaddle >= 0.9.0.0 && <0.10,
29+ data-default,
30+ text
31+ default-language: Haskell2010
32+ hs-source-dirs: src
33+ Include-dirs: cbits/include
34+ Includes: jsaddle.h
35+ Install-includes: jsaddle.h
36+ ghc-options: -ferror-spans -Wall
37+ if impl(ghcjs)
38+ hs-source-dirs: src-ghcjs
39+ else
40+ hs-source-dirs: src-ghc
jsaddle-clib/src-ghc/Language/Javascript/JSaddle/CLib.hsnew file+157
@@ -0,0 +1,157 @@
1+{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}
2+module Language.Javascript.JSaddle.CLib
3+ ( jsaddleInit
4+ , NativeCallbacks (..)
5+ , AppCallbacks (..)
6+ , AppConfig (..)
7+ , pokeAppConfig
8+ , appConfigToAppCallbacks
9+ ) where
10+
11+import Prelude ()
12+import Prelude.Compat
13+
14+import Control.Monad (void)
15+import Control.Concurrent (forkIO)
16+
17+import Data.Aeson (encode, decode)
18+import Data.ByteString (useAsCString, packCString)
19+import Data.ByteString.Char8 (unpack)
20+import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)
21+import Data.Default (def, Default)
22+import Data.Text (Text)
23+import qualified Data.Text.Encoding as T
24+
25+import Foreign.C.String (CString, newCString)
26+import Foreign.Ptr (FunPtr, Ptr)
27+import Foreign.Storable (poke)
28+import Foreign.Marshal.Utils (new)
29+
30+import Language.Javascript.JSaddle (JSM)
31+import Language.Javascript.JSaddle.Run (runJavaScript)
32+import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
33+
34+import Language.Javascript.JSaddle.CLib.Internal
35+
36+foreign import ccall safe "dynamic"
37+ mkCallback :: FunPtr (CString -> IO ()) -> CString -> IO ()
38+
39+foreign import ccall safe "wrapper"
40+ wrapStartCallback :: IO () -> IO (FunPtr (IO ()))
41+
42+foreign import ccall safe "wrapper"
43+ wrapMessageCallback :: (CString -> IO ()) -> IO (FunPtr (CString -> IO ()))
44+
45+foreign import ccall safe "wrapper"
46+ wrapMessageCallback2 :: (CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> IO ()))
47+
48+foreign import ccall safe "wrapper"
49+ wrapSyncCallback :: (CString -> IO CString) -> IO (FunPtr (CString -> IO CString))
50+
51+jsaddleInit :: JSM () -> FunPtr (CString -> IO ()) -> IO (Ptr NativeCallbacks)
52+jsaddleInit jsm evaluateJavascriptAsyncPtr = do
53+ let evaluateJavascriptAsync = mkCallback evaluateJavascriptAsyncPtr
54+ (processResult, processSyncResult, start) <- runJavaScript (\batch ->
55+ useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");")
56+ evaluateJavascriptAsync) jsm
57+ jsaddleStartPtr <- wrapStartCallback $ void $ forkIO start
58+ jsaddleResultPtr <- wrapMessageCallback $ \s -> do
59+ result <- decode . fromStrict <$> packCString s
60+ case result of
61+ Nothing -> error $ "jsaddle message decode failed: " <> show result
62+ Just r -> processResult r
63+ jsaddleSyncResultPtr <- wrapSyncCallback $ \s -> do
64+ result <- decode . fromStrict <$> packCString s
65+ case result of
66+ Nothing -> error $ "jsaddle message decode failed: " <> show result
67+ Just r -> newCString =<< unpack . toStrict . encode <$> processSyncResult r
68+ jsaddleJsPtr <- newCString $ unpack $ toStrict jsaddleJs
69+ jsaddleHtmlPtr <- newCString $ unpack $ toStrict indexHtml
70+ new NativeCallbacks
71+ { _nativeCallbacks_jsaddleStart = jsaddleStartPtr
72+ , _nativeCallbacks_jsaddleResult = jsaddleResultPtr
73+ , _nativeCallbacks_jsaddleSyncResult = jsaddleSyncResultPtr
74+ , _nativeCallbacks_jsaddleJsData = jsaddleJsPtr
75+ , _nativeCallbacks_jsaddleHtmlData = jsaddleHtmlPtr
76+ }
77+
78+data AppConfig = AppConfig
79+ { _appConfig_mainActivityOnCreate :: IO ()
80+ , _appConfig_mainActivityOnStart :: IO ()
81+ , _appConfig_mainActivityOnResume :: IO ()
82+ , _appConfig_mainActivityOnPause :: IO ()
83+ , _appConfig_mainActivityOnStop :: IO ()
84+ , _appConfig_mainActivityOnDestroy :: IO ()
85+ , _appConfig_mainActivityOnRestart :: IO ()
86+ , _appConfig_mainActivityOnNewIntent :: (Text -> Text -> IO ())
87+ , _appConfig_firebaseInstanceIdServiceSendRegistrationToServer :: Text -> IO ()
88+ }
89+
90+instance Default AppConfig where
91+ def = AppConfig
92+ { _appConfig_mainActivityOnCreate = return ()
93+ , _appConfig_mainActivityOnStart = return ()
94+ , _appConfig_mainActivityOnResume = return ()
95+ , _appConfig_mainActivityOnPause = return ()
96+ , _appConfig_mainActivityOnStop = return ()
97+ , _appConfig_mainActivityOnDestroy = return ()
98+ , _appConfig_mainActivityOnRestart = return ()
99+ , _appConfig_mainActivityOnNewIntent = \_ _ -> return ()
100+ , _appConfig_firebaseInstanceIdServiceSendRegistrationToServer = \_ -> return ()
101+ }
102+
103+appConfigToAppCallbacks :: AppConfig -> IO AppCallbacks
104+appConfigToAppCallbacks c = do
105+ create <- wrapStartCallback $ _appConfig_mainActivityOnCreate c
106+ start <- wrapStartCallback $ _appConfig_mainActivityOnStart c
107+ resume <- wrapStartCallback $ _appConfig_mainActivityOnResume c
108+ pause <- wrapStartCallback $ _appConfig_mainActivityOnPause c
109+ stop <- wrapStartCallback $ _appConfig_mainActivityOnStop c
110+ destroy <- wrapStartCallback $ _appConfig_mainActivityOnDestroy c
111+ restart <- wrapStartCallback $ _appConfig_mainActivityOnRestart c
112+ newIntent <- wrapMessageCallback2 $ \intentAction intentData -> do
113+ intentAction' <- fromUtf8CString intentAction
114+ intentData' <- fromUtf8CString intentData
115+ _appConfig_mainActivityOnNewIntent c intentAction' intentData'
116+ firebaseRegPtr <- wrapMessageCallback $ \token -> do
117+ token' <- fromUtf8CString token
118+ _appConfig_firebaseInstanceIdServiceSendRegistrationToServer c token'
119+ return $ AppCallbacks
120+ { _appCallbacks_mainActivity_onCreate = create
121+ , _appCallbacks_mainActivity_onStart = start
122+ , _appCallbacks_mainActivity_onResume = resume
123+ , _appCallbacks_mainActivity_onPause = pause
124+ , _appCallbacks_mainActivity_onStop = stop
125+ , _appCallbacks_mainActivity_onDestroy = destroy
126+ , _appCallbacks_mainActivity_onRestart = restart
127+ , _appCallbacks_mainActivity_onNewIntent = newIntent
128+ , _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer = firebaseRegPtr
129+ }
130+
131+fromUtf8CString :: CString -> IO Text
132+fromUtf8CString = fmap T.decodeUtf8 . packCString
133+
134+pokeAppConfig :: Ptr AppCallbacks -> AppConfig -> IO ()
135+pokeAppConfig ptr cfg = poke ptr =<< appConfigToAppCallbacks cfg
136+
137+jsaddleJs :: ByteString
138+jsaddleJs = ghcjsHelpers <> "\
139+ \runJSaddleBatch = (function() {\n\
140+ \ " <> initState <> "\n\
141+ \ return function(batch) {\n\
142+ \ " <> runBatch (\a -> "jsaddle.postMessage(JSON.stringify(" <> a <> "));")
143+ (Just (\a -> "JSON.parse(jsaddle.syncMessage(JSON.stringify(" <> a <> ")))")) <> "\
144+ \ };\n\
145+ \})();\n\
146+ \jsaddle.postReady();\n"
147+
148+indexHtml :: ByteString
149+indexHtml =
150+ "<!DOCTYPE html>\n\
151+ \<html>\n\
152+ \<head>\n\
153+ \<title>JSaddle</title>\n\
154+ \</head>\n\
155+ \<body>\n\
156+ \</body>\n\
157+ \</html>"
jsaddle-clib/src-ghcjs/Language/Javascript/JSaddle/CLib.hsnew file+7
@@ -0,0 +1,7 @@
1+module Language.Javascript.JSaddle.CLib
2+ ( run
3+ ) where
4+
5+run :: IO () -> IO ()
6+run = id
7+{-# INLINE run #-}
jsaddle-clib/src/Language/Javascript/JSaddle/CLib/Internal.hscnew file+67
@@ -0,0 +1,67 @@
1+{-# LANGUAGE ForeignFunctionInterface #-}
2+module Language.Javascript.JSaddle.CLib.Internal where
3+
4+import Foreign
5+import Foreign.C
6+
7+#include "jsaddle.h"
8+
9+data NativeCallbacks = NativeCallbacks
10+ { _nativeCallbacks_jsaddleStart :: !(FunPtr (IO ())) -- void (jsaddleStart *)()
11+ , _nativeCallbacks_jsaddleResult :: !(FunPtr (CString -> IO ())) -- void (jsaddleResult *)(char *)
12+ , _nativeCallbacks_jsaddleSyncResult :: !(FunPtr (CString -> IO CString)) -- char * (jsaddleSyncResult *)(char *)
13+ , _nativeCallbacks_jsaddleJsData :: !CString -- char * jsaddleJsData
14+ , _nativeCallbacks_jsaddleHtmlData :: !CString -- char * jsaddleHtmlData
15+ }
16+
17+instance Storable NativeCallbacks where
18+ sizeOf _ = #{size native_callbacks}
19+ alignment _ = #{alignment native_callbacks}
20+ poke p nc = do
21+ #{poke native_callbacks, jsaddleStart} p $ _nativeCallbacks_jsaddleStart nc
22+ #{poke native_callbacks, jsaddleResult} p $ _nativeCallbacks_jsaddleResult nc
23+ #{poke native_callbacks, jsaddleSyncResult} p $ _nativeCallbacks_jsaddleSyncResult nc
24+ #{poke native_callbacks, jsaddleJsData} p $ _nativeCallbacks_jsaddleJsData nc
25+ #{poke native_callbacks, jsaddleHtmlData} p $ _nativeCallbacks_jsaddleHtmlData nc
26+ peek p = NativeCallbacks
27+ <$> #{peek native_callbacks, jsaddleStart} p
28+ <*> #{peek native_callbacks, jsaddleResult} p
29+ <*> #{peek native_callbacks, jsaddleSyncResult} p
30+ <*> #{peek native_callbacks, jsaddleJsData} p
31+ <*> #{peek native_callbacks, jsaddleHtmlData} p
32+
33+data AppCallbacks = AppCallbacks
34+ { _appCallbacks_mainActivity_onCreate :: !(FunPtr (IO ()))
35+ , _appCallbacks_mainActivity_onStart :: !(FunPtr (IO ()))
36+ , _appCallbacks_mainActivity_onResume :: !(FunPtr (IO ()))
37+ , _appCallbacks_mainActivity_onPause :: !(FunPtr (IO ()))
38+ , _appCallbacks_mainActivity_onStop :: !(FunPtr (IO ()))
39+ , _appCallbacks_mainActivity_onDestroy :: !(FunPtr (IO ()))
40+ , _appCallbacks_mainActivity_onRestart :: !(FunPtr (IO ()))
41+ , _appCallbacks_mainActivity_onNewIntent :: !(FunPtr (CString -> CString -> IO ()))
42+ , _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer :: !(FunPtr (CString -> IO ()))
43+ }
44+
45+instance Storable AppCallbacks where
46+ sizeOf _ = #{size app_callbacks}
47+ alignment _ = #{alignment app_callbacks}
48+ poke p nc = do
49+ #{poke app_callbacks, mainActivity_onCreate} p $ _appCallbacks_mainActivity_onCreate nc
50+ #{poke app_callbacks, mainActivity_onStart} p $ _appCallbacks_mainActivity_onStart nc
51+ #{poke app_callbacks, mainActivity_onResume} p $ _appCallbacks_mainActivity_onResume nc
52+ #{poke app_callbacks, mainActivity_onPause} p $ _appCallbacks_mainActivity_onPause nc
53+ #{poke app_callbacks, mainActivity_onStop} p $ _appCallbacks_mainActivity_onStop nc
54+ #{poke app_callbacks, mainActivity_onDestroy} p $ _appCallbacks_mainActivity_onDestroy nc
55+ #{poke app_callbacks, mainActivity_onRestart} p $ _appCallbacks_mainActivity_onRestart nc
56+ #{poke app_callbacks, mainActivity_onNewIntent} p $ _appCallbacks_mainActivity_onNewIntent nc
57+ #{poke app_callbacks, firebaseInstanceIdService_sendRegistrationToServer} p $ _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer nc
58+ peek p = AppCallbacks
59+ <$> #{peek app_callbacks, mainActivity_onCreate} p
60+ <*> #{peek app_callbacks, mainActivity_onStart} p
61+ <*> #{peek app_callbacks, mainActivity_onResume} p
62+ <*> #{peek app_callbacks, mainActivity_onPause} p
63+ <*> #{peek app_callbacks, mainActivity_onStop} p
64+ <*> #{peek app_callbacks, mainActivity_onDestroy} p
65+ <*> #{peek app_callbacks, mainActivity_onRestart} p
66+ <*> #{peek app_callbacks, mainActivity_onNewIntent} p
67+ <*> #{peek app_callbacks, firebaseInstanceIdService_sendRegistrationToServer} p
jsaddle-warp/jsaddle-warp.cabal+37−14
@@ -1,5 +1,5 @@
11name: jsaddle-warp
2−version: 0.7.1.0
2+version: 0.9.8.0
33cabal-version: >=1.10
44build-type: Simple
55license: MIT
@@ -10,32 +10,37 @@ 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
1717source-repository head
1818 type: git
1919 location: https://github.com/ghcjs/jsaddle
20+ subdir: jsaddle-warp
2021
2122library
2223
2324 if !impl(ghcjs -any)
2425 exposed-modules:
2526 Language.Javascript.JSaddle.WebSockets
27+ other-modules:
28+ Language.Javascript.JSaddle.WebSockets.Compat
2629 build-depends:
27− aeson >=0.8.0.2 && <1.1,
28− containers >=0.5.6.2 && <0.6,
29− http-types >=0.8.6 && <0.10,
30− jsaddle >=0.7.0.0 && <0.8,
31− stm >=2.4.4 && <2.5,
30+ aeson >=0.8.0.2 && <1.6,
31+ bytestring >=0.10.6.0 && <0.11,
32+ containers >=0.5.6.2 && <0.7,
33+ foreign-store >=0.2 && <0.3,
34+ http-types >=0.8.6 && <0.13,
35+ jsaddle >=0.9.4.0 && <0.10,
36+ stm >=2.4.4 && <2.6,
3237 text >=1.2.1.3 && <1.3,
33− time >=1.5.0.1 && <1.7,
38+ time >=1.5.0.1 && <1.11,
3439 transformers >=0.4.2.0 && <0.6,
3540 wai >=3.0.3.0 && <3.3,
3641 wai-websockets >=3.0.0.6 && <3.1,
37− warp >=3.1.2 && <3.3,
38− websockets >=0.9.5.0 && <0.10
42+ warp >=3.1.2 && <3.4,
43+ websockets >=0.9.5.0 && <0.13
3944 exposed-modules:
4045 Language.Javascript.JSaddle.Warp
4146 build-depends:
@@ -45,21 +50,39 @@ library
4550 ghc-options: -ferror-spans -Wall
4651
4752test-suite test-tool
53+ if impl(ghcjs -any) || os(ios)
54+ buildable: False
4855
49− if !impl(ghcjs -any)
50− build-depends:
56+ build-depends:
5157 QuickCheck -any,
58+ aeson -any,
5259 bytestring -any,
60+ containers -any,
5361 deepseq -any,
54− doctest >=0.10.1 && <0.12,
62+ doctest >=0.10.1 && <0.19,
63+ exceptions -any,
5564 filepath >=1.4.0.0 && <1.5,
65+ foreign-store -any,
5666 ghc-prim -any,
67+ http-types -any,
5768 jsaddle -any,
5869 jsaddle-warp -any,
5970 lens -any,
71+ network -any,
6072 ref-tf -any,
6173 primitive -any,
62− process >=1.2.3.0 && <1.5
74+ process >=1.2.3.0 && <1.7,
75+ random -any,
76+ stm -any,
77+ text -any,
78+ time -any,
79+ transformers -any,
80+ unliftio-core -any,
81+ wai -any,
82+ wai-websockets -any,
83+ warp -any,
84+ webdriver >=0.8.4 && <0.10,
85+ websockets -any
6386 type: exitcode-stdio-1.0
6487 main-is: DocTest.hs
6588 build-depends:
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/Warp.hs+3−4
@@ -17,8 +17,7 @@ module Language.Javascript.JSaddle.Warp (
1717 -- * Running JSM over WebSockets
1818 run
1919#ifndef ghcjs_HOST_OS
20− , jsaddleOr
21− , jsaddleApp
20+ , module Language.Javascript.JSaddle.WebSockets
2221#endif
2322) where
2423
@@ -29,7 +28,7 @@ import Network.WebSockets (defaultConnectionOptions)
2928
3029import Language.Javascript.JSaddle.Types (JSM)
3130import Language.Javascript.JSaddle.Run (syncPoint)
32−import Language.Javascript.JSaddle.WebSockets (jsaddleOr, jsaddleApp)
31+import Language.Javascript.JSaddle.WebSockets
3332#endif
3433
3534-- | Run the given 'JSM' action as the main entry point. Either directly
@@ -40,6 +39,6 @@ run _port = id
4039#else
4140run :: Int -> JSM () -> IO ()
4241run port f =
43− runSettings (setPort port (setTimeout 3600 defaultSettings)) $
42+ runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
4443 jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp
4544#endif
jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs+287−40
@@ -1,5 +1,7 @@
11{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE RecursiveDo #-}
35-----------------------------------------------------------------------------
46--
57-- Module : Language.Javascript.JSaddle.WebSockets
@@ -16,57 +18,302 @@ module Language.Javascript.JSaddle.WebSockets (
1618 -- * Running JSM over WebSockets
1719 jsaddleOr
1820 , jsaddleApp
21+ , jsaddleWithAppOr
22+ , jsaddleAppWithJs
23+ , jsaddleAppWithJsOr
24+ , jsaddleAppPartial
25+ , jsaddleJs
26+ , jsaddleJs'
27+ , debug
28+ , debugOr
29+ , debugWrapper
1930) where
2031
21−import Control.Monad (forever)
22−import Control.Concurrent (forkIO)
32+import Control.Monad (when, void, forever)
33+import Control.Concurrent (killThread, forkIO, threadDelay)
34+import Control.Exception (handle, AsyncException, throwIO, fromException, finally)
2335
2436import Data.Monoid ((<>))
2537import Data.Aeson (encode, decode)
2638
27−import Network.Wai (Application)
39+import Network.Wai
40+ (Middleware, lazyRequestBody, Application, Request, Response,
41+ ResponseReceived)
2842import Network.WebSockets
29− (ConnectionOptions(..), sendTextData, receiveDataMessage,
30− acceptRequest, ServerApp)
31−import qualified Network.WebSockets as WS (DataMessage(..))
43+ (defaultConnectionOptions, ConnectionOptions(..), sendTextData,
44+ receiveDataMessage, acceptRequest, ServerApp, sendPing)
3245import Network.Wai.Handler.WebSockets (websocketsOr)
46+import Network.HTTP.Types (Status(..))
3347
34−import Language.Javascript.JSaddle.Types (JSM(..))
48+import Language.Javascript.JSaddle.Types (JSM(..), JSContextRef(..))
3549import qualified Network.Wai as W
36− (responseLBS, requestMethod, Application, pathInfo)
37−import Data.Text (Text)
50+ (responseLBS, requestMethod, pathInfo, modifyResponse, responseStatus)
51+import qualified Data.Text as T (pack)
3852import qualified Network.HTTP.Types as H
39− (status403, status200, status405)
40−import Language.Javascript.JSaddle.Run (runJavaScript)
41−import Language.Javascript.JSaddle.Run.Files (indexHtml, jsaddleJs)
42−
43−jsaddleOr :: ConnectionOptions -> JSM () -> Application -> Application
44−jsaddleOr opts entryPoint = websocketsOr opts wsApp
45− where
46− wsApp :: ServerApp
47− wsApp pending_conn = do
48− conn <- acceptRequest pending_conn
49− (processResult, start) <- runJavaScript (sendTextData conn . encode) entryPoint
50− _ <- forkIO . forever $
51− receiveDataMessage conn >>= \case
52− (WS.Text t) ->
53− case decode t of
54− Nothing -> error $ "jsaddle WebSocket decode failed : " <> show t
55− Just r -> processResult r
53+ (status403, status200)
54+import Language.Javascript.JSaddle.Run (syncPoint, runJavaScript)
55+import Language.Javascript.JSaddle.Run.Files (indexHtml, runBatch, ghcjsHelpers, initState)
56+import Language.Javascript.JSaddle.Debug
57+ (removeContext, addContext)
58+import Data.Maybe (fromMaybe)
59+import qualified Data.Map as M (empty, insert, lookup)
60+import Data.IORef
61+ (readIORef, newIORef, atomicModifyIORef')
62+import Data.ByteString.Lazy (ByteString)
63+import qualified Data.ByteString.Lazy as LBS
64+ (toStrict, stripPrefix)
65+import Control.Concurrent.MVar
66+ (tryTakeMVar, MVar, tryPutMVar, modifyMVar_, putMVar, takeMVar,
67+ readMVar, newMVar, newEmptyMVar, modifyMVar)
68+import Network.Wai.Handler.Warp
69+ (defaultSettings, setTimeout, setPort, runSettings)
70+import Foreign.Store (readStore, lookupStore, writeStore, Store(..))
71+import Language.Javascript.JSaddle (askJSM)
72+import Control.Monad.IO.Class (MonadIO(..))
73+
74+import Language.Javascript.JSaddle.WebSockets.Compat (getTextMessageByteString)
75+import qualified Data.Text.Encoding as T (decodeUtf8)
76+
77+jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application
78+jsaddleOr opts entryPoint otherApp = do
79+ syncHandlers <- newIORef M.empty
80+ asyncHandlers <- newIORef M.empty
81+ let wsApp :: ServerApp
82+ wsApp pending_conn = do
83+ conn <- acceptRequest pending_conn
84+ initMsg <- receiveDataMessage conn
85+ case getTextMessageByteString initMsg of
86+ Just "" -> do
87+ rec (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) $ do
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"
56106 _ -> error "jsaddle WebSocket unexpected binary data"
57− start
107+
108+ -- Based on Network.WebSocket.forkPingThread
109+ waitTillClosed conn = ignore `handle` go 1
110+ where
111+ go :: Int -> IO ()
112+ go i = do
113+ threadDelay (10 * 1000 * 1000)
114+ sendPing conn (T.pack $ show i)
115+ go (i + 1)
116+
117+ ignore e = case fromException e of
118+ Just async -> throwIO (async :: AsyncException)
119+ Nothing -> return ()
120+
121+ syncHandler :: Application
122+ syncHandler req sendResponse = case (W.requestMethod req, W.pathInfo req) of
123+ ("POST", ["sync", syncKey]) -> do
124+ body <- lazyRequestBody req
125+ case decode body of
126+ Nothing -> error $ "jsaddle sync message decode failed : " <> show body
127+ Just result ->
128+ M.lookup syncKey <$> readIORef syncHandlers >>= \case
129+ Nothing -> error "jsaddle missing sync message handler"
130+ Just handler -> do
131+ next <- encode <$> handler result
132+ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] next
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
138+ return $ websocketsOr opts wsApp syncHandler
139+
58140
59141jsaddleApp :: Application
60−jsaddleApp req = jsaddleAppPieces (W.pathInfo req) req
61−
62−jsaddleAppPieces :: [Text] -> W.Application
63−jsaddleAppPieces _ req sendResponse
64− | W.requestMethod req `notElem` ["GET", "HEAD"] = sendResponse $ W.responseLBS
65− H.status405
66− [("Content-Type", "text/plain")]
67− "Only GET or HEAD is supported"
68−jsaddleAppPieces [] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
69−jsaddleAppPieces ["jsaddle.js"] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs
70−jsaddleAppPieces _rawPieces _req sendResponse = sendResponse $ W.responseLBS H.status403
71− [ ("Content-Type", "text/plain")
72− ] "Forbidden"
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)
154+
155+jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application
156+jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->
157+ (fromMaybe (otherApp req sendResponse)
158+ (jsaddleAppPartial req sendResponse))
159+
160+jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
161+jsaddleAppPartial = jsaddleAppPartialWithJs $ jsaddleJs False
162+
163+indexResponse :: Response
164+indexResponse = W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
165+
166+jsaddleAppPartialWithJs :: ByteString -> Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
167+jsaddleAppPartialWithJs js req sendResponse = case (W.requestMethod req, W.pathInfo req) of
168+ ("GET", []) -> Just $ sendResponse indexResponse
169+ ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] js
170+ _ -> Nothing
171+
172+jsaddleJs :: Bool -> ByteString
173+jsaddleJs = jsaddleJs' Nothing
174+
175+-- Use this to generate this string for embedding
176+-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy
177+jsaddleJs' :: Maybe ByteString -> Bool -> ByteString
178+jsaddleJs' jsaddleUri refreshOnLoad = "\
179+ \if(typeof global !== \"undefined\" && typeof require === \"function\") {\n\
180+ \ global.window = global;\n\
181+ \ global.WebSocket = require('ws');\n\
182+ \}\n\
183+ \\n\
184+ \var connect = function() {\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\
190+ \\n\
191+ \ var ws0 = new WebSocket(wsaddress);\n\
192+ \ var syncKey = \"\";\n\
193+ \\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\
198+ \ " <> initState <> "\n\
199+ \\n\
200+ \ ws0.onmessage = function(e) {\n\
201+ \ var batch = JSON.parse(e.data);\n\
202+ \ if(inCallback > 0) {\n\
203+ \ asyncBatch = batch;\n\
204+ \ return;\n\
205+ \ }\n\
206+ \ if(typeof batch === \"string\") {\n\
207+ \ syncKey = batch;\n\
208+ \ var ws1 = new WebSocket(wsaddress);\n\
209+ \ ws1.onopen = function(e) {\n\
210+ \ ws1.send(syncKey);\n\
211+ \ initialResults.forEach(function(m){ ws1.send(m); });\n\
212+ \ initialResults = null;\n\
213+ \ ws = ws1;\n\
214+ \ }\n" <>
215+ (if refreshOnLoad
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\
225+ \ }\n\
226+ \\n\
227+ \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));")
228+ (Just (\a -> "(function(){\n\
229+ \ var xhr = new XMLHttpRequest();\n\
230+ \ xhr.open('POST', '" <> fromMaybe "" jsaddleUri <> "/sync/'+syncKey, false);\n\
231+ \ xhr.setRequestHeader(\"Content-type\", \"application/json\");\n\
232+ \ xhr.send(JSON.stringify(" <> a <> "));\n\
233+ \ return JSON.parse(xhr.response);})()")) <> "\
234+ \ };\n\
235+ \ };\n\
236+ \ ws0.onerror = function() {\n\
237+ \ setTimeout(connect, 1000);\n\
238+ \ };\n\
239+ \}\n\
240+ \\n\
241+ \ " <> ghcjsHelpers <> "\
242+ \connect();\n\
243+ \"
244+
245+-- | Start or restart the server.
246+-- To run this as part of every :reload use
247+-- > :def! reload (const $ return "::reload\nLanguage.Javascript.JSaddle.Warp.debug 3708 SomeMainModule.someMainFunction")
248+debug :: Int -> JSM () -> IO ()
249+debug port f = do
250+ debugWrapper $ \withRefresh registerContext ->
251+ runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
252+ jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJs $ jsaddleJs True)
253+ putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"
254+
255+debugOr :: Int -> JSM () -> Application -> IO ()
256+debugOr port f b = do
257+ debugWrapper $ \withRefresh registerContext ->
258+ runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
259+ jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJsOr (jsaddleJs True) b)
260+ putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"
261+
262+refreshMiddleware :: ((Response -> IO ResponseReceived) -> IO ResponseReceived) -> Middleware
263+refreshMiddleware refresh otherApp req sendResponse = case (W.requestMethod req, W.pathInfo req) of
264+ ("POST", ["reload", _syncKey]) -> refresh sendResponse
265+ _ -> otherApp req sendResponse
266+
267+debugWrapper :: (Middleware -> JSM () -> IO ()) -> IO ()
268+debugWrapper run = do
269+ reloadMVar <- newEmptyMVar
270+ reloadDoneMVars <- newMVar []
271+ contexts <- newMVar []
272+ let refresh sendResponse = do
273+ reloadDone <- newEmptyMVar
274+ modifyMVar_ reloadDoneMVars (return . (reloadDone:))
275+ readMVar reloadMVar
276+ r <- sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] ("reload" :: ByteString)
277+ putMVar reloadDone ()
278+ return r
279+ start :: Int -> IO (IO Int)
280+ start expectedConnections = do
281+ serverDone <- newEmptyMVar
282+ ready <- newEmptyMVar
283+ let registerContext :: JSM ()
284+ registerContext = do
285+ uuid <- contextId <$> askJSM
286+ browsersConnected <- liftIO $ modifyMVar contexts (\ctxs -> return (uuid:ctxs, length ctxs + 1))
287+ addContext
288+ when (browsersConnected == expectedConnections) . void . liftIO $ tryPutMVar ready ()
289+ thread <- forkIO $
290+ finally (run (refreshMiddleware refresh) registerContext)
291+ (putMVar serverDone ())
292+ _ <- forkIO $ threadDelay 10000000 >> void (tryPutMVar ready ())
293+ when (expectedConnections /= 0) $ takeMVar ready
294+ return $ do
295+ putMVar reloadMVar ()
296+ ctxs <- takeMVar contexts
297+ mapM_ removeContext ctxs
298+ takeMVar reloadDoneMVars >>= mapM_ takeMVar
299+ tryTakeMVar serverDone >>= \case
300+ Nothing -> do
301+ killThread thread
302+ takeMVar serverDone
303+ Just _ -> return ()
304+ return $ length ctxs
305+ restarter :: MVar (Int -> IO (IO Int)) -> IO Int -> IO ()
306+ restarter mvar stop = do
307+ start' <- takeMVar mvar
308+ n <- stop
309+ start' n >>= restarter mvar
310+ lookupStore storeId >>= \case
311+ Nothing -> do
312+ restartMVar <- newMVar start
313+ void . forkIO $ restarter restartMVar (return 0)
314+ void $ writeStore (Store storeId) restartMVar
315+ Just shutdownStore -> do
316+ restartMVar :: MVar (Int -> IO (IO Int)) <- readStore shutdownStore
317+ void $ tryTakeMVar restartMVar
318+ putMVar restartMVar start
319+ where storeId = 354
jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets/Compat.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+84−61
@@ -11,15 +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)
17+import Control.Monad.IO.Class (MonadIO(..))
1618import Data.Monoid ((<>))
1719import System.Environment (getArgs)
18−import Language.Javascript.JSaddle.Run.Files (jsaddleJs)
19−import qualified Data.ByteString.Lazy.Char8 as BS (unpack)
20+import Test.WebDriver (runSession, defaultConfig, openPage, closeSession)
2021
2122main :: IO ()
2223main = do
24+ putStrLn "Testing JSaddle"
2325 jsaddlePath <- getArgs >>= \case
2426 [arg] -> return arg
2527 _ -> do
@@ -27,63 +29,84 @@ main = do
2729 exitFailure
2830 hSetBuffering stdout LineBuffering
2931 hSetBuffering stderr LineBuffering
30− node <- system "nodejs --version" >>= \case
31− ExitSuccess -> return "nodejs"
32− _ -> return "node"
33− system (node <> " --version") >>= \case
34− ExitSuccess -> putStrLn "Node.js found"
32+ putStrLn "Checking for phantomjs"
33+ node <- system "phantomjs --version" >>= \case
34+ ExitSuccess -> return ()
3535 e -> do
36− putStrLn "Node.js not found"
36+ putStrLn "phantomjs not found"
3737 exitWith e
38− forkIO . void $ readProcess node ["--harmony"] (BS.unpack jsaddleJs) >>= putStr
39− doctest [
40− "-hide-all-packages",
41− "-package=base-" ++ VERSION_base,
42− "-package=lens-" ++ VERSION_lens,
43− "-package=text-" ++ VERSION_text,
44− "-package=bytestring-" ++ VERSION_bytestring,
45− "-package=transformers-" ++ VERSION_transformers,
46− "-package=websockets-" ++ VERSION_websockets,
47− "-package=primitive-" ++ VERSION_primitive,
48− "-package=aeson-" ++ VERSION_aeson,
49− "-package=websockets-" ++ VERSION_websockets,
50− "-package=wai-" ++ VERSION_wai,
51− "-package=wai-websockets-" ++ VERSION_wai_websockets,
52− "-package=warp-" ++ VERSION_warp,
53− "-package=http-types-" ++ VERSION_http_types,
54− "-package=stm-" ++ VERSION_stm,
55− "-package=time-" ++ VERSION_time,
56− "-package=containers-" ++ VERSION_containers,
57− "-package=process-" ++ VERSION_process,
58− "-package=filepath-" ++ VERSION_filepath,
59− "-package=ref-tf-" ++ VERSION_ref_tf,
60− "-package=deepseq-" ++ VERSION_deepseq,
61− "-package=ghc-prim-" ++ VERSION_ghc_prim,
62− "-i" <> jsaddlePath </> "jsaddle-warp/src",
63− "-i" <> jsaddlePath </> "jsaddle-warp/src-ghc",
64− jsaddlePath </> "jsaddle-warp/src/Language/Javascript/JSaddle/Test.hs",
65− "-i" <> jsaddlePath </> "jsaddle",
66− jsaddlePath </> "jsaddle/src-ghc/GHCJS/Marshal.hs",
67− jsaddlePath </> "jsaddle/src-ghc/GHCJS/Marshal/Pure.hs",
68− jsaddlePath </> "jsaddle/src-ghc/GHCJS/Marshal/Internal.hs",
69− jsaddlePath </> "jsaddle/src-ghc/JavaScript/Array/Internal.hs",
70− jsaddlePath </> "jsaddle/src-ghc/JavaScript/Object/Internal.hs",
71− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle.hs",
72− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Array.hs",
73− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Arguments.hs",
74− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Classes.hs",
75− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Classes/Internal.hs",
76− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Evaluate.hs",
77− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Exception.hs",
78− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Foreign.hs",
79− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Monad.hs",
80− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Marshal/String.hs",
81− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Native.hs",
82− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Native/Internal.hs",
83− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Object.hs",
84− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Properties.hs",
85− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Run.hs",
86− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs",
87− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/String.hs",
88− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Types.hs",
89− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Value.hs" ]
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
44+ liftIO $ doctest [
45+ "-hide-all-packages",
46+ "-package=base-" ++ VERSION_base,
47+ "-package=lens-" ++ VERSION_lens,
48+ "-package=text-" ++ VERSION_text,
49+ "-package=bytestring-" ++ VERSION_bytestring,
50+ "-package=transformers-" ++ VERSION_transformers,
51+ "-package=websockets-" ++ VERSION_websockets,
52+ "-package=primitive-" ++ VERSION_primitive,
53+ "-package=aeson-" ++ VERSION_aeson,
54+ "-package=websockets-" ++ VERSION_websockets,
55+ "-package=wai-" ++ VERSION_wai,
56+ "-package=wai-websockets-" ++ VERSION_wai_websockets,
57+ "-package=warp-" ++ VERSION_warp,
58+ "-package=http-types-" ++ VERSION_http_types,
59+ "-package=stm-" ++ VERSION_stm,
60+ "-package=time-" ++ VERSION_time,
61+ "-package=containers-" ++ VERSION_containers,
62+ "-package=process-" ++ VERSION_process,
63+ "-package=filepath-" ++ VERSION_filepath,
64+ "-package=ref-tf-" ++ VERSION_ref_tf,
65+ "-package=deepseq-" ++ VERSION_deepseq,
66+ "-package=ghc-prim-" ++ VERSION_ghc_prim,
67+ "-package=exceptions-" ++ VERSION_exceptions,
68+ "-package=unliftio-core-" ++ VERSION_unliftio_core,
69+ "-package=random-" ++ VERSION_random,
70+ "-package=foreign-store-" ++ VERSION_foreign_store,
71+ "-i" <> "src",
72+ "-i" <> "src-ghc",
73+ "src/Language/Javascript/JSaddle/Test.hs",
74+ "-i" <> jsaddlePath,
75+ jsaddlePath </> "src-ghc/Data/JSString/Text.hs",
76+ jsaddlePath </> "src-ghc/Data/JSString/Internal/Type.hs",
77+ jsaddlePath </> "src-ghc/GHCJS/Foreign.hs",
78+ jsaddlePath </> "src-ghc/GHCJS/Foreign/Internal.hs",
79+ jsaddlePath </> "src-ghc/GHCJS/Internal/Types.hs",
80+ jsaddlePath </> "src-ghc/GHCJS/Marshal.hs",
81+ jsaddlePath </> "src-ghc/GHCJS/Marshal/Pure.hs",
82+ jsaddlePath </> "src-ghc/GHCJS/Marshal/Internal.hs",
83+ jsaddlePath </> "src-ghc/GHCJS/Prim.hs",
84+ jsaddlePath </> "src-ghc/GHCJS/Prim/Internal.hs",
85+ jsaddlePath </> "src-ghc/GHCJS/Types.hs",
86+ jsaddlePath </> "src-ghc/JavaScript/Array.hs",
87+ jsaddlePath </> "src-ghc/JavaScript/Array/Internal.hs",
88+ jsaddlePath </> "src-ghc/JavaScript/Object/Internal.hs",
89+ jsaddlePath </> "src/Language/Javascript/JSaddle.hs",
90+ jsaddlePath </> "src/Language/Javascript/JSaddle/Arguments.hs",
91+ jsaddlePath </> "src/Language/Javascript/JSaddle/Classes.hs",
92+ jsaddlePath </> "src/Language/Javascript/JSaddle/Classes/Internal.hs",
93+ jsaddlePath </> "src/Language/Javascript/JSaddle/Debug.hs",
94+ jsaddlePath </> "src/Language/Javascript/JSaddle/Evaluate.hs",
95+ jsaddlePath </> "src/Language/Javascript/JSaddle/Exception.hs",
96+ jsaddlePath </> "src/Language/Javascript/JSaddle/Monad.hs",
97+ jsaddlePath </> "src/Language/Javascript/JSaddle/Marshal/String.hs",
98+ jsaddlePath </> "src/Language/Javascript/JSaddle/Native.hs",
99+ jsaddlePath </> "src/Language/Javascript/JSaddle/Native/Internal.hs",
100+ jsaddlePath </> "src/Language/Javascript/JSaddle/Object.hs",
101+ jsaddlePath </> "src/Language/Javascript/JSaddle/Properties.hs",
102+ jsaddlePath </> "src/Language/Javascript/JSaddle/Run.hs",
103+ jsaddlePath </> "src/Language/Javascript/JSaddle/Run/Files.hs",
104+ jsaddlePath </> "src/Language/Javascript/JSaddle/String.hs",
105+ jsaddlePath </> "src/Language/Javascript/JSaddle/Types.hs",
106+ jsaddlePath </> "src/Language/Javascript/JSaddle/Value.hs" ]
107+ putMVar done ()
108+ threadDelay 5000000
109+ runSession defaultConfig $ do
110+ openPage "http://127.0.0.1:3709"
111+ liftIO $ takeMVar done
112+ closeSession
jsaddle-webkit2gtk/jsaddle-webkit2gtk.cabal+19−12
@@ -1,5 +1,5 @@
11name: jsaddle-webkit2gtk
2−version: 0.7.1.0
2+version: 0.9.8.0
33cabal-version: >=1.10
44build-type: Simple
55license: MIT
@@ -17,25 +17,32 @@ author: Hamish Mackenzie
1717source-repository head
1818 type: git
1919 location: https://github.com/ghcjs/jsaddle
20+ subdir: jsaddle-webkit2gtk
2021
2122library
2223 exposed-modules:
23− Language.Javascript.JSaddle.WebKit2GTK
24+ Language.Javascript.JSaddle.WebKitGTK
2425 build-depends:
25− aeson >=0.8.0.2 && <1.1,
26+ base <5
27+ if !impl(ghcjs -any)
28+ build-depends:
29+ aeson >=0.8.0.2 && <1.6,
2630 base <5,
2731 bytestring >=0.10.6.0 && <0.11,
28− directory >=1.0.0.2 && <1.3,
29− gi-glib >=2.0.6 && <2.1,
30− gi-gio >=2.0.6 && <2.1,
31− gi-gtk >=3.0.6 && <3.1,
32− gi-webkit2 >=4.0.6 && <4.1,
33− gi-javascriptcore >=4.0.6 && <4.1,
34− haskell-gi-base >=0.20 && <0.21,
35− jsaddle >=0.7.0.0 && <0.8,
32+ directory >=1.0.0.2 && <1.4,
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,
3641 text >=1.2.1.3 && <1.3,
37− unix >=2.3.1.0 && <2.8,
3842 webkit2gtk3-javascriptcore >=0.14.0.0 && <0.15
43+ if !os(windows)
44+ build-depends:
45+ unix >=2.3.1.0 && <2.8
3946 default-language: Haskell2010
4047 hs-source-dirs: src
4148 ghc-options: -ferror-spans -Wall
jsaddle-webkit2gtk/src/Language/Javascript/JSaddle/WebKit2GTK.hs → jsaddle-webkit2gtk/src/Language/Javascript/JSaddle/WebKitGTK.hsrenamed+72−55
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE ScopedTypeVariables #-}
23{-# LANGUAGE OverloadedStrings #-}
34{-# LANGUAGE PatternSynonyms #-}
@@ -13,97 +14,95 @@
1314-- |
1415--
1516-----------------------------------------------------------------------------
16−module Language.Javascript.JSaddle.WebKit2GTK (
17+module Language.Javascript.JSaddle.WebKitGTK (
1718 -- * Running JSM in a WebView
1819 run
20+#ifndef ghcjs_HOST_OS
1921 , runInWebView
22+#endif
2023 ) where
2124
25+#ifdef ghcjs_HOST_OS
26+
27+run :: IO () -> IO ()
28+run = id
29+{-# INLINE run #-}
30+
31+#else
32+
2233import Control.Monad (void)
2334import Control.Monad.IO.Class (MonadIO(..), MonadIO)
2435import Control.Concurrent (forkIO, yield)
2536
37+#ifndef mingw32_HOST_OS
2638import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch))
39+#endif
2740import System.Directory (getCurrentDirectory)
2841
2942import Data.Monoid ((<>))
3043import Data.ByteString.Lazy (toStrict, fromStrict)
3144import qualified Data.ByteString.Lazy as LB (ByteString)
3245import Data.Aeson (encode, decode)
33−import Data.Text (Text)
3446import qualified Data.Text as T (pack)
35−import Data.Text.Foreign (fromPtr)
3647import Data.Text.Encoding (decodeUtf8, encodeUtf8)
3748
38−import Foreign.Ptr (castPtr, nullPtr)
39−
4049import Data.GI.Base.BasicTypes (GObject)
4150import Data.GI.Base.Signals
4251 (connectSignalFunPtr, SignalConnectMode(..), SignalConnectMode,
4352 SignalHandlerId)
44−import Data.GI.Base.ManagedPtr (withManagedPtr)
4553
4654import GI.GLib (timeoutAdd, idleAdd, pattern PRIORITY_HIGH, pattern PRIORITY_DEFAULT)
4755import qualified GI.Gtk as Gtk (main, init)
4856import GI.Gtk
4957 (windowSetPosition, windowSetDefaultSize, windowNew,
50− scrolledWindowNew, noAdjustment, containerAdd,
58+ scrolledWindowNew, Adjustment, containerAdd,
5159 WindowType(..), WindowPosition(..), widgetDestroy,
5260 widgetGetToplevel, widgetShowAll, onWidgetDestroy,
5361 mainQuit)
54−import GI.Gio (noCancellable)
55−import GI.JavaScriptCore (Value(..), GlobalContext(..))
62+import GI.Gio (Cancellable)
63+import GI.JavaScriptCore (valueToString)
5664import GI.WebKit2
57− (WebView, setSettingsEnableWriteConsoleMessagesToStdout,
58− setSettingsEnableJavascript,
59− webViewNewWithUserContentManager, userContentManagerNew,
65+ (scriptDialogPromptSetText, scriptDialogPromptGetDefaultText,
66+ scriptDialogGetMessage, scriptDialogGetDialogType,
67+ onWebViewScriptDialog, WebView,
68+ setSettingsEnableWriteConsoleMessagesToStdout,
69+ setSettingsEnableJavascript, webViewNewWithUserContentManager,
70+ userContentManagerNew,
6071 userContentManagerRegisterScriptMessageHandler,
61− javascriptResultGetValue, javascriptResultGetGlobalContext,
72+ javascriptResultGetJsValue,
6273 webViewGetUserContentManager,
6374 mk_UserContentManagerScriptMessageReceivedCallback,
6475 wrap_UserContentManagerScriptMessageReceivedCallback,
6576 webViewRunJavascript, LoadEvent(..),
6677 UserContentManagerScriptMessageReceivedCallback, webViewLoadHtml,
6778 onWebViewLoadChanged, setSettingsEnableDeveloperExtras,
68− webViewSetSettings, webViewGetSettings)
69−
70−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
71− (JSValueRef, JSContextRef)
72−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
73− (jsstringgetcharactersptr, jsstringgetlength, jsstringrelease)
74−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
75− (jsvaluetostringcopy)
79+ webViewSetSettings, webViewGetSettings, ScriptDialogType(..))
7680
77−import Language.Javascript.JSaddle (JSM, Results)
81+import Language.Javascript.JSaddle (JSM, Results, Batch)
7882import Language.Javascript.JSaddle.Run (runJavaScript)
7983import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
8084
85+noAdjustment :: Maybe Adjustment
86+noAdjustment = Nothing
87+
88+noCancellable :: Maybe Cancellable
89+noCancellable = Nothing
90+
8191quitWebView :: WebView -> IO ()
8292quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv --TODO: Shouldn't this be postGUISync?
8393 widgetDestroy w
8494
8595installQuitHandler :: WebView -> IO ()
96+#ifdef mingw32_HOST_OS
97+installQuitHandler wv = return () -- TODO: Maybe figure something out here for Windows users.
98+#else
8699installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) Nothing
100+#endif
87101
88102postGUIAsync :: IO () -> IO ()
89103postGUIAsync action =
90104 void . idleAdd PRIORITY_DEFAULT $ action >> return False
91105
92−withJSContextRef :: GlobalContext -> (JSContextRef -> IO a) -> IO a
93−withJSContextRef (GlobalContext ctx) f = withManagedPtr ctx (f . castPtr)
94−
95−withJSValueRef :: Value -> (JSValueRef -> IO a) -> IO a
96−withJSValueRef (Value ptr) f = withManagedPtr ptr (f . castPtr)
97−
98−valueToText :: JSContextRef -> JSValueRef -> IO Text
99−valueToText ctxRef s = do
100− jsstring <- jsvaluetostringcopy ctxRef s nullPtr
101− l <- jsstringgetlength jsstring
102− p <- jsstringgetcharactersptr jsstring
103− result <- fromPtr (castPtr p) (fromIntegral l)
104− jsstringrelease jsstring
105− return result
106−
107106run :: JSM () -> IO ()
108107run main = do
109108 _ <- Gtk.init Nothing
@@ -128,17 +127,17 @@ run main = do
128127 void . onWebViewLoadChanged webView $ \case
129128 LoadEventFinished -> runInWebView main webView
130129 _ -> return ()
131− webViewLoadHtml webView "" . Just $ "file://" <> T.pack pwd <> "/"
130+ webViewLoadHtml webView "" . Just $ "file://" <> T.pack pwd <> "/index.html"
132131 installQuitHandler webView
133132 Gtk.main
134133
135134runInWebView :: JSM () -> WebView -> IO ()
136135runInWebView f webView = do
137− (processResults, start) <- runJavaScript (\batch -> postGUIAsync $
136+ (processResults, syncResults, start) <- runJavaScript (\batch -> postGUIAsync $
138137 webViewRunJavascript webView (decodeUtf8 . toStrict $ "runJSaddleBatch(" <> encode batch <> ");") noCancellable Nothing)
139138 f
140139
141− addJSaddleHandler webView processResults
140+ addJSaddleHandler webView processResults syncResults
142141 webViewRunJavascript webView (decodeUtf8 $ toStrict jsaddleJs) noCancellable . Just $
143142 \_obj _asyncResult ->
144143 void $ forkIO start
@@ -152,25 +151,43 @@ connectUserContentManagerScriptMessageReceived obj cb after = liftIO $ do
152151 let cb' = wrap_UserContentManagerScriptMessageReceivedCallback cb
153152 cb'' <- mk_UserContentManagerScriptMessageReceivedCallback cb'
154153 connectSignalFunPtr obj "script-message-received::jsaddle" cb'' after
154+#if MIN_VERSION_haskell_gi_base(0,23,0)
155+ Nothing
156+#endif
155157
156−addJSaddleHandler :: WebView -> (Results -> IO ()) -> IO ()
157−addJSaddleHandler webView processResult = do
158+addJSaddleHandler :: WebView -> (Results -> IO ()) -> (Results -> IO Batch) -> IO ()
159+addJSaddleHandler webView processResult syncResults = do
158160 manager <- webViewGetUserContentManager webView
159161 _ <- onUserContentManagerScriptMessageReceived manager $ \result -> do
160− ctx <- javascriptResultGetGlobalContext result
161− arg <- javascriptResultGetValue result
162− bs <- withJSContextRef ctx $ \ctxRef ->
163− withJSValueRef arg $ \argRef ->
164− encodeUtf8 <$> valueToText ctxRef argRef
162+ arg <- javascriptResultGetJsValue result
163+ bs <- encodeUtf8 <$> valueToString arg
165164 mapM_ processResult (decode (fromStrict bs))
165+ _ <- onWebViewScriptDialog webView $ \dialog ->
166+ scriptDialogGetDialogType dialog >>= \case
167+ ScriptDialogTypePrompt ->
168+ scriptDialogGetMessage dialog >>= \case
169+ "JSaddleSync" -> do
170+ resultsText <- scriptDialogPromptGetDefaultText dialog
171+ case decode (fromStrict $ encodeUtf8 resultsText) of
172+ Just results -> do
173+ batch <- syncResults results
174+ scriptDialogPromptSetText dialog (decodeUtf8 . toStrict $ encode batch)
175+ return True
176+ Nothing -> return False
177+ _ -> return False
178+ _ -> return False
179+
166180 void $ userContentManagerRegisterScriptMessageHandler manager "jsaddle"
167181
168182jsaddleJs :: LB.ByteString
169−jsaddleJs = ghcjsHelpers <> "\
170− \runJSaddleBatch = (function() {\n\
171− \ " <> initState <> "\n\
172− \ return function(batch) {\n\
173− \ " <> runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));") <> "\
174− \ };\n\
175− \})()\n\
176− \"
183+jsaddleJs = ghcjsHelpers <> mconcat
184+ [ "runJSaddleBatch = (function() {\n"
185+ , initState
186+ , "\nreturn function(batch) {\n"
187+ , runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));\n")
188+ (Just (\a -> "JSON.parse(window.prompt(\"JSaddleSync\", JSON.stringify(" <> a <> ")))"))
189+ , "};\n"
190+ , "})()"
191+ ]
192+
193+#endif
jsaddle-webkitgtk/jsaddle-webkitgtk.cabal+8−5
@@ -1,5 +1,5 @@
11name: jsaddle-webkitgtk
2−version: 0.7.1.0
2+version: 0.9.0.0
33cabal-version: >=1.10
44build-type: Simple
55license: MIT
@@ -17,24 +17,27 @@ author: Hamish Mackenzie
1717source-repository head
1818 type: git
1919 location: https://github.com/ghcjs/jsaddle
20+ subdir: jsaddle-webkitgtk
2021
2122library
2223 exposed-modules:
2324 Language.Javascript.JSaddle.WebKitGTK
2425 build-depends:
25− aeson >=0.8.0.2 && <1.1,
26+ aeson >=0.8.0.2 && <1.3,
2627 base <5,
2728 bytestring >=0.10.6.0 && <0.11,
28− directory >=1.0.0.2 && <1.3,
29+ directory >=1.0.0.2 && <1.4,
2930 gi-glib >=2.0.6 && <2.1,
3031 gi-gtk >=3.0.6 && <3.1,
3132 gi-webkit >=3.0.6 && <3.1,
3233 gi-javascriptcore >=3.0.6 && <3.1,
3334 haskell-gi-base >=0.20 && <0.21,
34− jsaddle >=0.7.0.0 && <0.8,
35+ jsaddle >=0.9.0.0 && <0.10,
3536 text >=1.2.1.3 && <1.3,
36− unix >=2.3.1.0 && <2.8,
3737 webkitgtk3-javascriptcore >=0.14.0.0 && <0.15
38+ if !os(windows)
39+ build-depends:
40+ unix >=2.3.1.0 && <2.8
3841 default-language: Haskell2010
3942 hs-source-dirs: src
4043 ghc-options: -ferror-spans -Wall
jsaddle-webkitgtk/src/Language/Javascript/JSaddle/WebKitGTK.hs+30−11
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE ScopedTypeVariables #-}
23{-# LANGUAGE OverloadedStrings #-}
34{-# LANGUAGE PatternSynonyms #-}
@@ -16,15 +17,27 @@
1617module Language.Javascript.JSaddle.WebKitGTK (
1718 -- * Running JSM in a WebView
1819 run
20+#ifndef ghcjs_HOST_OS
1921 , runInWebView
22+#endif
2023 ) where
2124
25+#ifdef ghcjs_HOST_OS
26+
27+run :: IO () -> IO ()
28+run = id
29+{-# INLINE run #-}
30+
31+#else
32+
2233import Control.Monad (when, void)
2334import qualified Control.Exception as E (catch)
2435import Control.Exception (SomeException(..))
2536import Control.Concurrent (forkIO, yield)
2637
27−import System.Posix.Signals (installHandler)
38+#ifndef mingw32_HOST_OS
39+import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch))
40+#endif
2841import System.Directory (getCurrentDirectory)
2942
3043import Data.Monoid ((<>))
@@ -83,7 +96,11 @@ quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv --TODO: Shouldn't t
8396 widgetDestroy w
8497
8598installQuitHandler :: WebView -> IO ()
99+#ifdef mingw32_HOST_OS
100+installQuitHandler wv = return () -- TODO: Maybe figure something out here for Windows users.
101+#else
86102installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) Nothing
103+#endif
87104
88105postGUIAsync :: IO () -> IO ()
89106postGUIAsync action =
@@ -168,7 +185,7 @@ runInWebView f webView = do
168185 jsvalueprotect ctxRef result
169186 return result
170187
171− (processResults, start) <- runJavaScript (\batch -> postGUIAsync $
188+ (processResults, _, start) <- runJavaScript (\batch -> postGUIAsync $
172189 withJSContextRef ctx $ \ctxRef ->
173190 withJSString (decodeUtf8 . toStrict $ encode batch) $ \script -> do
174191 val <- jsvaluemakestring ctxRef script
@@ -200,12 +217,14 @@ addJSaddleHandler ctxRef processResult = do
200217 jsvaluemakeundefined ctxRef
201218
202219jsaddleJs :: LB.ByteString
203−jsaddleJs = ghcjsHelpers <> "\
204− \(function() {\n\
205− \ " <> initState <> "\n\
206− \ return function(batchJSON) {\n\
207− \ var batch = JSON.parse(batchJSON);\n\
208− \ " <> runBatch (\a -> "window.jsaddleCallback(JSON.stringify(" <> a <> "));") <> "\
209− \ };\n\
210− \})()\n\
211− \"
220+jsaddleJs = ghcjsHelpers <> mconcat
221+ [ "(function() {\n"
222+ , initState
223+ , "\nreturn function(batchJSON) {\n"
224+ , " var batch = JSON.parse(batchJSON);\n"
225+ , runBatch (\a -> "window.jsaddleCallback(JSON.stringify(" <> a <> "));\n") Nothing
226+ , "};\n"
227+ , "})()\n"
228+ ]
229+
230+#endif
jsaddle-wkwebview/cbits-cocoa/AppDelegate.mnew file+126
@@ -0,0 +1,126 @@
1+#include "HsFFI.h"
2+#import <Cocoa/Cocoa.h>
3+#import <WebKit/WebKit.h>
4+
5+extern void callIO(HsStablePtr);
6+extern bool callWithCStringReturningBool(const char * _Nonnull, HsStablePtr);
7+extern void callWithCString(const char * _Nonnull, HsStablePtr);
8+extern void callWithWebView(WKWebView *, HsStablePtr);
9+
10+@interface AppDelegate : NSObject <NSApplicationDelegate>
11+@property (nonatomic, assign) IBOutlet NSWindow *window;
12+@property (nonatomic, assign) HsStablePtr handler;
13+
14+- (instancetype)initApp:(HsStablePtr)handler progName:(NSString *)progName;
15+@end
16+
17+HsStablePtr global_willFinishLaunchingWithOptions = 0;
18+HsStablePtr global_didFinishLaunchingWithOptions = 0;
19+HsStablePtr global_applicationUniversalLink = 0;
20+HsStablePtr global_applicationOpenFile = 0;
21+uint64_t global_developerExtrasEnabled = 1;
22+
23+@implementation AppDelegate
24+
25+- (void)applicationWillTerminate:(NSNotification *)aNotification {
26+ // Insert code here to tear down your application
27+}
28+
29+-(id)initApp:(HsStablePtr)handler progName:(NSString *)progName {
30+ self = [super init];
31+ if (self) {
32+ _handler = handler;
33+ NSRect contentSize = NSMakeRect(0.0, 500.0, 1000.0, 700.0);
34+ // TODO replace with once nix has newer Cocoa NSUInteger windowStyleMask = NSWindowStyleMaskTitled | NSWindowStyleMaskResizable | NSWindowStyleMaskClosable | NSWindowStyleMaskMiniaturizable;
35+ NSUInteger windowStyleMask = NSTitledWindowMask | NSResizableWindowMask | NSClosableWindowMask | NSMiniaturizableWindowMask;
36+ _window = [[NSWindow alloc] initWithContentRect:contentSize styleMask:windowStyleMask backing:NSBackingStoreBuffered defer:YES];
37+ _window.backgroundColor = [NSColor whiteColor];
38+ _window.title = progName;
39+ }
40+ return self;
41+}
42+
43+-(BOOL)application:(NSApplication *)sender openFile:(NSString *)filename {
44+ bool b = callWithCStringReturningBool([filename UTF8String], global_applicationOpenFile);
45+ return b ? YES : NO;
46+}
47+
48+-(void)applicationWillFinishLaunching:(NSNotification *)notification {
49+ WKWebViewConfiguration *theConfiguration = [[WKWebViewConfiguration alloc] init];
50+ if (global_developerExtrasEnabled) {
51+ [theConfiguration.preferences setValue:@YES forKey:@"developerExtrasEnabled"];
52+ }
53+ WKWebView *webView = [[WKWebView alloc] initWithFrame: [_window.contentView frame] configuration:theConfiguration];
54+ [_window setContentView:webView];
55+ callWithWebView(webView, _handler);
56+ callIO(global_willFinishLaunchingWithOptions);
57+ // Listen to URL events
58+ NSAppleEventManager *manager = [NSAppleEventManager sharedAppleEventManager];
59+ [manager
60+ setEventHandler:self
61+ andSelector:@selector(applicationUniversalLink:)
62+ forEventClass:kInternetEventClass
63+ andEventID:kAEGetURL];
64+}
65+
66+- (void)applicationUniversalLink:(NSAppleEventDescriptor *)event {
67+ NSString *url = [[event paramDescriptorForKeyword:keyDirectObject] stringValue];
68+ callWithCString([url UTF8String], global_applicationUniversalLink);
69+}
70+
71+-(void)applicationDidFinishLaunching:(NSNotification *)notification {
72+ [_window orderFrontRegardless];
73+ [_window center];
74+ [NSApp activateIgnoringOtherApps:YES];
75+ callIO(global_didFinishLaunchingWithOptions);
76+}
77+
78+-(BOOL) applicationShouldTerminateAfterLastWindowClosed:(NSApplication *)app {
79+ return YES;
80+}
81+
82+@end
83+
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) {
105+ @autoreleasepool {
106+ global_willFinishLaunchingWithOptions = hs_willFinishLaunchingWithOptions;
107+ global_didFinishLaunchingWithOptions = hs_didFinishLaunchingWithOptions;
108+ global_applicationUniversalLink = hs_applicationUniversalLink;
109+ global_applicationOpenFile = hs_applicationOpenFile;
110+ global_developerExtrasEnabled = hs_developerExtrasEnabled;
111+ NSApplication *application = [NSApplication sharedApplication];
112+ AppDelegate *appDelegate = [[AppDelegate alloc] initApp:handler progName:[NSString stringWithCString:progName encoding:NSUTF8StringEncoding]];
113+ [application setDelegate:appDelegate];
114+ const char * _Nonnull argv [] = {"", 0};
115+ [application setActivationPolicy:NSApplicationActivationPolicyRegular];
116+ [application
117+ performSelectorOnMainThread:@selector(run)
118+ withObject:nil
119+ waitUntilDone:YES];
120+ }
121+}
122+
123+BOOL openApp(NSURL * url) {
124+ NSWorkspace *workspace = [NSWorkspace sharedWorkspace];
125+ return [workspace openURL:url];
126+}
jsaddle-wkwebview/cbits-uikit/AppDelegate.hnew file+8
@@ -0,0 +1,8 @@
1+#include "HsFFI.h"
2+#import <UIKit/UIKit.h>
3+
4+@interface AppDelegate : UIResponder <UIApplicationDelegate>
5+
6+@property (nonatomic, assign) UIWindow *window;
7+
8+@end
jsaddle-wkwebview/cbits-uikit/AppDelegate.mnew file+207
@@ -0,0 +1,207 @@
1+#import "AppDelegate.h"
2+#import "ViewController.h"
3+#import <UserNotifications/UserNotifications.h>
4+#import <stdint.h>
5+
6+extern void callIO(HsStablePtr);
7+extern void callWithCString(const char * _Nonnull, HsStablePtr);
8+extern void callWithCIntCString(int n, const char * _Nonnull, HsStablePtr);
9+
10+@interface AppDelegate ()
11+
12+@end
13+
14+HsStablePtr globalHandler = 0;
15+HsStablePtr global_willFinishLaunchingWithOptions = 0;
16+HsStablePtr global_didFinishLaunchingWithOptions = 0;
17+HsStablePtr global_applicationDidBecomeActive = 0;
18+HsStablePtr global_applicationWillResignActive = 0;
19+HsStablePtr global_applicationDidEnterBackground = 0;
20+HsStablePtr global_applicationWillEnterForeground = 0;
21+HsStablePtr global_applicationWillTerminate = 0;
22+HsStablePtr global_applicationSignificantTimeChange = 0;
23+HsStablePtr global_applicationUniversalLink = 0;
24+HsStablePtr global_applicationDidReceiveRemoteNotification = 0;
25+uint64_t global_requestAuthorizationWithOptions = 0;
26+uint64_t global_requestAuthorizationOptionBadge = 0;
27+uint64_t global_requestAuthorizationOptionSound = 0;
28+uint64_t global_requestAuthorizationOptionAlert = 0;
29+uint64_t global_requestAuthorizationOptionCarPlay = 0;
30+uint64_t global_registerForRemoteNotifications = 0;
31+HsStablePtr global_didRegisterForRemoteNotificationsWithDeviceToken = 0;
32+HsStablePtr global_didFailToRegisterForRemoteNotificationsWithError = 0;
33+
34+@implementation AppDelegate
35+
36+- (BOOL)application:(UIApplication *)application willFinishLaunchingWithOptions:(NSDictionary *)launchOptions {
37+ // Tells the delegate that the launch process has begun but that state restoration has not yet occurred.
38+ callIO(global_willFinishLaunchingWithOptions);
39+ return YES;
40+}
41+
42+- (BOOL)application:(UIApplication *)application didFinishLaunchingWithOptions:(NSDictionary *)launchOptions {
43+ // Tells the delegate that the launch process is almost done and the app is almost ready to run.
44+ self.window = [[UIWindow alloc] initWithFrame:[[UIScreen mainScreen] bounds]];
45+ // Override point for customization after application launch.
46+ self.window.rootViewController = [[ViewController alloc] initWithHandler:globalHandler];
47+ self.window.backgroundColor = [UIColor whiteColor];
48+ [self.window makeKeyAndVisible];
49+ UNUserNotificationCenter* center = [UNUserNotificationCenter currentNotificationCenter];
50+ center.delegate = self;
51+ if (global_requestAuthorizationWithOptions) {
52+ UNAuthorizationOptions options = (UNAuthorizationOptions)0;
53+ if (global_requestAuthorizationOptionBadge) {
54+ options = options | UNAuthorizationOptionBadge;
55+ }
56+ if (global_requestAuthorizationOptionSound) {
57+ options = options | UNAuthorizationOptionSound;
58+ }
59+ if (global_requestAuthorizationOptionAlert) {
60+ options = options | UNAuthorizationOptionAlert;
61+ }
62+ if (global_requestAuthorizationOptionCarPlay) {
63+ options = options | UNAuthorizationOptionCarPlay;
64+ }
65+ [center requestAuthorizationWithOptions:(options)
66+ completionHandler:^(BOOL granted, NSError * _Nullable error) {
67+ // Handler used to alter application behavior based on types of notifications authorized
68+ }];
69+ if (global_registerForRemoteNotifications) {
70+ [application registerForRemoteNotifications];
71+ }
72+ }
73+ callIO(global_didFinishLaunchingWithOptions);
74+ return YES;
75+}
76+
77+- (void)applicationWillResignActive:(UIApplication *)application {
78+ // Sent when the application is about to move from active to inactive state. This can occur for certain types of temporary interruptions (such as an incoming phone call or SMS message) or when the user quits the application and it begins the transition to the background state.
79+ // Use this method to pause ongoing tasks, disable timers, and invalidate graphics rendering callbacks. Games should use this method to pause the game.
80+ callIO(global_applicationWillResignActive);
81+}
82+
83+
84+- (void)applicationDidEnterBackground:(UIApplication *)application {
85+ // Use this method to release shared resources, save user data, invalidate timers, and store enough application state information to restore your application to its current state in case it is terminated later.
86+ // If your application supports background execution, this method is called instead of applicationWillTerminate: when the user quits.
87+ callIO(global_applicationDidEnterBackground);
88+}
89+
90+
91+- (void)applicationWillEnterForeground:(UIApplication *)application {
92+ // Called as part of the transition from the background to the active state; here you can undo many of the changes made on entering the background.
93+ callIO(global_applicationWillEnterForeground);
94+}
95+
96+
97+- (void)applicationDidBecomeActive:(UIApplication *)application {
98+ // Restart any tasks that were paused (or not yet started) while the application was inactive. If the application was previously in the background, optionally refresh the user interface.
99+ callIO(global_applicationDidBecomeActive);
100+}
101+
102+
103+- (void)applicationWillTerminate:(UIApplication *)application {
104+ // Called when the application is about to terminate. Save data if appropriate. See also applicationDidEnterBackground:.
105+ callIO(global_applicationWillTerminate);
106+}
107+
108+- (void)application:(UIApplication *)application didRegisterForRemoteNotificationsWithDeviceToken:(NSData *)deviceToken {
109+ // Tells the delegate that the app successfully registered with Apple Push Notification service (APNs).
110+ NSString *deviceTokenString = [deviceToken base64EncodedStringWithOptions: 0];
111+ callWithCString([deviceTokenString UTF8String], global_didRegisterForRemoteNotificationsWithDeviceToken);
112+}
113+
114+- (void)application:(UIApplication *)application didReceiveRemoteNotification:(NSDictionary *)userInfo fetchCompletionHandler:(void (^)(UIBackgroundFetchResult result))completionHandler {
115+ // Sent when the application receives remote notifications in the foreground or background
116+ // TODO Allow a configurable CString -> IO () to be passed into AppDelegateConfig
117+ if ([userInfo valueForKeyPath:@"aps.badge"] != nil) {
118+ [UIApplication sharedApplication].applicationIconBadgeNumber=[[[userInfo objectForKey:@"aps"] objectForKey:@"badge"] intValue];
119+ }
120+ NSError *error;
121+ NSData *jsonData = [NSJSONSerialization dataWithJSONObject:userInfo options:0 error:&error];
122+ if (jsonData) {
123+ NSString *jsonString = [[NSString alloc] initWithData:jsonData encoding:NSUTF8StringEncoding];
124+ callWithCIntCString((int) application.applicationState, [jsonString UTF8String], global_applicationDidReceiveRemoteNotification);
125+ } else {
126+ NSLog(@"jsaddle-wkwebview didReceiveRemoteNotification handler: error while serialising push notification as JSON");
127+ }
128+ completionHandler(UIBackgroundFetchResultNewData);
129+}
130+
131+- (void)application:(UIApplication *)application didFailToRegisterForRemoteNotificationsWithError:(NSError *)error {
132+ // Sent to the delegate when Apple Push Notification service cannot successfully complete the registration process.
133+ NSString *errorString = [error localizedDescription];
134+ callWithCString([errorString UTF8String], global_didFailToRegisterForRemoteNotificationsWithError);
135+}
136+
137+- (void)applicationSignificantTimeChange:(UIApplication *)application {
138+ // Tells the delegate when there is a significant change in the time.
139+ callIO(global_applicationSignificantTimeChange);
140+}
141+
142+- (BOOL)application:(UIApplication *)application continueUserActivity:(NSUserActivity *)userActivity restorationHandler:(void (^)(NSArray *restorableObjects))restorationHandler {
143+ // TODO: Reroute universal links when they're clicked in-app.
144+ // https://developer.apple.com/reference/webkit/wknavigationdelegate/1455643-webview?language=objc
145+ if ([userActivity.activityType isEqualToString:NSUserActivityTypeBrowsingWeb] && userActivity.webpageURL) {
146+ callWithCString([userActivity.webpageURL.absoluteString UTF8String], global_applicationUniversalLink);
147+ return YES;
148+ }
149+ return NO;
150+}
151+
152+@end
153+
154+void runInWKWebView(HsStablePtr handler,
155+ const char * _Nonnull progName,
156+ HsStablePtr hs_willFinishLaunchingWithOptions,
157+ HsStablePtr hs_didFinishLaunchingWithOptions,
158+ HsStablePtr hs_applicationDidBecomeActive,
159+ HsStablePtr hs_applicationWillResignActive,
160+ HsStablePtr hs_applicationDidEnterBackground,
161+ HsStablePtr hs_applicationWillEnterForeground,
162+ HsStablePtr hs_applicationWillTerminate,
163+ HsStablePtr hs_applicationSignificantTimeChange,
164+ HsStablePtr hs_applicationUniversalLink,
165+ HsStablePtr hs_applicationDidReceiveRemoteNotification,
166+ const uint64_t hs_requestAuthorizationWithOptions,
167+ const uint64_t hs_requestAuthorizationOptionBadge,
168+ const uint64_t hs_requestAuthorizationOptionSound,
169+ const uint64_t hs_requestAuthorizationOptionAlert,
170+ const uint64_t hs_requestAuthorizationOptionCarPlay,
171+ const uint64_t hs_registerForRemoteNotifications,
172+ HsStablePtr hs_didRegisterForRemoteNotificationsWithDeviceToken,
173+ HsStablePtr hs_didFailToRegisterForRemoteNotificationsWithError,
174+ const uint64_t hs_developerExtrasEnabled) {
175+ @autoreleasepool {
176+ globalHandler = handler;
177+ global_willFinishLaunchingWithOptions = hs_willFinishLaunchingWithOptions;
178+ global_didFinishLaunchingWithOptions = hs_didFinishLaunchingWithOptions;
179+ global_applicationDidBecomeActive = hs_applicationDidBecomeActive;
180+ global_applicationWillResignActive = hs_applicationWillResignActive;
181+ global_applicationDidEnterBackground = hs_applicationDidEnterBackground;
182+ global_applicationWillEnterForeground = hs_applicationWillEnterForeground;
183+ global_applicationWillTerminate = hs_applicationWillTerminate;
184+ global_applicationSignificantTimeChange = hs_applicationSignificantTimeChange;
185+ global_applicationUniversalLink = hs_applicationUniversalLink;
186+ global_applicationDidReceiveRemoteNotification = hs_applicationDidReceiveRemoteNotification;
187+ global_requestAuthorizationWithOptions = hs_requestAuthorizationWithOptions;
188+ global_requestAuthorizationOptionBadge = hs_requestAuthorizationOptionBadge;
189+ global_requestAuthorizationOptionSound = hs_requestAuthorizationOptionSound;
190+ global_requestAuthorizationOptionAlert = hs_requestAuthorizationOptionAlert;
191+ global_requestAuthorizationOptionCarPlay = hs_requestAuthorizationOptionCarPlay;
192+ global_registerForRemoteNotifications = hs_registerForRemoteNotifications;
193+ global_didRegisterForRemoteNotificationsWithDeviceToken = hs_didRegisterForRemoteNotificationsWithDeviceToken;
194+ global_didFailToRegisterForRemoteNotificationsWithError = hs_didFailToRegisterForRemoteNotificationsWithError;
195+ const char * _Nonnull argv [] = {"", 0};
196+ UIApplicationMain(0, argv, nil, NSStringFromClass([AppDelegate class]));
197+ }
198+}
199+
200+BOOL openApp(NSURL * url) {
201+ UIApplication *app = [UIApplication sharedApplication];
202+ if ([app canOpenURL:url]) {
203+ [app openURL:url];
204+ return true;
205+ }
206+ return false;
207+}
jsaddle-wkwebview/cbits-uikit/ViewController.hnew file+10
@@ -0,0 +1,10 @@
1+#include "HsFFI.h"
2+#import <UIKit/UIKit.h>
3+#import <WebKit/WebKit.h>
4+
5+@interface ViewController : UIViewController
6+@property (nonatomic, assign) HsStablePtr handler;
7+@property (nonatomic, assign) WKWebView *webView;
8+
9+- (instancetype)initWithHandler:(HsStablePtr)handler;
10+@end
jsaddle-wkwebview/cbits-uikit/ViewController.mnew file+40
@@ -0,0 +1,40 @@
1+#import "ViewController.h"
2+
3+extern void callWithWebView(WKWebView *, HsStablePtr);
4+
5+@interface ViewController ()
6+
7+@end
8+
9+@implementation ViewController
10+
11+-(id)initWithHandler:(HsStablePtr)handler {
12+ self = [super init];
13+ if (self) {
14+ _handler = handler;
15+ }
16+ return self;
17+}
18+
19+- (void)loadView {
20+ [super loadView];
21+ // WKWebViewConfiguration *theConfiguration = [[WKWebViewConfiguration alloc] init];
22+ // [theConfiguration.preferences setValue:@YES forKey:@"developerExtrasEnabled"];
23+ _webView = [[WKWebView alloc] init];
24+ _webView.autoresizingMask = UIViewAutoresizingFlexibleWidth | UIViewAutoresizingFlexibleHeight;
25+ self.view = _webView;
26+}
27+
28+- (void)viewDidLoad {
29+ [super viewDidLoad];
30+ callWithWebView(_webView, _handler);
31+}
32+
33+
34+- (void)didReceiveMemoryWarning {
35+ [super didReceiveMemoryWarning];
36+ // Dispose of any resources that can be recreated.
37+}
38+
39+
40+@end
jsaddle-wkwebview/cbits/WKWebView.m+79−10
@@ -2,26 +2,32 @@
22#import <Foundation/Foundation.h>
33#import <WebKit/WebKit.h>
44
5−extern void jsaddleStart(HsStablePtr);
6−extern void jsaddleResult(HsStablePtr, const char * _Nonnull result);
5+BOOL openApp(NSURL * url);
76
8−@interface JSaddleHandler : NSObject<WKNavigationDelegate, WKScriptMessageHandler>
7+@interface JSaddleHandler : NSObject<WKNavigationDelegate, WKScriptMessageHandler, WKUIDelegate>
98
109@property (nonatomic, assign) HsStablePtr startHandler;
1110@property (nonatomic, assign) HsStablePtr resultHandler;
11+@property (nonatomic, assign) HsStablePtr syncHandler;
12+@property (nonatomic, assign) void (^completionHandler)(NSString *result);
1213
13−- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler;
14+- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler syncHandler:(HsStablePtr)syncHandler;
1415
1516@end
1617
18+extern void jsaddleStart(HsStablePtr);
19+extern void jsaddleResult(HsStablePtr, const char * _Nonnull result);
20+extern void jsaddleSyncResult(HsStablePtr, JSaddleHandler *, const char * _Nonnull result);
21+
1722@implementation JSaddleHandler
1823
19−- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler
24+- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler syncHandler:(HsStablePtr)syncHandler
2025{
2126 self = [super init];
2227 if (self) {
2328 _startHandler = startHandler;
2429 _resultHandler = resultHandler;
30+ _syncHandler = syncHandler;
2531 }
2632 return self;
2733}
@@ -37,19 +43,82 @@ extern void jsaddleResult(HsStablePtr, const char * _Nonnull result);
3743 jsaddleResult(self.resultHandler, [s UTF8String]);
3844}
3945
46+- (void)webView:(WKWebView *)webView runJavaScriptTextInputPanelWithPrompt:(NSString *)prompt
47+ defaultText:(NSString *)defaultText initiatedByFrame:(WKFrameInfo *)frame completionHandler:(void (^)(NSString *result))completionHandler
48+{
49+ if([prompt isEqualToString:@"JSaddleSync"]) {
50+ _completionHandler = completionHandler;
51+ jsaddleSyncResult(self.syncHandler, self, [defaultText UTF8String]);
52+ }
53+ else {
54+ // TODO decide what if anything should go here
55+ }
56+}
57+
58+- (void)webView:(WKWebView *)webView decidePolicyForNavigationAction:(WKNavigationAction *)navigationAction decisionHandler:(void (^)(WKNavigationActionPolicy))decisionHandler
59+{
60+ NSURL *url = navigationAction.request.URL;
61+
62+ if(!navigationAction.targetFrame && ![url.scheme isEqualToString:@"file"]) {
63+ if(openApp(url))
64+ decisionHandler(WKNavigationActionPolicyCancel);
65+ else
66+ decisionHandler(WKNavigationActionPolicyAllow);
67+ }
68+ else
69+ decisionHandler(WKNavigationActionPolicyAllow);
70+}
71+
4072@end
4173
42−void addJSaddleHandler(WKWebView *webView, HsStablePtr startHandler, HsStablePtr resultHandler) {
43− JSaddleHandler * handler = [[JSaddleHandler alloc] initHandler:startHandler resultHandler:resultHandler];
74+void addJSaddleHandler(WKWebView *webView, HsStablePtr startHandler, HsStablePtr resultHandler, HsStablePtr syncHandler) {
75+ JSaddleHandler * handler = [[JSaddleHandler alloc] initHandler:startHandler resultHandler:resultHandler syncHandler:syncHandler];
4476 [[[webView configuration] userContentController] addScriptMessageHandler:handler name:@"jsaddle"];
77+#ifdef USE_UIKIT
78+ webView.scrollView.bounces = NO;
79+#endif
4580 webView.navigationDelegate = handler;
81+ webView.UIDelegate = handler;
4682}
4783
4884void evaluateJavaScript(WKWebView *webView, const char * _Nonnull js) {
49− [webView evaluateJavaScript:[NSString stringWithCString:js encoding:NSUTF8StringEncoding] completionHandler:NULL];
85+ NSString *jsString = [[NSString alloc] initWithCString:js encoding:NSUTF8StringEncoding];
86+ dispatch_async(dispatch_get_main_queue(), ^{
87+ [webView evaluateJavaScript:jsString completionHandler:NULL];
88+ [jsString release];
89+ });
90+}
91+
92+void completeSync(JSaddleHandler *handler, const char * _Nonnull s) {
93+ NSString *string = [[NSString alloc] initWithCString:s encoding:NSUTF8StringEncoding];
94+ handler.completionHandler(string);
95+ handler.completionHandler = NULL;
96+}
97+
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];
103+ });
50104}
51105
52−void loadHTMLString(WKWebView *webView, const char * _Nonnull html) {
53− [webView loadHTMLString:[NSString stringWithCString:html encoding:NSUTF8StringEncoding] baseURL:NULL];
106+const char * mainBundleResourcePathC() {
107+ NSBundle *main = [NSBundle mainBundle];
108+ if(!main) return NULL;
109+ NSString *path = main.resourcePath;
110+ if(!path) return NULL;
111+ return [path UTF8String];
54112}
55113
114+void loadBundleFile(WKWebView *webView, const char * _Nonnull file, const char * _Nonnull allowing) {
115+ NSBundle *main = [NSBundle mainBundle];
116+ if(main) {
117+ NSString *path = main.resourcePath;
118+ if(path) {
119+ NSURL *fileUrl = [NSURL fileURLWithPath:[NSString stringWithFormat: @"%@/%@", path, [NSString stringWithCString:file encoding:NSUTF8StringEncoding]]];
120+ NSURL *allowingUrl = [NSURL fileURLWithPath:[NSString stringWithFormat: @"%@/%@", path, [NSString stringWithCString:allowing encoding:NSUTF8StringEncoding]]];
121+ [webView loadFileURL:fileUrl allowingReadAccessToURL:allowingUrl];
122+ }
123+ }
124+}
jsaddle-wkwebview/default.nixnew file+14
@@ -0,0 +1,14 @@
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+39−7
@@ -1,5 +1,5 @@
11name: jsaddle-wkwebview
2−version: 0.7.0.0
2+version: 0.9.8.0
33cabal-version: >=1.10
44build-type: Simple
55license: MIT
@@ -14,6 +14,10 @@ description:
1414category: Web, Javascript
1515author: Hamish Mackenzie
1616
17+flag include-app-delegate
18+ description: Include default AppDelegate C sources.
19+ default: True
20+
1721source-repository head
1822 type: git
1923 location: https://github.com/ghcjs/jsaddle
@@ -22,12 +26,40 @@ library
2226 exposed-modules:
2327 Language.Javascript.JSaddle.WKWebView
2428 build-depends:
25− aeson >=0.8.0.2 && <1.1,
26− base <5,
27− bytestring >=0.10.6.0 && <0.11,
28− jsaddle >= 0.7.0.0 && <0.8
29+ base <5
2930 default-language: Haskell2010
3031 hs-source-dirs: src
3132 ghc-options: -ferror-spans -Wall
32− c-sources: cbits/WKWebView.m
33−
33+ if os(linux)
34+ buildable: False
35+ if impl(ghcjs)
36+ hs-source-dirs: src-ghcjs
37+ else
38+ frameworks: Foundation, WebKit
39+ build-depends:
40+ aeson >=0.8.0.2 && <1.6,
41+ bytestring >=0.10.6.0 && <0.11,
42+ directory,
43+ jsaddle >= 0.9.4.0 && <0.10,
44+ text,
45+ data-default,
46+ containers
47+ exposed-modules:
48+ Language.Javascript.JSaddle.WKWebView.Internal
49+ hs-source-dirs: src-ghc
50+ c-sources:
51+ cbits/WKWebView.m
52+ cc-options: -Wno-everything
53+ if os(ios)
54+ frameworks: UIKit, UserNotifications
55+ if flag(include-app-delegate)
56+ c-sources:
57+ cbits-uikit/AppDelegate.m
58+ cbits-uikit/ViewController.m
59+ cpp-options: -DUSE_UIKIT
60+ else
61+ frameworks: Cocoa
62+ if flag(include-app-delegate)
63+ c-sources:
64+ cbits-cocoa/AppDelegate.m
65+ cpp-options: -DUSE_COCOA
jsaddle-wkwebview/src-ghc/Language/Javascript/JSaddle/WKWebView.hsnew file+219
@@ -0,0 +1,219 @@
1+module Language.Javascript.JSaddle.WKWebView
2+ ( jsaddleMain
3+ , jsaddleMainHTMLWithBaseURL
4+ , jsaddleMainFile
5+ , WKWebView(..)
6+ , run
7+ , run'
8+ , runWithAppConfig
9+ , runHTMLWithBaseURL
10+ , runFile
11+ , mainBundleResourcePath
12+ , ApplicationState (..)
13+ , AppDelegateConfig (..)
14+ , AppDelegateNotificationConfig (..)
15+ , AuthorizationOption (..)
16+ ) where
17+
18+import Data.ByteString (ByteString)
19+import Data.Default (Default, def)
20+import Data.Set (Set)
21+import qualified Data.Set as Set
22+import Data.Word
23+import Foreign.Marshal.Utils (fromBool)
24+import Language.Javascript.JSaddle.WKWebView.Internal
25+ (jsaddleMain, jsaddleMainHTMLWithBaseURL, jsaddleMainFile, WKWebView(..), mainBundleResourcePath)
26+import System.Environment (getProgName)
27+import Foreign.C.String (CString, withCString)
28+import Foreign.C.Types (CBool, CInt)
29+import Foreign.StablePtr (StablePtr, newStablePtr)
30+import Language.Javascript.JSaddle (JSM)
31+
32+foreign import ccall runInWKWebView
33+ :: StablePtr (WKWebView -> IO ())
34+ -> CString
35+ -> StablePtr (IO ()) -- willFinishLaunchingWithOptions
36+ -> StablePtr (IO ()) -- didFinishLaunchingWithOptions
37+ -> StablePtr (IO ()) -- applicationDidBecomeActive
38+ -> StablePtr (IO ()) -- applicationWillResignActive
39+ -> StablePtr (IO ()) -- applicationDidEnterBackground
40+ -> StablePtr (IO ()) -- applicationWillEnterForeground
41+ -> StablePtr (IO ()) -- applicationWillTerminate
42+ -> StablePtr (IO ()) -- applicationSignificantTimeChange
43+ -> StablePtr (CString -> IO ()) -- applicationUniversalLink
44+ -> StablePtr (CInt -> CString -> IO ()) -- applicationDidReceiveRemoteNotification
45+ -> Word64 -- whether to run requestAuthorizationWithOptions
46+ -> Word64 -- Ask for Badge authorization
47+ -> Word64 -- Ask for Sound authorization
48+ -> Word64 -- Ask for Alert authorization
49+ -> Word64 -- Ask for CarPlay authorization
50+ -> Word64 -- registerForRemoteNotifications
51+ -> StablePtr (CString -> IO ()) -- didRegisterForRemoteNotificationsWithDeviceToken
52+ -> StablePtr (CString -> IO ()) -- didFailToRegisterForRemoteNotificationsWithError
53+ -> Word64 -- developerExtrasEnabled
54+ -> StablePtr (CString -> IO CBool) -- applicationOpenFile
55+ -> IO ()
56+
57+data AppDelegateConfig = AppDelegateConfig
58+ { _appDelegateConfig_willFinishLaunchingWithOptions :: IO ()
59+ , _appDelegateConfig_didFinishLaunchingWithOptions :: IO ()
60+ , _appDelegateConfig_applicationDidBecomeActive :: IO ()
61+ , _appDelegateConfig_applicationWillResignActive :: IO ()
62+ , _appDelegateConfig_applicationDidEnterBackground :: IO ()
63+ , _appDelegateConfig_applicationWillEnterForeground :: IO ()
64+ , _appDelegateConfig_applicationWillTerminate :: IO ()
65+ , _appDelegateConfig_applicationSignificantTimeChange :: IO ()
66+ , _appDelegateConfig_applicationUniversalLink :: CString -> IO ()
67+ -- ^ Called when the app is launched from a URL. 'CString' contains the URL.
68+ --
69+ -- The Core Foundation plist key CFBundleURLTypes controls which URL schemes
70+ -- the app should respond to.
71+ , _appDelegateConfig_applicationDidReceiveRemoteNotification :: ApplicationState -> CString -> IO ()
72+ -- ^ Called when the application receives a remote notification.
73+ -- 'ApplicationState' is the current state of the app.
74+ -- The 'CString' JSON-encoded user info contained in the notification.
75+ -- For more information see https://developer.apple.com/documentation/uikit/uiapplicationdelegate/1623117-application?language=objc
76+ , _appDelegateConfig_appDelegateNotificationConfig :: AppDelegateNotificationConfig
77+ , _appDelegateConfig_developerExtrasEnabled :: Bool
78+ -- ^ Allow devtools in the app. Defaults to 'True'
79+ , _appDelegateConfig_applicationOpenFile :: CString -> IO Bool
80+ -- ^ Called when the app is launched by opening a file. 'CString' contains
81+ -- the file path. Return value is 'True' if the file was successfully
82+ -- opened. Defaults to ignoring the file and returning 'False'.
83+ --
84+ -- The Core Foundation plist key CFBundleDocumentTypes controls which file
85+ -- types should be associated with the app.
86+ }
87+
88+instance Default AppDelegateConfig where
89+ def = AppDelegateConfig
90+ { _appDelegateConfig_willFinishLaunchingWithOptions = return ()
91+ , _appDelegateConfig_didFinishLaunchingWithOptions = return ()
92+ , _appDelegateConfig_applicationDidBecomeActive = return ()
93+ , _appDelegateConfig_applicationWillResignActive = return ()
94+ , _appDelegateConfig_applicationDidEnterBackground = return ()
95+ , _appDelegateConfig_applicationWillEnterForeground = return ()
96+ , _appDelegateConfig_applicationWillTerminate = return ()
97+ , _appDelegateConfig_applicationSignificantTimeChange = return ()
98+ , _appDelegateConfig_applicationUniversalLink = \_ -> return ()
99+ , _appDelegateConfig_applicationDidReceiveRemoteNotification = \_ _ -> return ()
100+ , _appDelegateConfig_appDelegateNotificationConfig = def
101+ , _appDelegateConfig_developerExtrasEnabled = True
102+ , _appDelegateConfig_applicationOpenFile = \_ -> return False
103+ }
104+
105+data AuthorizationOption = AuthorizationOption_Badge
106+ | AuthorizationOption_Sound
107+ | AuthorizationOption_Alert
108+ | AuthorizationOption_CarPlay
109+ deriving (Show, Read, Eq, Ord)
110+
111+data ApplicationState = ApplicationState_Active
112+ | ApplicationState_Inactive
113+ | ApplicationState_Background
114+ | ApplicationState_Unknown CInt
115+ deriving (Show, Read, Eq, Ord)
116+
117+data AppDelegateNotificationConfig = AppDelegateNotificationConfig
118+ { _appDelegateNotificationConfig_requestAuthorizationWithOptions :: Maybe (Set AuthorizationOption)
119+ , _appDelegateNotificationConfig_registerForRemoteNotifications :: Bool
120+ , _appDelegateNotificationConfig_didRegisterForRemoteNotificationsWithDeviceToken :: CString -> IO ()
121+ , _appDelegateNotificationConfig_didFailToRegisterForRemoteNotificationsWithError :: CString -> IO ()
122+ }
123+
124+instance Default AppDelegateNotificationConfig where
125+ def = AppDelegateNotificationConfig
126+ { _appDelegateNotificationConfig_requestAuthorizationWithOptions = Nothing
127+ , _appDelegateNotificationConfig_registerForRemoteNotifications = False
128+ , _appDelegateNotificationConfig_didRegisterForRemoteNotificationsWithDeviceToken = \_ -> return ()
129+ , _appDelegateNotificationConfig_didFailToRegisterForRemoteNotificationsWithError = \_ -> return ()
130+ }
131+
132+
133+-- | Run JSaddle in a WKWebView
134+run :: JSM () -> IO ()
135+run f = run' def (jsaddleMain f)
136+
137+-- | Run JSaddle in a WKWebView
138+runWithAppConfig :: AppDelegateConfig -> JSM () -> IO ()
139+runWithAppConfig cfg = run' cfg . jsaddleMain
140+
141+-- | Run JSaddle in a WKWebView first loading the specified file
142+-- from the mainBundle (relative to the resourcePath).
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 ())
164+ -> IO ()
165+run' cfg main = do
166+ handler <- newStablePtr main
167+ progName <- getProgName
168+
169+ -- AppDelegate callbacks
170+ willFinishLaunchingWithOptions <- newStablePtr $ _appDelegateConfig_willFinishLaunchingWithOptions cfg
171+ didFinishLaunchingWithOptions <- newStablePtr $ _appDelegateConfig_didFinishLaunchingWithOptions cfg
172+ applicationDidBecomeActive <- newStablePtr $ _appDelegateConfig_applicationDidBecomeActive cfg
173+ applicationWillResignActive <- newStablePtr $ _appDelegateConfig_applicationWillResignActive cfg
174+ applicationDidEnterBackground <- newStablePtr $ _appDelegateConfig_applicationDidEnterBackground cfg
175+ applicationWillEnterForeground <- newStablePtr $ _appDelegateConfig_applicationWillEnterForeground cfg
176+ applicationWillTerminate <- newStablePtr $ _appDelegateConfig_applicationWillTerminate cfg
177+ applicationSignificantTimeChange <- newStablePtr $ _appDelegateConfig_applicationSignificantTimeChange cfg
178+ applicationUniversalLink <- newStablePtr $ _appDelegateConfig_applicationUniversalLink cfg
179+ applicationDidReceiveRemoteNotification <- newStablePtr $ \n s -> do
180+ let appState = case n of
181+ 0 -> ApplicationState_Active
182+ 1 -> ApplicationState_Inactive
183+ 2 -> ApplicationState_Background
184+ _ -> ApplicationState_Unknown n
185+ _appDelegateConfig_applicationDidReceiveRemoteNotification cfg appState s
186+ applicationOpenFile <- newStablePtr $ fmap fromBool . _appDelegateConfig_applicationOpenFile cfg
187+
188+ -- AppDelegate notification configuration
189+ let ncfg = _appDelegateConfig_appDelegateNotificationConfig cfg
190+ (requestAuthorizationWithOptions, authorizationOptions) =
191+ case _appDelegateNotificationConfig_requestAuthorizationWithOptions ncfg of
192+ Nothing -> (False, Set.empty)
193+ Just opts -> (True, opts)
194+ registerForRemoteNotifications = _appDelegateNotificationConfig_registerForRemoteNotifications ncfg
195+ didRegisterForRemoteNotificationsWithDeviceToken <- newStablePtr $ _appDelegateNotificationConfig_didRegisterForRemoteNotificationsWithDeviceToken ncfg
196+ didFailToRegisterForRemoteNotificationsWithError <- newStablePtr $ _appDelegateNotificationConfig_didFailToRegisterForRemoteNotificationsWithError ncfg
197+ withCString progName $ \pn -> runInWKWebView
198+ handler
199+ pn
200+ willFinishLaunchingWithOptions
201+ didFinishLaunchingWithOptions
202+ applicationDidBecomeActive
203+ applicationWillResignActive
204+ applicationDidEnterBackground
205+ applicationWillEnterForeground
206+ applicationWillTerminate
207+ applicationSignificantTimeChange
208+ applicationUniversalLink
209+ applicationDidReceiveRemoteNotification
210+ (fromBool requestAuthorizationWithOptions)
211+ (fromBool $ Set.member AuthorizationOption_Badge authorizationOptions)
212+ (fromBool $ Set.member AuthorizationOption_Sound authorizationOptions)
213+ (fromBool $ Set.member AuthorizationOption_Alert authorizationOptions)
214+ (fromBool $ Set.member AuthorizationOption_CarPlay authorizationOptions)
215+ (fromBool registerForRemoteNotifications)
216+ didRegisterForRemoteNotificationsWithDeviceToken
217+ didFailToRegisterForRemoteNotificationsWithError
218+ (fromBool $ _appDelegateConfig_developerExtrasEnabled cfg)
219+ applicationOpenFile
jsaddle-wkwebview/src-ghcjs/Language/Javascript/JSaddle/WKWebView.hsnew file+7
@@ -0,0 +1,7 @@
1+module Language.Javascript.JSaddle.WKWebView
2+ ( run
3+ ) where
4+
5+run :: IO () -> IO ()
6+run = id
7+{-# INLINE run #-}
jsaddle-wkwebview/src/Language/Javascript/JSaddle/WKWebView.hsdeleted−76
@@ -1,76 +0,0 @@
1−{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}
2−module Language.Javascript.JSaddle.WKWebView
3− ( jsaddleMain
4− , WKWebView(..)
5− ) where
6−
7−import Control.Monad (void, join)
8−import Control.Concurrent (forkIO)
9−
10−import Data.Monoid ((<>))
11−import Data.ByteString (useAsCString, packCString)
12−import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)
13−import Data.Aeson (encode, decode)
14−
15−import Foreign.C.String (CString)
16−import Foreign.Ptr (Ptr)
17−import Foreign.StablePtr (StablePtr, newStablePtr, deRefStablePtr)
18−
19−import Language.Javascript.JSaddle (Result, JSM)
20−import Language.Javascript.JSaddle.Types (Batch(..))
21−import Language.Javascript.JSaddle.Run (runJavaScript)
22−import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
23−
24−newtype WKWebView = WKWebView (Ptr WKWebView)
25−
26−foreign export ccall jsaddleStart :: StablePtr (IO ()) -> IO ()
27−foreign export ccall jsaddleResult :: StablePtr (Result -> IO ()) -> CString -> IO ()
28−foreign import ccall addJSaddleHandler :: WKWebView -> StablePtr (IO ()) -> StablePtr (Result -> IO ()) -> IO ()
29−foreign import ccall loadHTMLString :: WKWebView -> CString -> IO ()
30−foreign import ccall evaluateJavaScript :: WKWebView -> CString -> IO ()
31−
32−jsaddleMain :: JSM () -> WKWebView -> IO ()
33−jsaddleMain f webView = do
34− (processResult, start) <- runJavaScript (\batch ->
35− useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");") $
36− evaluateJavaScript webView)
37− f
38−
39− startHandler <- newStablePtr (void $ forkIO start)
40− resultHandler <- newStablePtr processResult
41− addJSaddleHandler webView startHandler resultHandler
42−
43− useAsCString (toStrict indexHtml) $ loadHTMLString webView
44− useAsCString (toStrict jsaddleJs) $ evaluateJavaScript webView
45−
46−jsaddleStart :: StablePtr (IO ()) -> IO ()
47−jsaddleStart ptrHandler = join (deRefStablePtr ptrHandler)
48−
49−jsaddleResult :: StablePtr (Result -> IO ()) -> CString -> IO ()
50−jsaddleResult ptrHandler s = do
51− processResult <- deRefStablePtr ptrHandler
52− result <- packCString s
53− case decode (fromStrict result) of
54− Nothing -> error $ "jsaddle WebSocket decode failed : " <> show result
55− Just r -> processResult r
56−
57−jsaddleJs :: ByteString
58−jsaddleJs = ghcjsHelpers <> "\
59− \runJSaddleBatch = (function() {\n\
60− \ " <> initState <> "\n\
61− \ return function(batch) {\n\
62− \ " <> runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));") <> "\
63− \ };\n\
64− \})();\n\
65− \"
66−
67−indexHtml :: ByteString
68−indexHtml =
69− "<!DOCTYPE html>\n\
70− \<html>\n\
71− \<head>\n\
72− \<title>JSaddle</title>\n\
73− \</head>\n\
74− \<body>\n\
75− \</body>\n\
76− \</html>"
jsaddle-wkwebview/src/Language/Javascript/JSaddle/WKWebView/Internal.hsnew file+174
@@ -0,0 +1,174 @@
1+{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}
2+module Language.Javascript.JSaddle.WKWebView.Internal
3+ ( jsaddleMain
4+ , jsaddleMainHTMLWithBaseURL
5+ , jsaddleMainFile
6+ , WKWebView(..)
7+ , mainBundleResourcePath
8+ ) where
9+
10+import Control.Monad (void, join)
11+import Control.Concurrent (forkIO, forkOS)
12+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
13+
14+import Data.Monoid ((<>))
15+import Data.ByteString (useAsCString, packCString)
16+import qualified Data.ByteString as BS (ByteString)
17+import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)
18+import Data.Aeson (encode, decode)
19+import qualified Data.Text as T (pack)
20+import Data.Text.Encoding (encodeUtf8)
21+
22+import Foreign.C.String (CString)
23+import Foreign.C.Types (CBool(..), CInt(..))
24+import Foreign.Ptr (Ptr, nullPtr)
25+import Foreign.StablePtr (StablePtr, newStablePtr, deRefStablePtr)
26+
27+import Language.Javascript.JSaddle (Results, Batch, JSM)
28+import Language.Javascript.JSaddle.Run (runJavaScript)
29+import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
30+
31+import System.Directory (getCurrentDirectory)
32+
33+newtype WKWebView = WKWebView (Ptr WKWebView)
34+newtype JSaddleHandler = JSaddleHandler (Ptr JSaddleHandler)
35+
36+foreign export ccall jsaddleStart :: StablePtr (IO ()) -> IO ()
37+foreign export ccall jsaddleResult :: StablePtr (Results -> IO ()) -> CString -> IO ()
38+foreign export ccall jsaddleSyncResult :: StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()
39+foreign export ccall callWithWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()
40+foreign export ccall callWithCIntCString :: CInt -> CString -> StablePtr (CInt -> CString -> IO ()) -> IO ()
41+foreign export ccall callWithCString :: CString -> StablePtr (CString -> IO ()) -> IO ()
42+foreign export ccall callWithCStringReturningBool :: CString -> StablePtr (CString -> IO CBool) -> IO CBool
43+foreign export ccall callIO :: StablePtr (IO ()) -> IO ()
44+foreign import ccall addJSaddleHandler :: WKWebView -> StablePtr (IO ()) -> StablePtr (Results -> IO ()) -> StablePtr (Results -> IO Batch) -> IO ()
45+foreign import ccall loadHTMLStringWithBaseURL :: WKWebView -> CString -> CString -> IO ()
46+foreign import ccall loadBundleFile :: WKWebView -> CString -> CString -> IO ()
47+foreign import ccall evaluateJavaScript :: WKWebView -> CString -> IO ()
48+foreign import ccall completeSync :: JSaddleHandler -> CString -> IO ()
49+foreign import ccall mainBundleResourcePathC :: IO CString
50+
51+-- | Run JSaddle in WKWebView
52+jsaddleMain :: JSM () -> WKWebView -> IO ()
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 =
66+ jsaddleMain' f webView $
67+ useAsCString baseURL $ \url ->
68+ useAsCString initialHTML $ \html ->
69+ loadHTMLStringWithBaseURL webView html url
70+
71+-- | Run JSaddle in a WKWebView first loading the specified file
72+-- from the mainBundle (relative to the resourcePath).
73+jsaddleMainFile :: BS.ByteString -- ^ The file to navigate to.
74+ -> BS.ByteString -- ^ The path to allow read access to.
75+ -> JSM () -> WKWebView -> IO ()
76+jsaddleMainFile url allowing f webView =
77+ jsaddleMain' f webView $
78+ useAsCString url $ \u ->
79+ useAsCString allowing $ \a ->
80+ loadBundleFile webView u a
81+
82+jsaddleMain' :: JSM () -> WKWebView -> IO () -> IO ()
83+jsaddleMain' f webView loadHtml = do
84+ ready <- newEmptyMVar
85+
86+ (processResult, syncResult, start) <- runJavaScript (\batch ->
87+ useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");") $
88+ evaluateJavaScript webView)
89+ f
90+
91+ startHandler <- newStablePtr (putMVar ready ())
92+ resultHandler <- newStablePtr processResult
93+ syncResultHandler <- newStablePtr syncResult
94+ addJSaddleHandler webView startHandler resultHandler syncResultHandler
95+ loadHtml
96+ void . forkOS $ do
97+ takeMVar ready
98+ useAsCString (toStrict jsaddleJs) (evaluateJavaScript webView) >> void (forkIO start)
99+
100+jsaddleStart :: StablePtr (IO ()) -> IO ()
101+jsaddleStart ptrHandler = join (deRefStablePtr ptrHandler)
102+
103+jsaddleResult :: StablePtr (Results -> IO ()) -> CString -> IO ()
104+jsaddleResult ptrHandler s = do
105+ processResult <- deRefStablePtr ptrHandler
106+ result <- packCString s
107+ case decode (fromStrict result) of
108+ Nothing -> error $ "jsaddle Results decode failed : " <> show result
109+ Just r -> processResult r
110+
111+jsaddleSyncResult :: StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()
112+jsaddleSyncResult ptrHandler jsaddleHandler s = do
113+ syncProcessResult <- deRefStablePtr ptrHandler
114+ result <- packCString s
115+ case decode (fromStrict result) of
116+ Nothing -> error $ "jsaddle Results decode failed : " <> show result
117+ Just r -> do -- void . forkIO $ do
118+ batch <- syncProcessResult r
119+ useAsCString (toStrict $ encode batch) $
120+ completeSync jsaddleHandler
121+
122+callWithWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()
123+callWithWebView webView ptrF = do
124+ f <- deRefStablePtr ptrF
125+ f webView
126+
127+callWithCString :: CString -> StablePtr (CString -> IO ()) -> IO ()
128+callWithCString c fptr = do
129+ f <- deRefStablePtr fptr
130+ f c
131+
132+callWithCIntCString :: CInt -> CString -> StablePtr (CInt -> CString -> IO ()) -> IO ()
133+callWithCIntCString n s fptr = do
134+ f <- deRefStablePtr fptr
135+ f n s
136+
137+callWithCStringReturningBool :: CString -> StablePtr (CString -> IO CBool) -> IO CBool
138+callWithCStringReturningBool c fptr = do
139+ f <- deRefStablePtr fptr
140+ f c
141+
142+callIO :: StablePtr (IO ()) -> IO ()
143+callIO ptr = do
144+ f <- deRefStablePtr ptr
145+ f
146+
147+jsaddleJs :: ByteString
148+jsaddleJs = ghcjsHelpers <> "\
149+ \runJSaddleBatch = (function() {\n\
150+ \ " <> initState <> "\n\
151+ \ return function(batch) {\n\
152+ \ " <> runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));\n")
153+ (Just (\a -> "JSON.parse(window.prompt(\"JSaddleSync\", JSON.stringify(" <> a <> ")))")) <> "\
154+ \ };\n\
155+ \})();\n\
156+ \"
157+
158+indexHtml :: ByteString
159+indexHtml =
160+ "<!DOCTYPE html>\n\
161+ \<html>\n\
162+ \<head>\n\
163+ \<title>JSaddle</title>\n\
164+ \</head>\n\
165+ \<body>\n\
166+ \</body>\n\
167+ \</html>"
168+
169+mainBundleResourcePath :: IO (Maybe BS.ByteString)
170+mainBundleResourcePath = do
171+ bs <- mainBundleResourcePathC
172+ if bs == nullPtr
173+ then return Nothing
174+ else Just <$> packCString bs
jsaddle/jsaddle.cabal+61−16
@@ -1,5 +1,5 @@
11name: jsaddle
2−version: 0.7.1.0
2+version: 0.9.8.0
33cabal-version: >=1.10
44build-type: Simple
55license: MIT
@@ -10,13 +10,22 @@ 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
1717source-repository head
1818 type: git
1919 location: https://github.com/ghcjs/jsaddle
20+ subdir: jsaddle
21+
22+flag call-stacks
23+ description: Include HasCallStack constraint on calls unchecked calls
24+ default: False
25+
26+flag check-unchecked
27+ description: Fail unchecked calls when they are called (rather than when the result is evaluated)
28+ default: False
2029
2130library
2231
@@ -27,36 +36,67 @@ library
2736 else
2837 build-depends:
2938 attoparsec >=0.11 && <0.14,
30− containers >=0.5.6.2 && <0.6,
39+ containers >=0.5.6.2 && <0.7,
3140 deepseq >=1.3 && < 1.5,
3241 filepath >=1.4.0.0 && <1.5,
3342 ghc-prim,
34− http-types >=0.8.6 && <0.10,
35− 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,
3646 ref-tf >=0.4.0.1 && <0.5,
3747 scientific >=0.3 && <0.4,
38− stm >=2.4.4 && <2.5,
39− time >=1.5.0.1 && <1.7,
48+ stm >=2.4.4 && <2.6,
49+ time >=1.5.0.1 && <1.11,
4050 unordered-containers >=0.2 && <0.3,
41− vector >=0.10 && <0.12
51+ vector >=0.10 && <0.13,
52+ unliftio-core >=0.1 && < 0.3
4253 exposed-modules:
54+ Data.JSString
55+ Data.JSString.Internal
56+ Data.JSString.Internal.Fusion
57+ Data.JSString.Internal.Fusion.CaseMapping
58+ Data.JSString.Internal.Fusion.Common
59+ Data.JSString.Internal.Fusion.Types
60+ Data.JSString.Internal.Search
61+ Data.JSString.Internal.Type
62+ Data.JSString.Text
63+ GHCJS.Prim
64+ GHCJS.Prim.Internal
65+ GHCJS.Types
66+ GHCJS.Concurrent
67+ GHCJS.Foreign
68+ GHCJS.Foreign.Internal
69+ GHCJS.Internal.Types
4370 GHCJS.Marshal
4471 GHCJS.Marshal.Internal
4572 GHCJS.Marshal.Pure
73+ GHCJS.Buffer
74+ GHCJS.Buffer.Types
75+ JavaScript.TypedArray
76+ JavaScript.TypedArray.ArrayBuffer
77+ JavaScript.TypedArray.ArrayBuffer.Internal
78+ JavaScript.TypedArray.ArrayBuffer.Type
79+ JavaScript.TypedArray.DataView.Internal
80+ JavaScript.TypedArray.Immutable
81+ JavaScript.TypedArray.Internal
82+ JavaScript.TypedArray.Internal.Types
83+ JavaScript.Array
4684 JavaScript.Array.Internal
85+ JavaScript.Object
4786 JavaScript.Object.Internal
87+ Language.Javascript.JSaddle.Debug
4888 Language.Javascript.JSaddle.Native
4989 Language.Javascript.JSaddle.Native.Internal
90+ Language.Javascript.JSaddle.Null
5091 hs-source-dirs: src-ghc
5192 exposed-modules:
5293 Language.Javascript.JSaddle
53− Language.Javascript.JSaddle.Array
5494 Language.Javascript.JSaddle.Arguments
5595 Language.Javascript.JSaddle.Classes
5696 Language.Javascript.JSaddle.Classes.Internal
5797 Language.Javascript.JSaddle.Evaluate
5898 Language.Javascript.JSaddle.Exception
59− Language.Javascript.JSaddle.Foreign
99+ Language.Javascript.JSaddle.Helper
60100 Language.Javascript.JSaddle.Marshal.String
61101 Language.Javascript.JSaddle.Monad
62102 Language.Javascript.JSaddle.Object
@@ -67,15 +107,20 @@ library
67107 Language.Javascript.JSaddle.Value
68108 Language.Javascript.JSaddle.Types
69109 build-depends:
70− aeson >=0.8.0.2 && <1.1,
71− base <5,
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,
72114 bytestring >=0.10.6.0 && <0.11,
73− lens >=3.8.5 && <4.16,
74− 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,
75118 text >=1.2.1.3 && <1.3,
76119 transformers >=0.4.2.0 && <0.6
77120 default-language: Haskell2010
78121 hs-source-dirs: src
79122 ghc-options: -ferror-spans -Wall
80−
81−
123+ if flag(check-unchecked)
124+ cpp-options: -DCHECK_UNCHECKED
125+ if flag(call-stacks) || flag(check-unchecked)
126+ cpp-options: -DJSADDLE_HAS_CALL_STACK
jsaddle/src-ghc/Data/JSString.hsnew file+1404
@@ -0,0 +1,1404 @@
1+{-# LANGUAGE MagicHash, BangPatterns, UnboxedTuples, TypeFamilies
2+ #-}
3+{-# OPTIONS_GHC -fno-warn-orphans #-}
4+{-| Manipulation of JavaScript strings, API and fusion implementation
5+ based on Data.Text by Tom Harper, Duncan Coutts, Bryan O'Sullivan e.a.
6+ -}
7+module Data.JSString ( JSString
8+
9+ -- * Creation and elimination
10+ , pack
11+ , unpack, unpack'
12+ , singleton
13+ , empty
14+
15+ -- * Basic interface
16+ , cons
17+ , snoc
18+ , append
19+ , uncons
20+ , head
21+ , last
22+ , tail
23+ , init
24+ , null
25+ , length
26+ , compareLength
27+
28+ -- * Transformations
29+ , map
30+ , intercalate
31+ , intersperse
32+ , transpose
33+ , reverse
34+ , replace
35+
36+ -- ** Case conversion
37+ , toCaseFold
38+ , toLower
39+ , toUpper
40+ , toTitle
41+
42+ -- ** Justification
43+ , justifyLeft
44+ , justifyRight
45+ , center
46+
47+ -- * Folds
48+ , foldl
49+ , foldl'
50+ , foldl1
51+ , foldl1'
52+ , foldr
53+ , foldr1
54+
55+ -- ** Special folds
56+ , concat
57+ , concatMap
58+ , any
59+ , all
60+ , maximum
61+ , minimum
62+
63+ -- * Construction
64+
65+ -- ** Scans
66+ , scanl
67+ , scanl1
68+ , scanr
69+ , scanr1
70+
71+ -- ** Accumulating maps
72+ , mapAccumL
73+ , mapAccumR
74+
75+ -- ** Generation and unfolding
76+ , replicate
77+ , unfoldr
78+ , unfoldrN
79+
80+ -- * Substrings
81+
82+ -- ** Breaking strings
83+ , take
84+ , takeEnd
85+ , drop
86+ , dropEnd
87+ , takeWhile
88+ , dropWhile
89+ , dropWhileEnd
90+ , dropAround
91+ , strip
92+ , stripStart
93+ , stripEnd
94+ , splitAt
95+ , breakOn
96+ , breakOnEnd
97+ , break
98+ , span
99+ , group
100+ , group'
101+ , groupBy
102+ , inits
103+ , tails
104+
105+ -- ** Breaking into many substrings
106+ , splitOn, splitOn'
107+ , split
108+ , chunksOf, chunksOf'
109+
110+ -- ** Breaking into lines and words
111+ , lines, lines'
112+ , words, words'
113+ , unlines
114+ , unwords
115+
116+ -- * Predicates
117+ , isPrefixOf
118+ , isSuffixOf
119+ , isInfixOf
120+
121+ -- ** View patterns
122+ , stripPrefix
123+ , stripSuffix
124+ , commonPrefixes
125+
126+ -- * Searching
127+ , filter
128+ , breakOnAll, breakOnAll'
129+ , find
130+ , partition
131+
132+ -- * Indexing
133+ , index
134+ , findIndex
135+ , count
136+
137+ -- * Zipping
138+ , zip
139+ , zipWith
140+ ) where
141+
142+import Prelude
143+ ( Char, Bool(..), Int, Maybe(..), String, Eq(..), Ord(..), Ordering(..), (++)
144+ , Read(..), Show(..), (&&), (||), (+), (-), (.), ($), ($!), (>>)
145+ , not, seq, return, otherwise, quot)
146+import qualified Prelude as P
147+
148+import Control.DeepSeq (NFData(..))
149+import Data.Char (isSpace)
150+import Data.Coerce (coerce)
151+import qualified Data.List as L
152+import Data.Data
153+import qualified Data.Text as T
154+import qualified Data.Text.Internal.Fusion as TF
155+import qualified Data.Text.Internal.Fusion.Common as TF
156+
157+import GHC.Exts
158+ ( Int#, (+#), (-#), (>=#), (>#), isTrue#, chr#, Char(..)
159+ , Int(..), Addr#, tagToEnum#)
160+import qualified GHC.Exts as Exts
161+import qualified GHC.CString as GHC
162+
163+import Unsafe.Coerce
164+
165+import GHCJS.Prim (JSVal)
166+
167+import Data.JSString.Internal.Type
168+import Data.JSString.Internal.Fusion (stream, unstream)
169+import qualified Data.JSString.Internal.Fusion as S
170+import qualified Data.JSString.Internal.Fusion.Common as S
171+
172+instance Exts.IsList JSString where
173+ type Item JSString = Char
174+ fromList = pack
175+ toList = unpack
176+
177+-- -----------------------------------------------------------------------------
178+-- * Conversion to/from 'JSString'
179+
180+-- | /O(n)/ Convert a 'String' into a 'JSString'. Subject to
181+-- fusion.
182+pack :: String -> JSString
183+pack = coerce T.pack
184+{-# INLINE [1] pack #-}
185+
186+{-# RULES
187+"JSSTRING pack -> fused" [~1] forall x.
188+ pack x = unstream (S.map safe (S.streamList x))
189+"JSSTRING pack -> unfused" [1] forall x.
190+ unstream (S.map safe (S.streamList x)) = pack x
191+ #-}
192+
193+-- | /O(n)/ Convert a 'JSString' into a 'String'. Subject to fusion.
194+unpack :: JSString -> String
195+unpack = S.unstreamList . stream
196+{-# INLINE [1] unpack #-}
197+
198+unpack' :: JSString -> String
199+unpack' = coerce T.unpack
200+{-# INLINE unpack' #-}
201+
202+-- | /O(n)/ Convert a literal string into a JSString. Subject to fusion.
203+unpackCString# :: Addr# -> JSString
204+unpackCString# = coerce T.unpackCString#
205+{-# NOINLINE unpackCString# #-}
206+
207+{-# RULES "JSSTRING literal" forall a.
208+ unstream (S.map safe (S.streamList (GHC.unpackCString# a)))
209+ = unpackCString# a #-}
210+
211+{-# RULES "JSSTRING literal UTF8" forall a.
212+ unstream (S.map safe (S.streamList (GHC.unpackCStringUtf8# a)))
213+ = unpackCString# a #-}
214+
215+{-# RULES "JSSTRING empty literal"
216+ unstream (S.map safe (S.streamList []))
217+ = empty_ #-}
218+
219+{-# RULES "JSSTRING singleton literal" forall a.
220+ unstream (S.map safe (S.streamList [a]))
221+ = singleton a #-}
222+
223+
224+-- | /O(1)/ Convert a character into a 'JSString'. Subject to fusion.
225+-- Performs replacement on invalid scalar values.
226+singleton :: Char -> JSString
227+singleton = coerce T.singleton
228+{-# INLINE [1] singleton #-}
229+
230+{-# RULES
231+"JSSTRING singleton -> fused" [~1] forall a.
232+ singleton a = unstream (S.singleton (safe a))
233+"JSSTRING singleton -> unfused" [1] forall a.
234+ unstream (S.singleton (safe a)) = singleton a
235+ #-}
236+
237+-- This is intended to reduce inlining bloat.
238+-- singleton_ :: Char -> Text
239+-- singleton_ c = js_singleton c
240+
241+-- Text (A.run x) 0 len
242+-- where x :: ST s (A.MArray s)
243+-- x = do arr <- A.new len
244+-- _ <- unsafeWrite arr 0 d
245+-- return arr
246+-- len | d < '\x10000' = 1
247+-- x | otherwise = 2
248+-- d = safe c
249+-- {-# NOINLINE singleton_ #-}
250+
251+-- -----------------------------------------------------------------------------
252+-- * Basic functions
253+
254+-- | /O(n)/ Adds a character to the front of a 'JSString'. This function
255+-- is more costly than its 'List' counterpart because it requires
256+-- copying a new array. Subject to fusion. Performs replacement on
257+-- invalid scalar values.
258+cons :: Char -> JSString -> JSString
259+cons = coerce T.cons
260+{-# INLINE [1] cons #-}
261+
262+{-# RULES
263+"JSSTRING cons -> fused" [~1] forall c x.
264+ cons c x = unstream (S.cons (safe c) (stream x))
265+"JSSTRING cons -> unfused" [1] forall c x.
266+ unstream (S.cons (safe c) (stream x)) = cons c x
267+ #-}
268+
269+infixr 5 `cons`
270+
271+-- | /O(n)/ Adds a character to the end of a 'JSString'. This copies the
272+-- entire array in the process, unless fused. Subject to fusion.
273+-- Performs replacement on invalid scalar values.
274+snoc :: JSString -> Char -> JSString
275+snoc = coerce T.snoc
276+ -- unstream (S.snoc (stream t) (safe c))
277+{-# INLINE [1] snoc #-}
278+
279+{-# RULES
280+"JSSTRING snoc -> fused" [~1] forall x c.
281+ snoc x c = unstream (S.snoc (stream x) (safe c))
282+"JSSTRING snoc -> unfused" [1] forall x c.
283+ unstream (S.snoc (stream x) (safe c)) = snoc x c
284+ #-}
285+
286+-- | /O(n)/ Appends one 'JSString' to the other by copying both of them
287+-- into a new 'JSString'. Subject to fusion.
288+append :: JSString -> JSString -> JSString
289+append = coerce T.append
290+{-# INLINE [1] append #-}
291+
292+{-# RULES
293+"JSSTRING append -> fused" [~1] forall x1 x2.
294+ append x1 x2 = unstream (S.append (stream x1) (stream x2))
295+"JSSTRING append -> unfused" [1] forall x1 x2.
296+ unstream (S.append (stream x1) (stream x2)) = append x1 x2
297+ #-}
298+
299+-- | /O(1)/ Returns the first character of a 'JSString', which must be
300+-- non-empty. Subject to fusion.
301+head :: JSString -> Char
302+head = coerce T.head
303+{-# INLINE [1] head #-}
304+
305+{-# RULES
306+"JSSTRING head -> fused" [~1] forall x.
307+ head x = S.head (stream x)
308+"JSSTRING head -> unfused" [1] forall x.
309+ S.head (stream x) = head x
310+ #-}
311+
312+
313+-- | /O(1)/ Returns the first character and rest of a 'JSString', or
314+-- 'Nothing' if empty. Subject to fusion.
315+uncons :: JSString -> Maybe (Char, JSString)
316+uncons = coerce T.uncons
317+{-# INLINE [1] uncons #-}
318+
319+-- | Lifted from Control.Arrow and specialized.
320+second :: (b -> c) -> (a,b) -> (a,c)
321+second f (a, b) = (a, f b)
322+
323+-- | /O(1)/ Returns the last character of a 'JSString', which must be
324+-- non-empty. Subject to fusion.
325+last :: JSString -> Char
326+last = coerce T.last
327+{-# INLINE [1] last #-}
328+
329+{-# RULES
330+"JSSTRING last -> fused" [~1] forall x.
331+ last x = S.last (stream x)
332+"JSSTRING last -> unfused" [1] forall x.
333+ S.last (stream x) = last x
334+ #-}
335+
336+-- | /O(1)/ Returns all characters after the head of a 'JSString', which
337+-- must be non-empty. Subject to fusion.
338+tail :: JSString -> JSString
339+tail = coerce T.tail
340+{-# INLINE [1] tail #-}
341+
342+{-# RULES
343+"JSSTRING tail -> fused" [~1] forall x.
344+ tail x = unstream (S.tail (stream x))
345+"JSSTRING tail -> unfused" [1] forall x.
346+ unstream (S.tail (stream x)) = tail x
347+ #-}
348+
349+-- | /O(1)/ Returns all but the last character of a 'JSString', which must
350+-- be non-empty. Subject to fusion.
351+init :: JSString -> JSString
352+init = coerce T.init
353+{-# INLINE [1] init #-}
354+
355+{-# RULES
356+"JSSTRING init -> fused" [~1] forall t.
357+ init t = unstream (S.init (stream t))
358+"JSSTRING init -> unfused" [1] forall t.
359+ unstream (S.init (stream t)) = init t
360+ #-}
361+
362+-- | /O(1)/ Tests whether a 'JSString' is empty or not. Subject to
363+-- fusion.
364+null :: JSString -> Bool
365+null = coerce T.null
366+{-# INLINE [1] null #-}
367+
368+{-# RULES
369+"JSSTRING null -> fused" [~1] forall t.
370+ null t = S.null (stream t)
371+"JSSTRING null -> unfused" [1] forall t.
372+ S.null (stream t) = null t
373+ #-}
374+
375+-- | /O(n)/ Returns the number of characters in a 'JSString'.
376+-- Subject to fusion.
377+length :: JSString -> Int
378+length = coerce T.length
379+{-# INLINE [1] length #-}
380+
381+{-# RULES
382+"JSSTRING length -> fused" [~1] forall x.
383+ length x = S.length (stream x)
384+"JSSTRING length -> unfused" [1] forall x.
385+ S.length (stream x) = length x
386+ #-}
387+
388+-- | /O(n)/ Compare the count of characters in a 'JSString' to a number.
389+-- Subject to fusion.
390+--
391+-- This function gives the same answer as comparing against the result
392+-- of 'length', but can short circuit if the count of characters is
393+-- greater than the number, and hence be more efficient.
394+compareLength :: JSString -> Int -> Ordering
395+compareLength = coerce T.compareLength
396+{-# INLINE [1] compareLength #-}
397+
398+{-# RULES
399+"JSSTRING compareN/length -> compareLength" [~1] forall t n.
400+ compare (length t) n = compareLength t n
401+ #-}
402+
403+{-# RULES
404+"JSSTRING ==N/length -> compareLength/==EQ" [~1] forall t n.
405+ (==) (length t) n = compareLength t n == EQ
406+ #-}
407+
408+{-# RULES
409+"JSSTRING /=N/length -> compareLength//=EQ" [~1] forall t n.
410+ (/=) (length t) n = compareLength t n /= EQ
411+ #-}
412+
413+{-# RULES
414+"JSSTRING <N/length -> compareLength/==LT" [~1] forall t n.
415+ (<) (length t) n = compareLength t n == LT
416+ #-}
417+
418+{-# RULES
419+"JSSTRING <=N/length -> compareLength//=GT" [~1] forall t n.
420+ (<=) (length t) n = compareLength t n /= GT
421+ #-}
422+
423+{-# RULES
424+"JSSTRING >N/length -> compareLength/==GT" [~1] forall t n.
425+ (>) (length t) n = compareLength t n == GT
426+ #-}
427+
428+{-# RULES
429+"JSSTRING >=N/length -> compareLength//=LT" [~1] forall t n.
430+ (>=) (length t) n = compareLength t n /= LT
431+ #-}
432+
433+-- -----------------------------------------------------------------------------
434+-- * Transformations
435+-- | /O(n)/ 'map' @f@ @t@ is the 'JSString' obtained by applying @f@ to
436+-- each element of @t@. Subject to fusion. Performs replacement on
437+-- invalid scalar values.
438+map :: (Char -> Char) -> JSString -> JSString
439+map = coerce T.map
440+{-# INLINE [1] map #-}
441+
442+-- | /O(n)/ The 'intercalate' function takes a 'JSString' and a list of
443+-- 'JSString's and concatenates the list after interspersing the first
444+-- argument between each element of the list.
445+intercalate :: JSString -> [JSString] -> JSString
446+intercalate = coerce T.intercalate
447+{-# INLINE [1] intercalate #-}
448+
449+-- | /O(n)/ The 'intersperse' function takes a character and places it
450+-- between the characters of a 'JSString'. Subject to fusion. Performs
451+-- replacement on invalid scalar values.
452+intersperse :: Char -> JSString -> JSString
453+intersperse = coerce T.intersperse
454+{-# INLINE [1] intersperse #-}
455+
456+{-# RULES
457+"JSSTRING intersperse -> fused" [~1] forall c x.
458+ intersperse c x = unstream (S.intersperse (safe c) (stream x))
459+"JSSTRING intersperse -> unfused" [1] forall c x.
460+ unstream (S.intersperse (safe c) (stream x)) = intersperse c x
461+ #-}
462+
463+-- | /O(n)/ Reverse the characters of a string. Subject to fusion.
464+reverse :: JSString -> JSString
465+reverse = coerce T.reverse
466+{-# INLINE [1] reverse #-}
467+
468+{-# RULES
469+"JSSTRING reverse -> fused" [~1] forall x.
470+ reverse x = S.reverse (stream x)
471+"JSSTRING reverse -> unfused" [1] forall x.
472+ S.reverse (stream x) = reverse x
473+ #-}
474+
475+-- | /O(m+n)/ Replace every non-overlapping occurrence of @needle@ in
476+-- @haystack@ with @replacement@.
477+--
478+-- This function behaves as though it was defined as follows:
479+--
480+-- @
481+-- replace needle replacement haystack =
482+-- 'intercalate' replacement ('splitOn' needle haystack)
483+-- @
484+--
485+-- As this suggests, each occurrence is replaced exactly once. So if
486+-- @needle@ occurs in @replacement@, that occurrence will /not/ itself
487+-- be replaced recursively:
488+--
489+-- > replace "oo" "foo" "oo" == "foo"
490+--
491+-- In cases where several instances of @needle@ overlap, only the
492+-- first one will be replaced:
493+--
494+-- > replace "ofo" "bar" "ofofo" == "barfo"
495+--
496+-- In (unlikely) bad cases, this function's time complexity degrades
497+-- towards /O(n*m)/.
498+replace :: JSString
499+ -- ^ @needle@ to search for. If this string is empty, an
500+ -- error will occur.
501+ -> JSString
502+ -- ^ @replacement@ to replace @needle@ with.
503+ -> JSString
504+ -- ^ @haystack@ in which to search.
505+ -> JSString
506+replace = coerce T.replace
507+{-# INLINE replace #-}
508+
509+-- ----------------------------------------------------------------------------
510+-- ** Case conversions (folds)
511+
512+-- $case
513+--
514+-- When case converting 'JSString' values, do not use combinators like
515+-- @map toUpper@ to case convert each character of a string
516+-- individually, as this gives incorrect results according to the
517+-- rules of some writing systems. The whole-string case conversion
518+-- functions from this module, such as @toUpper@, obey the correct
519+-- case conversion rules. As a result, these functions may map one
520+-- input character to two or three output characters. For examples,
521+-- see the documentation of each function.
522+--
523+-- /Note/: In some languages, case conversion is a locale- and
524+-- context-dependent operation. The case conversion functions in this
525+-- module are /not/ locale sensitive. Programs that require locale
526+-- sensitivity should use appropriate versions of the
527+-- <http://hackage.haskell.org/package/text-icu-0.6.3.7/docs/Data-Text-ICU.html#g:4 case mapping functions from the text-icu package >.
528+
529+-- | /O(n)/ Convert a string to folded case. Subject to fusion.
530+--
531+-- This function is mainly useful for performing caseless (also known
532+-- as case insensitive) string comparisons.
533+--
534+-- A string @x@ is a caseless match for a string @y@ if and only if:
535+--
536+-- @toCaseFold x == toCaseFold y@
537+--
538+-- The result string may be longer than the input string, and may
539+-- differ from applying 'toLower' to the input string. For instance,
540+-- the Armenian small ligature \"&#xfb13;\" (men now, U+FB13) is case
541+-- folded to the sequence \"&#x574;\" (men, U+0574) followed by
542+-- \"&#x576;\" (now, U+0576), while the Greek \"&#xb5;\" (micro sign,
543+-- U+00B5) is case folded to \"&#x3bc;\" (small letter mu, U+03BC)
544+-- instead of itself.
545+toCaseFold :: JSString -> JSString
546+toCaseFold = coerce T.toCaseFold
547+{-# INLINE [0] toCaseFold #-}
548+
549+-- | /O(n)/ Convert a string to lower case, using simple case
550+-- conversion. Subject to fusion.
551+--
552+-- The result string may be longer than the input string. For
553+-- instance, \"&#x130;\" (Latin capital letter I with dot above,
554+-- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069)
555+-- followed by \" &#x307;\" (combining dot above, U+0307).
556+toLower :: JSString -> JSString
557+toLower = coerce T.toLower
558+{-# INLINE [1] toLower #-}
559+
560+{-# RULES
561+"JSSTRING toLower -> fused" [~1] forall x.
562+ toLower x = unstream (S.toLower (stream x))
563+"JSSTRING toLower -> unfused" [1] forall x.
564+ unstream (S.toLower (stream x)) = toLower x
565+ #-}
566+
567+-- | /O(n)/ Convert a string to upper case, using simple case
568+-- conversion. Subject to fusion.
569+--
570+-- The result string may be longer than the input string. For
571+-- instance, the German \"&#xdf;\" (eszett, U+00DF) maps to the
572+-- two-letter sequence \"SS\".
573+toUpper :: JSString -> JSString
574+toUpper = coerce T.toUpper
575+{-# INLINE [1] toUpper #-}
576+
577+{-# RULES
578+"JSSTRING toUpper -> fused" [~1] forall x.
579+ toUpper x = unstream (S.toUpper(stream x))
580+"JSSTRING toUpper -> unfused" [1] forall x.
581+ unstream (S.toUpper (stream x)) = toUpper x
582+ #-}
583+
584+-- | /O(n)/ Convert a string to title case, using simple case
585+-- conversion. Subject to fusion.
586+--
587+-- The first letter of the input is converted to title case, as is
588+-- every subsequent letter that immediately follows a non-letter.
589+-- Every letter that immediately follows another letter is converted
590+-- to lower case.
591+--
592+-- The result string may be longer than the input string. For example,
593+-- the Latin small ligature &#xfb02; (U+FB02) is converted to the
594+-- sequence Latin capital letter F (U+0046) followed by Latin small
595+-- letter l (U+006C).
596+--
597+-- /Note/: this function does not take language or culture specific
598+-- rules into account. For instance, in English, different style
599+-- guides disagree on whether the book name \"The Hill of the Red
600+-- Fox\" is correctly title cased&#x2014;but this function will
601+-- capitalize /every/ word.
602+toTitle :: JSString -> JSString
603+toTitle = coerce T.toTitle
604+{-# INLINE toTitle #-}
605+
606+-- | /O(n)/ Left-justify a string to the given length, using the
607+-- specified fill character on the right. Subject to fusion.
608+-- Performs replacement on invalid scalar values.
609+--
610+-- Examples:
611+--
612+-- > justifyLeft 7 'x' "foo" == "fooxxxx"
613+-- > justifyLeft 3 'x' "foobar" == "foobar"
614+justifyLeft :: Int -> Char -> JSString -> JSString
615+justifyLeft = coerce T.justifyLeft
616+{-# INLINE [1] justifyLeft #-}
617+
618+{-# RULES
619+"JSSTRING justifyLeft -> fused" [~1] forall k c t.
620+ justifyLeft k c t = unstream (S.justifyLeftI k c (stream t))
621+"JSSTRING justifyLeft -> unfused" [1] forall k c t.
622+ unstream (S.justifyLeftI k c (stream t)) = justifyLeft k c t
623+ #-}
624+
625+-- | /O(n)/ Right-justify a string to the given length, using the
626+-- specified fill character on the left. Performs replacement on
627+-- invalid scalar values.
628+--
629+-- Examples:
630+--
631+-- > justifyRight 7 'x' "bar" == "xxxxbar"
632+-- > justifyRight 3 'x' "foobar" == "foobar"
633+justifyRight :: Int -> Char -> JSString -> JSString
634+justifyRight = coerce T.justifyRight
635+{-# INLINE justifyRight #-}
636+
637+-- | /O(n)/ Center a string to the given length, using the specified
638+-- fill character on either side. Performs replacement on invalid
639+-- scalar values.
640+--
641+-- Examples:
642+--
643+-- > center 8 'x' "HS" = "xxxHSxxx"
644+center :: Int -> Char -> JSString -> JSString
645+center = coerce T.center
646+{-# INLINE center #-}
647+
648+-- | /O(n)/ The 'transpose' function transposes the rows and columns
649+-- of its 'JSString' argument. Note that this function uses 'pack',
650+-- 'unpack', and the list version of transpose, and is thus not very
651+-- efficient.
652+transpose :: [JSString] -> [JSString]
653+transpose = coerce T.transpose
654+
655+-- -----------------------------------------------------------------------------
656+-- * Reducing 'JSString's (folds)
657+
658+-- | /O(n)/ 'foldl', applied to a binary operator, a starting value
659+-- (typically the left-identity of the operator), and a 'JSString',
660+-- reduces the 'JSString' using the binary operator, from left to right.
661+-- Subject to fusion.
662+foldl :: (a -> Char -> a) -> a -> JSString -> a
663+foldl f = coerce (T.foldl f)
664+{-# INLINE foldl #-}
665+
666+-- | /O(n)/ A strict version of 'foldl'. Subject to fusion.
667+foldl' :: (a -> Char -> a) -> a -> JSString -> a
668+foldl' f = coerce (T.foldl' f)
669+{-# INLINE foldl' #-}
670+
671+-- | /O(n)/ A variant of 'foldl' that has no starting value argument,
672+-- and thus must be applied to a non-empty 'JSString'. Subject to fusion.
673+foldl1 :: (Char -> Char -> Char) -> JSString -> Char
674+foldl1 = coerce T.foldl1
675+{-# INLINE foldl1 #-}
676+
677+-- | /O(n)/ A strict version of 'foldl1'. Subject to fusion.
678+foldl1' :: (Char -> Char -> Char) -> JSString -> Char
679+foldl1' = coerce T.foldl1'
680+{-# INLINE foldl1' #-}
681+
682+-- | /O(n)/ 'foldr', applied to a binary operator, a starting value
683+-- (typically the right-identity of the operator), and a 'JSString',
684+-- reduces the 'JSString' using the binary operator, from right to left.
685+-- Subject to fusion.
686+foldr :: (Char -> a -> a) -> a -> JSString -> a
687+foldr f = coerce (T.foldr f)
688+{-# INLINE foldr #-}
689+
690+-- | /O(n)/ A variant of 'foldr' that has no starting value argument,
691+-- and thus must be applied to a non-empty 'JSString'. Subject to
692+-- fusion.
693+foldr1 :: (Char -> Char -> Char) -> JSString -> Char
694+foldr1 = coerce T.foldr1
695+{-# INLINE foldr1 #-}
696+
697+-- -----------------------------------------------------------------------------
698+-- ** Special folds
699+
700+-- | /O(n)/ Concatenate a list of 'JSString's.
701+concat :: [JSString] -> JSString
702+concat = coerce T.concat
703+
704+-- | /O(n)/ Map a function over a 'JSString' that results in a 'JSString', and
705+-- concatenate the results.
706+concatMap :: (Char -> JSString) -> JSString -> JSString
707+concatMap = coerce T.concatMap
708+{-# INLINE concatMap #-}
709+
710+-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the
711+-- 'JSString' @t@ satisifes the predicate @p@. Subject to fusion.
712+any :: (Char -> Bool) -> JSString -> Bool
713+any = coerce T.any
714+{-# INLINE any #-}
715+
716+-- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the
717+-- 'JSString' @t@ satisify the predicate @p@. Subject to fusion.
718+all :: (Char -> Bool) -> JSString -> Bool
719+all = coerce T.all
720+{-# INLINE all #-}
721+
722+-- | /O(n)/ 'maximum' returns the maximum value from a 'JSString', which
723+-- must be non-empty. Subject to fusion.
724+maximum :: JSString -> Char
725+maximum = coerce T.maximum
726+{-# INLINE maximum #-}
727+
728+-- | /O(n)/ 'minimum' returns the minimum value from a 'JSString', which
729+-- must be non-empty. Subject to fusion.
730+minimum :: JSString -> Char
731+minimum = coerce T.minimum
732+{-# INLINE minimum #-}
733+
734+-- -----------------------------------------------------------------------------
735+-- * Building 'JSString's
736+
737+-- | /O(n)/ 'scanl' is similar to 'foldl', but returns a list of
738+-- successive reduced values from the left. Subject to fusion.
739+-- Performs replacement on invalid scalar values.
740+--
741+-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
742+--
743+-- Note that
744+--
745+-- > last (scanl f z xs) == foldl f z xs.
746+scanl :: (Char -> Char -> Char) -> Char -> JSString -> JSString
747+scanl = coerce T.scanl
748+{-# INLINE scanl #-}
749+
750+-- | /O(n)/ 'scanl1' is a variant of 'scanl' that has no starting
751+-- value argument. Subject to fusion. Performs replacement on
752+-- invalid scalar values.
753+--
754+-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
755+scanl1 :: (Char -> Char -> Char) -> JSString -> JSString
756+scanl1 = coerce T.scanl1
757+{-# INLINE scanl1 #-}
758+
759+-- | /O(n)/ 'scanr' is the right-to-left dual of 'scanl'. Performs
760+-- replacement on invalid scalar values.
761+--
762+-- > scanr f v == reverse . scanl (flip f) v . reverse
763+scanr :: (Char -> Char -> Char) -> Char -> JSString -> JSString
764+scanr = coerce T.scanr
765+{-# INLINE scanr #-}
766+
767+-- | /O(n)/ 'scanr1' is a variant of 'scanr' that has no starting
768+-- value argument. Subject to fusion. Performs replacement on
769+-- invalid scalar values.
770+scanr1 :: (Char -> Char -> Char) -> JSString -> JSString
771+scanr1 = coerce T.scanr1
772+{-# INLINE scanr1 #-}
773+
774+-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a
775+-- function to each element of a 'JSString', passing an accumulating
776+-- parameter from left to right, and returns a final 'JSString'. Performs
777+-- replacement on invalid scalar values.
778+mapAccumL :: (a -> Char -> (a,Char)) -> a -> JSString -> (a, JSString)
779+mapAccumL f = coerce (T.mapAccumL f)
780+{-# INLINE mapAccumL #-}
781+
782+-- | The 'mapAccumR' function behaves like a combination of 'map' and
783+-- a strict 'foldr'; it applies a function to each element of a
784+-- 'JSString', passing an accumulating parameter from right to left, and
785+-- returning a final value of this accumulator together with the new
786+-- 'JSString'.
787+-- Performs replacement on invalid scalar values.
788+mapAccumR :: (a -> Char -> (a,Char)) -> a -> JSString -> (a, JSString)
789+mapAccumR f = coerce (T.mapAccumR f)
790+{-# INLINE mapAccumR #-}
791+
792+-- -----------------------------------------------------------------------------
793+-- ** Generating and unfolding 'JSString's
794+
795+-- | /O(n*m)/ 'replicate' @n@ @t@ is a 'JSString' consisting of the input
796+-- @t@ repeated @n@ times.
797+replicate :: Int -> JSString -> JSString
798+replicate = coerce T.replicate
799+{-# INLINE [1] replicate #-}
800+
801+-- | /O(n)/, where @n@ is the length of the result. The 'unfoldr'
802+-- function is analogous to the List 'L.unfoldr'. 'unfoldr' builds a
803+-- 'JSString' from a seed value. The function takes the element and
804+-- returns 'Nothing' if it is done producing the 'JSString', otherwise
805+-- 'Just' @(a,b)@. In this case, @a@ is the next 'Char' in the
806+-- string, and @b@ is the seed value for further production. Subject
807+-- to fusion. Performs replacement on invalid scalar values.
808+unfoldr :: (a -> Maybe (Char,a)) -> a -> JSString
809+unfoldr f = coerce (T.unfoldr f)
810+{-# INLINE unfoldr #-}
811+
812+-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a 'JSString' from a seed
813+-- value. However, the length of the result should be limited by the
814+-- first argument to 'unfoldrN'. This function is more efficient than
815+-- 'unfoldr' when the maximum length of the result is known and
816+-- correct, otherwise its performance is similar to 'unfoldr'. Subject
817+-- to fusion. Performs replacement on invalid scalar values.
818+unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> JSString
819+unfoldrN n f = coerce (T.unfoldrN n f)
820+{-# INLINE unfoldrN #-}
821+
822+-- -----------------------------------------------------------------------------
823+-- * Substrings
824+
825+-- | /O(n)/ 'take' @n@, applied to a 'JSString', returns the prefix of the
826+-- 'JSString' of length @n@, or the 'JSString' itself if @n@ is greater than
827+-- the length of the JSString. Subject to fusion.
828+take :: Int -> JSString -> JSString
829+take = coerce T.take
830+{-# INLINE [1] take #-}
831+{-
832+iterN :: Int -> JSString -> Int
833+iterN n t@(Text _arr _off len) = loop 0 0
834+ where loop !i !cnt
835+ | i >= len || cnt >= n = i
836+ | otherwise = loop (i+d) (cnt+1)
837+ where d = iter_ t i
838+-}
839+{-# RULES
840+"JSSTRING take -> fused" [~1] forall n t.
841+ take n t = unstream (S.take n (stream t))
842+"JSSTRING take -> unfused" [1] forall n t.
843+ unstream (S.take n (stream t)) = take n t
844+ #-}
845+
846+-- | /O(n)/ 'takeEnd' @n@ @t@ returns the suffix remaining after
847+-- taking @n@ characters from the end of @t@.
848+--
849+-- Examples:
850+--
851+-- > takeEnd 3 "foobar" == "bar"
852+takeEnd :: Int -> JSString -> JSString
853+takeEnd = coerce T.takeEnd
854+
855+-- | /O(n)/ 'drop' @n@, applied to a 'JSString', returns the suffix of the
856+-- 'JSString' after the first @n@ characters, or the empty 'JSString' if @n@
857+-- is greater than the length of the 'JSString'. Subject to fusion.
858+drop :: Int -> JSString -> JSString
859+drop = coerce T.drop
860+{-# INLINE [1] drop #-}
861+
862+{-# RULES
863+"JSSTRING drop -> fused" [~1] forall n t.
864+ drop n t = unstream (S.drop n (stream t))
865+"JSSTRING drop -> unfused" [1] forall n t.
866+ unstream (S.drop n (stream t)) = drop n t
867+ #-}
868+
869+-- | /O(n)/ 'dropEnd' @n@ @t@ returns the prefix remaining after
870+-- dropping @n@ characters from the end of @t@.
871+--
872+-- Examples:
873+--
874+-- > dropEnd 3 "foobar" == "foo"
875+dropEnd :: Int -> JSString -> JSString
876+dropEnd = coerce T.dropEnd
877+
878+-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'JSString',
879+-- returns the longest prefix (possibly empty) of elements that
880+-- satisfy @p@. Subject to fusion.
881+takeWhile :: (Char -> Bool) -> JSString -> JSString
882+takeWhile = coerce T.takeWhile
883+{-# INLINE [1] takeWhile #-}
884+
885+{-# RULES
886+"TEXT takeWhile -> fused" [~1] forall p t.
887+ takeWhile p t = unstream (S.takeWhile p (stream t))
888+"TEXT takeWhile -> unfused" [1] forall p t.
889+ unstream (S.takeWhile p (stream t)) = takeWhile p t
890+ #-}
891+
892+-- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after
893+-- 'takeWhile' @p@ @t@. Subject to fusion.
894+dropWhile :: (Char -> Bool) -> JSString -> JSString
895+dropWhile = coerce T.dropWhile
896+{-# INLINE [1] dropWhile #-}
897+
898+{-# RULES
899+"TEXT dropWhile -> fused" [~1] forall p t.
900+ dropWhile p t = unstream (S.dropWhile p (stream t))
901+"TEXT dropWhile -> unfused" [1] forall p t.
902+ unstream (S.dropWhile p (stream t)) = dropWhile p t
903+ #-}
904+
905+-- | /O(n)/ 'dropWhileEnd' @p@ @t@ returns the prefix remaining after
906+-- dropping characters that fail the predicate @p@ from the end of
907+-- @t@. Subject to fusion.
908+-- Examples:
909+--
910+-- > dropWhileEnd (=='.') "foo..." == "foo"
911+dropWhileEnd :: (Char -> Bool) -> JSString -> JSString
912+dropWhileEnd = coerce T.dropWhileEnd
913+{-# INLINE [1] dropWhileEnd #-}
914+
915+{-# RULES
916+"TEXT dropWhileEnd -> fused" [~1] forall p t.
917+ dropWhileEnd p t = S.reverse (S.dropWhile p (S.reverseStream t))
918+"TEXT dropWhileEnd -> unfused" [1] forall p t.
919+ S.reverse (S.dropWhile p (S.reverseStream t)) = dropWhileEnd p t
920+ #-}
921+
922+-- | /O(n)/ 'dropAround' @p@ @t@ returns the substring remaining after
923+-- dropping characters that fail the predicate @p@ from both the
924+-- beginning and end of @t@. Subject to fusion.
925+dropAround :: (Char -> Bool) -> JSString -> JSString
926+dropAround = coerce T.dropAround
927+{-# INLINE [1] dropAround #-}
928+
929+-- | /O(n)/ Remove leading white space from a string. Equivalent to:
930+--
931+-- > dropWhile isSpace
932+stripStart :: JSString -> JSString
933+stripStart = coerce T.stripStart
934+{-# INLINE [1] stripStart #-}
935+
936+-- | /O(n)/ Remove trailing white space from a string. Equivalent to:
937+--
938+-- > dropWhileEnd isSpace
939+stripEnd :: JSString -> JSString
940+stripEnd = coerce T.stripEnd
941+{-# INLINE [1] stripEnd #-}
942+
943+-- | /O(n)/ Remove leading and trailing white space from a string.
944+-- Equivalent to:
945+--
946+-- > dropAround isSpace
947+strip :: JSString -> JSString
948+strip = coerce T.strip
949+{-# INLINE [1] strip #-}
950+
951+-- | /O(n)/ 'splitAt' @n t@ returns a pair whose first element is a
952+-- prefix of @t@ of length @n@, and whose second is the remainder of
953+-- the string. It is equivalent to @('take' n t, 'drop' n t)@.
954+splitAt :: Int -> JSString -> (JSString, JSString)
955+splitAt = coerce T.splitAt
956+{-# INLINE splitAt #-}
957+
958+-- | /O(n)/ 'span', applied to a predicate @p@ and text @t@, returns
959+-- a pair whose first element is the longest prefix (possibly empty)
960+-- of @t@ of elements that satisfy @p@, and whose second is the
961+-- remainder of the list.
962+span :: (Char -> Bool) -> JSString -> (JSString, JSString)
963+span = coerce T.span
964+{-# INLINE span #-}
965+
966+-- | /O(n)/ 'break' is like 'span', but the prefix returned is
967+-- over elements that fail the predicate @p@.
968+break :: (Char -> Bool) -> JSString -> (JSString, JSString)
969+break = coerce T.break
970+{-# INLINE break #-}
971+
972+-- | /O(n)/ Group characters in a string according to a predicate.
973+groupBy :: (Char -> Char -> Bool) -> JSString -> [JSString]
974+groupBy = coerce T.groupBy
975+
976+-- | /O(n)/ Group characters in a string by equality.
977+group :: JSString -> [JSString]
978+group = coerce T.group
979+{-# INLINE group #-}
980+
981+group' :: JSString -> [JSString]
982+group' = coerce T.group
983+{-# INLINE group' #-}
984+
985+-- | /O(n^2)/ Return all initial segments of the given 'JSString', shortest
986+-- first.
987+inits :: JSString -> [JSString]
988+inits = coerce T.inits
989+
990+-- | /O(n^2)/ Return all final segments of the given 'JSString', longest
991+-- first.
992+tails :: JSString -> [JSString]
993+tails = coerce T.tails
994+
995+-- $split
996+--
997+-- Splitting functions in this library do not perform character-wise
998+-- copies to create substrings; they just construct new 'JSString's that
999+-- are slices of the original.
1000+
1001+-- | /O(m+n)/ Break a 'JSString' into pieces separated by the first 'JSString'
1002+-- argument (which cannot be empty), consuming the delimiter. An empty
1003+-- delimiter is invalid, and will cause an error to be raised.
1004+--
1005+-- Examples:
1006+--
1007+-- > splitOn "\r\n" "a\r\nb\r\nd\r\ne" == ["a","b","d","e"]
1008+-- > splitOn "aaa" "aaaXaaaXaaaXaaa" == ["","X","X","X",""]
1009+-- > splitOn "x" "x" == ["",""]
1010+--
1011+-- and
1012+--
1013+-- > intercalate s . splitOn s == id
1014+-- > splitOn (singleton c) == split (==c)
1015+--
1016+-- (Note: the string @s@ to split on above cannot be empty.)
1017+--
1018+-- In (unlikely) bad cases, this function's time complexity degrades
1019+-- towards /O(n*m)/.
1020+splitOn :: JSString
1021+ -- ^ String to split on. If this string is empty, an error
1022+ -- will occur.
1023+ -> JSString
1024+ -- ^ Input text.
1025+ -> [JSString]
1026+splitOn = coerce T.splitOn
1027+{-# INLINE [1] splitOn #-}
1028+
1029+-- RULES
1030+-- "JSSTRING splitOn/singleton -> split/==" [~1] forall c t.
1031+-- splitOn (singleton c) t = split (==c) t
1032+--
1033+
1034+splitOn' :: JSString
1035+ -- ^ String to split on. If this string is empty, an error
1036+ -- will occur.
1037+ -> JSString
1038+ -- ^ Input text.
1039+ -> [JSString]
1040+splitOn' = coerce T.splitOn
1041+{-# NOINLINE splitOn' #-}
1042+--- {-# INLINE [1] splitOn' #-}
1043+
1044+-- | /O(n)/ Splits a 'JSString' into components delimited by separators,
1045+-- where the predicate returns True for a separator element. The
1046+-- resulting components do not contain the separators. Two adjacent
1047+-- separators result in an empty component in the output. eg.
1048+--
1049+-- > split (=='a') "aabbaca" == ["","","bb","c",""]
1050+-- > split (=='a') "" == [""]
1051+split :: (Char -> Bool) -> JSString -> [JSString]
1052+split = coerce T.split
1053+{-# INLINE split #-}
1054+
1055+-- | /O(n)/ Splits a 'JSString' into components of length @k@. The last
1056+-- element may be shorter than the other chunks, depending on the
1057+-- length of the input. Examples:
1058+--
1059+-- > chunksOf 3 "foobarbaz" == ["foo","bar","baz"]
1060+-- > chunksOf 4 "haskell.org" == ["hask","ell.","org"]
1061+chunksOf :: Int -> JSString -> [JSString]
1062+chunksOf = coerce T.chunksOf
1063+{-# INLINE chunksOf #-}
1064+
1065+-- | /O(n)/ Splits a 'JSString' into components of length @k@. The last
1066+-- element may be shorter than the other chunks, depending on the
1067+-- length of the input. Examples:
1068+--
1069+-- > chunksOf 3 "foobarbaz" == ["foo","bar","baz"]
1070+-- > chunksOf 4 "haskell.org" == ["hask","ell.","org"]
1071+chunksOf' :: Int -> JSString -> [JSString]
1072+chunksOf' = coerce T.chunksOf
1073+{-# INLINE chunksOf' #-}
1074+
1075+-- ----------------------------------------------------------------------------
1076+-- * Searching
1077+
1078+-------------------------------------------------------------------------------
1079+-- ** Searching with a predicate
1080+
1081+-- | /O(n)/ The 'find' function takes a predicate and a 'JSString', and
1082+-- returns the first element matching the predicate, or 'Nothing' if
1083+-- there is no such element.
1084+find :: (Char -> Bool) -> JSString -> Maybe Char
1085+find = coerce T.find
1086+{-# INLINE find #-}
1087+
1088+-- | /O(n)/ The 'partition' function takes a predicate and a 'JSString',
1089+-- and returns the pair of 'JSString's with elements which do and do not
1090+-- satisfy the predicate, respectively; i.e.
1091+--
1092+-- > partition p t == (filter p t, filter (not . p) t)
1093+partition :: (Char -> Bool) -> JSString -> (JSString, JSString)
1094+partition = coerce T.partition
1095+{-# INLINE partition #-}
1096+
1097+-- | /O(n)/ 'filter', applied to a predicate and a 'JSString',
1098+-- returns a 'JSString' containing those characters that satisfy the
1099+-- predicate.
1100+filter :: (Char -> Bool) -> JSString -> JSString
1101+filter = coerce T.filter
1102+{-# INLINE filter #-}
1103+
1104+-- | /O(n+m)/ Find the first instance of @needle@ (which must be
1105+-- non-'null') in @haystack@. The first element of the returned tuple
1106+-- is the prefix of @haystack@ before @needle@ is matched. The second
1107+-- is the remainder of @haystack@, starting with the match.
1108+--
1109+-- Examples:
1110+--
1111+-- > breakOn "::" "a::b::c" ==> ("a", "::b::c")
1112+-- > breakOn "/" "foobar" ==> ("foobar", "")
1113+--
1114+-- Laws:
1115+--
1116+-- > append prefix match == haystack
1117+-- > where (prefix, match) = breakOn needle haystack
1118+--
1119+-- If you need to break a string by a substring repeatedly (e.g. you
1120+-- want to break on every instance of a substring), use 'breakOnAll'
1121+-- instead, as it has lower startup overhead.
1122+--
1123+-- In (unlikely) bad cases, this function's time complexity degrades
1124+-- towards /O(n*m)/.
1125+breakOn :: JSString -> JSString -> (JSString, JSString)
1126+breakOn = coerce T.breakOn
1127+{-# INLINE breakOn #-}
1128+
1129+-- | /O(n+m)/ Similar to 'breakOn', but searches from the end of the
1130+-- string.
1131+--
1132+-- The first element of the returned tuple is the prefix of @haystack@
1133+-- up to and including the last match of @needle@. The second is the
1134+-- remainder of @haystack@, following the match.
1135+--
1136+-- > breakOnEnd "::" "a::b::c" ==> ("a::b::", "c")
1137+breakOnEnd :: JSString -> JSString -> (JSString, JSString)
1138+breakOnEnd = coerce T.breakOnEnd
1139+{-# INLINE breakOnEnd #-}
1140+
1141+-- | /O(n+m)/ Find all non-overlapping instances of @needle@ in
1142+-- @haystack@. Each element of the returned list consists of a pair:
1143+--
1144+-- * The entire string prior to the /k/th match (i.e. the prefix)
1145+--
1146+-- * The /k/th match, followed by the remainder of the string
1147+--
1148+-- Examples:
1149+--
1150+-- > breakOnAll "::" ""
1151+-- > ==> []
1152+-- > breakOnAll "/" "a/b/c/"
1153+-- > ==> [("a", "/b/c/"), ("a/b", "/c/"), ("a/b/c", "/")]
1154+--
1155+-- In (unlikely) bad cases, this function's time complexity degrades
1156+-- towards /O(n*m)/.
1157+--
1158+-- The @needle@ parameter may not be empty.
1159+breakOnAll :: JSString -- ^ @needle@ to search for
1160+ -> JSString -- ^ @haystack@ in which to search
1161+ -> [(JSString, JSString)]
1162+breakOnAll = coerce T.breakOnAll
1163+{-# INLINE breakOnAll #-}
1164+
1165+breakOnAll' :: JSString -- ^ @needle@ to search for
1166+ -> JSString -- ^ @haystack@ in which to search
1167+ -> [(JSString, JSString)]
1168+breakOnAll' = coerce T.breakOnAll
1169+{-# INLINE breakOnAll' #-}
1170+
1171+-------------------------------------------------------------------------------
1172+-- ** Indexing 'JSString's
1173+
1174+-- $index
1175+--
1176+-- If you think of a 'JSString' value as an array of 'Char' values (which
1177+-- it is not), you run the risk of writing inefficient code.
1178+--
1179+-- An idiom that is common in some languages is to find the numeric
1180+-- offset of a character or substring, then use that number to split
1181+-- or trim the searched string. With a 'JSString' value, this approach
1182+-- would require two /O(n)/ operations: one to perform the search, and
1183+-- one to operate from wherever the search ended.
1184+--
1185+-- For example, suppose you have a string that you want to split on
1186+-- the substring @\"::\"@, such as @\"foo::bar::quux\"@. Instead of
1187+-- searching for the index of @\"::\"@ and taking the substrings
1188+-- before and after that index, you would instead use @breakOnAll \"::\"@.
1189+
1190+-- | /O(n)/ 'JSString' index (subscript) operator, starting from 0.
1191+index :: JSString -> Int -> Char
1192+index = coerce T.index
1193+{-# INLINE index #-}
1194+
1195+-- | /O(n)/ The 'findIndex' function takes a predicate and a 'JSString'
1196+-- and returns the index of the first element in the 'JSString' satisfying
1197+-- the predicate. Subject to fusion.
1198+findIndex :: (Char -> Bool) -> JSString -> Maybe Int
1199+findIndex = coerce T.findIndex
1200+{-# INLINE findIndex #-}
1201+
1202+-- | /O(n+m)/ The 'count' function returns the number of times the
1203+-- query string appears in the given 'JSString'. An empty query string is
1204+-- invalid, and will cause an error to be raised.
1205+--
1206+-- In (unlikely) bad cases, this function's time complexity degrades
1207+-- towards /O(n*m)/.
1208+count :: JSString -> JSString -> Int
1209+count = coerce T.count
1210+{-# INLINE [1] count #-}
1211+
1212+-- RULES
1213+-- "JSSTRING count/singleton -> countChar" [~1] forall c t.
1214+-- count (singleton c) t = countChar c t
1215+--
1216+
1217+-------------------------------------------------------------------------------
1218+-- * Zipping
1219+
1220+-- | /O(n)/ 'zip' takes two 'JSString's and returns a list of
1221+-- corresponding pairs of bytes. If one input 'JSString' is short,
1222+-- excess elements of the longer 'JSString' are discarded. This is
1223+-- equivalent to a pair of 'unpack' operations.
1224+zip :: JSString -> JSString -> [(Char,Char)]
1225+zip = coerce T.zip
1226+{-# INLINE [0] zip #-}
1227+
1228+-- | /O(n)/ 'zipWith' generalises 'zip' by zipping with the function
1229+-- given as the first argument, instead of a tupling function.
1230+-- Performs replacement on invalid scalar values.
1231+zipWith :: (Char -> Char -> Char) -> JSString -> JSString -> JSString
1232+zipWith = coerce T.zipWith
1233+{-# INLINE [0] zipWith #-}
1234+
1235+-- | /O(n)/ Breaks a 'JSString' up into a list of words, delimited by 'Char's
1236+-- representing white space.
1237+words :: JSString -> [JSString]
1238+words = coerce T.words
1239+{-# INLINE words #-}
1240+
1241+-- fixme: strict words' that allocates the whole list in one go
1242+words' :: JSString -> [JSString]
1243+words' = coerce T.words
1244+{-# INLINE words' #-}
1245+
1246+-- | /O(n)/ Breaks a 'JSString' up into a list of 'JSString's at
1247+-- newline 'Char's. The resulting strings do not contain newlines.
1248+lines :: JSString -> [JSString]
1249+lines = coerce T.lines
1250+{-# INLINE lines #-}
1251+
1252+lines' :: JSString -> [JSString]
1253+lines' = coerce T.lines
1254+{-# INLINE lines' #-}
1255+
1256+{-
1257+-- | /O(n)/ Portably breaks a 'JSString' up into a list of 'JSString's at line
1258+-- boundaries.
1259+--
1260+-- A line boundary is considered to be either a line feed, a carriage
1261+-- return immediately followed by a line feed, or a carriage return.
1262+-- This accounts for both Unix and Windows line ending conventions,
1263+-- and for the old convention used on Mac OS 9 and earlier.
1264+lines' :: Text -> [Text]
1265+lines' ps | null ps = []
1266+ | otherwise = h : case uncons t of
1267+ Nothing -> []
1268+ Just (c,t')
1269+ | c == '\n' -> lines t'
1270+ | c == '\r' -> case uncons t' of
1271+ Just ('\n',t'') -> lines t''
1272+ _ -> lines t'
1273+ where (h,t) = span notEOL ps
1274+ notEOL c = c /= '\n' && c /= '\r'
1275+
1276+-}
1277+
1278+-- | /O(n)/ Joins lines, after appending a terminating newline to
1279+-- each.
1280+unlines :: [JSString] -> JSString
1281+unlines = coerce T.unlines
1282+{-# INLINE unlines #-}
1283+
1284+-- | /O(n)/ Joins words using single space characters.
1285+unwords :: [JSString] -> JSString
1286+unwords = coerce T.unwords
1287+{-# INLINE unwords #-}
1288+
1289+-- | /O(n)/ The 'isPrefixOf' function takes two 'JSString's and returns
1290+-- 'True' iff the first is a prefix of the second. Subject to fusion.
1291+isPrefixOf :: JSString -> JSString -> Bool
1292+isPrefixOf = coerce T.isPrefixOf
1293+{-# INLINE [1] isPrefixOf #-}
1294+
1295+{-# RULES
1296+"JSSTRING isPrefixOf -> fused" [~1] forall x y.
1297+ isPrefixOf x y = S.isPrefixOf (stream x) (stream y)
1298+"JSSTRING isPrefixOf -> unfused" [1] forall x y.
1299+ S.isPrefixOf (stream x) (stream y) = isPrefixOf x y
1300+ #-}
1301+
1302+-- | /O(n)/ The 'isSuffixOf' function takes two 'JSString's and returns
1303+-- 'True' iff the first is a suffix of the second.
1304+isSuffixOf :: JSString -> JSString -> Bool
1305+isSuffixOf = coerce T.isSuffixOf
1306+{-# INLINE isSuffixOf #-}
1307+
1308+-- | The 'isInfixOf' function takes two 'JSString's and returns
1309+-- 'True' iff the first is contained, wholly and intact, anywhere
1310+-- within the second.
1311+--
1312+-- Complexity depends on how the JavaScript engine implements
1313+-- String.prototype.find.
1314+isInfixOf :: JSString -> JSString -> Bool
1315+isInfixOf = coerce T.isInfixOf
1316+{-# INLINE [1] isInfixOf #-}
1317+
1318+{-# RULES
1319+"JSSTRING isInfixOf/singleton -> S.elem/S.stream" [~1] forall n h.
1320+ isInfixOf (singleton n) h = S.elem n (S.stream h)
1321+ #-}
1322+
1323+-------------------------------------------------------------------------------
1324+-- * View patterns
1325+
1326+-- | /O(n)/ Return the suffix of the second string if its prefix
1327+-- matches the entire first string.
1328+--
1329+-- Examples:
1330+--
1331+-- > stripPrefix "foo" "foobar" == Just "bar"
1332+-- > stripPrefix "" "baz" == Just "baz"
1333+-- > stripPrefix "foo" "quux" == Nothing
1334+--
1335+-- This is particularly useful with the @ViewPatterns@ extension to
1336+-- GHC, as follows:
1337+--
1338+-- > {-# LANGUAGE ViewPatterns #-}
1339+-- > import Data.Text as T
1340+-- >
1341+-- > fnordLength :: JSString -> Int
1342+-- > fnordLength (stripPrefix "fnord" -> Just suf) = T.length suf
1343+-- > fnordLength _ = -1
1344+stripPrefix :: JSString -> JSString -> Maybe JSString
1345+stripPrefix = coerce T.stripPrefix
1346+{-# INLINE stripPrefix #-}
1347+
1348+-- | /O(n)/ Find the longest non-empty common prefix of two strings
1349+-- and return it, along with the suffixes of each string at which they
1350+-- no longer match.
1351+--
1352+-- If the strings do not have a common prefix or either one is empty,
1353+-- this function returns 'Nothing'.
1354+--
1355+-- Examples:
1356+--
1357+-- > commonPrefixes "foobar" "fooquux" == Just ("foo","bar","quux")
1358+-- > commonPrefixes "veeble" "fetzer" == Nothing
1359+-- > commonPrefixes "" "baz" == Nothing
1360+commonPrefixes :: JSString -> JSString -> Maybe (JSString,JSString,JSString)
1361+commonPrefixes = coerce T.commonPrefixes
1362+{-# INLINE commonPrefixes #-}
1363+
1364+-- | /O(n)/ Return the prefix of the second string if its suffix
1365+-- matches the entire first string.
1366+--
1367+-- Examples:
1368+--
1369+-- > stripSuffix "bar" "foobar" == Just "foo"
1370+-- > stripSuffix "" "baz" == Just "baz"
1371+-- > stripSuffix "foo" "quux" == Nothing
1372+--
1373+-- This is particularly useful with the @ViewPatterns@ extension to
1374+-- GHC, as follows:
1375+--
1376+-- > {-# LANGUAGE ViewPatterns #-}
1377+-- > import Data.Text as T
1378+-- >
1379+-- > quuxLength :: Text -> Int
1380+-- > quuxLength (stripSuffix "quux" -> Just pre) = T.length pre
1381+-- > quuxLength _ = -1
1382+stripSuffix :: JSString -> JSString -> Maybe JSString
1383+stripSuffix = coerce T.stripSuffix
1384+{-# INLINE stripSuffix #-}
1385+
1386+---- | Add a list of non-negative numbers. Errors out on overflow.
1387+--sumP :: String -> [Int] -> Int
1388+--sumP fun = go 0
1389+-- where go !a (x:xs)
1390+-- | ax >= 0 = go ax xs
1391+-- | otherwise = overflowError fun
1392+-- where ax = a + x
1393+-- go a _ = a
1394+--
1395+--emptyError :: String -> a
1396+--emptyError fun = P.error $ "Data.JSString." ++ fun ++ ": empty input"
1397+--
1398+--overflowError :: String -> a
1399+--overflowError fun = P.error $ "Data.JSString." ++ fun ++ ": size overflow"
1400+--
1401+--charWidth :: Int# -> Int#
1402+--charWidth cp | isTrue# (cp >=# 0x10000#) = 2#
1403+-- | otherwise = 1#
1404+--{-# INLINE charWidth #-}
jsaddle/src-ghc/Data/JSString/Internal.hsnew file+1
@@ -0,0 +1 @@
1+module Data.JSString.Internal where
jsaddle/src-ghc/Data/JSString/Internal/Fusion.hsnew file+127
@@ -0,0 +1,127 @@
1+{-# LANGUAGE BangPatterns, MagicHash
2+ #-}
3+module Data.JSString.Internal.Fusion ( -- * Types
4+ Stream(..)
5+ , Step(..)
6+
7+ -- * Creation and elimination
8+ , stream
9+ , unstream
10+ , reverseStream
11+
12+ , length
13+
14+ -- * Transformations
15+ , reverse
16+
17+ -- * Construction
18+ -- ** Scans
19+ , reverseScanr
20+
21+ -- ** Accumulating maps
22+ , mapAccumL
23+
24+ -- ** Generation and unfolding
25+ , unfoldrN
26+
27+ -- * Indexing
28+ , index
29+ , findIndex
30+ , countChar
31+ ) where
32+
33+--import GHC.Exts (Char(..), Int(..), chr#, Int#, isTrue#, (-#), (+#), (>=#))
34+
35+import Prelude hiding (length, reverse)
36+import qualified Data.Text.Internal.Fusion as T
37+--import Data.Char
38+import Data.Coerce (coerce)
39+
40+import Data.JSString.Internal.Type (JSString(..))
41+--import qualified Data.JSString.Internal.Type as I
42+import Data.JSString.Internal.Fusion.Types
43+import qualified Data.JSString.Internal.Fusion.Common as S
44+
45+--import System.IO.Unsafe
46+
47+--import GHCJS.Prim
48+
49+default (Int)
50+
51+-- | /O(n)/ Convert a 'JSString' into a 'Stream Char'.
52+stream :: JSString -> Stream Char
53+stream = coerce T.stream
54+{-# INLINE [0] stream #-}
55+
56+-- | /O(n)/ Convert a 'JSString' into a 'Stream Char', but iterate
57+-- backwards.
58+reverseStream :: JSString -> Stream Char
59+reverseStream = coerce T.reverseStream
60+{-# INLINE [0] reverseStream #-}
61+
62+-- | /O(n)/ Convert a 'Stream Char' into a 'JSString'.
63+unstream :: Stream Char -> JSString
64+unstream = coerce T.unstream
65+{-# INLINE [0] unstream #-}
66+{-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-}
67+
68+
69+-- ----------------------------------------------------------------------------
70+-- * Basic stream functions
71+
72+--runJSString :: ((a -> IO a) -> IO a) -> a
73+--runJSString f = unsafePerformIO (f pure)
74+
75+length :: Stream Char -> Int
76+length = S.lengthI
77+{-# INLINE[0] length #-}
78+
79+-- | /O(n)/ Reverse the characters of a string.
80+reverse :: Stream Char -> JSString
81+reverse = coerce T.reverse
82+{-# INLINE [0] reverse #-}
83+
84+-- | /O(n)/ Perform the equivalent of 'scanr' over a list, only with
85+-- the input and result reversed.
86+reverseScanr :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char
87+reverseScanr = coerce T.reverseScanr
88+{-# INLINE reverseScanr #-}
89+
90+-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a stream from a seed
91+-- value. However, the length of the result is limited by the
92+-- first argument to 'unfoldrN'. This function is more efficient than
93+-- 'unfoldr' when the length of the result is known.
94+unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Stream Char
95+unfoldrN n = S.unfoldrNI n
96+{-# INLINE [0] unfoldrN #-}
97+
98+-------------------------------------------------------------------------------
99+-- ** Indexing streams
100+
101+-- | /O(n)/ stream index (subscript) operator, starting from 0.
102+index :: Stream Char -> Int -> Char
103+index = S.indexI
104+{-# INLINE [0] index #-}
105+
106+-- | The 'findIndex' function takes a predicate and a stream and
107+-- returns the index of the first element in the stream
108+-- satisfying the predicate.
109+findIndex :: (Char -> Bool) -> Stream Char -> Maybe Int
110+findIndex = S.findIndexI
111+{-# INLINE [0] findIndex #-}
112+
113+-- | /O(n)/ The 'count' function returns the number of times the query
114+-- element appears in the given stream.
115+countChar :: Char -> Stream Char -> Int
116+countChar = S.countCharI
117+{-# INLINE [0] countChar #-}
118+
119+-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a
120+-- function to each element of a 'Text', passing an accumulating
121+-- parameter from left to right, and returns a final 'JSString'.
122+mapAccumL :: (a -> Char -> (a, Char)) -> a -> Stream Char -> (a, JSString)
123+mapAccumL a b c = coerce (T.mapAccumL a b c)
124+{-# INLINE [0] mapAccumL #-}
125+
126+-------------------------------------------------------------------------------
127+
jsaddle/src-ghc/Data/JSString/Internal/Fusion/CaseMapping.hsnew file+570
@@ -0,0 +1,570 @@
1+{-# LANGUAGE Rank2Types #-}
2+-- AUTOMATICALLY GENERATED - DO NOT EDIT
3+-- Generated by scripts/SpecialCasing.hs
4+-- CaseFolding-6.3.0.txt
5+-- Date: 2012-12-20, 22:14:35 GMT [MD]
6+-- SpecialCasing-6.3.0.txt
7+-- Date: 2013-05-08, 13:54:51 GMT [MD]
8+
9+module Data.JSString.Internal.Fusion.CaseMapping where
10+import Data.Char
11+import Data.JSString.Internal.Fusion.Types
12+
13+upperMapping :: forall s. Char -> s -> Step (CC s) Char
14+{-# INLINE upperMapping #-}
15+-- LATIN SMALL LETTER SHARP S
16+upperMapping '\x00df' s = Yield '\x0053' (CC s '\x0053' '\x0000')
17+-- LATIN SMALL LIGATURE FF
18+upperMapping '\xfb00' s = Yield '\x0046' (CC s '\x0046' '\x0000')
19+-- LATIN SMALL LIGATURE FI
20+upperMapping '\xfb01' s = Yield '\x0046' (CC s '\x0049' '\x0000')
21+-- LATIN SMALL LIGATURE FL
22+upperMapping '\xfb02' s = Yield '\x0046' (CC s '\x004c' '\x0000')
23+-- LATIN SMALL LIGATURE FFI
24+upperMapping '\xfb03' s = Yield '\x0046' (CC s '\x0046' '\x0049')
25+-- LATIN SMALL LIGATURE FFL
26+upperMapping '\xfb04' s = Yield '\x0046' (CC s '\x0046' '\x004c')
27+-- LATIN SMALL LIGATURE LONG S T
28+upperMapping '\xfb05' s = Yield '\x0053' (CC s '\x0054' '\x0000')
29+-- LATIN SMALL LIGATURE ST
30+upperMapping '\xfb06' s = Yield '\x0053' (CC s '\x0054' '\x0000')
31+-- ARMENIAN SMALL LIGATURE ECH YIWN
32+upperMapping '\x0587' s = Yield '\x0535' (CC s '\x0552' '\x0000')
33+-- ARMENIAN SMALL LIGATURE MEN NOW
34+upperMapping '\xfb13' s = Yield '\x0544' (CC s '\x0546' '\x0000')
35+-- ARMENIAN SMALL LIGATURE MEN ECH
36+upperMapping '\xfb14' s = Yield '\x0544' (CC s '\x0535' '\x0000')
37+-- ARMENIAN SMALL LIGATURE MEN INI
38+upperMapping '\xfb15' s = Yield '\x0544' (CC s '\x053b' '\x0000')
39+-- ARMENIAN SMALL LIGATURE VEW NOW
40+upperMapping '\xfb16' s = Yield '\x054e' (CC s '\x0546' '\x0000')
41+-- ARMENIAN SMALL LIGATURE MEN XEH
42+upperMapping '\xfb17' s = Yield '\x0544' (CC s '\x053d' '\x0000')
43+-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE
44+upperMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000')
45+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
46+upperMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301')
47+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
48+upperMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301')
49+-- LATIN SMALL LETTER J WITH CARON
50+upperMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000')
51+-- LATIN SMALL LETTER H WITH LINE BELOW
52+upperMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000')
53+-- LATIN SMALL LETTER T WITH DIAERESIS
54+upperMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000')
55+-- LATIN SMALL LETTER W WITH RING ABOVE
56+upperMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000')
57+-- LATIN SMALL LETTER Y WITH RING ABOVE
58+upperMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000')
59+-- LATIN SMALL LETTER A WITH RIGHT HALF RING
60+upperMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000')
61+-- GREEK SMALL LETTER UPSILON WITH PSILI
62+upperMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000')
63+-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA
64+upperMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300')
65+-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA
66+upperMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301')
67+-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI
68+upperMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342')
69+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI
70+upperMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000')
71+-- GREEK SMALL LETTER ETA WITH PERISPOMENI
72+upperMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000')
73+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA
74+upperMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300')
75+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA
76+upperMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301')
77+-- GREEK SMALL LETTER IOTA WITH PERISPOMENI
78+upperMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000')
79+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI
80+upperMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342')
81+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA
82+upperMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300')
83+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA
84+upperMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301')
85+-- GREEK SMALL LETTER RHO WITH PSILI
86+upperMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000')
87+-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI
88+upperMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000')
89+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI
90+upperMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342')
91+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI
92+upperMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000')
93+-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI
94+upperMapping '\x1f80' s = Yield '\x1f08' (CC s '\x0399' '\x0000')
95+-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI
96+upperMapping '\x1f81' s = Yield '\x1f09' (CC s '\x0399' '\x0000')
97+-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI
98+upperMapping '\x1f82' s = Yield '\x1f0a' (CC s '\x0399' '\x0000')
99+-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI
100+upperMapping '\x1f83' s = Yield '\x1f0b' (CC s '\x0399' '\x0000')
101+-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI
102+upperMapping '\x1f84' s = Yield '\x1f0c' (CC s '\x0399' '\x0000')
103+-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI
104+upperMapping '\x1f85' s = Yield '\x1f0d' (CC s '\x0399' '\x0000')
105+-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
106+upperMapping '\x1f86' s = Yield '\x1f0e' (CC s '\x0399' '\x0000')
107+-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
108+upperMapping '\x1f87' s = Yield '\x1f0f' (CC s '\x0399' '\x0000')
109+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI
110+upperMapping '\x1f88' s = Yield '\x1f08' (CC s '\x0399' '\x0000')
111+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI
112+upperMapping '\x1f89' s = Yield '\x1f09' (CC s '\x0399' '\x0000')
113+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI
114+upperMapping '\x1f8a' s = Yield '\x1f0a' (CC s '\x0399' '\x0000')
115+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI
116+upperMapping '\x1f8b' s = Yield '\x1f0b' (CC s '\x0399' '\x0000')
117+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI
118+upperMapping '\x1f8c' s = Yield '\x1f0c' (CC s '\x0399' '\x0000')
119+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI
120+upperMapping '\x1f8d' s = Yield '\x1f0d' (CC s '\x0399' '\x0000')
121+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
122+upperMapping '\x1f8e' s = Yield '\x1f0e' (CC s '\x0399' '\x0000')
123+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
124+upperMapping '\x1f8f' s = Yield '\x1f0f' (CC s '\x0399' '\x0000')
125+-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI
126+upperMapping '\x1f90' s = Yield '\x1f28' (CC s '\x0399' '\x0000')
127+-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI
128+upperMapping '\x1f91' s = Yield '\x1f29' (CC s '\x0399' '\x0000')
129+-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI
130+upperMapping '\x1f92' s = Yield '\x1f2a' (CC s '\x0399' '\x0000')
131+-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI
132+upperMapping '\x1f93' s = Yield '\x1f2b' (CC s '\x0399' '\x0000')
133+-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI
134+upperMapping '\x1f94' s = Yield '\x1f2c' (CC s '\x0399' '\x0000')
135+-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI
136+upperMapping '\x1f95' s = Yield '\x1f2d' (CC s '\x0399' '\x0000')
137+-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
138+upperMapping '\x1f96' s = Yield '\x1f2e' (CC s '\x0399' '\x0000')
139+-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
140+upperMapping '\x1f97' s = Yield '\x1f2f' (CC s '\x0399' '\x0000')
141+-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI
142+upperMapping '\x1f98' s = Yield '\x1f28' (CC s '\x0399' '\x0000')
143+-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI
144+upperMapping '\x1f99' s = Yield '\x1f29' (CC s '\x0399' '\x0000')
145+-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI
146+upperMapping '\x1f9a' s = Yield '\x1f2a' (CC s '\x0399' '\x0000')
147+-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI
148+upperMapping '\x1f9b' s = Yield '\x1f2b' (CC s '\x0399' '\x0000')
149+-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI
150+upperMapping '\x1f9c' s = Yield '\x1f2c' (CC s '\x0399' '\x0000')
151+-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI
152+upperMapping '\x1f9d' s = Yield '\x1f2d' (CC s '\x0399' '\x0000')
153+-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
154+upperMapping '\x1f9e' s = Yield '\x1f2e' (CC s '\x0399' '\x0000')
155+-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
156+upperMapping '\x1f9f' s = Yield '\x1f2f' (CC s '\x0399' '\x0000')
157+-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI
158+upperMapping '\x1fa0' s = Yield '\x1f68' (CC s '\x0399' '\x0000')
159+-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI
160+upperMapping '\x1fa1' s = Yield '\x1f69' (CC s '\x0399' '\x0000')
161+-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI
162+upperMapping '\x1fa2' s = Yield '\x1f6a' (CC s '\x0399' '\x0000')
163+-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI
164+upperMapping '\x1fa3' s = Yield '\x1f6b' (CC s '\x0399' '\x0000')
165+-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI
166+upperMapping '\x1fa4' s = Yield '\x1f6c' (CC s '\x0399' '\x0000')
167+-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI
168+upperMapping '\x1fa5' s = Yield '\x1f6d' (CC s '\x0399' '\x0000')
169+-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
170+upperMapping '\x1fa6' s = Yield '\x1f6e' (CC s '\x0399' '\x0000')
171+-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
172+upperMapping '\x1fa7' s = Yield '\x1f6f' (CC s '\x0399' '\x0000')
173+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI
174+upperMapping '\x1fa8' s = Yield '\x1f68' (CC s '\x0399' '\x0000')
175+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI
176+upperMapping '\x1fa9' s = Yield '\x1f69' (CC s '\x0399' '\x0000')
177+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI
178+upperMapping '\x1faa' s = Yield '\x1f6a' (CC s '\x0399' '\x0000')
179+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI
180+upperMapping '\x1fab' s = Yield '\x1f6b' (CC s '\x0399' '\x0000')
181+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI
182+upperMapping '\x1fac' s = Yield '\x1f6c' (CC s '\x0399' '\x0000')
183+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI
184+upperMapping '\x1fad' s = Yield '\x1f6d' (CC s '\x0399' '\x0000')
185+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
186+upperMapping '\x1fae' s = Yield '\x1f6e' (CC s '\x0399' '\x0000')
187+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
188+upperMapping '\x1faf' s = Yield '\x1f6f' (CC s '\x0399' '\x0000')
189+-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI
190+upperMapping '\x1fb3' s = Yield '\x0391' (CC s '\x0399' '\x0000')
191+-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI
192+upperMapping '\x1fbc' s = Yield '\x0391' (CC s '\x0399' '\x0000')
193+-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI
194+upperMapping '\x1fc3' s = Yield '\x0397' (CC s '\x0399' '\x0000')
195+-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI
196+upperMapping '\x1fcc' s = Yield '\x0397' (CC s '\x0399' '\x0000')
197+-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI
198+upperMapping '\x1ff3' s = Yield '\x03a9' (CC s '\x0399' '\x0000')
199+-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI
200+upperMapping '\x1ffc' s = Yield '\x03a9' (CC s '\x0399' '\x0000')
201+-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI
202+upperMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0399' '\x0000')
203+-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI
204+upperMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0399' '\x0000')
205+-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI
206+upperMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0399' '\x0000')
207+-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI
208+upperMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0399' '\x0000')
209+-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI
210+upperMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0399' '\x0000')
211+-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI
212+upperMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0399' '\x0000')
213+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI
214+upperMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0399')
215+-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI
216+upperMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0399')
217+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI
218+upperMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0399')
219+upperMapping c s = Yield (toUpper c) (CC s '\0' '\0')
220+lowerMapping :: forall s. Char -> s -> Step (CC s) Char
221+{-# INLINE lowerMapping #-}
222+-- LATIN CAPITAL LETTER I WITH DOT ABOVE
223+lowerMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000')
224+lowerMapping c s = Yield (toLower c) (CC s '\0' '\0')
225+titleMapping :: forall s. Char -> s -> Step (CC s) Char
226+{-# INLINE titleMapping #-}
227+-- LATIN SMALL LETTER SHARP S
228+titleMapping '\x00df' s = Yield '\x0053' (CC s '\x0073' '\x0000')
229+-- LATIN SMALL LIGATURE FF
230+titleMapping '\xfb00' s = Yield '\x0046' (CC s '\x0066' '\x0000')
231+-- LATIN SMALL LIGATURE FI
232+titleMapping '\xfb01' s = Yield '\x0046' (CC s '\x0069' '\x0000')
233+-- LATIN SMALL LIGATURE FL
234+titleMapping '\xfb02' s = Yield '\x0046' (CC s '\x006c' '\x0000')
235+-- LATIN SMALL LIGATURE FFI
236+titleMapping '\xfb03' s = Yield '\x0046' (CC s '\x0066' '\x0069')
237+-- LATIN SMALL LIGATURE FFL
238+titleMapping '\xfb04' s = Yield '\x0046' (CC s '\x0066' '\x006c')
239+-- LATIN SMALL LIGATURE LONG S T
240+titleMapping '\xfb05' s = Yield '\x0053' (CC s '\x0074' '\x0000')
241+-- LATIN SMALL LIGATURE ST
242+titleMapping '\xfb06' s = Yield '\x0053' (CC s '\x0074' '\x0000')
243+-- ARMENIAN SMALL LIGATURE ECH YIWN
244+titleMapping '\x0587' s = Yield '\x0535' (CC s '\x0582' '\x0000')
245+-- ARMENIAN SMALL LIGATURE MEN NOW
246+titleMapping '\xfb13' s = Yield '\x0544' (CC s '\x0576' '\x0000')
247+-- ARMENIAN SMALL LIGATURE MEN ECH
248+titleMapping '\xfb14' s = Yield '\x0544' (CC s '\x0565' '\x0000')
249+-- ARMENIAN SMALL LIGATURE MEN INI
250+titleMapping '\xfb15' s = Yield '\x0544' (CC s '\x056b' '\x0000')
251+-- ARMENIAN SMALL LIGATURE VEW NOW
252+titleMapping '\xfb16' s = Yield '\x054e' (CC s '\x0576' '\x0000')
253+-- ARMENIAN SMALL LIGATURE MEN XEH
254+titleMapping '\xfb17' s = Yield '\x0544' (CC s '\x056d' '\x0000')
255+-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE
256+titleMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000')
257+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
258+titleMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301')
259+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
260+titleMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301')
261+-- LATIN SMALL LETTER J WITH CARON
262+titleMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000')
263+-- LATIN SMALL LETTER H WITH LINE BELOW
264+titleMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000')
265+-- LATIN SMALL LETTER T WITH DIAERESIS
266+titleMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000')
267+-- LATIN SMALL LETTER W WITH RING ABOVE
268+titleMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000')
269+-- LATIN SMALL LETTER Y WITH RING ABOVE
270+titleMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000')
271+-- LATIN SMALL LETTER A WITH RIGHT HALF RING
272+titleMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000')
273+-- GREEK SMALL LETTER UPSILON WITH PSILI
274+titleMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000')
275+-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA
276+titleMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300')
277+-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA
278+titleMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301')
279+-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI
280+titleMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342')
281+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI
282+titleMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000')
283+-- GREEK SMALL LETTER ETA WITH PERISPOMENI
284+titleMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000')
285+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA
286+titleMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300')
287+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA
288+titleMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301')
289+-- GREEK SMALL LETTER IOTA WITH PERISPOMENI
290+titleMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000')
291+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI
292+titleMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342')
293+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA
294+titleMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300')
295+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA
296+titleMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301')
297+-- GREEK SMALL LETTER RHO WITH PSILI
298+titleMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000')
299+-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI
300+titleMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000')
301+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI
302+titleMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342')
303+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI
304+titleMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000')
305+-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI
306+titleMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0345' '\x0000')
307+-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI
308+titleMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0345' '\x0000')
309+-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI
310+titleMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0345' '\x0000')
311+-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI
312+titleMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0345' '\x0000')
313+-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI
314+titleMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0345' '\x0000')
315+-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI
316+titleMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0345' '\x0000')
317+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI
318+titleMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0345')
319+-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI
320+titleMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0345')
321+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI
322+titleMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0345')
323+titleMapping c s = Yield (toTitle c) (CC s '\0' '\0')
324+foldMapping :: forall s. Char -> s -> Step (CC s) Char
325+{-# INLINE foldMapping #-}
326+-- MICRO SIGN
327+foldMapping '\x00b5' s = Yield '\x03bc' (CC s '\x0000' '\x0000')
328+-- LATIN SMALL LETTER SHARP S
329+foldMapping '\x00df' s = Yield '\x0073' (CC s '\x0073' '\x0000')
330+-- LATIN CAPITAL LETTER I WITH DOT ABOVE
331+foldMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000')
332+-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE
333+foldMapping '\x0149' s = Yield '\x02bc' (CC s '\x006e' '\x0000')
334+-- LATIN SMALL LETTER LONG S
335+foldMapping '\x017f' s = Yield '\x0073' (CC s '\x0000' '\x0000')
336+-- LATIN SMALL LETTER J WITH CARON
337+foldMapping '\x01f0' s = Yield '\x006a' (CC s '\x030c' '\x0000')
338+-- COMBINING GREEK YPOGEGRAMMENI
339+foldMapping '\x0345' s = Yield '\x03b9' (CC s '\x0000' '\x0000')
340+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
341+foldMapping '\x0390' s = Yield '\x03b9' (CC s '\x0308' '\x0301')
342+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
343+foldMapping '\x03b0' s = Yield '\x03c5' (CC s '\x0308' '\x0301')
344+-- GREEK SMALL LETTER FINAL SIGMA
345+foldMapping '\x03c2' s = Yield '\x03c3' (CC s '\x0000' '\x0000')
346+-- GREEK BETA SYMBOL
347+foldMapping '\x03d0' s = Yield '\x03b2' (CC s '\x0000' '\x0000')
348+-- GREEK THETA SYMBOL
349+foldMapping '\x03d1' s = Yield '\x03b8' (CC s '\x0000' '\x0000')
350+-- GREEK PHI SYMBOL
351+foldMapping '\x03d5' s = Yield '\x03c6' (CC s '\x0000' '\x0000')
352+-- GREEK PI SYMBOL
353+foldMapping '\x03d6' s = Yield '\x03c0' (CC s '\x0000' '\x0000')
354+-- GREEK KAPPA SYMBOL
355+foldMapping '\x03f0' s = Yield '\x03ba' (CC s '\x0000' '\x0000')
356+-- GREEK RHO SYMBOL
357+foldMapping '\x03f1' s = Yield '\x03c1' (CC s '\x0000' '\x0000')
358+-- GREEK LUNATE EPSILON SYMBOL
359+foldMapping '\x03f5' s = Yield '\x03b5' (CC s '\x0000' '\x0000')
360+-- ARMENIAN SMALL LIGATURE ECH YIWN
361+foldMapping '\x0587' s = Yield '\x0565' (CC s '\x0582' '\x0000')
362+-- GEORGIAN CAPITAL LETTER YN
363+foldMapping '\x10c7' s = Yield '\x2d27' (CC s '\x0000' '\x0000')
364+-- GEORGIAN CAPITAL LETTER AEN
365+foldMapping '\x10cd' s = Yield '\x2d2d' (CC s '\x0000' '\x0000')
366+-- LATIN SMALL LETTER H WITH LINE BELOW
367+foldMapping '\x1e96' s = Yield '\x0068' (CC s '\x0331' '\x0000')
368+-- LATIN SMALL LETTER T WITH DIAERESIS
369+foldMapping '\x1e97' s = Yield '\x0074' (CC s '\x0308' '\x0000')
370+-- LATIN SMALL LETTER W WITH RING ABOVE
371+foldMapping '\x1e98' s = Yield '\x0077' (CC s '\x030a' '\x0000')
372+-- LATIN SMALL LETTER Y WITH RING ABOVE
373+foldMapping '\x1e99' s = Yield '\x0079' (CC s '\x030a' '\x0000')
374+-- LATIN SMALL LETTER A WITH RIGHT HALF RING
375+foldMapping '\x1e9a' s = Yield '\x0061' (CC s '\x02be' '\x0000')
376+-- LATIN SMALL LETTER LONG S WITH DOT ABOVE
377+foldMapping '\x1e9b' s = Yield '\x1e61' (CC s '\x0000' '\x0000')
378+-- LATIN CAPITAL LETTER SHARP S
379+foldMapping '\x1e9e' s = Yield '\x0073' (CC s '\x0073' '\x0000')
380+-- GREEK SMALL LETTER UPSILON WITH PSILI
381+foldMapping '\x1f50' s = Yield '\x03c5' (CC s '\x0313' '\x0000')
382+-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA
383+foldMapping '\x1f52' s = Yield '\x03c5' (CC s '\x0313' '\x0300')
384+-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA
385+foldMapping '\x1f54' s = Yield '\x03c5' (CC s '\x0313' '\x0301')
386+-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI
387+foldMapping '\x1f56' s = Yield '\x03c5' (CC s '\x0313' '\x0342')
388+-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI
389+foldMapping '\x1f80' s = Yield '\x1f00' (CC s '\x03b9' '\x0000')
390+-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI
391+foldMapping '\x1f81' s = Yield '\x1f01' (CC s '\x03b9' '\x0000')
392+-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI
393+foldMapping '\x1f82' s = Yield '\x1f02' (CC s '\x03b9' '\x0000')
394+-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI
395+foldMapping '\x1f83' s = Yield '\x1f03' (CC s '\x03b9' '\x0000')
396+-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI
397+foldMapping '\x1f84' s = Yield '\x1f04' (CC s '\x03b9' '\x0000')
398+-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI
399+foldMapping '\x1f85' s = Yield '\x1f05' (CC s '\x03b9' '\x0000')
400+-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
401+foldMapping '\x1f86' s = Yield '\x1f06' (CC s '\x03b9' '\x0000')
402+-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
403+foldMapping '\x1f87' s = Yield '\x1f07' (CC s '\x03b9' '\x0000')
404+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI
405+foldMapping '\x1f88' s = Yield '\x1f00' (CC s '\x03b9' '\x0000')
406+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI
407+foldMapping '\x1f89' s = Yield '\x1f01' (CC s '\x03b9' '\x0000')
408+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI
409+foldMapping '\x1f8a' s = Yield '\x1f02' (CC s '\x03b9' '\x0000')
410+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI
411+foldMapping '\x1f8b' s = Yield '\x1f03' (CC s '\x03b9' '\x0000')
412+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI
413+foldMapping '\x1f8c' s = Yield '\x1f04' (CC s '\x03b9' '\x0000')
414+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI
415+foldMapping '\x1f8d' s = Yield '\x1f05' (CC s '\x03b9' '\x0000')
416+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
417+foldMapping '\x1f8e' s = Yield '\x1f06' (CC s '\x03b9' '\x0000')
418+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
419+foldMapping '\x1f8f' s = Yield '\x1f07' (CC s '\x03b9' '\x0000')
420+-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI
421+foldMapping '\x1f90' s = Yield '\x1f20' (CC s '\x03b9' '\x0000')
422+-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI
423+foldMapping '\x1f91' s = Yield '\x1f21' (CC s '\x03b9' '\x0000')
424+-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI
425+foldMapping '\x1f92' s = Yield '\x1f22' (CC s '\x03b9' '\x0000')
426+-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI
427+foldMapping '\x1f93' s = Yield '\x1f23' (CC s '\x03b9' '\x0000')
428+-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI
429+foldMapping '\x1f94' s = Yield '\x1f24' (CC s '\x03b9' '\x0000')
430+-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI
431+foldMapping '\x1f95' s = Yield '\x1f25' (CC s '\x03b9' '\x0000')
432+-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
433+foldMapping '\x1f96' s = Yield '\x1f26' (CC s '\x03b9' '\x0000')
434+-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
435+foldMapping '\x1f97' s = Yield '\x1f27' (CC s '\x03b9' '\x0000')
436+-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI
437+foldMapping '\x1f98' s = Yield '\x1f20' (CC s '\x03b9' '\x0000')
438+-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI
439+foldMapping '\x1f99' s = Yield '\x1f21' (CC s '\x03b9' '\x0000')
440+-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI
441+foldMapping '\x1f9a' s = Yield '\x1f22' (CC s '\x03b9' '\x0000')
442+-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI
443+foldMapping '\x1f9b' s = Yield '\x1f23' (CC s '\x03b9' '\x0000')
444+-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI
445+foldMapping '\x1f9c' s = Yield '\x1f24' (CC s '\x03b9' '\x0000')
446+-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI
447+foldMapping '\x1f9d' s = Yield '\x1f25' (CC s '\x03b9' '\x0000')
448+-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
449+foldMapping '\x1f9e' s = Yield '\x1f26' (CC s '\x03b9' '\x0000')
450+-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
451+foldMapping '\x1f9f' s = Yield '\x1f27' (CC s '\x03b9' '\x0000')
452+-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI
453+foldMapping '\x1fa0' s = Yield '\x1f60' (CC s '\x03b9' '\x0000')
454+-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI
455+foldMapping '\x1fa1' s = Yield '\x1f61' (CC s '\x03b9' '\x0000')
456+-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI
457+foldMapping '\x1fa2' s = Yield '\x1f62' (CC s '\x03b9' '\x0000')
458+-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI
459+foldMapping '\x1fa3' s = Yield '\x1f63' (CC s '\x03b9' '\x0000')
460+-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI
461+foldMapping '\x1fa4' s = Yield '\x1f64' (CC s '\x03b9' '\x0000')
462+-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI
463+foldMapping '\x1fa5' s = Yield '\x1f65' (CC s '\x03b9' '\x0000')
464+-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
465+foldMapping '\x1fa6' s = Yield '\x1f66' (CC s '\x03b9' '\x0000')
466+-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
467+foldMapping '\x1fa7' s = Yield '\x1f67' (CC s '\x03b9' '\x0000')
468+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI
469+foldMapping '\x1fa8' s = Yield '\x1f60' (CC s '\x03b9' '\x0000')
470+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI
471+foldMapping '\x1fa9' s = Yield '\x1f61' (CC s '\x03b9' '\x0000')
472+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI
473+foldMapping '\x1faa' s = Yield '\x1f62' (CC s '\x03b9' '\x0000')
474+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI
475+foldMapping '\x1fab' s = Yield '\x1f63' (CC s '\x03b9' '\x0000')
476+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI
477+foldMapping '\x1fac' s = Yield '\x1f64' (CC s '\x03b9' '\x0000')
478+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI
479+foldMapping '\x1fad' s = Yield '\x1f65' (CC s '\x03b9' '\x0000')
480+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
481+foldMapping '\x1fae' s = Yield '\x1f66' (CC s '\x03b9' '\x0000')
482+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
483+foldMapping '\x1faf' s = Yield '\x1f67' (CC s '\x03b9' '\x0000')
484+-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI
485+foldMapping '\x1fb2' s = Yield '\x1f70' (CC s '\x03b9' '\x0000')
486+-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI
487+foldMapping '\x1fb3' s = Yield '\x03b1' (CC s '\x03b9' '\x0000')
488+-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI
489+foldMapping '\x1fb4' s = Yield '\x03ac' (CC s '\x03b9' '\x0000')
490+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI
491+foldMapping '\x1fb6' s = Yield '\x03b1' (CC s '\x0342' '\x0000')
492+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI
493+foldMapping '\x1fb7' s = Yield '\x03b1' (CC s '\x0342' '\x03b9')
494+-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI
495+foldMapping '\x1fbc' s = Yield '\x03b1' (CC s '\x03b9' '\x0000')
496+-- GREEK PROSGEGRAMMENI
497+foldMapping '\x1fbe' s = Yield '\x03b9' (CC s '\x0000' '\x0000')
498+-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI
499+foldMapping '\x1fc2' s = Yield '\x1f74' (CC s '\x03b9' '\x0000')
500+-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI
501+foldMapping '\x1fc3' s = Yield '\x03b7' (CC s '\x03b9' '\x0000')
502+-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI
503+foldMapping '\x1fc4' s = Yield '\x03ae' (CC s '\x03b9' '\x0000')
504+-- GREEK SMALL LETTER ETA WITH PERISPOMENI
505+foldMapping '\x1fc6' s = Yield '\x03b7' (CC s '\x0342' '\x0000')
506+-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI
507+foldMapping '\x1fc7' s = Yield '\x03b7' (CC s '\x0342' '\x03b9')
508+-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI
509+foldMapping '\x1fcc' s = Yield '\x03b7' (CC s '\x03b9' '\x0000')
510+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA
511+foldMapping '\x1fd2' s = Yield '\x03b9' (CC s '\x0308' '\x0300')
512+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA
513+foldMapping '\x1fd3' s = Yield '\x03b9' (CC s '\x0308' '\x0301')
514+-- GREEK SMALL LETTER IOTA WITH PERISPOMENI
515+foldMapping '\x1fd6' s = Yield '\x03b9' (CC s '\x0342' '\x0000')
516+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI
517+foldMapping '\x1fd7' s = Yield '\x03b9' (CC s '\x0308' '\x0342')
518+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA
519+foldMapping '\x1fe2' s = Yield '\x03c5' (CC s '\x0308' '\x0300')
520+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA
521+foldMapping '\x1fe3' s = Yield '\x03c5' (CC s '\x0308' '\x0301')
522+-- GREEK SMALL LETTER RHO WITH PSILI
523+foldMapping '\x1fe4' s = Yield '\x03c1' (CC s '\x0313' '\x0000')
524+-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI
525+foldMapping '\x1fe6' s = Yield '\x03c5' (CC s '\x0342' '\x0000')
526+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI
527+foldMapping '\x1fe7' s = Yield '\x03c5' (CC s '\x0308' '\x0342')
528+-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI
529+foldMapping '\x1ff2' s = Yield '\x1f7c' (CC s '\x03b9' '\x0000')
530+-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI
531+foldMapping '\x1ff3' s = Yield '\x03c9' (CC s '\x03b9' '\x0000')
532+-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI
533+foldMapping '\x1ff4' s = Yield '\x03ce' (CC s '\x03b9' '\x0000')
534+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI
535+foldMapping '\x1ff6' s = Yield '\x03c9' (CC s '\x0342' '\x0000')
536+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI
537+foldMapping '\x1ff7' s = Yield '\x03c9' (CC s '\x0342' '\x03b9')
538+-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI
539+foldMapping '\x1ffc' s = Yield '\x03c9' (CC s '\x03b9' '\x0000')
540+-- COPTIC CAPITAL LETTER BOHAIRIC KHEI
541+foldMapping '\x2cf2' s = Yield '\x2cf3' (CC s '\x0000' '\x0000')
542+-- LATIN CAPITAL LETTER C WITH BAR
543+foldMapping '\xa792' s = Yield '\xa793' (CC s '\x0000' '\x0000')
544+-- LATIN CAPITAL LETTER H WITH HOOK
545+foldMapping '\xa7aa' s = Yield '\x0266' (CC s '\x0000' '\x0000')
546+-- LATIN SMALL LIGATURE FF
547+foldMapping '\xfb00' s = Yield '\x0066' (CC s '\x0066' '\x0000')
548+-- LATIN SMALL LIGATURE FI
549+foldMapping '\xfb01' s = Yield '\x0066' (CC s '\x0069' '\x0000')
550+-- LATIN SMALL LIGATURE FL
551+foldMapping '\xfb02' s = Yield '\x0066' (CC s '\x006c' '\x0000')
552+-- LATIN SMALL LIGATURE FFI
553+foldMapping '\xfb03' s = Yield '\x0066' (CC s '\x0066' '\x0069')
554+-- LATIN SMALL LIGATURE FFL
555+foldMapping '\xfb04' s = Yield '\x0066' (CC s '\x0066' '\x006c')
556+-- LATIN SMALL LIGATURE LONG S T
557+foldMapping '\xfb05' s = Yield '\x0073' (CC s '\x0074' '\x0000')
558+-- LATIN SMALL LIGATURE ST
559+foldMapping '\xfb06' s = Yield '\x0073' (CC s '\x0074' '\x0000')
560+-- ARMENIAN SMALL LIGATURE MEN NOW
561+foldMapping '\xfb13' s = Yield '\x0574' (CC s '\x0576' '\x0000')
562+-- ARMENIAN SMALL LIGATURE MEN ECH
563+foldMapping '\xfb14' s = Yield '\x0574' (CC s '\x0565' '\x0000')
564+-- ARMENIAN SMALL LIGATURE MEN INI
565+foldMapping '\xfb15' s = Yield '\x0574' (CC s '\x056b' '\x0000')
566+-- ARMENIAN SMALL LIGATURE VEW NOW
567+foldMapping '\xfb16' s = Yield '\x057e' (CC s '\x0576' '\x0000')
568+-- ARMENIAN SMALL LIGATURE MEN XEH
569+foldMapping '\xfb17' s = Yield '\x0574' (CC s '\x056d' '\x0000')
570+foldMapping c s = Yield (toLower c) (CC s '\0' '\0')
jsaddle/src-ghc/Data/JSString/Internal/Fusion/Common.hsnew file+92
@@ -0,0 +1,92 @@
1+{-# LANGUAGE BangPatterns, MagicHash, RankNTypes #-}
2+
3+module Data.JSString.Internal.Fusion.Common ( -- * Creation and elimination
4+ singleton
5+ , streamList
6+ , unstreamList
7+ , streamCString#
8+
9+ -- * Basic interface
10+ , cons
11+ , snoc
12+ , append
13+ , head
14+ , uncons
15+ , last
16+ , tail
17+ , init
18+ , null
19+ , lengthI
20+ , compareLengthI
21+ , isSingleton
22+
23+ -- * Transformations
24+ , map
25+ , intercalate
26+ , intersperse
27+
28+ -- ** Case conversion
29+ -- $case
30+ , toCaseFold
31+ , toLower
32+ , toTitle
33+ , toUpper
34+
35+ -- ** Justification
36+ , justifyLeftI
37+
38+ -- * Folds
39+ , foldl
40+ , foldl'
41+ , foldl1
42+ , foldl1'
43+ , foldr
44+ , foldr1
45+
46+ -- ** Special folds
47+ , concat
48+ , concatMap
49+ , any
50+ , all
51+ , maximum
52+ , minimum
53+
54+ -- * Construction
55+ -- ** Scans
56+ , scanl
57+
58+ -- ** Accumulating maps
59+ -- , mapAccumL
60+
61+ -- ** Generation and unfolding
62+ , replicateCharI
63+ , replicateI
64+ , unfoldr
65+ , unfoldrNI
66+
67+ -- * Substrings
68+ -- ** Breaking strings
69+ , take
70+ , drop
71+ , takeWhile
72+ , dropWhile
73+
74+ -- * Predicates
75+ , isPrefixOf
76+
77+ -- * Searching
78+ , elem
79+ , filter
80+
81+ -- * Indexing
82+ , findBy
83+ , indexI
84+ , findIndexI
85+ , countCharI
86+
87+ -- * Zipping and unzipping
88+ , zipWith
89+ ) where
90+
91+import Data.Text.Internal.Fusion.Common
92+import Prelude ()
jsaddle/src-ghc/Data/JSString/Internal/Fusion/Types.hsnew file+122
@@ -0,0 +1,122 @@
1+{-# LANGUAGE BangPatterns, ExistentialQuantification #-}
2+-- |
3+-- Module : Data.Text.Internal.Fusion.Types
4+-- Copyright : (c) Tom Harper 2008-2009,
5+-- (c) Bryan O'Sullivan 2009,
6+-- (c) Duncan Coutts 2009,
7+-- (c) Jasper Van der Jeugt 2011
8+--
9+-- License : BSD-style
10+-- Maintainer : bos@serpentine.com
11+-- Stability : experimental
12+-- Portability : GHC
13+--
14+-- /Warning/: this is an internal module, and does not have a stable
15+-- API or name. Functions in this module may not check or enforce
16+-- preconditions expected by public modules. Use at your own risk!
17+--
18+-- Core stream fusion functionality for text.
19+
20+module Data.JSString.Internal.Fusion.Types
21+ (
22+ CC(..)
23+-- , M(..)
24+-- , M8
25+ , PairS(..)
26+ , RS(..)
27+ , Step(..)
28+ , Stream(..)
29+-- , Switch(..)
30+ , empty
31+ ) where
32+
33+import Data.Text.Internal.Fusion.Types
34+-- import Data.Text.Internal.Fusion.Size
35+-- import Data.Word (Word8)
36+
37+---- | Specialised tuple for case conversion.
38+--data CC s = CC !s {-# UNPACK #-} !Char {-# UNPACK #-} !Char
39+--
40+---- | Specialised, strict Maybe-like type.
41+--data M a = N
42+-- | J !a
43+--
44+--type M8 = M Word8
45+--
46+---- Restreaming state.
47+--data RS s
48+-- = RS0 !s
49+-- | RS1 !s {-# UNPACK #-} !Word8
50+-- | RS2 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
51+-- | RS3 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
52+--
53+--infixl 2 :*:
54+--data PairS a b = !a :*: !b
55+-- -- deriving (Eq, Ord, Show)
56+--
57+---- | Allow a function over a stream to switch between two states.
58+--data Switch = S1 | S2
59+--
60+--data Step s a = Done
61+-- | Skip !s
62+-- | Yield !a !s
63+--
64+--{-
65+--instance (Show a) => Show (Step s a)
66+-- where show Done = "Done"
67+-- show (Skip _) = "Skip"
68+-- show (Yield x _) = "Yield " ++ show x
69+---}
70+--
71+--instance (Eq a) => Eq (Stream a) where
72+-- (==) = eq
73+--
74+--instance (Ord a) => Ord (Stream a) where
75+-- compare = cmp
76+--
77+---- The length hint in a Stream has two roles. If its value is zero,
78+---- we trust it, and treat the stream as empty. Otherwise, we treat it
79+---- as a hint: it should usually be accurate, so we use it when
80+---- unstreaming to decide what size array to allocate. However, the
81+---- unstreaming functions must be able to cope with the hint being too
82+---- small or too large.
83+--
84+--data Stream a =
85+-- forall s. Stream
86+-- (s -> Step s a) -- stepper function
87+-- !s -- current state
88+--
89+---- | /O(n)/ Determines if two streams are equal.
90+--eq :: (Eq a) => Stream a -> Stream a -> Bool
91+--eq (Stream next1 s1) (Stream next2 s2) = loop (next1 s1) (next2 s2)
92+-- where
93+-- loop Done Done = True
94+-- loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
95+-- loop (Skip s1') x2 = loop (next1 s1') x2
96+-- loop x1 (Skip s2') = loop x1 (next2 s2')
97+-- loop Done _ = False
98+-- loop _ Done = False
99+-- loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
100+-- loop (next1 s1') (next2 s2')
101+--{-# INLINE [0] eq #-}
102+--
103+--cmp :: (Ord a) => Stream a -> Stream a -> Ordering
104+--cmp (Stream next1 s1) (Stream next2 s2) = loop (next1 s1) (next2 s2)
105+-- where
106+-- loop Done Done = EQ
107+-- loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
108+-- loop (Skip s1') x2 = loop (next1 s1') x2
109+-- loop x1 (Skip s2') = loop x1 (next2 s2')
110+-- loop Done _ = LT
111+-- loop _ Done = GT
112+-- loop (Yield x1 s1') (Yield x2 s2') =
113+-- case compare x1 x2 of
114+-- EQ -> loop (next1 s1') (next2 s2')
115+-- other -> other
116+--{-# INLINE [0] cmp #-}
117+--
118+---- | The empty stream.
119+--empty :: Stream a
120+--empty = Stream next ()
121+-- where next _ = Done
122+--{-# INLINE [0] empty #-}
jsaddle/src-ghc/Data/JSString/Internal/Search.hsnew file+11
@@ -0,0 +1,11 @@
1+module Data.JSString.Internal.Search ( indices
2+ ) where
3+
4+import Data.Coerce (coerce)
5+
6+import Data.JSString.Internal.Type (JSString(..))
7+
8+import qualified Data.Text.Internal.Search as T
9+
10+indices :: JSString -> JSString -> [Int]
11+indices = coerce T.indices
jsaddle/src-ghc/Data/JSString/Internal/Type.hsnew file+116
@@ -0,0 +1,116 @@
1+{-# LANGUAGE DeriveDataTypeable, UnboxedTuples, MagicHash,
2+ BangPatterns, GeneralizedNewtypeDeriving #-}
3+{-# OPTIONS_HADDOCK not-home #-}
4+module Data.JSString.Internal.Type ( JSString(..)
5+ , empty
6+ , empty_
7+ , safe
8+ , firstf
9+ ) where
10+
11+ {-
12+ -- * Construction
13+ , text
14+ , textP
15+ -- * Safety
16+ , safe
17+ -- * Code that must be here for accessibility
18+ , empty
19+ , empty_
20+ -- * Utilities
21+ , firstf
22+ -- * Checked multiplication
23+ , mul
24+ , mul32
25+ , mul64
26+ -- * Debugging
27+ , showText
28+
29+ ) where
30+-}
31+import Control.DeepSeq
32+
33+import Data.Coerce (coerce)
34+import Data.Text (Text)
35+import qualified Data.Text as T (empty)
36+import Data.String (IsString)
37+import Data.Aeson (ToJSON(..), FromJSON(..))
38+import Data.Data (Data)
39+-- import Data.Text.Internal.Unsafe.Char (ord)
40+import Data.Typeable (Typeable)
41+import Data.Semigroup (Semigroup)
42+import GHC.Exts (Char(..), ord#, andI#, (/=#), isTrue#)
43+
44+-- | A wrapper around a JavaScript string
45+newtype JSString = JSString Text deriving(Show, Read, IsString, Semigroup, Monoid, Ord, Eq, Data, ToJSON, FromJSON, Typeable)
46+
47+instance NFData JSString where rnf !_ = ()
48+
49+-- | /O(1)/ The empty 'JSString'.
50+empty :: JSString
51+empty = coerce T.empty
52+{-# INLINE [1] empty #-}
53+
54+-- | A non-inlined version of 'empty'.
55+empty_ :: JSString
56+empty_ = coerce T.empty
57+{-# NOINLINE empty_ #-}
58+
59+safe :: Char -> Char
60+safe c@(C# cc)
61+ | isTrue# (andI# (ord# cc) 0x1ff800# /=# 0xd800#) = c
62+ | otherwise = '\xfffd'
63+{-# INLINE [0] safe #-}
64+
65+
66+-- | Apply a function to the first element of an optional pair.
67+firstf :: (a -> c) -> Maybe (a,b) -> Maybe (c,b)
68+firstf f (Just (a, b)) = Just (f a, b)
69+firstf _ Nothing = Nothing
70+
71+{-
72+-- | Checked multiplication. Calls 'error' if the result would
73+-- overflow.
74+mul :: Int -> Int -> Int
75+#if WORD_SIZE_IN_BITS == 64
76+mul a b = fromIntegral $ fromIntegral a `mul64` fromIntegral b
77+#else
78+mul a b = fromIntegral $ fromIntegral a `mul32` fromIntegral b
79+#endif
80+{-# INLINE mul #-}
81+infixl 7 `mul`
82+
83+-- | Checked multiplication. Calls 'error' if the result would
84+-- overflow.
85+mul64 :: Int64 -> Int64 -> Int64
86+mul64 a b
87+ | a >= 0 && b >= 0 = mul64_ a b
88+ | a >= 0 = -mul64_ a (-b)
89+ | b >= 0 = -mul64_ (-a) b
90+ | otherwise = mul64_ (-a) (-b)
91+{-# INLINE mul64 #-}
92+infixl 7 `mul64`
93+
94+mul64_ :: Int64 -> Int64 -> Int64
95+mul64_ a b
96+ | ahi > 0 && bhi > 0 = error "overflow"
97+ | top > 0x7fffffff = error "overflow"
98+ | total < 0 = error "overflow"
99+ | otherwise = total
100+ where (# ahi, alo #) = (# a `shiftR` 32, a .&. 0xffffffff #)
101+ (# bhi, blo #) = (# b `shiftR` 32, b .&. 0xffffffff #)
102+ top = ahi * blo + alo * bhi
103+ total = (top `shiftL` 32) + alo * blo
104+{-# INLINE mul64_ #-}
105+
106+-- | Checked multiplication. Calls 'error' if the result would
107+-- overflow.
108+mul32 :: Int32 -> Int32 -> Int32
109+mul32 a b = case fromIntegral a * fromIntegral b of
110+ ab | ab < min32 || ab > max32 -> error "overflow"
111+ | otherwise -> fromIntegral ab
112+ where min32 = -0x80000000 :: Int64
113+ max32 = 0x7fffffff
114+{-# INLINE mul32 #-}
115+infixl 7 `mul32`
116+-}
jsaddle/src-ghc/Data/JSString/Text.hsnew file+52
@@ -0,0 +1,52 @@
1+{- | Conversion between 'Data.Text.Text' and 'Data.JSString.JSString' -}
2+
3+module Data.JSString.Text
4+ ( textToJSString
5+ , textFromJSString
6+ , lazyTextToJSString
7+ , lazyTextFromJSString
8+ , textFromJSVal
9+ , lazyTextFromJSVal
10+ ) where
11+
12+import GHCJS.Prim.Internal (JSVal)
13+
14+import Data.Coerce (coerce)
15+import qualified Data.Text as T
16+import qualified Data.Text.Lazy as TL
17+
18+import Data.JSString.Internal.Type
19+
20+import Language.Javascript.JSaddle.Types (JSM, GHCJSPure(..))
21+import Language.Javascript.JSaddle.Native.Internal
22+ (valueToString)
23+
24+textToJSString :: T.Text -> JSString
25+textToJSString = coerce
26+{-# INLINE textToJSString #-}
27+
28+textFromJSString :: JSString -> T.Text
29+textFromJSString = coerce
30+{-# INLINE textFromJSString #-}
31+
32+lazyTextToJSString :: TL.Text -> JSString
33+lazyTextToJSString = coerce . TL.toStrict
34+{-# INLINE lazyTextToJSString #-}
35+
36+lazyTextFromJSString :: JSString -> TL.Text
37+lazyTextFromJSString = TL.fromStrict . coerce
38+{-# INLINE lazyTextFromJSString #-}
39+
40+-- | returns the empty Text if not a string
41+textFromJSVal :: JSVal -> GHCJSPure T.Text
42+textFromJSVal j = GHCJSPure $ textFromJSString <$> valToJSString j
43+{-# INLINE textFromJSVal #-}
44+
45+-- | returns the empty Text if not a string
46+lazyTextFromJSVal :: JSVal -> GHCJSPure TL.Text
47+lazyTextFromJSVal j = GHCJSPure $ lazyTextFromJSString <$> valToJSString j
48+{-# INLINE lazyTextFromJSVal #-}
49+
50+valToJSString :: JSVal -> JSM JSString
51+valToJSString = valueToString
52+{-# INLINE valToJSString #-}
jsaddle/src-ghc/GHCJS/Buffer.hsnew file+117
@@ -0,0 +1,117 @@
1+module GHCJS.Buffer
2+ ( Buffer
3+ , MutableBuffer
4+ , create
5+ , createFromArrayBuffer
6+ , thaw, freeze, clone
7+ -- * JavaScript properties
8+ , byteLength
9+ , getArrayBuffer
10+ , getUint8Array
11+ , getUint16Array
12+ , getInt32Array
13+ , getDataView
14+ , getFloat32Array
15+ , getFloat64Array
16+ -- * bytestring
17+ , toByteString, fromByteString
18+ ) where
19+
20+import GHCJS.Buffer.Types
21+
22+import Control.Lens.Operators ((^.))
23+
24+import Data.ByteString (ByteString)
25+import qualified Data.ByteString as BS
26+import qualified Data.ByteString.Base64 as B64 (encode, decode)
27+import Data.Text.Encoding (encodeUtf8, decodeUtf8)
28+
29+import qualified JavaScript.TypedArray.Internal.Types as I
30+import JavaScript.TypedArray.ArrayBuffer.Internal (SomeArrayBuffer(..))
31+import JavaScript.TypedArray.DataView.Internal (SomeDataView(..))
32+
33+import GHCJS.Marshal (FromJSVal(..))
34+import Language.Javascript.JSaddle.Types (JSM, GHCJSPure(..), ghcjsPure)
35+import Language.Javascript.JSaddle.Object (js, js2, jsg1, jsg3)
36+
37+create :: Int -> JSM MutableBuffer
38+create n | n >= 0 = SomeBuffer <$> jsg1 "h$newByteArray" n
39+ | otherwise = error "create: negative size"
40+{-# INLINE create #-}
41+
42+createFromArrayBuffer :: SomeArrayBuffer any -> GHCJSPure (SomeBuffer any)
43+createFromArrayBuffer (SomeArrayBuffer buf) = GHCJSPure $ SomeBuffer <$> jsg1 "h$wrapBuffer" buf
44+{-# INLINE createFromArrayBuffer #-}
45+
46+getArrayBuffer :: SomeBuffer any -> GHCJSPure (SomeArrayBuffer any)
47+getArrayBuffer (SomeBuffer buf) = GHCJSPure $ SomeArrayBuffer <$> buf ^. js "buf"
48+{-# INLINE getArrayBuffer #-}
49+
50+getInt32Array :: SomeBuffer any -> GHCJSPure (I.SomeInt32Array any)
51+getInt32Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "i3"
52+{-# INLINE getInt32Array #-}
53+
54+getUint8Array :: SomeBuffer any -> GHCJSPure (I.SomeUint8Array any)
55+getUint8Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "u8"
56+{-# INLINE getUint8Array #-}
57+
58+getUint16Array :: SomeBuffer any -> GHCJSPure (I.SomeUint16Array any)
59+getUint16Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "u1"
60+{-# INLINE getUint16Array #-}
61+
62+getFloat32Array :: SomeBuffer any -> GHCJSPure (I.SomeFloat32Array any)
63+getFloat32Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "f3"
64+{-# INLINE getFloat32Array #-}
65+
66+getFloat64Array :: SomeBuffer any -> GHCJSPure (I.SomeFloat64Array any)
67+getFloat64Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "f6"
68+{-# INLINE getFloat64Array #-}
69+
70+getDataView :: SomeBuffer any -> GHCJSPure (SomeDataView any)
71+getDataView (SomeBuffer buf) = GHCJSPure $ SomeDataView <$> buf ^. js "dv"
72+{-# INLINE getDataView #-}
73+
74+freeze :: MutableBuffer -> JSM Buffer
75+freeze = js_clone
76+{-# INLINE freeze #-}
77+
78+thaw :: Buffer -> JSM MutableBuffer
79+thaw = js_clone
80+{-# INLINE thaw #-}
81+
82+clone :: MutableBuffer -> JSM (SomeBuffer any2)
83+clone = js_clone
84+{-# INLINE clone #-}
85+
86+fromByteString :: ByteString -> GHCJSPure (Buffer, Int, Int)
87+fromByteString bs = GHCJSPure $ do
88+ buffer <- SomeBuffer <$> jsg1 "h$newByteArrayFromBase64String" (decodeUtf8 $ B64.encode bs)
89+ return (buffer, 0, BS.length bs)
90+{-# INLINE fromByteString #-}
91+
92+-- | Wrap a 'Buffer' into a 'ByteString' using the given offset
93+-- and length.
94+toByteString :: Int -> Maybe Int -> Buffer -> GHCJSPure ByteString
95+toByteString off mbLen buf = GHCJSPure $ do
96+ bufLen <- ghcjsPure $ byteLength buf
97+ case mbLen of
98+ _ | off < 0 -> error "toByteString: negative offset"
99+ | off > bufLen -> error "toByteString: offset past end of buffer"
100+ Just len | len < 0 -> error "toByteString: negative length"
101+ | len > bufLen - off -> error "toByteString: length past end of buffer"
102+ | otherwise -> ghcjsPure $ unsafeToByteString off len buf
103+ Nothing -> ghcjsPure $ unsafeToByteString off (bufLen - off) buf
104+
105+unsafeToByteString :: Int -> Int -> Buffer -> GHCJSPure ByteString
106+unsafeToByteString off len (SomeBuffer buf) = GHCJSPure $ do
107+ b64 <- jsg3 "h$byteArrayToBase64String" off len buf >>= fromJSValUnchecked
108+ return $ case B64.decode (encodeUtf8 b64) of
109+ Left err -> error $ "unsafeToByteString base 64 decode error :" ++ err
110+ Right bs -> bs
111+
112+byteLength :: SomeBuffer any -> GHCJSPure Int
113+byteLength (SomeBuffer buf) = GHCJSPure $ buf ^. js "len" >>= fromJSValUnchecked
114+{-# INLINE byteLength #-}
115+
116+js_clone :: SomeBuffer any1 -> JSM (SomeBuffer any2)
117+js_clone (SomeBuffer buf) = SomeBuffer <$> jsg1 "h$wrapBuffer" (buf ^. js "buf" ^. js2 "slice" (buf ^. js "u8" ^. js "byteOffset") (buf ^. js "len"))
jsaddle/src-ghc/GHCJS/Buffer/Types.hsnew file+11
@@ -0,0 +1,11 @@
1+{-# LANGUAGE DataKinds, KindSignatures, PolyKinds #-}
2+
3+module GHCJS.Buffer.Types where
4+
5+import GHCJS.Types
6+import GHCJS.Internal.Types
7+
8+newtype SomeBuffer (a :: MutabilityType s) = SomeBuffer JSVal
9+
10+type Buffer = SomeBuffer Immutable
11+type MutableBuffer = SomeBuffer Mutable
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.hsnew file+64
@@ -0,0 +1,64 @@
1+{-# LANGUAGE CPP #-}
2+-----------------------------------------------------------------------------
3+--
4+-- Module : Language.Javascript.JSaddle.Value
5+-- Copyright : (c) Hamish Mackenzie
6+-- License : MIT
7+--
8+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
9+--
10+-- |
11+--
12+-----------------------------------------------------------------------------
13+module GHCJS.Foreign (
14+ jsTrue
15+ , jsFalse
16+ , jsNull
17+ , toJSBool
18+-- , fromJSBool
19+ , jsUndefined
20+ , isTruthy
21+ , isNull
22+ , isUndefined
23+ , isObject
24+ , isFunction
25+ , isString
26+ , isBoolean
27+ , isSymbol
28+ , isNumber
29+ , JSType(..)
30+ , jsTypeOf
31+) where
32+
33+import GHCJS.Foreign.Internal
34+import Language.Javascript.JSaddle.Types (JSVal(..), GHCJSPure(..))
35+import Language.Javascript.JSaddle.Object (jsg1)
36+import GHCJS.Marshal (FromJSVal(..))
37+
38+isObject :: JSVal -> GHCJSPure Bool
39+isObject v = GHCJSPure $ jsg1 "h$isObject" v >>= fromJSValUnchecked
40+{-# INLINE isObject #-}
41+
42+isFunction :: JSVal -> GHCJSPure Bool
43+isFunction v = GHCJSPure $ jsg1 "h$isFunction" v >>= fromJSValUnchecked
44+{-# INLINE isFunction #-}
45+
46+isString :: JSVal -> GHCJSPure Bool
47+isString v = GHCJSPure $ jsg1 "h$isString" v >>= fromJSValUnchecked
48+{-# INLINE isString #-}
49+
50+isBoolean :: JSVal -> GHCJSPure Bool
51+isBoolean v = GHCJSPure $ jsg1 "h$isBoolean" v >>= fromJSValUnchecked
52+{-# INLINE isBoolean #-}
53+
54+isSymbol :: JSVal -> GHCJSPure Bool
55+isSymbol v = GHCJSPure $ jsg1 "h$isSymbol" v >>= fromJSValUnchecked
56+{-# INLINE isSymbol #-}
57+
58+isNumber :: JSVal -> GHCJSPure Bool
59+isNumber v = GHCJSPure $ jsg1 "h$isNumber" v >>= fromJSValUnchecked
60+{-# INLINE isNumber #-}
61+
62+jsTypeOf :: JSVal -> GHCJSPure JSType
63+jsTypeOf v = GHCJSPure $ toEnum <$> (jsg1 "h$jsonTypeOf" v >>= fromJSValUnchecked)
64+{-# INLINE jsTypeOf #-}
jsaddle/src-ghc/GHCJS/Foreign/Internal.hsnew file+67
@@ -0,0 +1,67 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.Javascript.JSaddle.Value
4+-- Copyright : (c) Hamish Mackenzie
5+-- License : MIT
6+--
7+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
8+--
9+-- |
10+--
11+-----------------------------------------------------------------------------
12+module GHCJS.Foreign.Internal (
13+ jsTrue
14+ , jsFalse
15+ , jsNull
16+ , toJSBool
17+-- , fromJSBool
18+ , jsUndefined
19+ , isTruthy
20+ , isNull
21+ , isUndefined
22+ , JSType(..)
23+) where
24+
25+import Language.Javascript.JSaddle.Types (JSVal(..), GHCJSPure(..))
26+import Language.Javascript.JSaddle.Native.Internal
27+ (valueToBool)
28+import Data.Typeable (Typeable)
29+import GHCJS.Prim (isNull, isUndefined)
30+import System.IO.Unsafe (unsafePerformIO)
31+import Data.IORef (newIORef)
32+
33+jsTrue :: JSVal
34+jsTrue = JSVal . unsafePerformIO $ newIORef 3
35+{-# NOINLINE jsTrue #-}
36+
37+jsFalse :: JSVal
38+jsFalse = JSVal . unsafePerformIO $ newIORef 2
39+{-# NOINLINE jsFalse #-}
40+
41+jsNull :: JSVal
42+jsNull = JSVal . unsafePerformIO $ newIORef 0
43+{-# NOINLINE jsNull #-}
44+
45+toJSBool :: Bool -> JSVal
46+toJSBool b = JSVal . unsafePerformIO . newIORef $ if b then 3 else 2
47+{-# NOINLINE toJSBool #-}
48+
49+jsUndefined :: JSVal
50+jsUndefined = JSVal . unsafePerformIO $ newIORef 1
51+{-# NOINLINE jsUndefined #-}
52+
53+isTruthy :: JSVal -> GHCJSPure Bool
54+isTruthy = GHCJSPure . valueToBool
55+{-# INLINE isTruthy #-}
56+
57+-- types returned by JS typeof operator
58+data JSType = Undefined
59+ | Object
60+ | Boolean
61+ | Number
62+ | String
63+ | Symbol
64+ | Function
65+ | Other -- ^ implementation dependent
66+ deriving (Show, Eq, Ord, Enum, Typeable)
67+
jsaddle/src-ghc/GHCJS/Internal/Types.hsnew file+16
@@ -0,0 +1,16 @@
1+module GHCJS.Internal.Types ( IsJSVal(..)
2+ , jsval
3+ , MutabilityType(..)
4+ , Mutable
5+ , Immutable
6+ , IsItMutable(..)
7+ , Mutability
8+ ) where
9+
10+import Language.Javascript.JSaddle.Types
11+import Language.Javascript.JSaddle.Native.Internal (stringToValue)
12+
13+instance IsJSVal JSString where
14+ jsval_ a = GHCJSPure $ stringToValue a
15+ {-# INLINE jsval_ #-}
16+
jsaddle/src-ghc/GHCJS/Marshal.hs+37−36
@@ -17,19 +17,23 @@ import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
1717
1818import qualified Data.Aeson as AE
1919import Data.Int (Int8, Int16, Int32)
20+import Data.Text (Text)
2021import Data.Word (Word8, Word16, Word32, Word)
2122
2223import GHC.Prim
2324
24−import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), Command(ValueToJSONValue), Result(ValueToJSONValueResult))
25−import Language.Javascript.JSaddle.Native (withToJSVal)
26−import Language.Javascript.JSaddle.Run(sendCommand)
27−import GHCJS.Marshal.Internal
25+import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), ghcjsPure)
26+import Language.Javascript.JSaddle.Native.Internal
27+ (valueToJSONValue, jsonValueToValue, valueToNumber)
28+
29+import GHCJS.Types (JSString, isUndefined, isNull)
30+import GHCJS.Foreign.Internal (isTruthy)
2831import GHCJS.Marshal.Pure ()
29−import Language.Javascript.JSaddle.Value (isUndefinedIO, valToNumber,
30− valToBool, valMakeJSON)
31−import Language.Javascript.JSaddle.Array (fromListIO)
32−import qualified Language.Javascript.JSaddle.Array as A (read)
32+
33+import JavaScript.Array (fromListIO)
34+import qualified JavaScript.Array as A (read)
35+
36+import GHCJS.Marshal.Internal
3337
3438instance FromJSVal JSVal where
3539 fromJSValUnchecked x = return x
@@ -42,65 +46,62 @@ instance FromJSVal () where
4246 fromJSVal = fromJSVal_pure
4347-- {-# INLINE fromJSVal #-}
4448instance FromJSVal Bool where
45− fromJSValUnchecked = valToBool
49+ fromJSValUnchecked = ghcjsPure . isTruthy
4650 {-# INLINE fromJSValUnchecked #-}
47− fromJSVal = fmap Just . valToBool
51+ fromJSVal = fmap Just . ghcjsPure . isTruthy
4852 {-# INLINE fromJSVal #-}
4953instance FromJSVal Int where
50− fromJSValUnchecked = fmap round . valToNumber
54+ fromJSValUnchecked = fmap round . valueToNumber
5155 {-# INLINE fromJSValUnchecked #-}
52− fromJSVal = fmap (Just . round) . valToNumber
56+ fromJSVal = fmap (Just . round) . valueToNumber
5357 {-# INLINE fromJSVal #-}
5458instance FromJSVal Int8 where
55− fromJSValUnchecked = fmap round . valToNumber
59+ fromJSValUnchecked = fmap round . valueToNumber
5660 {-# INLINE fromJSValUnchecked #-}
57− fromJSVal = fmap (Just . round) . valToNumber
61+ fromJSVal = fmap (Just . round) . valueToNumber
5862 {-# INLINE fromJSVal #-}
5963instance FromJSVal Int16 where
60− fromJSValUnchecked = fmap round . valToNumber
64+ fromJSValUnchecked = fmap round . valueToNumber
6165 {-# INLINE fromJSValUnchecked #-}
62− fromJSVal = fmap (Just . round) . valToNumber
66+ fromJSVal = fmap (Just . round) . valueToNumber
6367 {-# INLINE fromJSVal #-}
6468instance FromJSVal Int32 where
65− fromJSValUnchecked = fmap round . valToNumber
69+ fromJSValUnchecked = fmap round . valueToNumber
6670 {-# INLINE fromJSValUnchecked #-}
67− fromJSVal = fmap (Just . round) . valToNumber
71+ fromJSVal = fmap (Just . round) . valueToNumber
6872 {-# INLINE fromJSVal #-}
6973instance FromJSVal Word where
70− fromJSValUnchecked = fmap round . valToNumber
74+ fromJSValUnchecked = fmap round . valueToNumber
7175 {-# INLINE fromJSValUnchecked #-}
72− fromJSVal = fmap (Just . round) . valToNumber
76+ fromJSVal = fmap (Just . round) . valueToNumber
7377 {-# INLINE fromJSVal #-}
7478instance FromJSVal Word8 where
75− fromJSValUnchecked = fmap round . valToNumber
79+ fromJSValUnchecked = fmap round . valueToNumber
7680 {-# INLINE fromJSValUnchecked #-}
77− fromJSVal = fmap (Just . round) . valToNumber
81+ fromJSVal = fmap (Just . round) . valueToNumber
7882 {-# INLINE fromJSVal #-}
7983instance FromJSVal Word16 where
80− fromJSValUnchecked = fmap round . valToNumber
84+ fromJSValUnchecked = fmap round . valueToNumber
8185 {-# INLINE fromJSValUnchecked #-}
82− fromJSVal = fmap (Just . round) . valToNumber
86+ fromJSVal = fmap (Just . round) . valueToNumber
8387 {-# INLINE fromJSVal #-}
8488instance FromJSVal Word32 where
85− fromJSValUnchecked = fmap round . valToNumber
89+ fromJSValUnchecked = fmap round . valueToNumber
8690 {-# INLINE fromJSValUnchecked #-}
87− fromJSVal = fmap (Just . round) . valToNumber
91+ fromJSVal = fmap (Just . round) . valueToNumber
8892 {-# INLINE fromJSVal #-}
8993instance FromJSVal Float where
90− fromJSValUnchecked = fmap realToFrac . valToNumber
94+ fromJSValUnchecked = fmap realToFrac . valueToNumber
9195 {-# INLINE fromJSValUnchecked #-}
92− fromJSVal = fmap (Just . realToFrac) . valToNumber
96+ fromJSVal = fmap (Just . realToFrac) . valueToNumber
9397 {-# INLINE fromJSVal #-}
9498instance FromJSVal Double where
95− fromJSValUnchecked = valToNumber
99+ fromJSValUnchecked = valueToNumber
96100 {-# INLINE fromJSValUnchecked #-}
97− fromJSVal = fmap Just . valToNumber
101+ fromJSVal = fmap Just . valueToNumber
98102 {-# INLINE fromJSVal #-}
99103instance FromJSVal AE.Value where
100− fromJSVal r =
101− withToJSVal r $ \rval -> do
102− ~(ValueToJSONValueResult result) <- sendCommand (ValueToJSONValue rval)
103− return $ Just result
104+ fromJSVal r = Just <$> valueToJSONValue r
104105 {-# INLINE fromJSVal #-}
105106instance (FromJSVal a, FromJSVal b) => FromJSVal (a,b) where
106107 fromJSVal r = runMaybeT $ (,) <$> jf r 0 <*> jf r 1
@@ -127,7 +128,7 @@ instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJ
127128jf :: FromJSVal a => JSVal -> Int -> MaybeT JSM a
128129jf r n = MaybeT $ do
129130 r' <- A.read n (SomeJSArray r)
130− isUndefinedIO r >>= \case
131+ ghcjsPure (isUndefined r) >>= \case
131132 True -> return Nothing
132133 False -> fromJSVal r'
133134
@@ -164,5 +165,5 @@ arr7 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSM JSVal
164165arr7 a b c d e f g = coerce <$> fromListIO [a,b,c,d,e,f,g]
165166
166167toJSVal_aeson :: AE.ToJSON a => a -> JSM JSVal
167−toJSVal_aeson = valMakeJSON . AE.toJSON
168+toJSVal_aeson = jsonValueToValue . AE.toJSON
168169
jsaddle/src-ghc/GHCJS/Marshal/Internal.hs+66−32
@@ -1,21 +1,21 @@
1−{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, DefaultSignatures,
1+{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, DefaultSignatures,
22 TypeOperators, TupleSections, FlexibleContexts, FlexibleInstances,
33 LambdaCase
44 #-}
55
6−module GHCJS.Marshal.Internal (
7− FromJSVal(..)
8− , ToJSVal(..)
9− , PToJSVal(..)
10− , PFromJSVal(..)
11− , Purity(..)
12− , toJSVal_generic
13− , fromJSVal_generic
14− , toJSVal_pure
15− , fromJSVal_pure
16− , fromJSValUnchecked_pure
17− ) where
18−
6+module GHCJS.Marshal.Internal ( FromJSVal(..)
7+ , ToJSVal(..)
8+ , PToJSVal(..)
9+ , PFromJSVal(..)
10+ , Purity(..)
11+ , toJSVal_generic
12+ , fromJSVal_generic
13+ , toJSVal_pure
14+ , fromJSVal_pure
15+ , fromJSValUnchecked_pure
16+ ) where
17+
18+import Control.Applicative
1919import Control.Monad
2020
2121import Data.Data
@@ -25,11 +25,17 @@ import qualified Data.Text as T (pack)
2525
2626import GHC.Generics
2727
28−import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), MutableJSArray, JSString)
29−import Language.Javascript.JSaddle.Foreign (jsNull, jsTrue, isUndefinedIO)
30−import Language.Javascript.JSaddle.String (textToStr)
28+import qualified GHCJS.Prim.Internal as Prim
29+import qualified GHCJS.Foreign.Internal as F
30+import GHCJS.Types
31+
32+import qualified Data.JSString.Internal.Type as JSS
33+
3134import qualified JavaScript.Object.Internal as OI (Object(..), create, setProp, getProp)
32−import qualified JavaScript.Array.Internal as AI (create, push, read, fromListIO, toListIO)
35+import qualified JavaScript.Array.Internal as AI (SomeJSArray(..), create, push, read, fromListIO, toListIO)
36+
37+import Language.Javascript.JSaddle.Types (JSM, MutableJSArray, GHCJSPure(..), ghcjsPure, ghcjsPureMap, JSadddleHasCallStack)
38+import Language.Javascript.JSaddle.String (textToStr)
3339
3440data Purity = PureShared -- ^ conversion is pure even if the original value is shared
3541 | PureExclusive -- ^ conversion is pure if the we only convert once
@@ -49,25 +55,53 @@ class ToJSVal a where
4955 toJSValListOf :: [a] -> JSM JSVal
5056 toJSValListOf = fmap coerce . AI.fromListIO <=< mapM toJSVal
5157
58+ -- default toJSVal :: PToJSVal a => a -> JSM (JSVal a)
59+ -- toJSVal x = return (pToJSVal x)
60+
5261 default toJSVal :: (Generic a, GToJSVal (Rep a ())) => a -> JSM JSVal
5362 toJSVal = toJSVal_generic id
5463
64+fromJustWithStack :: JSadddleHasCallStack => Maybe a -> a
65+fromJustWithStack Nothing = error "fromJSValUnchecked: fromJSVal result was Nothing"
66+fromJustWithStack (Just x) = x
67+
5568class FromJSVal a where
5669 fromJSVal :: JSVal -> JSM (Maybe a)
5770
71+#if MIN_VERSION_base(4,9,0) && defined(JSADDLE_HAS_CALL_STACK)
72+ fromJSValUnchecked :: JSadddleHasCallStack => JSVal -> JSM a
73+#ifdef CHECK_UNCHECKED
74+ fromJSValUnchecked v = fromJSVal v >>= \case
75+ Nothing -> error "fromJSValUnchecked: fromJSVal result was Nothing"
76+ Just x -> return x
77+#else
78+ fromJSValUnchecked = fmap fromJustWithStack . fromJSVal
79+#endif
80+#else
5881 fromJSValUnchecked :: JSVal -> JSM a
5982 fromJSValUnchecked = fmap fromJust . fromJSVal
83+#endif
6084 {-# INLINE fromJSValUnchecked #-}
6185
6286 fromJSValListOf :: JSVal -> JSM (Maybe [a])
6387 fromJSValListOf = fmap sequence . (mapM fromJSVal <=< AI.toListIO . coerce) -- fixme should check that it's an array
6488
89+#if MIN_VERSION_base(4,9,0) && defined(JSADDLE_HAS_CALL_STACK)
90+ fromJSValUncheckedListOf :: JSadddleHasCallStack => JSVal -> JSM [a]
91+#else
6592 fromJSValUncheckedListOf :: JSVal -> JSM [a]
93+#endif
6694 fromJSValUncheckedListOf = mapM fromJSValUnchecked <=< AI.toListIO . coerce
6795
96+ -- default fromJSVal :: PFromJSVal a => JSVal a -> JSM (Maybe a)
97+ -- fromJSVal x = return (Just (pFromJSVal x))
98+
6899 default fromJSVal :: (Generic a, GFromJSVal (Rep a ())) => JSVal -> JSM (Maybe a)
69100 fromJSVal = fromJSVal_generic id
70101
102+ -- default fromJSValUnchecked :: PFromJSVal a => a -> IO a
103+ -- fromJSValUnchecked x = return (pFromJSVal x)
104+
71105-- -----------------------------------------------------------------------------
72106
73107class GToJSVal a where
@@ -92,8 +126,8 @@ instance (GToJSVal (a p), GToJSVal (b p)) => GToJSVal ((a :+: b) p) where
92126 gToJSVal f _ (L1 x) = gToJSVal f True x
93127 gToJSVal f _ (R1 x) = gToJSVal f True x
94128
95−instance (GToJSVal (a p)) => GToJSVal (M1 D c a p) where
96− gToJSVal f b (M1 x) = gToJSVal f b x
129+instance (Datatype c, GToJSVal (a p)) => GToJSVal (M1 D c a p) where
130+ gToJSVal f b m@(M1 x) = gToJSVal f b x
97131
98132instance (Constructor c, GToJSVal (a p)) => GToJSVal (M1 C c a p) where
99133 gToJSVal f True m@(M1 x) = do
@@ -109,7 +143,7 @@ instance (GToJSArr (a p), GToJSArr (b p), GToJSProp (a p), GToJSProp (b p)) => G
109143 gToJSProp f obj' xy
110144 return obj'
111145 gToJSVal f False xy = do
112− arr@(SomeJSArray arr') <- AI.create
146+ arr@(AI.SomeJSArray arr') <- AI.create
113147 gToJSArr f arr xy
114148 return arr'
115149
@@ -133,10 +167,10 @@ instance GToJSVal (a p) => GToJSArr (M1 S c a p) where
133167 AI.push r a
134168
135169instance GToJSVal (V1 p) where
136− gToJSVal _ _ _ = return jsNull
170+ gToJSVal _ _ _ = return Prim.jsNull
137171
138172instance GToJSVal (U1 p) where
139− gToJSVal _ _ _ = return jsTrue
173+ gToJSVal _ _ _ = return F.jsTrue
140174
141175toJSVal_generic :: forall a . (Generic a, GToJSVal (Rep a ()))
142176 => (String -> String) -> a -> JSM JSVal
@@ -163,26 +197,26 @@ instance GFromJSVal (f p) => GFromJSVal (Rec1 f p) where
163197 gFromJSVal f b r = gFromJSVal f b r
164198
165199instance (GFromJSVal (a p), GFromJSVal (b p)) => GFromJSVal ((a :+: b) p) where
166− gFromJSVal f _b r = do
200+ gFromJSVal f b r = do
167201 l <- gFromJSVal f True r
168202 case l of
169203 Just x -> return (L1 <$> Just x)
170204 Nothing -> fmap R1 <$> gFromJSVal f True r
171205
172−instance GFromJSVal (a p) => GFromJSVal (M1 D c a p) where
206+instance (Datatype c, GFromJSVal (a p)) => GFromJSVal (M1 D c a p) where
173207 gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r
174208
175209instance forall c a p . (Constructor c, GFromJSVal (a p)) => GFromJSVal (M1 C c a p) where
176210 gFromJSVal f True r = do
177211 r' <- OI.getProp (packJSS . f $ conName (undefined :: M1 C c a p)) (OI.Object r)
178− isUndefinedIO r' >>= \case
212+ ghcjsPure (isUndefined r') >>= \case
179213 True -> return Nothing
180214 False -> fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r'
181215 gFromJSVal f _ r = fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r
182216
183217instance (GFromJSArr (a p), GFromJSArr (b p), GFromJSProp (a p), GFromJSProp (b p)) => GFromJSVal ((a :*: b) p) where
184218 gFromJSVal f True r = gFromJSProp f r
185− gFromJSVal f False r = fmap fst <$> gFromJSArr f (SomeJSArray r) 0
219+ gFromJSVal f False r = fmap fst <$> gFromJSArr f (AI.SomeJSArray r) 0
186220
187221instance GFromJSVal (a p) => GFromJSVal (M1 S c a p) where
188222 gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r
@@ -197,7 +231,7 @@ instance (GFromJSProp (a p), GFromJSProp (b p)) => GFromJSProp ((a :*: b) p) whe
197231instance forall c a p . (Selector c, GFromJSVal (a p)) => GFromJSProp (M1 S c a p) where
198232 gFromJSProp f o = do
199233 p <- OI.getProp (packJSS . f $ selName (undefined :: M1 S c a p)) (OI.Object o)
200− isUndefinedIO p >>= \case
234+ ghcjsPure (isUndefined p) >>= \case
201235 True -> return Nothing
202236 False -> fmap M1 <$> gFromJSVal f False p
203237
@@ -214,7 +248,7 @@ instance (GFromJSArr (a p), GFromJSArr (b p)) => GFromJSArr ((a :*: b) p) where
214248instance (GFromJSVal (a p)) => GFromJSArr (M1 S c a p) where
215249 gFromJSArr f o n = do
216250 r <- AI.read n o
217− isUndefinedIO r >>= \case
251+ ghcjsPure (isUndefined r) >>= \case
218252 True -> return Nothing
219253 False -> fmap ((,n+1) . M1) <$> gFromJSVal f False r
220254
@@ -231,15 +265,15 @@ fromJSVal_generic f x = fmap to <$> (gFromJSVal f False x :: JSM (Maybe (Rep a (
231265-- -----------------------------------------------------------------------------
232266
233267fromJSVal_pure :: PFromJSVal a => JSVal -> JSM (Maybe a)
234−fromJSVal_pure x = return (Just (pFromJSVal x))
268+fromJSVal_pure = return . Just . pFromJSVal
235269{-# INLINE fromJSVal_pure #-}
236270
237271fromJSValUnchecked_pure :: PFromJSVal a => JSVal -> JSM a
238−fromJSValUnchecked_pure x = return (pFromJSVal x)
272+fromJSValUnchecked_pure = return . pFromJSVal
239273{-# INLINE fromJSValUnchecked_pure #-}
240274
241275toJSVal_pure :: PToJSVal a => a -> JSM JSVal
242−toJSVal_pure x = return (pToJSVal x)
276+toJSVal_pure = return . pToJSVal
243277{-# INLINE toJSVal_pure #-}
244278
245279-- -----------------------------------------------------------------------------
jsaddle/src-ghc/GHCJS/Marshal/Pure.hs+5−6
@@ -1,12 +1,11 @@
11{-# OPTIONS_GHC -fno-warn-orphans #-}
2−module GHCJS.Marshal.Pure
3− ( PFromJSVal(..)
4− , PToJSVal(..)
5− ) where
2+module GHCJS.Marshal.Pure ( PFromJSVal(..)
3+ , PToJSVal(..)
4+ ) where
65
6+import GHCJS.Types
7+import GHCJS.Foreign.Internal (jsFalse, jsTrue)
78import GHCJS.Marshal.Internal
8−import Language.Javascript.JSaddle.Types (JSVal(..))
9−import Language.Javascript.JSaddle.Foreign (jsFalse, jsTrue)
109
1110instance PFromJSVal JSVal where pFromJSVal = id
1211 {-# INLINE pFromJSVal #-}
jsaddle/src-ghc/GHCJS/Prim.hsnew file+84
@@ -0,0 +1,84 @@
1+{-# LANGUAGE MagicHash #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+
5+module GHCJS.Prim ( module GHCJS.Prim.Internal
6+ , fromJSString
7+ , toJSString
8+ , isNull
9+ , isUndefined
10+ ) where
11+
12+import GHCJS.Prim.Internal
13+--import Data.Int (Int64)
14+--import Data.Typeable (Typeable)
15+--import Unsafe.Coerce (unsafeCoerce)
16+
17+--import Data.Aeson (ToJSON(..), FromJSON(..))
18+import qualified Data.Text as T (unpack, pack)
19+import Data.JSString.Text (textFromJSVal)
20+
21+--import GHC.Prim
22+--import qualified GHC.Exception as Ex
23+--import qualified GHC.Exts as Exts
24+
25+import Language.Javascript.JSaddle.Types (JSVal(..), JSString(..), GHCJSPure(..), ghcjsPureMap)
26+import qualified Language.Javascript.JSaddle.Native.Internal as N
27+ (stringToValue, isNull, isUndefined)
28+{- | Low-level conversion utilities for packages that cannot
29+ depend on ghcjs-base
30+ -}
31+
32+fromJSString :: JSVal -> GHCJSPure String
33+fromJSString = ghcjsPureMap T.unpack . textFromJSVal
34+{-# INLINE fromJSString #-}
35+
36+toJSString :: String -> GHCJSPure JSVal
37+toJSString s = GHCJSPure $ N.stringToValue (JSString $ T.pack s)
38+{-# INLINE toJSString #-}
39+
40+--fromJSArray :: JSVal -> IO [JSVal]
41+--fromJSArray = unsafeCoerce . js_fromJSArray
42+--{-# INLINE fromJSArray #-}
43+--
44+--toJSArray :: [JSVal] -> IO JSVal
45+--toJSArray = js_toJSArray . unsafeCoerce . seqList
46+--{-# INLINE toJSArray #-}
47+--
48+--{- | returns zero if the JSVal does not contain a number
49+-- -}
50+--fromJSInt :: JSVal -> Int
51+--fromJSInt = js_fromJSInt
52+--{-# INLINE fromJSInt #-}
53+--
54+--toJSInt :: Int -> JSVal
55+--toJSInt = js_toJSInt
56+--{-# INLINE toJSInt #-}
57+--
58+
59+isNull :: JSVal -> GHCJSPure Bool
60+isNull = GHCJSPure . N.isNull
61+{-# INLINE isNull #-}
62+
63+isUndefined :: JSVal -> GHCJSPure Bool
64+isUndefined = GHCJSPure . N.isUndefined
65+{-# INLINE isUndefined #-}
66+
67+--getProp :: JSVal -> String -> IO JSVal
68+--getProp o p = js_getProp o (unsafeCoerce $ seqList p)
69+--{-# INLINE getProp #-}
70+--
71+--getProp' :: JSVal -> JSVal -> IO JSVal
72+--getProp' o p = js_getProp' o p
73+--{-# INLINE getProp' #-}
74+--
75+---- reduce the spine and all list elements to whnf
76+--seqList :: [a] -> [a]
77+--seqList xs = go xs `seq` xs
78+-- where go (x:xs) = x `seq` go xs
79+-- go [] = ()
80+--
81+--seqListSpine :: [a] -> [a]
82+--seqListSpine xs = go xs `seq` xs
83+-- where go (x:xs) = go xs
84+-- go [] = ()
jsaddle/src-ghc/GHCJS/Prim/Internal.hsnew file+68
@@ -0,0 +1,68 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+
4+module GHCJS.Prim.Internal ( JSVal(..)
5+ , JSValueRef
6+ , JSException(..)
7+ , WouldBlockException(..)
8+ , mkJSException
9+ , jsNull
10+ ) where
11+
12+import Control.DeepSeq (NFData(..))
13+import Data.Int (Int64)
14+import Data.Typeable (Typeable)
15+import Unsafe.Coerce (unsafeCoerce)
16+
17+import Data.Aeson (ToJSON(..), FromJSON(..))
18+
19+import qualified GHC.Exception as Ex
20+import Data.IORef (newIORef, IORef)
21+import System.IO.Unsafe (unsafePerformIO)
22+
23+-- A reference to a particular JavaScript value inside the JavaScript context
24+type JSValueRef = Int64
25+
26+{-
27+ JSVal is a boxed type that can be used as FFI
28+ argument or result.
29+-}
30+newtype JSVal = JSVal (IORef JSValueRef)
31+
32+instance NFData JSVal where
33+ rnf x = x `seq` ()
34+
35+
36+{-
37+ When a JavaScript exception is raised inside
38+ a safe or interruptible foreign call, it is converted
39+ to a JSException
40+ -}
41+data JSException = JSException JSVal String
42+ deriving (Typeable)
43+
44+instance Ex.Exception JSException
45+
46+instance Show JSException where
47+ show (JSException _ xs) = "JavaScript exception: " ++ xs
48+
49+mkJSException :: JSVal -> IO JSException
50+mkJSException ref =
51+ return (JSException (unsafeCoerce ref) "")
52+
53+jsNull :: JSVal
54+jsNull = JSVal . unsafePerformIO $ newIORef 0
55+{-# NOINLINE jsNull #-}
56+
57+{- | If a synchronous thread tries to do something that can only
58+ be done asynchronously, and the thread is set up to not
59+ continue asynchronously, it receives this exception.
60+ -}
61+data WouldBlockException = WouldBlockException
62+ deriving (Typeable)
63+
64+instance Show WouldBlockException where
65+ show _ = "thread would block"
66+
67+instance Ex.Exception WouldBlockException
68+
jsaddle/src-ghc/GHCJS/Types.hsnew file+60
@@ -0,0 +1,60 @@
1+{-# LANGUAGE EmptyDataDecls #-}
2+{-# LANGUAGE MagicHash #-}
3+{-# LANGUAGE BangPatterns #-}
4+
5+module GHCJS.Types ( JSVal
6+ , WouldBlockException(..)
7+ , JSException(..)
8+ , IsJSVal
9+ , jsval
10+ , isNull
11+ , isUndefined
12+ , nullRef
13+ , JSString
14+ , mkRef
15+ , Ref#
16+-- , toPtr
17+-- , fromPtr
18+ , JSRef
19+ ) where
20+
21+import Data.JSString.Internal.Type (JSString)
22+import GHCJS.Internal.Types
23+
24+import GHCJS.Prim
25+
26+import GHC.Int
27+import GHC.Types
28+import GHC.Prim
29+import GHC.Ptr
30+import GHC.IORef
31+import GHC.IO.Unsafe (unsafePerformIO)
32+
33+import Control.DeepSeq
34+import Unsafe.Coerce
35+
36+type Ref# = IORef Int64
37+
38+mkRef :: Ref# -> JSVal
39+mkRef = JSVal
40+{-# INLINE mkRef #-}
41+
42+nullRef :: JSVal
43+nullRef = JSVal . unsafePerformIO $ newIORef 0
44+{-# NOINLINE nullRef #-}
45+
46+--toPtr :: JSVal -> Ptr a
47+--toPtr (JSVal x) = unsafeCoerce (Ptr' x 0#)
48+--{-# INLINE toPtr #-}
49+--
50+--fromPtr :: Ptr a -> JSVal
51+--fromPtr p = js_ptrVal p
52+--{-# INLINE fromPtr #-}
53+--
54+--data Ptr' a = Ptr' ByteArray# Int#
55+
56+-- | This is a deprecated copmatibility wrapper for the old JSRef type.
57+--
58+-- See https://github.com/ghcjs/ghcjs/issues/421
59+type JSRef a = JSVal
60+{-# DEPRECATED JSRef "Use JSVal instead, or a more specific newtype wrapper of JSVal " #-}
jsaddle/src/Language/Javascript/JSaddle/Array.hs → jsaddle/src-ghc/JavaScript/Array.hsrenamed+36−23
@@ -1,17 +1,6 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE TypeSynonymInstances #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−{-# LANGUAGE Rank2Types #-}
6−#ifdef ghcjs_HOST_OS
7−{-# LANGUAGE ForeignFunctionInterface #-}
8−{-# LANGUAGE JavaScriptFFI #-}
9−{-# OPTIONS_GHC -Wno-dodgy-exports -Wno-dodgy-imports #-}
10−#endif
11−{-# OPTIONS_GHC -fno-warn-orphans #-}
121-----------------------------------------------------------------------------
132--
14−-- Module : Language.Javascript.JSaddle.Object
3+-- Module : JavaScript.Array
154-- Copyright : (c) Hamish Mackenzie
165-- License : MIT
176--
@@ -20,17 +9,19 @@
209-- | Interface to JavaScript array
2110--
2211-----------------------------------------------------------------------------
23−
24−module Language.Javascript.JSaddle.Array
12+module JavaScript.Array
2513 ( SomeJSArray(..)
2614 , JSArray
2715 , MutableJSArray
2816 , create
2917 , length
3018 , lengthIO
31− , nullIO
19+ , null
20+ , fromList
3221 , fromListIO
22+ , toList
3323 , toListIO
24+ , index, (!)
3425 , read
3526 , write
3627 , append
@@ -39,8 +30,11 @@ module Language.Javascript.JSaddle.Array
3930 , unshift
4031 , shift
4132 , reverse
33+ , take
4234 , takeIO
35+ , drop
4336 , dropIO
37+ , slice
4438 , sliceIO
4539 , freeze
4640 , unsafeFreeze
@@ -48,30 +42,34 @@ module Language.Javascript.JSaddle.Array
4842 , unsafeThaw
4943 ) where
5044
51−import Prelude hiding (read, reverse, null)
45+import Prelude hiding (length, drop, read, take, reverse, null)
5246import Control.Monad (void)
5347import Language.Javascript.JSaddle.Types
5448 (JSM, JSVal, SomeJSArray(..), JSArray,
55− MutableJSArray)
49+ MutableJSArray, GHCJSPure(..))
5650import Control.Lens.Operators ((^.))
57−import Language.Javascript.JSaddle.Object (js2, js0, (##), js1, js)
51+import Language.Javascript.JSaddle.Object (js2, js0, (<##), js1, js)
5852import Language.Javascript.JSaddle.Value (valToNumber)
59−import JavaScript.Array.Internal (create, fromListIO, toListIO, read, push)
53+import JavaScript.Array.Internal (create, fromList, fromListIO, toList, toListIO, index, read, push)
54+
55+length :: SomeJSArray m -> GHCJSPure Int
56+length = GHCJSPure . lengthIO
57+{-# INLINE length #-}
6058
6159lengthIO :: SomeJSArray m -> JSM Int
6260lengthIO (SomeJSArray x) = round <$> (x ^. js "length" >>= valToNumber)
6361{-# INLINE lengthIO #-}
6462
65−nullIO :: SomeJSArray m -> JSM Bool
66−nullIO = fmap (== 0) . lengthIO
67−{-# INLINE nullIO #-}
63+null :: SomeJSArray m -> GHCJSPure Bool
64+null = GHCJSPure . fmap (== 0) . lengthIO
65+{-# INLINE null #-}
6866
6967append :: SomeJSArray m -> SomeJSArray m -> JSM (SomeJSArray m1)
7068append (SomeJSArray x) (SomeJSArray y) = SomeJSArray <$> x ^. js1 "concat" y
7169{-# INLINE append #-}
7270
7371write :: Int -> JSVal -> MutableJSArray -> JSM ()
74−write n e (SomeJSArray x) = void $ (x ## n) e
72+write n e (SomeJSArray x) = void $ (x <## n) e
7573{-# INLINE write #-}
7674
7775pop :: MutableJSArray -> JSM JSVal
@@ -90,14 +88,26 @@ reverse :: MutableJSArray -> JSM ()
9088reverse (SomeJSArray x) = void $ x ^. js0 "reverse"
9189{-# INLINE reverse #-}
9290
91+take :: Int -> SomeJSArray m -> GHCJSPure (SomeJSArray m1)
92+take n = GHCJSPure . takeIO n
93+{-# INLINE take #-}
94+
9395takeIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1)
9496takeIO n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" (0::Int) n
9597{-# INLINE takeIO #-}
9698
99+drop :: Int -> SomeJSArray m -> GHCJSPure (SomeJSArray m1)
100+drop n = GHCJSPure . dropIO n
101+{-# INLINE drop #-}
102+
97103dropIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1)
98104dropIO n (SomeJSArray x) = SomeJSArray <$> x ^. js1 "slice1" n
99105{-# INLINE dropIO #-}
100106
107+slice :: Int -> Int -> JSArray -> GHCJSPure (SomeJSArray m1)
108+slice s n = GHCJSPure . sliceIO s n
109+{-# INLINE slice #-}
110+
101111sliceIO :: Int -> Int -> JSArray -> JSM (SomeJSArray m1)
102112sliceIO s n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" s n
103113{-# INLINE sliceIO #-}
@@ -118,4 +128,7 @@ unsafeThaw :: JSArray -> JSM MutableJSArray
118128unsafeThaw (SomeJSArray x) = pure (SomeJSArray x)
119129{-# INLINE unsafeThaw #-}
120130
131+(!) :: JSArray -> Int -> GHCJSPure JSVal
132+x ! n = GHCJSPure $ read n x
133+{-# INLINE (!) #-}
121134
jsaddle/src-ghc/JavaScript/Array/Internal.hs+33−20
@@ -1,46 +1,59 @@
11{-# LANGUAGE OverloadedStrings #-}
22module JavaScript.Array.Internal
3− ( create
3+ ( SomeJSArray(..)
4+ , JSArray
5+ , MutableJSArray
6+ , STJSArray
7+ , create
8+ , fromList
49 , fromListIO
10+ , toList
511 , toListIO
12+ , index
613 , read
714 , push
815 ) where
916
1017import Prelude hiding(read)
1118import Control.Monad (void)
12−import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), MutableJSArray, Object(..), JSString(..))
19+import GHCJS.Types (JSVal)
20+import Data.JSString.Internal.Type (JSString(..))
21+import Language.Javascript.JSaddle.Types (JSM, SomeJSArray(..), JSArray, MutableJSArray, STJSArray, Object(..), GHCJSPure(..))
1322import Language.Javascript.JSaddle.Native.Internal
14− (withObject, withJSVal, withJSString, withJSVals)
15−import Language.Javascript.JSaddle.Run
16− (Command(..), Result(..), AsyncCommand(..), sendCommand, sendLazyCommand)
23+ (newArray, getPropertyByName, getPropertyAtIndex, callAsFunction, valueToNumber)
1724
1825create :: JSM MutableJSArray
19−create = SomeJSArray <$> sendLazyCommand (NewArray [])
26+create = SomeJSArray <$> newArray []
2027{-# INLINE create #-}
2128
29+fromList :: [JSVal] -> GHCJSPure (SomeJSArray m)
30+fromList = GHCJSPure . fromListIO
31+{-# INLINE fromList #-}
32+
2233fromListIO :: [JSVal] -> JSM (SomeJSArray m)
23−fromListIO xs = withJSVals xs $ \xs' -> SomeJSArray <$> sendLazyCommand (NewArray xs')
34+fromListIO xs = SomeJSArray <$> newArray xs
2435{-# INLINE fromListIO #-}
2536
37+toList :: SomeJSArray m -> GHCJSPure [JSVal]
38+toList = GHCJSPure . toListIO
39+{-# INLINE toList #-}
40+
2641toListIO :: SomeJSArray m -> JSM [JSVal]
27−toListIO (SomeJSArray x) =
28− withObject (Object x) $ \this -> do
29− l <- withJSString (JSString "length") $ sendLazyCommand . GetPropertyByName this
30− withJSVal l $ \l' -> do
31− ~(ValueToNumberResult len) <- sendCommand (ValueToNumber l')
32− mapM (sendLazyCommand . GetPropertyAtIndex this) [0..round len - 1]
42+toListIO (SomeJSArray x) = do
43+ len <- getPropertyByName (JSString "length") (Object x) >>= valueToNumber
44+ mapM (`getPropertyAtIndex` Object x) [0..round len - 1]
3345{-# INLINE toListIO #-}
3446
47+index :: Int -> SomeJSArray m -> GHCJSPure JSVal
48+index n = GHCJSPure . read n
49+{-# INLINE index #-}
50+
3551read :: Int -> SomeJSArray m -> JSM JSVal
36−read n (SomeJSArray x) =
37− withObject (Object x) $ \this -> sendLazyCommand $ GetPropertyAtIndex this n
52+read n (SomeJSArray x) = getPropertyAtIndex n $ Object x
3853{-# INLINE read #-}
3954
4055push :: JSVal -> MutableJSArray -> JSM ()
41−push e (SomeJSArray x) =
42− void $ withJSVal e $ \e' ->
43− withObject (Object x) $ \this -> do
44− f <- withJSString (JSString "push") $ sendLazyCommand . GetPropertyByName this
45− withObject (Object f) $ \f' -> sendLazyCommand $ CallAsFunction f' this [e']
56+push e (SomeJSArray x) = void $ do
57+ f <- getPropertyByName (JSString "push") (Object x)
58+ void $ callAsFunction (Object f) (Object x) [e]
4659{-# INLINE push #-}
jsaddle/src-ghc/JavaScript/Object.hsnew file+10
@@ -0,0 +1,10 @@
1+module JavaScript.Object ( Object
2+ , create
3+ , getProp, unsafeGetProp
4+ , setProp, unsafeSetProp
5+ -- , allProps
6+ , listProps
7+ -- , isInstanceOf
8+ ) where
9+
10+import JavaScript.Object.Internal
jsaddle/src-ghc/JavaScript/Object/Internal.hs+26−22
@@ -7,43 +7,47 @@ module JavaScript.Object.Internal
77 , unsafeGetProp
88 , setProp
99 , unsafeSetProp
10−-- , isInstanceOfIO
10+-- , isInstanceOf
1111 ) where
1212
1313import Language.Javascript.JSaddle.Types (JSM, JSVal, Object(..), JSString)
1414import Language.Javascript.JSaddle.Native.Internal
15− (withObject, withJSString, withJSVal, wrapJSString)
16−import Language.Javascript.JSaddle.Run
17− (Command(..), AsyncCommand(..), Result(..), sendCommand, sendLazyCommand, sendAsyncCommand)
15+ (newEmptyObject, propertyNames, getPropertyByName, setPropertyByName)
1816
17+-- | create an empty object
1918create :: JSM Object
20−create = Object <$> sendLazyCommand NewEmptyObject
19+create = newEmptyObject
20+{-# INLINE create #-}
21+
22+--allProps :: Object -> JSM JSArray
23+--allProps o = js_allProps o
24+--{-# INLINE allProps #-}
2125
2226listProps :: Object -> JSM [JSString]
23−listProps this =
24− withObject this $ \rthis -> do
25− ~(PropertyNamesResult result) <- sendCommand $ PropertyNames rthis
26− mapM wrapJSString result
27+listProps = propertyNames
2728{-# INLINE listProps #-}
2829
29−unsafeGetProp :: JSString -> Object -> JSM JSVal
30−unsafeGetProp name this =
31− withObject this $ \rthis ->
32− withJSString name $ sendLazyCommand . GetPropertyByName rthis
33−{-# INLINE unsafeGetProp #-}
34−
30+{- | get a property from an object. If accessing the property results in
31+ an exception, the exception is converted to a JSException. Since exception
32+ handling code prevents some optimizations in some JS engines, you may want
33+ to use unsafeGetProp instead
34+ -}
3535getProp :: JSString -> Object -> JSM JSVal
3636getProp = unsafeGetProp
3737{-# INLINE getProp #-}
3838
39−unsafeSetProp :: JSString -> JSVal -> Object -> JSM ()
40−unsafeSetProp name val this =
41− withObject this $ \rthis ->
42− withJSString name $ \rname ->
43− withJSVal val $ \rval ->
44− sendAsyncCommand $ SetPropertyByName rthis rname rval
45−{-# INLINE unsafeSetProp #-}
39+unsafeGetProp :: JSString -> Object -> JSM JSVal
40+unsafeGetProp = getPropertyByName
41+{-# INLINE unsafeGetProp #-}
4642
4743setProp :: JSString -> JSVal -> Object -> JSM ()
4844setProp = unsafeSetProp
4945{-# INLINE setProp #-}
46+
47+unsafeSetProp :: JSString -> JSVal -> Object -> JSM ()
48+unsafeSetProp = setPropertyByName
49+{-# INLINE unsafeSetProp #-}
50+
51+--isInstanceOf :: Object -> JSVal -> GHCJSPure Bool
52+--isInstanceOf o s = js_isInstanceOf o s
53+--{-# INLINE isInstanceOf #-}
jsaddle/src-ghc/JavaScript/TypedArray.hsnew file+19
@@ -0,0 +1,19 @@
1+module JavaScript.TypedArray
2+ ( TypedArray(..)
3+ , Int8Array, Int16Array, Int32Array
4+ , Uint8Array, Uint16Array, Uint32Array
5+ , Uint8ClampedArray, Float32Array, Float64Array
6+ , length
7+ , byteLength
8+ , byteOffset
9+ , buffer
10+ , subarray
11+ , set
12+ , unsafeSet
13+ ) where
14+
15+import Prelude ()
16+
17+import JavaScript.TypedArray.Internal
18+import JavaScript.TypedArray.Internal.Types
19+
jsaddle/src-ghc/JavaScript/TypedArray/ArrayBuffer.hsnew file+51
@@ -0,0 +1,51 @@
1+module JavaScript.TypedArray.ArrayBuffer
2+ ( ArrayBuffer
3+ , MutableArrayBuffer
4+ , freeze, unsafeFreeze
5+ , thaw, unsafeThaw
6+ , byteLengthIO
7+ ) where
8+
9+import Control.Lens.Operators ((^.))
10+
11+import GHCJS.Marshal (fromJSValUnchecked)
12+
13+import Language.Javascript.JSaddle.Types (JSM)
14+import Language.Javascript.JSaddle.Object (jsg, new, js, js1, js2)
15+import JavaScript.TypedArray.ArrayBuffer.Internal
16+
17+create :: Int -> JSM MutableArrayBuffer
18+create n = SomeArrayBuffer <$> new (jsg "ArrayBuffer") [n]
19+{-# INLINE create #-}
20+
21+{- | Create an immutable 'ArrayBuffer' by copying a 'MutableArrayBuffer' -}
22+freeze :: MutableArrayBuffer -> JSM ArrayBuffer
23+freeze (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js1 "slice" (0 :: Int)
24+{-# INLINE freeze #-}
25+
26+{- | Create an immutable 'ArrayBuffer' from a 'MutableArrayBuffer' without
27+ copying. The result shares the buffer with the argument, not modify
28+ the data in the 'MutableArrayBuffer' after freezing
29+ -}
30+unsafeFreeze :: MutableArrayBuffer -> JSM ArrayBuffer
31+unsafeFreeze (SomeArrayBuffer b) = pure (SomeArrayBuffer b)
32+{-# INLINE unsafeFreeze #-}
33+
34+{- | Create a 'MutableArrayBuffer' by copying an immutable 'ArrayBuffer' -}
35+thaw :: ArrayBuffer -> JSM MutableArrayBuffer
36+thaw (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js1 "slice" (0 :: Int)
37+{-# INLINE thaw #-}
38+
39+unsafeThaw :: ArrayBuffer -> JSM MutableArrayBuffer
40+unsafeThaw (SomeArrayBuffer b) = pure (SomeArrayBuffer b)
41+{-# INLINE unsafeThaw #-}
42+
43+sliceIO :: Int -> Maybe Int -> SomeArrayBuffer any -> JSM (SomeArrayBuffer any)
44+sliceIO begin (Just end) (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js2 "slice" begin end
45+sliceIO begin _ (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js1 "slice" begin
46+{-# INLINE sliceIO #-}
47+
48+byteLengthIO :: SomeArrayBuffer any -> JSM Int
49+byteLengthIO (SomeArrayBuffer b) = b ^. js "byteLength" >>= fromJSValUnchecked
50+{-# INLINE byteLengthIO #-}
51+
jsaddle/src-ghc/JavaScript/TypedArray/ArrayBuffer/Internal.hsnew file+33
@@ -0,0 +1,33 @@
1+{-# LANGUAGE GHCForeignImportPrim #-}
2+{-# LANGUAGE MagicHash #-}
3+{-# LANGUAGE UnboxedTuples #-}
4+{-# LANGUAGE MagicHash #-}
5+{-# LANGUAGE TypeSynonymInstances #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE DataKinds #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE DeriveDataTypeable #-}
10+
11+module JavaScript.TypedArray.ArrayBuffer.Internal where
12+
13+import GHCJS.Types
14+
15+import GHCJS.Internal.Types
16+import GHCJS.Marshal.Pure
17+
18+import GHC.Exts (State#)
19+
20+import Data.Typeable
21+
22+newtype SomeArrayBuffer (a :: MutabilityType s) =
23+ SomeArrayBuffer JSVal deriving Typeable
24+instance IsJSVal (SomeArrayBuffer m)
25+
26+type ArrayBuffer = SomeArrayBuffer Immutable
27+type MutableArrayBuffer = SomeArrayBuffer Mutable
28+type STArrayBuffer s = SomeArrayBuffer (STMutable s)
29+
30+instance PToJSVal MutableArrayBuffer where
31+ pToJSVal (SomeArrayBuffer b) = b
32+instance PFromJSVal MutableArrayBuffer where
33+ pFromJSVal = SomeArrayBuffer
jsaddle/src-ghc/JavaScript/TypedArray/ArrayBuffer/Type.hsnew file+6
@@ -0,0 +1,6 @@
1+module JavaScript.TypedArray.ArrayBuffer.Type where
2+
3+import GHCJS.Prim
4+
5+
6+
jsaddle/src-ghc/JavaScript/TypedArray/DataView/Internal.hsnew file+147
@@ -0,0 +1,147 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE JavaScriptFFI #-}
3+{-# LANGUAGE ForeignFunctionInterface #-}
4+{-# LANGUAGE UnliftedFFITypes #-}
5+{-# LANGUAGE GHCForeignImportPrim #-}
6+{-# LANGUAGE MagicHash #-}
7+{-# LANGUAGE UnboxedTuples #-}
8+{-# LANGUAGE DeriveDataTypeable #-}
9+{-# LANGUAGE DataKinds #-}
10+{-# LANGUAGE KindSignatures #-}
11+{-# LANGUAGE PolyKinds #-}
12+
13+module JavaScript.TypedArray.DataView.Internal where
14+
15+import Data.Int
16+import Data.Typeable
17+import Data.Word
18+
19+import GHC.Exts ( State# )
20+
21+import GHCJS.Prim
22+import GHCJS.Internal.Types
23+
24+import JavaScript.TypedArray.ArrayBuffer.Internal
25+
26+newtype SomeDataView (a :: MutabilityType s) = SomeDataView JSVal
27+ deriving Typeable
28+
29+type DataView = SomeDataView Immutable
30+type MutableDataView = SomeDataView Mutable
31+type STDataView s = SomeDataView (STMutable s)
32+
33+-- #define JSU foreign import javascript unsafe
34+-- #define JSS foreign import javascript safe
35+--
36+--JSU "new DataView($1)"
37+-- js_dataView1 :: JSVal -> JSVal
38+--JSS "new DataView($2,$1)"
39+-- js_dataView2 :: Int -> JSVal -> SomeDataView m
40+--JSU "new DataView($2,$1)"
41+-- js_unsafeDataView2 :: Int -> JSVal-> SomeDataView m
42+--JSS "new DataView($3,$1,$2)"
43+-- js_dataView :: Int -> Int -> JSVal -> SomeDataView m
44+--JSU "new DataView($3,$1,$2)"
45+-- js_unsafeDataView :: Int -> Int -> JSVal -> JSVal
46+--JSU "new DataView($1.buffer.slice($1.byteOffset, $1.byteLength))"
47+-- js_cloneDataView :: SomeDataView m -> IO (SomeDataView m1)
48+--
49+---- ----------------------------------------------------------------------------
50+---- immutable getters
51+--
52+--JSU "$2.getInt8($1)" js_i_unsafeGetInt8 :: Int -> DataView -> Int8
53+--JSU "$2.getUint8($1)" js_i_unsafeGetUint8 :: Int -> DataView -> Word8
54+--JSU "$2.getInt16($1)" js_i_unsafeGetInt16BE :: Int -> DataView -> Int16
55+--JSU "$2.getInt32($1)" js_i_unsafeGetInt32BE :: Int -> DataView -> Int
56+--JSU "$2.getUint16($1)" js_i_unsafeGetUint16BE :: Int -> DataView -> Word16
57+--JSU "$2.getUint32($1)|0" js_i_unsafeGetUint32BE :: Int -> DataView -> Word
58+--JSU "$2.getFloat32($1)" js_i_unsafeGetFloat32BE :: Int -> DataView -> Double
59+--JSU "$2.getFloat64($1)" js_i_unsafeGetFloat64BE :: Int -> DataView -> Double
60+--JSU "$2.getInt16($1,true)" js_i_unsafeGetInt16LE :: Int -> DataView -> Int16
61+--JSU "$2.getInt32($1,true)" js_i_unsafeGetInt32LE :: Int -> DataView -> Int
62+--JSU "$2.getUint16($1,true)" js_i_unsafeGetUint16LE :: Int -> DataView -> Word16
63+--JSU "$2.getUint32($1,true)|0" js_i_unsafeGetUint32LE :: Int -> DataView -> Word
64+--JSU "$2.getFloat32($1,true)" js_i_unsafeGetFloat32LE :: Int -> DataView -> Double
65+--JSU "$2.getFloat64($1,true)" js_i_unsafeGetFloat64LE :: Int -> DataView -> Double
66+--
67+--JSS "$2.getInt8($1)" js_i_getInt8 :: Int -> DataView -> Int8
68+--JSS "$2.getUint8($1)" js_i_getUint8 :: Int -> DataView -> Word8
69+--JSS "$2.getInt16($1)" js_i_getInt16BE :: Int -> DataView -> Int16
70+--JSS "$2.getInt32($1)" js_i_getInt32BE :: Int -> DataView -> Int
71+--JSS "$2.getUint16($1)" js_i_getUint16BE :: Int -> DataView -> Word16
72+--JSS "$2.getUint32($1)|0" js_i_getUint32BE :: Int -> DataView -> Word
73+--JSS "$2.getFloat32($1)" js_i_getFloat32BE :: Int -> DataView -> Double
74+--JSS "$2.getFloat64($1)" js_i_getFloat64BE :: Int -> DataView -> Double
75+--JSS "$2.getInt16($1,true)" js_i_getInt16LE :: Int -> DataView -> Int16
76+--JSS "$2.getInt32($1,true)" js_i_getInt32LE :: Int -> DataView -> Int
77+--JSS "$2.getUint16($1,true)" js_i_getUint16LE :: Int -> DataView -> Word16
78+--JSS "$2.getUint32($1,true)|0" js_i_getUint32LE :: Int -> DataView -> Word
79+--JSS "$2.getFloat32($1,true)" js_i_getFloat32LE :: Int -> DataView -> Double
80+--JSS "$2.getFloat64($1,true)" js_i_getFloat64LE :: Int -> DataView -> Double
81+--
82+---- ----------------------------------------------------------------------------
83+---- mutable getters
84+--
85+--JSU "$2.getInt8($1)" js_m_unsafeGetInt8 :: Int -> SomeDataView m -> State# s -> (# State# s, Int8 #)
86+--JSU "$2.getUint8($1)" js_m_unsafeGetUint8 :: Int -> SomeDataView m -> State# s -> (# State# s, Word8 #)
87+--JSU "$2.getInt16($1)" js_m_unsafeGetInt16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)
88+--JSU "$2.getInt32($1)" js_m_unsafeGetInt32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)
89+--JSU "$2.getUint16($1)" js_m_unsafeGetUint16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)
90+--JSU "$2.getUint32($1)|0" js_m_unsafeGetUint32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)
91+--JSU "$2.getFloat32($1)" js_m_unsafeGetFloat32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
92+--JSU "$2.getFloat64($1)" js_m_unsafeGetFloat64BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
93+--JSU "$2.getInt16($1,true)" js_m_unsafeGetInt16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)
94+--JSU "$2.getInt32($1,true)" js_m_unsafeGetInt32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)
95+--JSU "$2.getUint16($1,true)" js_m_unsafeGetUint16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)
96+--JSU "$2.getUint32($1,true)|0" js_m_unsafeGetUint32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)
97+--JSU "$2.getFloat32($1,true)" js_m_unsafeGetFloat32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
98+--JSU "$2.getFloat64($1,true)" js_m_unsafeGetFloat64LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
99+--
100+--JSS "$2.getInt8($1)" js_m_getInt8 :: Int -> SomeDataView m -> State# s -> (# State# s, Int8 #)
101+--JSS "$2.getUint8($1)" js_m_getUint8 :: Int -> SomeDataView m -> State# s -> (# State# s, Word8 #)
102+--JSS "$2.getInt16($1)" js_m_getInt16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)
103+--JSS "$2.getInt32($1)" js_m_getInt32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)
104+--JSS "$2.getUint16($1)" js_m_getUint16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)
105+--JSS "$2.getUint32($1)|0" js_m_getUint32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)
106+--JSS "$2.getFloat32($1)" js_m_getFloat32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
107+--JSS "$2.getFloat64($1)" js_m_getFloat64BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
108+--JSS "$2.getInt16($1,true)" js_m_getInt16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)
109+--JSS "$2.getInt32($1,true)" js_m_getInt32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)
110+--JSS "$2.getUint16($1,true)" js_m_getUint16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)
111+--JSS "$2.getUint32($1,true)|0" js_m_getUint32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)
112+--JSS "$2.getFloat32($1,true)" js_m_getFloat32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
113+--JSS "$2.getFloat64($1,true)" js_m_getFloat64LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
114+--
115+---- ----------------------------------------------------------------------------
116+---- mutable setters
117+--
118+--JSU "$3.setInt8($1,$2)" js_unsafeSetInt8 :: Int -> Int8 -> SomeDataView m -> State# s -> (# State# s, () #)
119+--JSU "$3.setUint8($1,$2)" js_unsafeSetUint8 :: Int -> Word8 -> SomeDataView m -> State# s -> (# State# s, () #)
120+--JSU "$3.setInt16($1,$2)" js_unsafeSetInt16BE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)
121+--JSU "$3.setInt32($1,$2)" js_unsafeSetInt32BE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)
122+--JSU "$3.setUint16($1,$2)" js_unsafeSetUint16BE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)
123+--JSU "$3.setUint32($1,$2)" js_unsafeSetUint32BE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)
124+--JSU "$3.setFloat32($1,$2)" js_unsafeSetFloat32BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
125+--JSU "$3.setFloat64($1,$2)" js_unsafeSetFloat64BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
126+--JSU "$3.setInt16($1,$2,true)" js_unsafeSetInt16LE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)
127+--JSU "$3.setInt32($1,$2,true)" js_unsafeSetInt32LE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)
128+--JSU "$3.setUint16($1,$2,true)" js_unsafeSetUint16LE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)
129+--JSU "$3.setUint32($1,$2,true)" js_unsafeSetUint32LE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)
130+--JSU "$3.setFloat32($1,$2,true)" js_unsafeSetFloat32LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
131+--JSU "$3.setFloat64($1,$2,true)" js_unsafeSetFloat64LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
132+--
133+--JSS "$3.setInt8($1,$2)" js_setInt8 :: Int -> Int8 -> SomeDataView m -> State# s -> (# State# s, () #)
134+--JSS "$3.setUint8($1,$2)" js_setUint8 :: Int -> Word8 -> SomeDataView m -> State# s -> (# State# s, () #)
135+--JSS "$3.setInt16($1,$2)" js_setInt16BE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)
136+--JSS "$3.setInt32($1,$2)" js_setInt32BE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)
137+--JSS "$3.setUint16($1,$2)" js_setUint16BE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)
138+--JSS "$3.setUint32($1,$2)" js_setUint32BE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)
139+--JSS "$3.setFloat32($1,$2)" js_setFloat32BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
140+--JSS "$3.setFloat64($1,$2)" js_setFloat64BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
141+--JSS "$3.setInt16($1,$2,true)" js_setInt16LE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)
142+--JSS "$3.setInt32($1,$2,true)" js_setInt32LE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)
143+--JSS "$3.setUint16($1,$2,true)" js_setUint16LE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)
144+--JSS "$3.setUint32($1,$2,true)" js_setUint32LE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)
145+--JSS "$3.setFloat32($1,$2,true)" js_setFloat32LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
146+--JSS "$3.setFloat64($1,$2,true)" js_setFloat64LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
147+
jsaddle/src-ghc/JavaScript/TypedArray/Immutable.hsnew file+1
@@ -0,0 +1 @@
1+module JavaScript.TypedArray.Immutable where
jsaddle/src-ghc/JavaScript/TypedArray/Internal.hsnew file+344
@@ -0,0 +1,344 @@
1+{-# LANGUAGE TypeFamilies #-}
2+{-# LANGUAGE TypeSynonymInstances #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE DataKinds #-}
5+{-# LANGUAGE PolyKinds #-}
6+
7+module JavaScript.TypedArray.Internal where
8+
9+import Prelude hiding ((!!))
10+
11+import GHC.Int
12+import GHC.Word
13+
14+import GHCJS.Internal.Types
15+
16+import Control.Monad (void)
17+import Control.Lens.Operators ((^.))
18+
19+import GHCJS.Marshal (fromJSValUnchecked)
20+
21+import JavaScript.Array.Internal (SomeJSArray(..))
22+import JavaScript.TypedArray.ArrayBuffer
23+import JavaScript.TypedArray.ArrayBuffer.Internal (SomeArrayBuffer(..))
24+import JavaScript.TypedArray.Internal.Types
25+
26+import Language.Javascript.JSaddle.Types (JSM, GHCJSPure(..))
27+import Language.Javascript.JSaddle.Object (js, jsg, js1, js2, new, (!!), (<##))
28+
29+elemSize :: SomeTypedArray e m -> GHCJSPure Int
30+elemSize (SomeTypedArray a) = GHCJSPure $ a ^. js "BYTES_PER_ELEMENT" >>= fromJSValUnchecked
31+{-# INLINE [1] elemSize #-}
32+{-# RULES "elemSizeUint8Clamped" forall (x :: SomeUint8ClampedArray m). elemSize x = GHCJSPure $ return 1 #-}
33+{-# RULES "elemSizeUint8" forall (x :: SomeUint8Array m). elemSize x = GHCJSPure $ return 1 #-}
34+{-# RULES "elemSizeUint16" forall (x :: SomeUint16Array m). elemSize x = GHCJSPure $ return 2 #-}
35+{-# RULES "elemSizeUint32" forall (x :: SomeUint32Array m). elemSize x = GHCJSPure $ return 4 #-}
36+{-# RULES "elemSizeInt8" forall (x :: SomeInt8Array m). elemSize x = GHCJSPure $ return 1 #-}
37+{-# RULES "elemSizeInt16" forall (x :: SomeInt16Array m). elemSize x = GHCJSPure $ return 2 #-}
38+{-# RULES "elemSizeInt32" forall (x :: SomeInt32Array m). elemSize x = GHCJSPure $ return 4 #-}
39+{-# RULES "elemSizeFloat32" forall (x :: SomeFloat32Array m). elemSize x = GHCJSPure $ return 4 #-}
40+{-# RULES "elemSizeFloat64" forall (x :: SomeFloat64Array m). elemSize x = GHCJSPure $ return 8 #-}
41+
42+instance TypedArray IOInt8Array where
43+ index = indexI8
44+ unsafeIndex = unsafeIndexI8
45+ setIndex i x = setIndexI i (fromIntegral x)
46+ unsafeSetIndex i x = unsafeSetIndexI i (fromIntegral x)
47+ indexOf s x = indexOfI s (fromIntegral x)
48+ lastIndexOf s x = lastIndexOfI s (fromIntegral x)
49+ create l = SomeTypedArray <$> new (jsg "Int8Array") [l]
50+ fromArray = int8ArrayFrom
51+ fromArrayBuffer = undefined
52+
53+instance TypedArray IOInt16Array where
54+ index = indexI16
55+ unsafeIndex = unsafeIndexI16
56+ setIndex i x = setIndexI i (fromIntegral x)
57+ unsafeSetIndex i x = unsafeSetIndexI i (fromIntegral x)
58+ indexOf s x = indexOfI s (fromIntegral x)
59+ lastIndexOf s x = lastIndexOfI s (fromIntegral x)
60+ create l = SomeTypedArray <$> new (jsg "Int16Array") [l]
61+ fromArray = int16ArrayFrom
62+ fromArrayBuffer = undefined
63+
64+instance TypedArray IOInt32Array where
65+ index = indexI
66+ unsafeIndex = unsafeIndexI
67+ setIndex = setIndexI
68+ unsafeSetIndex = unsafeSetIndexI
69+ indexOf = indexOfI
70+ lastIndexOf = lastIndexOfI
71+ create l = SomeTypedArray <$> new (jsg "Int32Array") [l]
72+ fromArray = int32ArrayFrom
73+ fromArrayBuffer = undefined
74+
75+instance TypedArray IOUint8ClampedArray where
76+ index = indexW8
77+ unsafeIndex = unsafeIndexW8
78+ setIndex i x = setIndexW i (fromIntegral x)
79+ unsafeSetIndex i x = unsafeSetIndexW i (fromIntegral x)
80+ indexOf s x = indexOfW s (fromIntegral x)
81+ lastIndexOf s x = lastIndexOfW s (fromIntegral x)
82+ create l = SomeTypedArray <$> new (jsg "Uint8ClampedArray") [l]
83+ fromArray = uint8ClampedArrayFrom
84+ fromArrayBuffer = undefined
85+
86+instance TypedArray IOUint8Array where
87+ index = indexW8
88+ unsafeIndex = unsafeIndexW8
89+ setIndex i x = setIndexW i (fromIntegral x)
90+ unsafeSetIndex i x = unsafeSetIndexW i (fromIntegral x)
91+ indexOf s x = indexOfW s (fromIntegral x)
92+ lastIndexOf s x = lastIndexOfW s (fromIntegral x)
93+ create l = SomeTypedArray <$> new (jsg "Uint8Array") [l]
94+ fromArray = uint8ArrayFrom
95+ fromArrayBuffer = undefined
96+
97+instance TypedArray IOUint16Array where
98+ index = indexW16
99+ unsafeIndex = unsafeIndexW16
100+ setIndex i x = setIndexW i (fromIntegral x)
101+ unsafeSetIndex i x = unsafeSetIndexW i (fromIntegral x)
102+ indexOf s x = indexOfW s (fromIntegral x)
103+ lastIndexOf s x = lastIndexOfW s (fromIntegral x)
104+ create l = SomeTypedArray <$> new (jsg "Uint16Array") [l]
105+ fromArray = uint16ArrayFrom
106+ fromArrayBuffer = undefined
107+
108+instance TypedArray IOUint32Array where
109+ index = indexW
110+ unsafeIndex = unsafeIndexW
111+ setIndex = setIndexW
112+ unsafeSetIndex = unsafeSetIndexW
113+ indexOf = indexOfW
114+ lastIndexOf = lastIndexOfW
115+ create l = SomeTypedArray <$> new (jsg "Uint32Array") [l]
116+ fromArray = uint32ArrayFrom
117+ fromArrayBuffer = undefined
118+
119+instance TypedArray IOFloat32Array where
120+ index = indexD
121+ unsafeIndex = unsafeIndexD
122+ setIndex = setIndexD
123+ unsafeSetIndex = unsafeSetIndexD
124+ indexOf = indexOfD
125+ lastIndexOf = lastIndexOfD
126+ create l = SomeTypedArray <$> new (jsg "Float32Array") [l]
127+ fromArray = float32ArrayFrom
128+ fromArrayBuffer = undefined
129+
130+instance TypedArray IOFloat64Array where
131+ index = indexD
132+ unsafeIndex = unsafeIndexD
133+ setIndex = setIndexD
134+ unsafeSetIndex = unsafeSetIndexD
135+ indexOf = indexOfD
136+ lastIndexOf = lastIndexOfD
137+ create l = SomeTypedArray <$> new (jsg "Float64Array") [l]
138+ fromArray = float64ArrayFrom
139+ fromArrayBuffer = undefined
140+
141+
142+class TypedArray a where
143+ unsafeIndex :: Int -> a -> JSM (Elem a)
144+ index :: Int -> a -> JSM (Elem a)
145+ unsafeSetIndex :: Int -> Elem a -> a -> JSM ()
146+ setIndex :: Int -> Elem a -> a -> JSM ()
147+ create :: Int -> JSM a
148+ fromArray :: SomeJSArray m -> JSM a
149+ fromArrayBuffer :: MutableArrayBuffer -> Int -> Maybe Int -> JSM a
150+ indexOf :: Int -> Elem a -> a -> JSM Int
151+ lastIndexOf :: Int -> Elem a -> a -> JSM Int
152+
153+-- -----------------------------------------------------------------------------
154+
155+indexI :: Int -> SomeTypedArray e m -> JSM Int
156+indexI i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
157+{-# INLINE indexI #-}
158+
159+indexI16 :: Int -> SomeTypedArray e m -> JSM Int16
160+indexI16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
161+{-# INLINE indexI16 #-}
162+
163+indexI8 :: Int -> SomeTypedArray e m -> JSM Int8
164+indexI8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
165+{-# INLINE indexI8 #-}
166+
167+indexW :: Int -> SomeTypedArray e m -> JSM Word
168+indexW i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
169+{-# INLINE indexW #-}
170+
171+indexW16 :: Int -> SomeTypedArray e m -> JSM Word16
172+indexW16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
173+{-# INLINE indexW16 #-}
174+
175+indexW8 :: Int -> SomeTypedArray e m -> JSM Word8
176+indexW8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
177+{-# INLINE indexW8 #-}
178+
179+indexD :: Int -> SomeTypedArray e m -> JSM Double
180+indexD i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
181+{-# INLINE indexD #-}
182+
183+-- -----------------------------------------------------------------------------
184+
185+unsafeIndexI :: Int -> SomeTypedArray e m -> JSM Int
186+unsafeIndexI i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
187+{-# INLINE unsafeIndexI #-}
188+
189+unsafeIndexI16 :: Int -> SomeTypedArray e m -> JSM Int16
190+unsafeIndexI16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
191+{-# INLINE unsafeIndexI16 #-}
192+
193+unsafeIndexI8 :: Int -> SomeTypedArray e m -> JSM Int8
194+unsafeIndexI8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
195+{-# INLINE unsafeIndexI8 #-}
196+
197+unsafeIndexW :: Int -> SomeTypedArray e m -> JSM Word
198+unsafeIndexW i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
199+{-# INLINE unsafeIndexW #-}
200+
201+unsafeIndexW16 :: Int -> SomeTypedArray e m -> JSM Word16
202+unsafeIndexW16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
203+{-# INLINE unsafeIndexW16 #-}
204+
205+unsafeIndexW8 :: Int -> SomeTypedArray e m -> JSM Word8
206+unsafeIndexW8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
207+{-# INLINE unsafeIndexW8 #-}
208+
209+unsafeIndexD :: Int -> SomeTypedArray e m -> JSM Double
210+unsafeIndexD i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
211+{-# INLINE unsafeIndexD #-}
212+
213+-- -----------------------------------------------------------------------------
214+
215+int8ArrayFrom :: SomeJSArray m0 -> JSM (SomeInt8Array m1)
216+int8ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Int8Array" ^. js1 "from" a
217+{-# INLINE int8ArrayFrom #-}
218+
219+int16ArrayFrom :: SomeJSArray m0 -> JSM (SomeInt16Array m1)
220+int16ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Int16Array" ^. js1 "from" a
221+{-# INLINE int16ArrayFrom #-}
222+
223+int32ArrayFrom :: SomeJSArray m0 -> JSM (SomeInt32Array m1)
224+int32ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Int32Array" ^. js1 "from" a
225+{-# INLINE int32ArrayFrom #-}
226+
227+uint8ArrayFrom :: SomeJSArray m0 -> JSM (SomeUint8Array m1)
228+uint8ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint8Array" ^. js1 "from" a
229+{-# INLINE uint8ArrayFrom #-}
230+
231+uint8ClampedArrayFrom :: SomeJSArray m0 -> JSM (SomeUint8ClampedArray m1)
232+uint8ClampedArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint8ClampedArray" ^. js1 "from" a
233+{-# INLINE uint8ClampedArrayFrom #-}
234+
235+uint16ArrayFrom :: SomeJSArray m0 -> JSM (SomeUint16Array m1)
236+uint16ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint16Array" ^. js1 "from" a
237+{-# INLINE uint16ArrayFrom #-}
238+
239+uint32ArrayFrom :: SomeJSArray m0 -> JSM (SomeUint32Array m1)
240+uint32ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint32Array" ^. js1 "from" a
241+{-# INLINE uint32ArrayFrom #-}
242+
243+float32ArrayFrom :: SomeJSArray m0 -> JSM (SomeFloat32Array m1)
244+float32ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Float32Array" ^. js1 "from" a
245+{-# INLINE float32ArrayFrom #-}
246+
247+float64ArrayFrom :: SomeJSArray m0 -> JSM (SomeFloat64Array m1)
248+float64ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Float64Array" ^. js1 "from" a
249+{-# INLINE float64ArrayFrom #-}
250+
251+-- -----------------------------------------------------------------------------
252+
253+setIndexI :: Mutability m ~ IsMutable
254+ => Int -> Int -> SomeTypedArray e m -> JSM ()
255+setIndexI i x (SomeTypedArray a) = (a <## i) x
256+{-# INLINE setIndexI #-}
257+
258+unsafeSetIndexI :: Mutability m ~ IsMutable
259+ => Int -> Int -> SomeTypedArray e m -> JSM ()
260+unsafeSetIndexI i x (SomeTypedArray a) = (a <## i) x
261+{-# INLINE unsafeSetIndexI #-}
262+
263+setIndexW :: Mutability m ~ IsMutable
264+ => Int -> Word -> SomeTypedArray e m -> JSM ()
265+setIndexW i x (SomeTypedArray a) = (a <## i) x
266+{-# INLINE setIndexW #-}
267+
268+unsafeSetIndexW :: Mutability m ~ IsMutable
269+ => Int -> Word -> SomeTypedArray e m -> JSM ()
270+unsafeSetIndexW i x (SomeTypedArray a) = (a <## i) x
271+{-# INLINE unsafeSetIndexW #-}
272+
273+setIndexD :: Mutability m ~ IsMutable
274+ => Int -> Double -> SomeTypedArray e m -> JSM ()
275+setIndexD i x (SomeTypedArray a) = (a <## i) x
276+{-# INLINE setIndexD #-}
277+
278+unsafeSetIndexD :: Mutability m ~ IsMutable
279+ => Int -> Double -> SomeTypedArray e m -> JSM ()
280+unsafeSetIndexD i x (SomeTypedArray a) = (a <## i) x
281+{-# INLINE unsafeSetIndexD #-}
282+
283+indexOfI :: Mutability m ~ IsMutable
284+ => Int -> Int -> SomeTypedArray e m -> JSM Int
285+indexOfI s x (SomeTypedArray a) = a ^. js2 "indexOf" x s >>= fromJSValUnchecked
286+{-# INLINE indexOfI #-}
287+
288+indexOfW :: Int -> Word -> SomeTypedArray e m -> JSM Int
289+indexOfW s x (SomeTypedArray a) = a ^. js2 "indexOf" x s >>= fromJSValUnchecked
290+{-# INLINE indexOfW #-}
291+
292+indexOfD :: Int -> Double -> SomeTypedArray e m -> JSM Int
293+indexOfD s x (SomeTypedArray a) = a ^. js2 "indexOf" x s >>= fromJSValUnchecked
294+{-# INLINE indexOfD #-}
295+
296+lastIndexOfI :: Int -> Int -> SomeTypedArray e m -> JSM Int
297+lastIndexOfI s x (SomeTypedArray a) = a ^. js2 "lastIndexOf" x s >>= fromJSValUnchecked
298+{-# INLINE lastIndexOfI #-}
299+
300+lastIndexOfW :: Int -> Word -> SomeTypedArray e m -> JSM Int
301+lastIndexOfW s x (SomeTypedArray a) = a ^. js2 "lastIndexOf" x s >>= fromJSValUnchecked
302+{-# INLINE lastIndexOfW #-}
303+
304+lastIndexOfD :: Int -> Double -> SomeTypedArray e m -> JSM Int
305+lastIndexOfD s x (SomeTypedArray a) = a ^. js2 "lastIndexOf" x s >>= fromJSValUnchecked
306+{-# INLINE lastIndexOfD #-}
307+
308+-- -----------------------------------------------------------------------------
309+-- non-class operations usable for all typed array
310+{-| length of the typed array in elements -}
311+length :: SomeTypedArray e m -> GHCJSPure Int
312+length (SomeTypedArray a) = GHCJSPure $ a ^. js "length" >>= fromJSValUnchecked
313+{-# INLINE length #-}
314+
315+{-| length of the array in bytes -}
316+byteLength :: SomeTypedArray e m -> GHCJSPure Int
317+byteLength (SomeTypedArray a) = GHCJSPure $ a ^. js "byteLength" >>= fromJSValUnchecked
318+{-# INLINE byteLength #-}
319+
320+{-| offset of the array in the buffer -}
321+byteOffset :: SomeTypedArray e m -> GHCJSPure Int
322+byteOffset (SomeTypedArray a) = GHCJSPure $ a ^. js "byteOffset" >>= fromJSValUnchecked
323+{-# INLINE byteOffset #-}
324+
325+{-| the underlying buffer of the array -}
326+buffer :: SomeTypedArray e m -> GHCJSPure (SomeArrayBuffer m)
327+buffer (SomeTypedArray a) = GHCJSPure $ SomeArrayBuffer <$> a ^. js "buffer"
328+{-# INLINE buffer #-}
329+
330+{-| create a view of the existing array -}
331+subarray :: Int -> Int -> SomeTypedArray e m -> GHCJSPure (SomeTypedArray e m)
332+subarray begin end (SomeTypedArray a) = GHCJSPure$ SomeTypedArray <$> a ^. js2 "subarray" begin end
333+{-# INLINE subarray #-}
334+
335+-- fixme convert JSException to Haskell exception
336+{-| copy the elements of one typed array to another -}
337+set :: Int -> SomeTypedArray e m -> SomeTypedArray e1 Mutable -> GHCJSPure ()
338+set offset (SomeTypedArray src) (SomeTypedArray dest) = GHCJSPure $ void $ dest ^. js2 "set" offset src
339+{-# INLINE set #-}
340+
341+unsafeSet :: Int -> SomeTypedArray e m -> SomeTypedArray e1 Mutable -> GHCJSPure ()
342+unsafeSet offset (SomeTypedArray src) (SomeTypedArray dest) = GHCJSPure $ void $ dest ^. js2 "set" offset src
343+{-# INLINE unsafeSet #-}
344+
jsaddle/src-ghc/JavaScript/TypedArray/Internal/Types.hsnew file+121
@@ -0,0 +1,121 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE PolyKinds #-}
5+
6+module JavaScript.TypedArray.Internal.Types where
7+
8+import GHCJS.Types
9+import GHCJS.Internal.Types
10+import Language.Javascript.JSaddle (IsJSVal)
11+
12+import Data.Int
13+import Data.Typeable
14+import Data.Word
15+
16+newtype SomeTypedArray (e :: TypedArrayElem) (m :: MutabilityType s) =
17+ SomeTypedArray JSVal deriving Typeable
18+instance IsJSVal (SomeTypedArray e m)
19+
20+{-
21+newtype SomeSTTypedArray s e = SomeSTTypedArray JSVal
22+ deriving (Typeable)
23+-}
24+
25+type SomeSTTypedArray s (e :: TypedArrayElem) = SomeTypedArray e (STMutable s)
26+
27+-- -----------------------------------------------------------------------------
28+
29+data TypedArrayElem = Int8Elem
30+ | Int16Elem
31+ | Int32Elem
32+ | Uint8Elem
33+ | Uint16Elem
34+ | Uint32Elem
35+ | Uint8ClampedElem
36+ | Float32Elem
37+ | Float64Elem
38+
39+-- -----------------------------------------------------------------------------
40+
41+type SomeInt8Array = SomeTypedArray Int8Elem
42+type SomeInt16Array = SomeTypedArray Int16Elem
43+type SomeInt32Array = SomeTypedArray Int32Elem
44+
45+type SomeUint8Array = SomeTypedArray Uint8Elem
46+type SomeUint16Array = SomeTypedArray Uint16Elem
47+type SomeUint32Array = SomeTypedArray Uint32Elem
48+
49+type SomeFloat32Array = SomeTypedArray Float32Elem
50+type SomeFloat64Array = SomeTypedArray Float64Elem
51+
52+type SomeUint8ClampedArray = SomeTypedArray Uint8ClampedElem
53+
54+-- -----------------------------------------------------------------------------
55+
56+type Int8Array = SomeInt8Array Immutable
57+type Int16Array = SomeInt16Array Immutable
58+type Int32Array = SomeInt32Array Immutable
59+
60+type Uint8Array = SomeUint8Array Immutable
61+type Uint16Array = SomeUint16Array Immutable
62+type Uint32Array = SomeUint32Array Immutable
63+
64+type Uint8ClampedArray = SomeUint8ClampedArray Immutable
65+
66+type Float32Array = SomeFloat32Array Immutable
67+type Float64Array = SomeFloat64Array Immutable
68+
69+-- -----------------------------------------------------------------------------
70+
71+type IOInt8Array = SomeInt8Array Mutable
72+type IOInt16Array = SomeInt16Array Mutable
73+type IOInt32Array = SomeInt32Array Mutable
74+
75+type IOUint8Array = SomeUint8Array Mutable
76+type IOUint16Array = SomeUint16Array Mutable
77+type IOUint32Array = SomeUint32Array Mutable
78+
79+type IOUint8ClampedArray = SomeUint8ClampedArray Mutable
80+
81+type IOFloat32Array = SomeFloat32Array Mutable
82+type IOFloat64Array = SomeFloat64Array Mutable
83+
84+-- -----------------------------------------------------------------------------
85+
86+type STInt8Array s = SomeSTTypedArray s Int8Elem
87+type STInt16Array s = SomeSTTypedArray s Int16Elem
88+type STInt32Array s = SomeSTTypedArray s Int32Elem
89+
90+type STUint8Array s = SomeSTTypedArray s Uint8Elem
91+type STUint16Array s = SomeSTTypedArray s Uint16Elem
92+type STUint32Array s = SomeSTTypedArray s Uint32Elem
93+
94+type STFloat32Array s = SomeSTTypedArray s Float32Elem
95+type STFloat64Array s = SomeSTTypedArray s Float64Elem
96+
97+type STUint8ClampedArray s = SomeSTTypedArray s Uint8ClampedElem
98+
99+-- -----------------------------------------------------------------------------
100+
101+type family Elem x where
102+ Elem (SomeUint8Array m) = Word8
103+ Elem (SomeUint8ClampedArray m) = Word8
104+ Elem (SomeUint16Array m) = Word16
105+ Elem (SomeUint32Array m) = Word
106+ Elem (SomeInt8Array m) = Int8
107+ Elem (SomeInt16Array m) = Int16
108+ Elem (SomeInt32Array m) = Int
109+ Elem (SomeFloat32Array m) = Double
110+ Elem (SomeFloat64Array m) = Double
111+
112+ Elem (STUint8Array s) = Word8
113+ Elem (STUint8ClampedArray s) = Word8
114+ Elem (STUint16Array s) = Word16
115+ Elem (STUint32Array s) = Word
116+ Elem (STInt8Array s) = Int8
117+ Elem (STInt16Array s) = Int16
118+ Elem (STInt32Array s) = Int
119+ Elem (STFloat32Array s) = Double
120+ Elem (STFloat64Array s) = Double
121+
jsaddle/src/Language/Javascript/JSaddle.hs+5−6
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
21-----------------------------------------------------------------------------
32--
43-- Module : Language.Javascript.JSaddle
@@ -10,7 +9,7 @@
109-- | This package provides an EDSL for calling JavaScript that
1110-- can be used both from GHCJS and GHC. When using GHC
1211-- the application is run using Warp and WebSockets to
13−-- drive a small JavaScipt helper.
12+-- drive a small JavaScript helper.
1413-----------------------------------------------------------------------------
1514
1615module Language.Javascript.JSaddle (
@@ -36,10 +35,10 @@ module Language.Javascript.JSaddle (
3635 --
3736 -- Where it makes sense code examples are given in two forms. One
3837 -- that uses 'eval' to run a purely JavaScript version and one that
39− -- uses more of the JSaddle EDSL feature being demonstated.
38+ -- uses more of the JSaddle EDSL feature being demonstrated.
4039
4140 -- * Calling Haskell from JavaScript
42− -- | You can call back into haskell from JavaScript using 'fun' to
41+ -- | You can call back into Haskell from JavaScript using 'fun' to
4342 -- convert a Haskell function in the JSM monad into a javascript
4443 -- value.
4544
@@ -53,8 +52,8 @@ module Language.Javascript.JSaddle (
5352 -- and the server will run the Haskell code. The JSaddle parts will
5453 -- be executed by sending commands back to the browser.
5554
56− -- Although the code JavaScript code is executed in the the strict order
57− -- 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.
5857 -- This improves the performance by reducing the number of round trips
5958 -- needed between the Haskell and JavaScript code.
6059
jsaddle/src/Language/Javascript/JSaddle/Debug.hsnew file+48
@@ -0,0 +1,48 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+-----------------------------------------------------------------------------
4+--
5+-- Module : Language.Javascript.JSaddle.WebSockets
6+-- Copyright : (c) Hamish Mackenzie
7+-- License : MIT
8+--
9+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.Javascript.JSaddle.Debug (
16+ contexts
17+ , addContext
18+ , removeContext
19+ , runOnAll
20+ , runOnAll_
21+) where
22+
23+import Language.Javascript.JSaddle
24+ (runJSM, askJSM, JSM, JSContextRef(..))
25+import Data.IORef (readIORef, atomicModifyIORef', newIORef, IORef)
26+import System.IO.Unsafe (unsafePerformIO)
27+import Data.Monoid ((<>))
28+import Control.Monad.IO.Class (MonadIO(..))
29+import Data.Int (Int64)
30+
31+contexts :: IORef [JSContextRef]
32+contexts = unsafePerformIO $ newIORef []
33+{-# NOINLINE contexts #-}
34+
35+addContext :: JSM ()
36+addContext = do
37+ ctx <- askJSM
38+ liftIO $ atomicModifyIORef' contexts $ \c -> (c <> [ctx], ())
39+
40+removeContext :: MonadIO m => Int64 -> m ()
41+removeContext cid =
42+ liftIO $ atomicModifyIORef' contexts $ \c -> (filter ((/= cid) . contextId) c, ())
43+
44+runOnAll :: MonadIO m => JSM a -> m [a]
45+runOnAll f = liftIO (readIORef contexts) >>= mapM (runJSM f)
46+
47+runOnAll_ :: MonadIO m => JSM a -> m ()
48+runOnAll_ f = liftIO (readIORef contexts) >>= mapM_ (runJSM f)
jsaddle/src/Language/Javascript/JSaddle/Evaluate.hs+3−7
@@ -27,9 +27,7 @@ import Control.Monad.IO.Class (MonadIO(..))
2727import Language.Javascript.JSaddle.Types (JSString)
2828#else
2929import Language.Javascript.JSaddle.Native.Internal
30− (withJSString)
31−import Language.Javascript.JSaddle.Run
32− (AsyncCommand(..), sendLazyCommand)
30+ (evaluateScript)
3331#endif
3432import Language.Javascript.JSaddle.Marshal.String (ToJSString(..))
3533import Language.Javascript.JSaddle.Monad (JSM)
@@ -52,10 +50,8 @@ eval :: (ToJSString script)
5250 -> JSM JSVal
5351#ifdef ghcjs_HOST_OS
5452eval script = liftIO $ js_eval (toJSString script)
55−foreign import javascript unsafe "$r = eval($1);"
53+foreign import javascript safe "$r = eval($1);"
5654 js_eval :: JSString -> IO JSVal
5755#else
58−eval script = do
59− let rscript = toJSString script
60− withJSString rscript $ sendLazyCommand . EvaluateScript
56+eval = evaluateScript . toJSString
6157#endif
jsaddle/src/Language/Javascript/JSaddle/Exception.hs+6−1
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DeriveDataTypeable #-}
23-----------------------------------------------------------------------------
34--
@@ -17,7 +18,11 @@ module Language.Javascript.JSaddle.Exception (
1718) where
1819
1920import qualified Control.Exception as E (Exception)
20−import Language.Javascript.JSaddle.Types (JSVal)
21+#ifdef ghcjs_HOST_OS
22+import GHCJS.Prim (JSVal)
23+#else
24+import GHCJS.Prim.Internal (JSVal)
25+#endif
2126import Data.Typeable (Typeable)
2227
2328newtype JSException = JSException JSVal deriving (Typeable)
jsaddle/src/Language/Javascript/JSaddle/Foreign.hsdeleted−99
@@ -1,99 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−-----------------------------------------------------------------------------
3−--
4−-- Module : Language.Javascript.JSaddle.Value
5−-- Copyright : (c) Hamish Mackenzie
6−-- License : MIT
7−--
8−-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
9−--
10−-- | This module is like `GHCJS.Foreign` but some functions are in
11−--
12−-----------------------------------------------------------------------------
13−module Language.Javascript.JSaddle.Foreign (
14− jsTrue
15− , jsFalse
16− , jsNull
17− , toJSBool
18−-- , fromJSBoolIO
19− , jsUndefined
20− , isTruthyIO
21− , isNullIO
22− , isUndefinedIO
23−-- , isObjectIO
24−-- , isFunctionIO
25−-- , isStringIO
26−-- , isBooleanIO
27−-- , isSymbolIO
28−-- , isNumberIO
29−) where
30−
31−#ifdef ghcjs_HOST_OS
32−import Language.Javascript.JSaddle.Types (JSM, JSVal)
33−import GHCJS.Foreign (toJSBool, isTruthy, jsNull, jsUndefined, jsTrue, jsFalse, isNull, isUndefined)
34−#else
35−import Language.Javascript.JSaddle.Types (JSM, JSVal(..))
36−import Language.Javascript.JSaddle.Native.Internal
37− (withJSVal)
38−import Language.Javascript.JSaddle.Run
39− (Command(..), Result(..), sendCommand)
40−#endif
41−
42−#ifndef ghcjs_HOST_OS
43−jsTrue :: JSVal
44−jsTrue = JSVal 3
45−{-# INLINE jsTrue #-}
46−
47−jsFalse :: JSVal
48−jsFalse = JSVal 2
49−{-# INLINE jsFalse #-}
50−
51−jsNull :: JSVal
52−jsNull = JSVal 0
53−{-# INLINE jsNull #-}
54−
55−toJSBool :: Bool -> JSVal
56−toJSBool b = JSVal $ if b then 3 else 2
57−{-# INLINE toJSBool #-}
58−
59−jsUndefined :: JSVal
60−jsUndefined = JSVal 1
61−{-# INLINE jsUndefined #-}
62−#endif
63−
64−isTruthyIO :: JSVal -> JSM Bool
65−#ifdef ghcjs_HOST_OS
66−isTruthyIO = return . isTruthy
67−#else
68−isTruthyIO (JSVal 0) = return False -- null
69−isTruthyIO (JSVal 1) = return False -- undefined
70−isTruthyIO (JSVal 2) = return False -- false
71−isTruthyIO (JSVal 3) = return True -- true
72−isTruthyIO v = withJSVal v $ \rval -> do
73− ~(ValueToBoolResult result) <- sendCommand (ValueToBool rval)
74− return result
75−#endif
76−{-# INLINE isTruthyIO #-}
77−
78−isNullIO :: JSVal -> JSM Bool
79−#ifdef ghcjs_HOST_OS
80−isNullIO = return . isNull
81−#else
82−isNullIO (JSVal 0) = return True
83−isNullIO v = withJSVal v $ \rval -> do
84− ~(IsNullResult result) <- sendCommand $ IsNull rval
85− return result
86−#endif
87−{-# INLINE isNullIO #-}
88−
89−isUndefinedIO :: JSVal -> JSM Bool
90−#ifdef ghcjs_HOST_OS
91−isUndefinedIO = return . isUndefined
92−#else
93−isUndefinedIO (JSVal 1) = return True
94−isUndefinedIO v = withJSVal v $ \rval -> do
95− ~(IsUndefinedResult result) <- sendCommand $ IsUndefined rval
96− return result
97−#endif
98−{-# INLINE isUndefinedIO #-}
99−
jsaddle/src/Language/Javascript/JSaddle/Helper.hsnew file+30
@@ -0,0 +1,30 @@
1+{-# LANGUAGE CPP #-}
2+module Language.Javascript.JSaddle.Helper where
3+
4+import GHCJS.Types (JSVal)
5+import Language.Javascript.JSaddle.Types (JSM)
6+
7+#ifdef ghcjs_HOST_OS
8+import GHCJS.Marshal.Pure (pFromJSVal, pToJSVal)
9+import JavaScript.TypedArray.ArrayBuffer (MutableArrayBuffer)
10+#else
11+import JavaScript.TypedArray.ArrayBuffer.Internal (MutableArrayBuffer, SomeArrayBuffer(..))
12+#endif
13+
14+-- | Helper function needed because there is no FromJSVal instance for MutableArrayBuffer
15+mutableArrayBufferFromJSVal :: JSVal -> JSM MutableArrayBuffer
16+#ifdef ghcjs_HOST_OS
17+mutableArrayBufferFromJSVal = return . pFromJSVal
18+#else
19+mutableArrayBufferFromJSVal = return . SomeArrayBuffer
20+#endif
21+{-# INLINE mutableArrayBufferFromJSVal #-}
22+
23+-- | Helper function needed because there is no ToJSVal instance for MutableArrayBuffer
24+mutableArrayBufferToJSVal :: MutableArrayBuffer -> JSM JSVal
25+#ifdef ghcjs_HOST_OS
26+mutableArrayBufferToJSVal = return . pToJSVal
27+#else
28+mutableArrayBufferToJSVal (SomeArrayBuffer v) = return v
29+#endif
30+{-# INLINE mutableArrayBufferToJSVal #-}
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.hs+1−6
@@ -11,12 +11,7 @@
1111-----------------------------------------------------------------------------
1212
1313module Language.Javascript.JSaddle.Native (
14− wrapJSVal
15− , wrapJSString
16− , withJSVal
17− , withJSVals
18− , withObject
19− , withJSString
14+ module Language.Javascript.JSaddle.Native.Internal
2015 , withToJSVal
2116) where
2217
jsaddle/src/Language/Javascript/JSaddle/Native/Internal.hs+212−23
@@ -1,3 +1,6 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE MagicHash #-}
3+{-# LANGUAGE UnboxedTuples #-}
14-----------------------------------------------------------------------------
25--
36-- Module : Language.Javascript.JSaddle.Native
@@ -17,48 +20,234 @@ module Language.Javascript.JSaddle.Native.Internal (
1720 , withJSVals
1821 , withObject
1922 , withJSString
23+ , setPropertyByName
24+ , setPropertyAtIndex
25+ , stringToValue
26+ , numberToValue
27+ , jsonValueToValue
28+ , getPropertyByName
29+ , getPropertyAtIndex
30+ , callAsFunction
31+ , callAsConstructor
32+ , newEmptyObject
33+ , newAsyncCallback
34+ , newSyncCallback
35+ , newArray
36+ , evaluateScript
37+ , deRefVal
38+ , valueToBool
39+ , valueToNumber
40+ , valueToString
41+ , valueToJSON
42+ , valueToJSONValue
43+ , isNull
44+ , isUndefined
45+ , strictEqual
46+ , instanceOf
47+ , propertyNames
2048) where
2149
22−import Control.Monad.Trans.Reader (ask)
2350import Control.Monad.IO.Class (MonadIO(..))
51+
52+import Data.Aeson (Value)
53+
2454import Language.Javascript.JSaddle.Types
25− (JSContextRef(..), AsyncCommand(..), JSM(..), JSString(..),
26− Object(..), JSVal(..), JSValueReceived(..), JSValueForSend(..),
55+ (AsyncCommand(..), JSM(..), JSString(..), addCallback,
56+ Object(..), JSVal(..), JSValueForSend(..), JSCallAsFunction,
2757 JSStringReceived(..), JSStringForSend(..), JSObjectForSend(..))
28−import System.Mem.Weak (addFinalizer)
29−import Control.Monad.Primitive (touch)
30−import Control.Monad (when)
31−
32−wrapJSVal :: JSValueReceived -> JSM JSVal
33−wrapJSVal (JSValueReceived ref) = do
34− -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
35− let result = JSVal ref
36− when (ref >= 5) $ do
37− ctx <- JSM ask
38− liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref
39− return result
58+import Language.Javascript.JSaddle.Monad (askJSM)
59+import Language.Javascript.JSaddle.Run
60+ (Command(..), Result(..), sendCommand,
61+ sendAsyncCommand, sendLazyCommand, wrapJSVal)
62+import GHC.IORef (IORef(..), readIORef)
63+import GHC.STRef (STRef(..))
64+import GHC.IO (IO(..))
65+import GHC.Base (touch#)
4066
4167wrapJSString :: MonadIO m => JSStringReceived -> m JSString
4268wrapJSString (JSStringReceived ref) = return $ JSString ref
4369
70+touchIORef :: IORef a -> IO ()
71+touchIORef (IORef (STRef r#)) = IO $ \s -> case touch# r# s of s' -> (# s', () #)
72+
4473withJSVal :: MonadIO m => JSVal -> (JSValueForSend -> m a) -> m a
45−withJSVal v@(JSVal ref) f =
46− do result <- f (JSValueForSend ref)
47− liftIO $ touch v
74+withJSVal (JSVal ref) f = do
75+ result <- (f . JSValueForSend) =<< liftIO (readIORef ref)
76+ liftIO $ touchIORef ref
4877 return result
4978
5079withJSVals :: MonadIO m => [JSVal] -> ([JSValueForSend] -> m a) -> m a
5180withJSVals v f =
52− do result <- f (map (\(JSVal ref) -> JSValueForSend ref) v)
53− liftIO $ mapM_ touch v
81+ do result <- f =<< mapM (\(JSVal ref) -> liftIO $ JSValueForSend <$> readIORef ref) v
82+ liftIO $ mapM_ (\(JSVal ref) -> touchIORef ref) v
5483 return result
5584
5685withObject :: MonadIO m => Object -> (JSObjectForSend -> m a) -> m a
5786withObject (Object o) f = withJSVal o (f . JSObjectForSend)
5887
5988withJSString :: MonadIO m => JSString -> (JSStringForSend -> m a) -> m a
60−withJSString v@(JSString ref) f =
61− do result <- f (JSStringForSend ref)
62− liftIO $ touch v
89+withJSString (JSString ref) f = f (JSStringForSend ref)
90+
91+setPropertyByName :: JSString -> JSVal -> Object -> JSM ()
92+setPropertyByName name val this =
93+ withObject this $ \rthis ->
94+ withJSString name $ \rname ->
95+ withJSVal val $ \rval ->
96+ sendAsyncCommand $ SetPropertyByName rthis rname rval
97+{-# INLINE setPropertyByName #-}
98+
99+setPropertyAtIndex :: Int -> JSVal -> Object -> JSM ()
100+setPropertyAtIndex index val this =
101+ withObject this $ \rthis ->
102+ withJSVal val $ \rval ->
103+ sendAsyncCommand $ SetPropertyAtIndex rthis index rval
104+{-# INLINE setPropertyAtIndex #-}
105+
106+stringToValue :: JSString -> JSM JSVal
107+stringToValue s = withJSString s $ sendLazyCommand . StringToValue
108+{-# INLINE stringToValue #-}
109+
110+numberToValue :: Double -> JSM JSVal
111+numberToValue = sendLazyCommand . NumberToValue
112+{-# INLINE numberToValue #-}
113+
114+jsonValueToValue :: Value -> JSM JSVal
115+jsonValueToValue = sendLazyCommand . JSONValueToValue
116+{-# INLINE jsonValueToValue #-}
117+
118+getPropertyByName :: JSString -> Object -> JSM JSVal
119+getPropertyByName name this =
120+ withObject this $ \rthis ->
121+ withJSString name $ sendLazyCommand . GetPropertyByName rthis
122+{-# INLINE getPropertyByName #-}
123+
124+getPropertyAtIndex :: Int -> Object -> JSM JSVal
125+getPropertyAtIndex index this =
126+ withObject this $ \rthis -> sendLazyCommand $ GetPropertyAtIndex rthis index
127+{-# INLINE getPropertyAtIndex #-}
128+
129+callAsFunction :: Object -> Object -> [JSVal] -> JSM JSVal
130+callAsFunction f this args =
131+ withObject f $ \rfunction ->
132+ withObject this $ \rthis ->
133+ withJSVals args $ sendLazyCommand . CallAsFunction rfunction rthis
134+{-# INLINE callAsFunction #-}
135+
136+callAsConstructor :: Object -> [JSVal] -> JSM JSVal
137+callAsConstructor f args =
138+ withObject f $ \rfunction ->
139+ withJSVals args $ sendLazyCommand . CallAsConstructor rfunction
140+{-# INLINE callAsConstructor #-}
141+
142+newEmptyObject :: JSM Object
143+newEmptyObject = Object <$> sendLazyCommand NewEmptyObject
144+{-# INLINE newEmptyObject #-}
145+
146+newAsyncCallback :: JSCallAsFunction -> JSM Object
147+newAsyncCallback f = do
148+ object <- Object <$> sendLazyCommand NewAsyncCallback
149+ add <- addCallback <$> askJSM
150+ liftIO $ add object f
151+ return object
152+{-# INLINE newAsyncCallback #-}
153+
154+newSyncCallback :: JSCallAsFunction -> JSM Object
155+newSyncCallback f = do
156+ object <- Object <$> sendLazyCommand NewSyncCallback
157+ add <- addCallback <$> askJSM
158+ liftIO $ add object f
159+ return object
160+{-# INLINE newSyncCallback #-}
161+
162+newArray :: [JSVal] -> JSM JSVal
163+newArray xs = withJSVals xs $ \xs' -> sendLazyCommand (NewArray xs')
164+{-# INLINE newArray #-}
165+
166+evaluateScript :: JSString -> JSM JSVal
167+evaluateScript script = withJSString script $ sendLazyCommand . EvaluateScript
168+{-# INLINE evaluateScript #-}
169+
170+deRefVal :: JSVal -> JSM Result
171+deRefVal value = withJSVal value $ sendCommand . DeRefVal
172+{-# INLINE deRefVal #-}
173+
174+valueToBool :: JSVal -> JSM Bool
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
183+{-# INLINE valueToBool #-}
184+
185+valueToNumber :: JSVal -> JSM Double
186+valueToNumber value =
187+ withJSVal value $ \rval -> do
188+ ~(ValueToNumberResult result) <- sendCommand (ValueToNumber rval)
189+ return result
190+{-# INLINE valueToNumber #-}
191+
192+valueToString :: JSVal -> JSM JSString
193+valueToString value = withJSVal value $ \rval -> do
194+ ~(ValueToStringResult result) <- sendCommand (ValueToString rval)
195+ wrapJSString result
196+{-# INLINE valueToString #-}
197+
198+valueToJSON :: JSVal -> JSM JSString
199+valueToJSON value = withJSVal value $ \rval -> do
200+ ~(ValueToJSONResult result) <- sendCommand (ValueToJSON rval)
201+ wrapJSString result
202+{-# INLINE valueToJSON #-}
203+
204+valueToJSONValue :: JSVal -> JSM Value
205+valueToJSONValue value = withJSVal value $ \rval -> do
206+ ~(ValueToJSONValueResult result) <- sendCommand (ValueToJSONValue rval)
63207 return result
208+{-# INLINE valueToJSONValue #-}
209+
210+isNull :: JSVal -> JSM Bool
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
219+{-# INLINE isNull #-}
220+
221+isUndefined :: JSVal -> JSM Bool
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
230+{-# INLINE isUndefined #-}
231+
232+strictEqual :: JSVal -> JSVal -> JSM Bool
233+strictEqual a b =
234+ withJSVal a $ \aref ->
235+ withJSVal b $ \bref -> do
236+ ~(StrictEqualResult result) <- sendCommand $ StrictEqual aref bref
237+ return result
238+{-# INLINE strictEqual #-}
239+
240+instanceOf :: JSVal -> Object -> JSM Bool
241+instanceOf value constructor =
242+ withJSVal value $ \rval ->
243+ withObject constructor $ \c' -> do
244+ ~(InstanceOfResult result) <- sendCommand $ InstanceOf rval c'
245+ return result
246+{-# INLINE instanceOf #-}
64247
248+propertyNames :: Object -> JSM [JSString]
249+propertyNames this =
250+ withObject this $ \rthis -> do
251+ ~(PropertyNamesResult result) <- sendCommand $ PropertyNames rthis
252+ mapM wrapJSString result
253+{-# INLINE propertyNames #-}
jsaddle/src/Language/Javascript/JSaddle/Null.hsnew file+56
@@ -0,0 +1,56 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+-----------------------------------------------------------------------------
4+--
5+-- Module : Language.Javascript.JSaddle.WebSockets
6+-- Copyright : (c) Hamish Mackenzie
7+-- License : MIT
8+--
9+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.Javascript.JSaddle.Null (
16+ run
17+) where
18+
19+import Language.Javascript.JSaddle.Types
20+ (BatchResults(..), JSM, JSStringReceived(..), Batch(..),
21+ Results(..), Result(..), Command(..))
22+import Control.Concurrent.Chan (readChan, writeChan, newChan)
23+import Language.Javascript.JSaddle.Run (runJavaScript)
24+import Control.Concurrent (forkIO)
25+import Control.Monad (forever)
26+import Data.Aeson (Value(..))
27+import Data.Maybe (mapMaybe)
28+
29+-- | This is for performance testing JSaddle code that does not need to
30+-- to read anything back from the JavaScript context.
31+-- Anthing that does try to read will get JS null, 0 or "" back (depending
32+-- on how the value is read).
33+run :: JSM () -> IO ()
34+run f = do
35+ batches <- newChan
36+ (processResult, _processSyncResult, start) <- runJavaScript (writeChan batches) f
37+ _ <- forkIO $ forever $
38+ readChan batches >>= \case
39+ Batch commands _ batchNumber ->
40+ processResult $ BatchResults batchNumber . Success [] $ mapMaybe (\case
41+ Left _ -> Nothing
42+ Right command -> Just $
43+ case command of
44+ DeRefVal _ -> DeRefValResult 0 ""
45+ ValueToBool _ -> ValueToBoolResult False
46+ ValueToNumber _ -> ValueToNumberResult 0
47+ ValueToString _ -> ValueToStringResult (JSStringReceived "")
48+ ValueToJSON _ -> ValueToJSONResult (JSStringReceived "null")
49+ ValueToJSONValue _ -> ValueToJSONValueResult Null
50+ IsNull _ -> IsNullResult True
51+ IsUndefined _ -> IsUndefinedResult False
52+ StrictEqual _ _ -> StrictEqualResult False
53+ InstanceOf _ _ -> InstanceOfResult False
54+ PropertyNames _ -> PropertyNamesResult []
55+ Sync -> SyncResult) commands
56+ start
jsaddle/src/Language/Javascript/JSaddle/Object.hs+54−28
@@ -66,6 +66,7 @@ module Language.Javascript.JSaddle.Object (
6666 -- * Calling Haskell From JavaScript
6767 , Function(..)
6868 , function
69+ , asyncFunction
6970 , freeFunction
7071 , fun
7172 , JSCallAsFunction
@@ -102,7 +103,7 @@ import Data.Coerce (coerce)
102103#ifdef ghcjs_HOST_OS
103104import GHCJS.Types (nullRef)
104105import GHCJS.Foreign.Callback
105− (releaseCallback, syncCallback2, OnBlocked(..), Callback)
106+ (releaseCallback, syncCallback2, asyncCallback2, OnBlocked(..), Callback)
106107import GHCJS.Marshal (ToJSVal(..))
107108import JavaScript.Array (MutableJSArray)
108109import qualified JavaScript.Array as Array (toListIO, fromListIO)
@@ -115,14 +116,13 @@ import Language.Javascript.JSaddle.Types
115116#else
116117import GHCJS.Marshal.Internal (ToJSVal(..))
117118import Language.Javascript.JSaddle.Native
118− (withJSVals, withObject)
119−import Language.Javascript.JSaddle.Run
120− (AsyncCommand(..), sendLazyCommand)
119+ (newAsyncCallback, newSyncCallback, callAsFunction, callAsConstructor)
121120import Language.Javascript.JSaddle.Monad (askJSM, JSM)
122121import Language.Javascript.JSaddle.Types
123− (JSString, Object(..), SomeJSArray(..),
124− JSVal(..), JSCallAsFunction, JSContextRef(..))
122+ (JSValueForSend(..), AsyncCommand(..), JSString, Object(..),
123+ SomeJSArray(..), JSVal(..), JSCallAsFunction, JSContextRef(..))
125124import JavaScript.Object.Internal (create, listProps)
125+import Language.Javascript.JSaddle.Run (sendAsyncCommand)
126126#endif
127127import JavaScript.Array.Internal (fromListIO)
128128import Language.Javascript.JSaddle.Value (valToObject)
@@ -132,6 +132,8 @@ import Language.Javascript.JSaddle.Arguments (MakeArgs(..))
132132import Control.Monad.IO.Class (MonadIO(..))
133133import Language.Javascript.JSaddle.Properties
134134import Control.Lens (IndexPreservingGetter, to)
135+import Data.IORef (newIORef, readIORef)
136+import System.IO.Unsafe (unsafePerformIO)
135137
136138-- $setup
137139-- >>> import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
@@ -279,6 +281,7 @@ jsgf name = global # name
279281-- > jsg0 name = jsgf name ()
280282--
281283-- >>> testJSaddle $ jsg0 "globalFunc" >>= valToText
284+-- A JavaScript exception was thrown! (may not reach Haskell code)
282285-- TypeError:...undefine...
283286jsg0 :: (ToJSString name) => name -> JSM JSVal
284287jsg0 name = jsgf name ()
@@ -436,9 +439,16 @@ newtype Function = Function {functionObject :: Object}
436439#endif
437440
438441
442+#ifdef ghcjs_HOST_OS
443+foreign import javascript unsafe "$r = function () { $1(this, arguments); }"
444+ makeFunctionWithCallback :: Callback (JSVal -> JSVal -> IO ()) -> IO Object
445+#endif
446+
439447-- ^ Make a JavaScript function object that wraps a Haskell function.
448+-- Calls made to the function will be synchronous where possible
449+-- (on GHCJS it uses on `syncCallback2` with `ContinueAsync`).
440450function :: JSCallAsFunction -- ^ Haskell function to call
441− -> JSM Function -- ^ Returns a JavaScript function object that will
451+ -> JSM Function -- ^ Returns a JavaScript function object that will
442452 -- call the Haskell one when it is called
443453#ifdef ghcjs_HOST_OS
444454function f = do
@@ -446,13 +456,26 @@ function f = do
446456 rargs <- Array.toListIO (coerce args)
447457 f this this rargs -- TODO pass function object through
448458 Function callback <$> makeFunctionWithCallback callback
449−foreign import javascript unsafe "$r = function () { $1(this, arguments); }"
450− makeFunctionWithCallback :: Callback (JSVal -> JSVal -> IO ()) -> IO Object
451459#else
452460function f = do
453− object <- Object <$> sendLazyCommand NewCallback
454− add <- addCallback <$> askJSM
455− liftIO $ add object f
461+ object <- newSyncCallback f
462+ return $ Function object
463+#endif
464+
465+-- ^ Make a JavaScript function object that wraps a Haskell function.
466+-- Calls made to the function will be Asynchronous.
467+asyncFunction :: JSCallAsFunction -- ^ Haskell function to call
468+ -> JSM Function -- ^ Returns a JavaScript function object that will
469+ -- call the Haskell one when it is called
470+#ifdef ghcjs_HOST_OS
471+asyncFunction f = do
472+ callback <- asyncCallback2 $ \this args -> do
473+ rargs <- Array.toListIO (coerce args)
474+ f this this rargs -- TODO pass function object through
475+ Function callback <$> makeFunctionWithCallback callback
476+#else
477+asyncFunction f = do
478+ object <- newAsyncCallback f
456479 return $ Function object
457480#endif
458481
@@ -461,9 +484,16 @@ freeFunction :: Function -> JSM ()
461484freeFunction (Function callback _) = liftIO $
462485 releaseCallback callback
463486#else
464−freeFunction (Function object) = do
465− free <- freeCallback <$> askJSM
466− 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))
467497#endif
468498
469499instance ToJSVal Function where
@@ -496,13 +526,12 @@ array args = do
496526 Object . coerce <$> fromListIO rargs
497527
498528-- | JavaScript's global object
499−global :: Object
500529#ifdef ghcjs_HOST_OS
501−global = js_window
502−foreign import javascript unsafe "$r = window"
503− js_window :: Object
530+foreign import javascript unsafe "$r = globalThis"
531+ global :: Object
504532#else
505−global = Object (JSVal 4)
533+global :: Object
534+global = Object . JSVal . unsafePerformIO $ newIORef 4
506535#endif
507536
508537-- | Get a list containing the property names present on a given object
@@ -527,14 +556,12 @@ objCallAsFunction :: MakeArgs args
527556objCallAsFunction f this args = do
528557 rargs <- makeArgs args >>= liftIO . Array.fromListIO
529558 liftIO $ js_apply f this rargs
530−foreign import javascript unsafe "$r = $1.apply($2, $3)"
559+foreign import javascript safe "$r = $1.apply($2, $3)"
531560 js_apply :: Object -> Object -> MutableJSArray -> IO JSVal
532561#else
533562objCallAsFunction f this args = do
534563 rargs <- makeArgs args
535− withObject f $ \rfunction ->
536− withObject this $ \rthis ->
537− withJSVals rargs $ sendLazyCommand . CallAsFunction rfunction rthis
564+ callAsFunction f this rargs
538565#endif
539566
540567-- | Call a JavaScript object as a constructor. Consider using 'new'.
@@ -549,7 +576,7 @@ objCallAsConstructor :: MakeArgs args
549576objCallAsConstructor f args = do
550577 rargs <- makeArgs args >>= liftIO . Array.fromListIO
551578 liftIO $ js_new f rargs
552−foreign import javascript unsafe "\
579+foreign import javascript safe "\
553580 switch($2.length) {\
554581 case 0 : $r = new $1(); break;\
555582 case 1 : $r = new $1($2[0]); break;\
@@ -576,8 +603,7 @@ foreign import javascript unsafe "\
576603#else
577604objCallAsConstructor f args = do
578605 rargs <- makeArgs args
579− withObject f $ \rfunction ->
580− withJSVals rargs $ sendLazyCommand . CallAsConstructor rfunction
606+ callAsConstructor f rargs
581607#endif
582608
583609-- >>> testJSaddle $ strictEqual nullObject (eval "null")
@@ -586,5 +612,5 @@ nullObject :: Object
586612#ifdef ghcjs_HOST_OS
587613nullObject = Object nullRef
588614#else
589−nullObject = Object (JSVal 0)
615+nullObject = Object . JSVal . unsafePerformIO $ newIORef 0
590616#endif
jsaddle/src/Language/Javascript/JSaddle/Run.hs+174−64
@@ -1,6 +1,9 @@
1+{-# LANGUAGE BangPatterns #-}
12{-# LANGUAGE CPP #-}
23{-# LANGUAGE LambdaCase #-}
34{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE MagicHash #-}
6+{-# LANGUAGE UnboxedTuples #-}
47-----------------------------------------------------------------------------
58--
69-- Module : Language.Javascript.JSaddle.Run
@@ -19,6 +22,7 @@ module Language.Javascript.JSaddle.Run (
1922 , syncAfter
2023 , waitForAnimationFrame
2124 , nextAnimationFrame
25+ , enableLogging
2226#ifndef ghcjs_HOST_OS
2327 -- * Functions used to implement JSaddle using JSON messaging
2428 , runJavaScript
@@ -28,61 +32,72 @@ module Language.Javascript.JSaddle.Run (
2832 , sendCommand
2933 , sendLazyCommand
3034 , sendAsyncCommand
35+ , wrapJSVal
3136#endif
3237) where
3338
3439#ifdef ghcjs_HOST_OS
35−import Language.Javascript.JSaddle.Types (JSM)
40+import Language.Javascript.JSaddle.Types (JSM, syncPoint, syncAfter)
3641import qualified JavaScript.Web.AnimationFrame as GHCJS
3742 (waitForAnimationFrame)
3843#else
39−import Control.Exception (throwIO)
40−import Control.Monad (void, forever, zipWithM_)
44+import Control.Exception (throwIO, evaluate)
45+import Control.Monad (void, when, zipWithM_)
4146import Control.Monad.IO.Class (MonadIO(..))
4247import Control.Monad.Trans.Reader (ask, runReaderT)
4348import Control.Monad.STM (atomically)
44−import Control.Concurrent (forkIO)
49+import Control.Concurrent (forkIO, myThreadId)
4550import Control.Concurrent.STM.TChan
4651 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
4752import Control.Concurrent.STM.TVar
48− (writeTVar, readTVar, readTVarIO, modifyTVar, newTVarIO)
53+ (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
4954import Control.Concurrent.MVar
50− (MVar, MVar, putMVar, takeMVar, newEmptyMVar)
55+ (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)
5156
5257import System.IO.Unsafe (unsafeInterleaveIO)
58+import System.Mem.Weak (addFinalizer)
59+import System.Random
5360
61+import GHC.Base (IO(..), mkWeak#)
62+import GHC.Conc (ThreadId(..))
5463import Data.Monoid ((<>))
55−import qualified Data.Text as T (unpack)
56−import qualified Data.Map as M (lookup, delete, insert, empty)
64+import qualified Data.Text as T (unpack, pack)
65+import qualified Data.Map as M (lookup, delete, insert, empty, size)
66+import qualified Data.Set as S (empty, member, insert, delete)
5767import Data.Time.Clock (getCurrentTime,diffUTCTime)
68+import Data.IORef
69+ (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)
5870
5971import Language.Javascript.JSaddle.Types
60− (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),
61− Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
72+ (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
73+ Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand)
6274import Language.Javascript.JSaddle.Exception (JSException(..))
63−import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
64−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
79+import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
80+#endif
81+import Data.Foldable (forM_)
6582#endif
6683
67−-- | Forces execution of pending asyncronous code
68−syncPoint :: JSM ()
69−#ifdef ghcjs_HOST_OS
70−syncPoint = return ()
84+#ifndef ghcjs_HOST_OS
85+#if MIN_VERSION_base(4,11,0)
86+currentBytesUsed = gcdetails_live_bytes . gc
7187#else
72−syncPoint = do
73− SyncResult <- sendCommand Sync
74− return ()
88+getRTSStatsEnabled = getGCStatsEnabled
89+getRTSStats = getGCStats
90+#endif
7591#endif
7692
77−-- | Forces execution of pending asyncronous code after performing `f`
78−syncAfter :: JSM a -> JSM a
93+-- | Enable (or disable) JSaddle logging
94+enableLogging :: Bool -> JSM ()
7995#ifdef ghcjs_HOST_OS
80−syncAfter = id
96+enableLogging _ = return ()
8197#else
82−syncAfter f = do
83− result <- f
84− syncPoint
85− return result
98+enableLogging v = do
99+ f <- doEnableLogging <$> JSM ask
100+ liftIO $ f v
86101#endif
87102
88103-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
@@ -110,17 +125,12 @@ nextAnimationFrame f = do
110125 syncAfter (f t)
111126
112127#ifndef ghcjs_HOST_OS
113−sendCommand :: Command -> JSM Result
114−sendCommand cmd = do
115− s <- doSendCommand <$> JSM ask
116− liftIO $ s cmd
117−
118128sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
119129sendLazyCommand cmd = do
120130 nextRefTVar <- nextRef <$> JSM ask
121131 n <- liftIO . atomically $ do
122132 n <- subtract 1 <$> readTVar nextRefTVar
123− writeTVar nextRefTVar n
133+ writeTVar nextRefTVar $! n
124134 return n
125135 s <- doSendAsyncCommand <$> JSM ask
126136 liftIO $ s (cmd $ JSValueForSend n)
@@ -131,48 +141,112 @@ sendAsyncCommand cmd = do
131141 s <- doSendAsyncCommand <$> JSM ask
132142 liftIO $ s cmd
133143
134−runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ())
144+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
135145runJavaScript sendBatch entryPoint = do
146+ contextId' <- randomIO
136147 startTime' <- getCurrentTime
137− recvChan <- newTChanIO
148+ recvMVar <- newEmptyMVar
149+ lastAsyncBatch <- newEmptyMVar
138150 commandChan <- newTChanIO
139151 callbacks <- newTVarIO M.empty
140152 nextRef' <- newTVarIO 0
153+ finalizerThreads' <- newMVar S.empty
154+ animationFrameHandlers' <- newMVar []
155+ loggingEnabled <- newIORef False
156+ liveRefs' <- newMVar S.empty
141157 let ctx = JSContextRef {
142− startTime = startTime'
143− , doSendCommand = \cmd -> cmd `deepseq` do
144− result <- newEmptyMVar
145− atomically $ writeTChan commandChan (Right (cmd, result))
146− unsafeInterleaveIO $
147− takeMVar result >>= \case
148− (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
149− r -> return r
150− , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
151− , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar callbacks (M.insert val cb)
152− , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar callbacks (M.delete val)
153− , nextRef = nextRef'
154− }
155− let processResults = \case
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 ()
180+ processResults syncCallbacks = \case
156181 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
157− (Callback f this a) -> do
158− f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
182+ (Callback n br (JSValueReceived fNumber) f this a) -> do
183+ putMVar recvMVar (n, br)
184+ f' <- runReaderT (unJSM $ wrapJSVal f) ctx
159185 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
160186 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
187+ logInfo (("Call " <> show fNumber <> " ") <>)
161188 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
162189 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
163− Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
164− m -> atomically $ writeTChan recvChan m
165− _ <- forkIO . forever $ readBatch commandChan >>= \case
166− (batch, resultMVars) -> do
190+ Just cb -> void . forkIO $ do
191+ runReaderT (unJSM $ cb f' this' args) ctx
192+ when syncCallbacks $
193+ doSendAsyncCommand ctx EndSyncBlock
194+ Duplicate nBatch nExpected -> do
195+ putStrLn $ "Error : Unexpected Duplicate. syncCallbacks=" <> show syncCallbacks <>
196+ " nBatch=" <> show nBatch <> " nExpected=" <> show nExpected
197+ void $ doSendCommand ctx Sync
198+ BatchResults n br -> putMVar recvMVar (n, br)
199+ asyncResults :: Results -> IO ()
200+ asyncResults results =
201+ void . forkIO $ processResults False results
202+ syncResults :: Results -> IO Batch
203+ syncResults results = do
204+ void . forkIO $ processResults True results
205+ readMVar lastAsyncBatch
206+ logInfo s =
207+ readIORef loggingEnabled >>= \case
208+ True -> do
209+ currentBytesUsedStr <- getRTSStatsEnabled >>= \case
210+ True -> show . currentBytesUsed <$> getRTSStats
211+ False -> return "??"
212+ cbCount <- M.size <$> readTVarIO callbacks
213+ putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "
214+ False -> return ()
215+ _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->
216+ readBatch nBatch commandChan >>= \case
217+ (batch@(Batch cmds _ _), resultMVars) -> do
218+ logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
219+ _ <- tryTakeMVar lastAsyncBatch
220+ putMVar lastAsyncBatch batch
167221 sendBatch batch
168− atomically (readTChan recvChan) >>= \case
169− Success results -> zipWithM_ putMVar resultMVars results
170− Failure results exception -> zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
171− _ -> error "Unexpected jsaddle results"
172− return (processResults, runReaderT (unJSM entryPoint) ctx)
222+ takeResult recvMVar nBatch >>= \case
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))
238+ return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)
173239 where
174− readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
175− readBatch chan = do
240+ numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m ()
241+ numberForeverFromM_ !n f = do
242+ _ <- f n
243+ numberForeverFromM_ (succ n) f
244+ takeResult recvMVar nBatch =
245+ takeMVar recvMVar >>= \case
246+ (n, _) | n < nBatch -> takeResult recvMVar nBatch
247+ r -> return r
248+ readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
249+ readBatch nBatch chan = do
176250 first <- atomically $ readTChan chan -- We want at least one command to send
177251 loop first ([], [])
178252 where
@@ -183,19 +257,55 @@ runJavaScript sendBatch entryPoint = do
183257 let cmds = Right syncCmd:cmds'
184258 resultMVars = resultMVar:resultMVars'
185259 atomically (tryReadTChan chan) >>= \case
186− Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
260+ Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
187261 Just cmd -> loop cmd (cmds, resultMVars)
188262 loop (Left asyncCmd) (cmds', resultMVars) = do
189263 let cmds = Left asyncCmd:cmds'
190264 atomically (tryReadTChan chan) >>= \case
191− Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
265+ Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
192266 Just cmd -> loop cmd (cmds, resultMVars)
193267 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
194268 loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
195269 loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =
196− return (Batch (reverse (Right Sync:cmds)) True, reverse (resultMVar:resultMVars))
270+ return (Batch (reverse (Right Sync:cmds)) True nBatch, reverse (resultMVar:resultMVars))
197271 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
198272 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
199273 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
200274 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
275+
276+addThreadFinalizer :: ThreadId -> IO () -> IO ()
277+addThreadFinalizer t@(ThreadId t#) (IO finalizer) =
278+ IO $ \s -> case mkWeak# t# t finalizer s of { (# s1, _ #) -> (# s1, () #) }
279+
280+
281+wrapJSVal :: JSValueReceived -> JSM JSVal
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
299+ ft <- takeMVar $ finalizerThreads ctx
300+ t <- myThreadId
301+ let tname = T.pack $ show t
302+ doSendAsyncCommand ctx $ FreeRef tname $ JSValueForSend n
303+ if tname `S.member` ft
304+ then putMVar (finalizerThreads ctx) ft
305+ else do
306+ addThreadFinalizer t $ do
307+ modifyMVar (finalizerThreads ctx) $ \s -> return (S.delete tname s, ())
308+ doSendAsyncCommand ctx $ FreeRefs tname
309+ putMVar (finalizerThreads ctx) =<< evaluate (S.insert tname ft)
310+ return (JSVal ref)
201311#endif
jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+186−56
@@ -13,7 +13,6 @@
1313
1414module Language.Javascript.JSaddle.Run.Files (
1515 indexHtml
16− , jsaddleJs
1716 , initState
1817 , runBatch
1918 , ghcjsHelpers
@@ -31,25 +30,38 @@ 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
3837initState = "\
3938 \ var jsaddle_values = new Map();\n\
39+ \ var jsaddle_free = new Map();\n\
4040 \ jsaddle_values.set(0, null);\n\
4141 \ jsaddle_values.set(1, undefined);\n\
4242 \ jsaddle_values.set(2, false);\n\
4343 \ jsaddle_values.set(3, true);\n\
44− \ jsaddle_values.set(4, window);\n\
44+ \ jsaddle_values.set(4, globalThis);\n\
4545 \ var jsaddle_index = 100;\n\
46+ \ var expectedBatch = 1;\n\
47+ \ var lastResults = [0, {\"tag\": \"Success\", \"contents\": [[], []]}];\n\
48+ \ var inCallback = 0;\n\
49+ \ var asyncBatch = null;\n\
4650 \"
4751
48−runBatch :: (ByteString -> ByteString) -> ByteString
49−runBatch send = "\
52+runBatch :: (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString
53+runBatch send sendSync = "\
54+ \ var runBatch = function(firstBatch, initialSyncDepth) {\n\
5055 \ var processBatch = function(timestamp) {\n\
51− \ var results = [];\n\
52− \ try {\n\
56+ \ var batch = firstBatch;\n\
57+ \ var callbacksToFree = [];\n\
58+ \ var results = [];\n\
59+ \ inCallback++;\n\
60+ \ try {\n\
61+ \ syncDepth = initialSyncDepth || 0;\n\
62+ \ for(;;){\n\
63+ \ if(batch[2] === expectedBatch) {\n\
64+ \ expectedBatch++;\n\
5365 \ var nCommandsLength = batch[0].length;\n\
5466 \ for (var nCommand = 0; nCommand != nCommandsLength; nCommand++) {\n\
5567 \ var cmd = batch[0][nCommand];\n\
@@ -57,7 +69,15 @@ runBatch send = "\
5769 \ var d = cmd.Left;\n\
5870 \ switch (d.tag) {\n\
5971 \ case \"FreeRef\":\n\
60− \ jsaddle_values.delete(d.contents);\n\
72+ \ var refsToFree = jsaddle_free.get(d.contents[0]) || [];\n\
73+ \ refsToFree.push(d.contents[1]);\n\
74+ \ jsaddle_free.set(d.contents[0], refsToFree);\n\
75+ \ break;\n\
76+ \ case \"FreeRefs\":\n\
77+ \ var refsToFree = jsaddle_free.get(d.contents) || [];\n\
78+ \ for(var nRef = 0; nRef != refsToFree.length; nRef++)\n\
79+ \ jsaddle_values.delete(refsToFree[nRef]);\n\
80+ \ jsaddle_free.delete(d.contents);\n\
6181 \ break;\n\
6282 \ case \"SetPropertyByName\":\n\
6383 \ jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]);\n\
@@ -73,6 +93,10 @@ runBatch send = "\
7393 \ var n = d.contents[1];\n\
7494 \ jsaddle_values.set(n, d.contents[0]);\n\
7595 \ 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\
76100 \ case \"GetPropertyByName\":\n\
77101 \ var n = d.contents[2];\n\
78102 \ jsaddle_values.set(n, jsaddle_values.get(d.contents[0])[d.contents[1]]);\n\
@@ -89,10 +113,12 @@ runBatch send = "\
89113 \ var n = d.contents;\n\
90114 \ jsaddle_values.set(n, {});\n\
91115 \ break;\n\
92− \ case \"NewCallback\":\n\
116+ \ case \"NewAsyncCallback\":\n\
93117 \ (function() {\n\
94118 \ var nFunction = d.contents;\n\
95− \ jsaddle_values.set(nFunction, function() {\n\
119+ \ var func = function() {\n\
120+ \ var nFunctionInFunc = ++jsaddle_index;\n\
121+ \ jsaddle_values.set(nFunctionInFunc, func);\n\
96122 \ var nThis = ++jsaddle_index;\n\
97123 \ jsaddle_values.set(nThis, this);\n\
98124 \ var args = [];\n\
@@ -101,8 +127,41 @@ runBatch send = "\
101127 \ jsaddle_values.set(nArg, arguments[i]);\n\
102128 \ args[i] = nArg;\n\
103129 \ }\n\
104− \ " <> send "{\"tag\": \"Callback\", \"contents\": [nFunction, nThis, args]}" <> "\n\
105− \ })})();\n\
130+ \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n\
131+ \ };\n\
132+ \ jsaddle_values.set(nFunction, func);\n\
133+ \ })();\n\
134+ \ break;\n\
135+ \ case \"NewSyncCallback\":\n\
136+ \ (function() {\n\
137+ \ var nFunction = d.contents;\n\
138+ \ var func = function() {\n\
139+ \ var nFunctionInFunc = ++jsaddle_index;\n\
140+ \ jsaddle_values.set(nFunctionInFunc, func);\n\
141+ \ var nThis = ++jsaddle_index;\n\
142+ \ jsaddle_values.set(nThis, this);\n\
143+ \ var args = [];\n\
144+ \ for (var i = 0; i != arguments.length; i++) {\n\
145+ \ var nArg = ++jsaddle_index;\n\
146+ \ jsaddle_values.set(nArg, arguments[i]);\n\
147+ \ args[i] = nArg;\n\
148+ \ }\n" <> (
149+ case sendSync of
150+ Just s ->
151+ " if(inCallback > 0) {\n\
152+ \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n\
153+ \ } else {\n\
154+ \ runBatch(" <> s "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> ", 1);\n\
155+ \ }\n"
156+ Nothing ->
157+ " " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n"
158+ ) <>
159+ " };\n\
160+ \ jsaddle_values.set(nFunction, func);\n\
161+ \ })();\n\
162+ \ break;\n\
163+ \ case \"FreeCallback\":\n\
164+ \ callbacksToFree.push(d.contents);\n\
106165 \ break;\n\
107166 \ case \"CallAsFunction\":\n\
108167 \ var n = d.contents[3];\n\
@@ -145,9 +204,15 @@ runBatch send = "\
145204 \ jsaddle_values.set(n, d.contents[0].map(function(v){return jsaddle_values.get(v);}));\n\
146205 \ break;\n\
147206 \ case \"SyncWithAnimationFrame\":\n\
148− \ var n = d.contents[0];\n\
207+ \ var n = d.contents;\n\
149208 \ jsaddle_values.set(n, timestamp);\n\
150209 \ break;\n\
210+ \ case \"StartSyncBlock\":\n\
211+ \ syncDepth++;\n\
212+ \ break;\n\
213+ \ case \"EndSyncBlock\":\n\
214+ \ syncDepth--;\n\
215+ \ break;\n\
151216 \ default:\n\
152217 \ " <> send "{\"tag\": \"ProtocolError\", \"contents\": e.data}" <> "\n\
153218 \ return;\n\
@@ -182,7 +247,7 @@ runBatch send = "\
182247 \ (v === true ) ? [3, \"\"] :\n\
183248 \ (typeof v === \"number\") ? [-1, v.toString()] :\n\
184249 \ (typeof v === \"string\") ? [-2, v]\n\
185− \ : [n, \"\"];\n\
250+ \ : [-3, \"\"];\n\
186251 \ results.push({\"tag\": \"DeRefValResult\", \"contents\": c});\n\
187252 \ break;\n\
188253 \ case \"IsNull\":\n\
@@ -210,55 +275,66 @@ runBatch send = "\
210275 \ }\n\
211276 \ }\n\
212277 \ }\n\
213− \ " <> send "{\"tag\": \"Success\", \"contents\": results}" <> "\n\
214− \ }\n\
215− \ catch (err) {\n\
216− \ var n = ++jsaddle_index;\n\
217− \ jsaddle_values.set(n, err);\n\
218− \ " <> send "{\"tag\": \"Failure\", \"contents\": [results,n]}" <> "\n\
278+ \ if(syncDepth <= 0) {\n\
279+ \ lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": [callbacksToFree, results]}];\n\
280+ \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> "\n\
281+ \ break;\n\
282+ \ } else {\n" <> (
283+ case sendSync of
284+ Just s ->
285+ " lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": [callbacksToFree, results]}];\n\
286+ \ batch = " <> s "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> ";\n\
287+ \ results = [];\n\
288+ \ callbacksToFree = [];\n"
289+ Nothing ->
290+ " " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Success\", \"contents\": [callbacksToFree, results]}]}" <> "\n\
291+ \ break;\n"
292+ ) <>
293+ " }\n\
294+ \ } else {\n\
295+ \ if(syncDepth <= 0) {\n\
296+ \ break;\n\
297+ \ } else {\n" <> (
298+ case sendSync of
299+ Just s ->
300+ " if(batch[2] === expectedBatch - 1) {\n\
301+ \ batch = " <> s "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> ";\n\
302+ \ } else {\n\
303+ \ batch = " <> s "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> ";\n\
304+ \ }\n\
305+ \ results = [];\n\
306+ \ callbacksToFree = [];\n"
307+ Nothing ->
308+ " " <> send "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> "\n\
309+ \ break;\n"
310+ ) <>
311+ " }\n\
312+ \ }\n\
219313 \ }\n\
314+ \ }\n\
315+ \ catch (err) {\n\
316+ \ var n = ++jsaddle_index;\n\
317+ \ jsaddle_values.set(n, err);\n\
318+ \ console.log(err);\n\
319+ \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Failure\", \"contents\": [callbacksToFree, results, n, String(err)]}]}" <> "\n\
320+ \ }\n\
321+ \ if(inCallback == 1) {\n\
322+ \ while(asyncBatch !== null) {\n\
323+ \ var b = asyncBatch;\n\
324+ \ asyncBatch = null;\n\
325+ \ if(b[2] == expectedBatch) runBatch(b);\n\
326+ \ }\n\
327+ \ }\n\
328+ \ inCallback--;\n\
220329 \ };\n\
221− \ if(batch[1]) {\n\
330+ \ if(batch[1] && (initialSyncDepth || 0) === 0) {\n\
222331 \ window.requestAnimationFrame(processBatch);\n\
223332 \ }\n\
224333 \ else {\n\
225334 \ processBatch(window.performance ? window.performance.now() : null);\n\
226335 \ }\n\
227− \"
228−
229−-- Use this to generate this string for embedding
230−-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy
231−jsaddleJs :: ByteString
232−jsaddleJs = "\
233− \if(typeof global !== \"undefined\") {\n\
234− \ global.window = global;\n\
235− \ global.WebSocket = require('ws');\n\
236− \}\n\
237− \\n\
238− \var connect = function() {\n\
239− \ var wsaddress =\n\
240− \ typeof window.location === \"undefined\"\n\
241− \ ? \"ws://localhost:3709/\"\n\
242− \ : window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\");\n\
243− \\n\
244− \ var ws = new WebSocket(wsaddress);\n\
245− \\n\
246− \ ws.onopen = function(e) {\n\
247− \ " <> initState <> "\
248− \\n\
249− \ ws.onmessage = function(e) {\n\
250− \ var batch = JSON.parse(e.data);\n\
251− \\n\
252− \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));") <> "\
253− \ };\n\
254− \ };\n\
255− \ ws.onerror = function() {\n\
256− \ setTimeout(connect, 1000);\n\
257− \ };\n\
258− \}\n\
259− \\n\
260− \ " <> ghcjsHelpers <> "\
261− \connect();\n\
336+ \ };\n\
337+ \ runBatch(batch);\n\
262338 \"
263339
264340ghcjsHelpers :: ByteString
@@ -329,4 +405,58 @@ ghcjsHelpers = "\
329405 \ }\n\
330406 \\n\
331407 \}\n\
408+ \function h$roundUpToMultipleOf(n,m) {\n\
409+ \ var rem = n % m;\n\
410+ \ return rem === 0 ? n : n - rem + m;\n\
411+ \}\n\
412+ \\n\
413+ \function h$newByteArray(len) {\n\
414+ \ var len0 = Math.max(h$roundUpToMultipleOf(len, 8), 8);\n\
415+ \ var buf = new ArrayBuffer(len0);\n\
416+ \ return { buf: buf\n\
417+ \ , len: len\n\
418+ \ , i3: new Int32Array(buf)\n\
419+ \ , u8: new Uint8Array(buf)\n\
420+ \ , u1: new Uint16Array(buf)\n\
421+ \ , f3: new Float32Array(buf)\n\
422+ \ , f6: new Float64Array(buf)\n\
423+ \ , dv: new DataView(buf)\n\
424+ \ }\n\
425+ \}\n\
426+ \function h$wrapBuffer(buf, unalignedOk, offset, length) {\n\
427+ \ if(!unalignedOk && offset && offset % 8 !== 0) {\n\
428+ \ throw (\"h$wrapBuffer: offset not aligned:\" + offset);\n\
429+ \ }\n\
430+ \ if(!buf || !(buf instanceof ArrayBuffer))\n\
431+ \ throw \"h$wrapBuffer: not an ArrayBuffer\"\n\
432+ \ if(!offset) { offset = 0; }\n\
433+ \ if(!length || length < 0) { length = buf.byteLength - offset; }\n\
434+ \ return { buf: buf\n\
435+ \ , len: length\n\
436+ \ , i3: (offset%4) ? null : new Int32Array(buf, offset, length >> 2)\n\
437+ \ , u8: new Uint8Array(buf, offset, length)\n\
438+ \ , u1: (offset%2) ? null : new Uint16Array(buf, offset, length >> 1)\n\
439+ \ , f3: (offset%4) ? null : new Float32Array(buf, offset, length >> 2)\n\
440+ \ , f6: (offset%8) ? null : new Float64Array(buf, offset, length >> 3)\n\
441+ \ , dv: new DataView(buf, offset, length)\n\
442+ \ };\n\
443+ \}\n\
444+ \function h$newByteArrayFromBase64String(base64) {\n\
445+ \ var bin = window.atob(base64);\n\
446+ \ var ba = h$newByteArray(bin.length);\n\
447+ \ var u8 = ba.u8;\n\
448+ \ for (var i = 0; i < bin.length; i++) {\n\
449+ \ u8[i] = bin.charCodeAt(i);\n\
450+ \ }\n\
451+ \ return ba;\n\
452+ \}\n\
453+ \function h$byteArrayToBase64String(off, len, ba) {\n\
454+ \ var bin = '';\n\
455+ \ var u8 = ba.u8;\n\
456+ \ var end = off + len;\n\
457+ \ for (var i = off; i < end; i++) {\n\
458+ \ bin += String.fromCharCode(u8[i]);\n\
459+ \ }\n\
460+ \ return window.btoa(bin);\n\
461+ \}\n\
332462 \"
jsaddle/src/Language/Javascript/JSaddle/Types.hs+239−45
@@ -1,18 +1,20 @@
11{-# LANGUAGE CPP #-}
22#ifdef ghcjs_HOST_OS
3−{-# LANGUAGE ConstraintKinds #-}
43{-# OPTIONS_GHC -Wno-dodgy-exports #-}
54#else
65{-# LANGUAGE TypeFamilies #-}
76{-# LANGUAGE UndecidableInstances #-}
87{-# LANGUAGE GeneralizedNewtypeDeriving #-}
98{-# LANGUAGE DeriveGeneric #-}
10−{-# LANGUAGE DefaultSignatures #-}
119{-# LANGUAGE DataKinds #-}
12−{-# LANGUAGE KindSignatures #-}
1310{-# LANGUAGE PolyKinds #-}
1411{-# LANGUAGE FlexibleContexts #-}
12+{-# LANGUAGE DefaultSignatures #-}
13+{-# LANGUAGE ImplicitParams #-}
1514#endif
15+{-# LANGUAGE ConstraintKinds #-}
16+{-# LANGUAGE KindSignatures #-}
17+{-# LANGUAGE AllowAmbiguousTypes #-}
1618-----------------------------------------------------------------------------
1719--
1820-- Module : Language.Javascript.JSaddle.Types
@@ -34,20 +36,41 @@ module Language.Javascript.JSaddle.Types (
3436 , MonadJSM(..)
3537 , liftJSM
3638
39+ -- * Pure GHCJS functions
40+ , GHCJSPure(..)
41+ , ghcjsPure
42+ , ghcjsPureMap
43+ , ghcjsPureId
44+
3745 -- * JavaScript Value Types
3846 , JSVal(..)
39− , IsJSVal
47+ , IsJSVal(..)
4048 , jsval
4149 , SomeJSArray(..)
4250 , JSArray
4351 , MutableJSArray
52+ , STJSArray
4453 , Object(..)
4554 , JSString(..)
4655 , Nullable(..)
4756 , JSCallAsFunction
4857
49− -- * JavaScript Context Commands
58+ -- * Debugging
59+ , JSadddleHasCallStack
60+
61+ -- * Sync JSM
62+ , syncPoint
63+ , syncAfter
64+
5065#ifndef ghcjs_HOST_OS
66+ , sendCommand
67+
68+ -- * JavaScript Context Commands
69+ , MutabilityType(..)
70+ , Mutable
71+ , Immutable
72+ , IsItMutable(..)
73+ , Mutability
5174 , JSValueReceived(..)
5275 , JSValueForSend(..)
5376 , JSStringReceived(..)
@@ -57,6 +80,7 @@ module Language.Javascript.JSaddle.Types (
5780 , Command(..)
5881 , Batch(..)
5982 , Result(..)
83+ , BatchResults(..)
6084 , Results(..)
6185#endif
6286) where
@@ -65,26 +89,48 @@ import Control.Monad.IO.Class (MonadIO(..))
6589#ifdef ghcjs_HOST_OS
6690import GHCJS.Types
6791import JavaScript.Object.Internal (Object(..))
68−import JavaScript.Array.Internal (SomeJSArray(..), JSArray, MutableJSArray)
92+import JavaScript.Array.Internal (SomeJSArray(..), JSArray, MutableJSArray, STJSArray)
6993import GHCJS.Nullable (Nullable(..))
7094#else
95+import GHCJS.Prim.Internal (JSVal(..), JSValueRef)
96+import Data.JSString.Internal.Type (JSString(..))
7197import Control.DeepSeq (NFData(..))
72−import Control.Monad.Trans.Reader (ReaderT(..))
73−import Control.Monad.Trans.State.Lazy (StateT(..))
74−import qualified Control.Monad.Trans.State.Strict as Strict
75− (StateT(..))
98+import Control.Monad.Catch (MonadThrow, MonadCatch(..), MonadMask(..))
99+import Control.Monad.Trans.Cont (ContT(..))
100+import Control.Monad.Trans.Error (Error(..), ErrorT(..))
101+import Control.Monad.Trans.Except (ExceptT(..))
102+import Control.Monad.Trans.Identity (IdentityT(..))
103+import Control.Monad.Trans.List (ListT(..))
104+import Control.Monad.Trans.Maybe (MaybeT(..))
105+import Control.Monad.Trans.Reader (ReaderT(..), ask)
106+import Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))
107+import Control.Monad.Trans.RWS.Strict as Strict (RWST(..))
108+import Control.Monad.Trans.State.Lazy as Lazy (StateT(..))
109+import Control.Monad.Trans.State.Strict as Strict (StateT(..))
110+import Control.Monad.Trans.Writer.Lazy as Lazy (WriterT(..))
111+import Control.Monad.Trans.Writer.Strict as Strict (WriterT(..))
76112import Control.Monad.Trans.Class (MonadTrans(..))
77113import Control.Monad.Fix (MonadFix)
78114import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))
79115import Control.Concurrent.STM.TVar (TVar)
80−import Data.Coerce (Coercible, coerce)
116+import Control.Concurrent.MVar (MVar)
81117import Data.Int (Int64)
118+import Data.Set (Set)
82119import Data.Text (Text)
83120import Data.Time.Clock (UTCTime(..))
84121import Data.Typeable (Typeable)
122+import Data.Coerce (coerce, Coercible)
85123import Data.Aeson
86124 (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..), Value)
87125import GHC.Generics (Generic)
126+import Control.Monad.IO.Unlift (MonadUnliftIO)
127+import qualified Control.Monad.Fail as Fail
128+#endif
129+
130+#if MIN_VERSION_base(4,9,0) && defined(CHECK_UNCHECKED)
131+import GHC.Stack (HasCallStack)
132+#else
133+import GHC.Exts (Constraint)
88134#endif
89135
90136-- | Identifies a JavaScript execution context.
@@ -95,12 +141,16 @@ import GHC.Generics (Generic)
95141type JSContextRef = ()
96142#else
97143data JSContextRef = JSContextRef {
98− startTime :: UTCTime
99− , doSendCommand :: Command -> IO Result
100− , doSendAsyncCommand :: AsyncCommand -> IO ()
101− , addCallback :: Object -> JSCallAsFunction -> IO ()
102− , freeCallback :: Object -> IO ()
103− , nextRef :: TVar JSValueRef
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)
104154}
105155#endif
106156
@@ -116,8 +166,96 @@ data JSContextRef = JSContextRef {
116166type JSM = IO
117167#else
118168newtype JSM a = JSM { unJSM :: ReaderT JSContextRef IO a }
119− 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
211+#endif
212+
213+#ifndef ghcjs_HOST_OS
214+sendCommand :: Command -> JSM Result
215+sendCommand cmd = do
216+ s <- doSendCommand <$> JSM ask
217+ liftIO $ s cmd
218+#endif
219+
220+-- | Type we can give to functions that are pure when using ghcjs, but
221+-- live in JSM when using jsaddle.
222+--
223+-- Some functions that can be pure in GHCJS cannot be implemented in
224+-- a pure way in JSaddle (because we need to know the JSContextRef).
225+-- Instead we implement versions of these functions in that return
226+-- `GHCJSPure a` instead of `a`. To call them in a way that will
227+-- work when compiling with GHCJS use `ghcjsPure`.
228+#ifdef ghcjs_HOST_OS
229+type GHCJSPure a = a
230+#else
231+newtype GHCJSPure a = GHCJSPure (JSM a)
232+#endif
233+
234+-- | Used when you want to call a functions that is pure in GHCJS, but
235+-- lives in the JSM in jsaddle.
236+ghcjsPure :: GHCJSPure a -> JSM a
237+#ifdef ghcjs_HOST_OS
238+ghcjsPure = pure
239+#else
240+ghcjsPure (GHCJSPure x) = x
241+#endif
242+{-# INLINE ghcjsPure #-}
243+
244+ghcjsPureMap :: (a -> b) -> GHCJSPure a -> GHCJSPure b
245+#ifdef ghcjs_HOST_OS
246+ghcjsPureMap = id
247+#else
248+ghcjsPureMap f (GHCJSPure x) = GHCJSPure (f <$> x)
249+#endif
250+{-# INLINE ghcjsPureMap #-}
251+
252+ghcjsPureId :: a -> GHCJSPure a
253+#ifdef ghcjs_HOST_OS
254+ghcjsPureId = id
255+#else
256+ghcjsPureId = GHCJSPure . return
120257#endif
258+{-# INLINE ghcjsPureId #-}
121259
122260-- | The 'MonadJSM' is to 'JSM' what 'MonadIO' is to 'IO'.
123261-- When using GHCJS it is 'MonadIO'.
@@ -126,21 +264,64 @@ type MonadJSM = MonadIO
126264#else
127265class (Applicative m, MonadIO m) => MonadJSM m where
128266 liftJSM' :: JSM a -> m a
129− {-# MINIMAL liftJSM' #-}
267+
268+ default liftJSM' :: (MonadJSM m', MonadTrans t, m ~ t m') => JSM a -> m a
269+ liftJSM' = lift . (liftJSM' :: MonadJSM m' => JSM a -> m' a)
270+ {-# INLINE liftJSM' #-}
130271
131272instance MonadJSM JSM where
132273 liftJSM' = id
133274 {-# INLINE liftJSM' #-}
134275
135−instance MonadJSM m => MonadJSM (ReaderT e m) where
276+instance (MonadJSM m) => MonadJSM (ContT r m) where
277+ liftJSM' = lift . liftJSM'
278+ {-# INLINE liftJSM' #-}
279+
280+instance (Error e, MonadJSM m) => MonadJSM (ErrorT e m) where
281+ liftJSM' = lift . liftJSM'
282+ {-# INLINE liftJSM' #-}
283+
284+instance (MonadJSM m) => MonadJSM (ExceptT e m) where
285+ liftJSM' = lift . liftJSM'
286+ {-# INLINE liftJSM' #-}
287+
288+instance (MonadJSM m) => MonadJSM (IdentityT m) where
289+ liftJSM' = lift . liftJSM'
290+ {-# INLINE liftJSM' #-}
291+
292+instance (MonadJSM m) => MonadJSM (ListT m) where
293+ liftJSM' = lift . liftJSM'
294+ {-# INLINE liftJSM' #-}
295+
296+instance (MonadJSM m) => MonadJSM (MaybeT m) where
297+ liftJSM' = lift . liftJSM'
298+ {-# INLINE liftJSM' #-}
299+
300+instance (MonadJSM m) => MonadJSM (ReaderT r m) where
301+ liftJSM' = lift . liftJSM'
302+ {-# INLINE liftJSM' #-}
303+
304+instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.RWST r w s m) where
305+ liftJSM' = lift . liftJSM'
306+ {-# INLINE liftJSM' #-}
307+
308+instance (Monoid w, MonadJSM m) => MonadJSM (Strict.RWST r w s m) where
309+ liftJSM' = lift . liftJSM'
310+ {-# INLINE liftJSM' #-}
311+
312+instance (MonadJSM m) => MonadJSM (Lazy.StateT s m) where
313+ liftJSM' = lift . liftJSM'
314+ {-# INLINE liftJSM' #-}
315+
316+instance (MonadJSM m) => MonadJSM (Strict.StateT s m) where
136317 liftJSM' = lift . liftJSM'
137318 {-# INLINE liftJSM' #-}
138319
139−instance MonadJSM m => MonadJSM (StateT r m) where
320+instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.WriterT w m) where
140321 liftJSM' = lift . liftJSM'
141322 {-# INLINE liftJSM' #-}
142323
143−instance MonadJSM m => MonadJSM (Strict.StateT r m) where
324+instance (Monoid w, MonadJSM m) => MonadJSM (Strict.WriterT w m) where
144325 liftJSM' = lift . liftJSM'
145326 {-# INLINE liftJSM' #-}
146327
@@ -175,23 +356,15 @@ type JSCallAsFunction = JSVal -- ^ Function object
175356 -- as an argument and invoke it from haskell.
176357
177358#ifndef ghcjs_HOST_OS
178−-- A reference to a particular JavaScript value inside the JavaScript context
179−type JSValueRef = Int64
180−
181−-- | See 'GHCJS.Prim.JSVal'
182−newtype JSVal = JSVal JSValueRef deriving(Show, ToJSON, FromJSON)
183−
184−instance NFData JSVal where
185− rnf x = x `seq` ()
186359
187360class IsJSVal a where
188− jsval_ :: a -> JSVal
361+ jsval_ :: a -> GHCJSPure JSVal
189362
190− default jsval_ :: Coercible a JSVal => a -> JSVal
191− jsval_ = coerce
363+ default jsval_ :: Coercible a JSVal => a -> GHCJSPure JSVal
364+ jsval_ = GHCJSPure . return . coerce
192365 {-# INLINE jsval_ #-}
193366
194−jsval :: IsJSVal a => a -> JSVal
367+jsval :: IsJSVal a => a -> GHCJSPure JSVal
195368jsval = jsval_
196369{-# INLINE jsval #-}
197370
@@ -212,21 +385,22 @@ type family Mutability (a :: MutabilityType s) :: IsItMutable where
212385
213386newtype SomeJSArray (m :: MutabilityType s) = SomeJSArray JSVal
214387 deriving (Typeable)
388+instance IsJSVal (SomeJSArray m)
215389
216390-- | See 'JavaScript.Array.Internal.JSArray'
217391type JSArray = SomeJSArray Immutable
218392-- | See 'JavaScript.Array.Internal.MutableJSArray'
219393type MutableJSArray = SomeJSArray Mutable
220394
395+-- | See 'JavaScript.Array.Internal.STJSArray'
396+type STJSArray s = SomeJSArray (STMutable s)
397+
221398-- | See 'JavaScript.Object.Internal.Object'
222−newtype Object = Object JSVal deriving(Show, ToJSON, FromJSON)
399+newtype Object = Object JSVal
223400
224401-- | See 'GHCJS.Nullable.Nullable'
225402newtype Nullable a = Nullable a
226403
227−-- | See 'Data.JSString.Internal.Type'
228−newtype JSString = JSString Text deriving(Show, ToJSON, FromJSON)
229−
230404-- | Wrapper used when receiving a 'JSVal' from the JavaScript context
231405newtype JSValueReceived = JSValueReceived JSValueRef deriving(Show, ToJSON, FromJSON)
232406
@@ -246,7 +420,8 @@ newtype JSStringForSend = JSStringForSend Text deriving(Show, ToJSON, FromJSON,
246420instance NFData JSStringForSend
247421
248422-- | Command sent to a JavaScript context for execution asynchronously
249−data AsyncCommand = FreeRef JSValueForSend
423+data AsyncCommand = FreeRef Text JSValueForSend
424+ | FreeRefs Text
250425 | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend
251426 | SetPropertyAtIndex JSObjectForSend Int JSValueForSend
252427 | StringToValue JSStringForSend JSValueForSend
@@ -257,11 +432,15 @@ data AsyncCommand = FreeRef JSValueForSend
257432 | CallAsFunction JSObjectForSend JSObjectForSend [JSValueForSend] JSValueForSend
258433 | CallAsConstructor JSObjectForSend [JSValueForSend] JSValueForSend
259434 | NewEmptyObject JSValueForSend
260− | NewCallback JSValueForSend
435+ | NewAsyncCallback JSValueForSend
436+ | NewSyncCallback JSValueForSend
437+ | FreeCallback JSValueForSend
261438 | NewArray [JSValueForSend] JSValueForSend
262439 | EvaluateScript JSStringForSend JSValueForSend
263440 | SyncWithAnimationFrame JSValueForSend
264− deriving (Show, Generic)
441+ | StartSyncBlock
442+ | EndSyncBlock
443+ deriving (Show, Generic)
265444
266445instance ToJSON AsyncCommand where
267446 toEncoding = genericToEncoding defaultOptions
@@ -293,7 +472,7 @@ instance FromJSON Command
293472instance NFData Command
294473
295474-- | Batch of commands that can be sent together to the JavaScript context
296−data Batch = Batch [Either AsyncCommand Command] Bool
475+data Batch = Batch [Either AsyncCommand Command] Bool Int
297476 deriving (Show, Generic)
298477
299478instance ToJSON Batch where
@@ -324,9 +503,18 @@ instance ToJSON Result where
324503
325504instance FromJSON Result
326505
327−data Results = Success [Result]
328− | Failure [Result] JSValueReceived
329− | Callback JSValueReceived JSValueReceived [JSValueReceived]
506+data BatchResults = Success [JSValueReceived] [Result]
507+ | Failure [JSValueReceived] [Result] JSValueReceived String
508+ deriving (Show, Generic)
509+
510+instance ToJSON BatchResults where
511+ toEncoding = genericToEncoding defaultOptions
512+
513+instance FromJSON BatchResults
514+
515+data Results = BatchResults Int BatchResults
516+ | Duplicate Int Int
517+ | Callback Int BatchResults JSValueReceived JSValueReceived JSValueReceived [JSValueReceived]
330518 | ProtocolError Text
331519 deriving (Show, Generic)
332520
@@ -336,5 +524,11 @@ instance ToJSON Results where
336524instance FromJSON Results
337525#endif
338526
527+-- | Like HasCallStack, but only when jsaddle cabal flag check-unchecked is set
528+#if MIN_VERSION_base(4,9,0) && defined(CHECK_UNCHECKED)
529+type JSadddleHasCallStack = HasCallStack
530+#else
531+type JSadddleHasCallStack = (() :: Constraint)
532+#endif
339533
340534
jsaddle/src/Language/Javascript/JSaddle/Value.hs+57−88
@@ -45,7 +45,7 @@ module Language.Javascript.JSaddle.Value (
4545 , showJSValue
4646
4747 -- * Converting JavaScript values
48− , isTruthyIO
48+ , isTruthy
4949 , valToBool
5050 , valToNumber
5151 , valToStr
@@ -57,11 +57,11 @@ module Language.Javascript.JSaddle.Value (
5757 , val
5858 , jsNull
5959 , valNull
60− , isNullIO
60+ , isNull
6161 , valIsNull
6262 , jsUndefined
6363 , valUndefined
64− , isUndefinedIO
64+ , isUndefined
6565 , valIsUndefined
6666 , maybeNullOrUndefined
6767 , maybeNullOrUndefined'
@@ -84,32 +84,31 @@ module Language.Javascript.JSaddle.Value (
8484import Data.Text (Text)
8585import qualified Data.Text as T (pack, unpack)
8686import Data.Aeson (Value)
87+import Data.JSString.Text (textToJSString)
8788
8889#ifdef ghcjs_HOST_OS
8990import Language.Javascript.JSaddle.Types
90− (Object(..), JSString(..), JSVal(..))
91+ (Object(..), JSString(..), JSVal(..), ghcjsPure)
9192import GHCJS.Marshal (ToJSVal(..))
92−import GHCJS.Marshal.Pure (pToJSVal)
93−import Data.JSString.Text (textToJSString)
9493#else
9594import Data.Char (chr, ord)
9695import Data.Word (Word, Word8, Word16, Word32)
9796import Data.Int (Int8, Int16, Int32)
9897import GHCJS.Marshal.Internal (ToJSVal(..), FromJSVal(..))
9998import Language.Javascript.JSaddle.Types
100− (Object(..), JSString(..), JSVal(..))
99+ (Object(..), JSString(..), JSVal(..), ghcjsPure)
101100import Language.Javascript.JSaddle.Native
102− (wrapJSString, withJSVal, withObject, withJSString, withToJSVal)
103−import Language.Javascript.JSaddle.Run
104− (Command(..), AsyncCommand(..), Result(..), sendCommand,
105− sendLazyCommand)
101+ (valueToNumber, valueToString, valueToJSON, numberToValue, stringToValue, jsonValueToValue)
102+import qualified Language.Javascript.JSaddle.Native as N
103+ (deRefVal, strictEqual, instanceOf)
104+import Language.Javascript.JSaddle.Run (Result(..))
106105#endif
107106import Language.Javascript.JSaddle.Monad (JSM)
108107import Language.Javascript.JSaddle.Classes
109108 (MakeObject(..), MakeArgs(..))
110109import Language.Javascript.JSaddle.Marshal.String (ToJSString(..), FromJSString(..))
111110import Language.Javascript.JSaddle.String (strToText, textToStr)
112−import Language.Javascript.JSaddle.Foreign (jsTrue, jsFalse, jsNull, toJSBool, jsUndefined, isTruthyIO, isNullIO, isUndefinedIO)
111+import GHCJS.Foreign.Internal (jsTrue, jsFalse, jsNull, toJSBool, jsUndefined, isTruthy, isNull, isUndefined)
113112
114113-- $setup
115114-- >>> import Language.Javascript.JSaddle.Test (testJSaddle)
@@ -166,7 +165,7 @@ showJSValue (ValObject _) = "object"
166165-- >>> testJSaddle $ valToBool "1"
167166-- true
168167valToBool :: ToJSVal value => value -> JSM Bool
169−valToBool value = toJSVal value >>= isTruthyIO
168+valToBool value = toJSVal value >>= ghcjsPure . isTruthy
170169
171170-- | Given a JavaScript value get its numeric value.
172171-- May throw JSException.
@@ -192,10 +191,7 @@ valToNumber :: ToJSVal value => value -> JSM Double
192191valToNumber value = jsrefToNumber <$> toJSVal value
193192foreign import javascript unsafe "$r = Number($1);" jsrefToNumber :: JSVal -> Double
194193#else
195−valToNumber value =
196− withToJSVal value $ \rval -> do
197− ~(ValueToNumberResult result) <- sendCommand (ValueToNumber rval)
198− return result
194+valToNumber value = toJSVal value >>= valueToNumber
199195#endif
200196
201197-- | Given a JavaScript value get its string value (as a JavaScript string).
@@ -222,10 +218,7 @@ valToStr :: ToJSVal value => value -> JSM JSString
222218valToStr value = jsrefToString <$> toJSVal value
223219foreign import javascript unsafe "$r = $1.toString();" jsrefToString :: JSVal -> JSString
224220#else
225−valToStr value =
226− withToJSVal value $ \rval -> do
227− ~(ValueToStringResult result) <- sendCommand (ValueToString rval)
228− wrapJSString result
221+valToStr value = toJSVal value >>= valueToString
229222#endif
230223
231224-- | Given a JavaScript value get its string value (as a Haskell 'Text').
@@ -276,10 +269,7 @@ valToJSON :: ToJSVal value => value -> JSM JSString
276269valToJSON value = jsrefToJSON <$> toJSVal value
277270foreign import javascript unsafe "$r = $1 === undefined ? \"\" : JSON.stringify($1);" jsrefToJSON :: JSVal -> JSString
278271#else
279−valToJSON value =
280− withToJSVal value $ \rval -> do
281− ~(ValueToJSONResult result) <- sendCommand (ValueToJSON rval)
282− wrapJSString result
272+valToJSON value = toJSVal value >>= valueToJSON
283273#endif
284274
285275-- | Given a JavaScript value get its object value.
@@ -305,7 +295,7 @@ valToObject :: ToJSVal value => value -> JSM Object
305295valToObject value = Object <$> toJSVal value
306296
307297instance MakeObject JSVal where
308− makeObject = valToObject
298+ makeObject = return . Object
309299
310300instance ToJSVal Object where
311301 toJSVal (Object r) = return r
@@ -356,16 +346,16 @@ instance ToJSVal a => ToJSVal (Maybe a) where
356346 {-# INLINE toJSVal #-}
357347instance FromJSVal a => FromJSVal (Maybe a) where
358348 fromJSValUnchecked x =
359− isUndefinedIO x >>= \case
349+ ghcjsPure (isUndefined x) >>= \case
360350 True -> return Nothing
361− False -> isNullIO x >>= \case
351+ False -> ghcjsPure (isNull x) >>= \case
362352 True -> return Nothing
363353 False -> fromJSVal x
364354 {-# INLINE fromJSValUnchecked #-}
365355 fromJSVal x =
366− isUndefinedIO x >>= \case
356+ ghcjsPure (isUndefined x) >>= \case
367357 True -> return (Just Nothing)
368− False -> isNullIO x >>= \case
358+ False -> ghcjsPure (isNull x) >>= \case
369359 True -> return (Just Nothing)
370360 False -> fmap (fmap Just) fromJSVal x
371361 {-# INLINE fromJSVal #-}
@@ -382,7 +372,7 @@ instance FromJSVal a => FromJSVal [a] where
382372
383373-- | Test a JavaScript value to see if it is @null@
384374valIsNull :: ToJSVal value => value -> JSM Bool
385−valIsNull value = toJSVal value >>= isNullIO
375+valIsNull value = toJSVal value >>= ghcjsPure . isNull
386376
387377----------- undefined ---------------
388378-- | An @undefined@ JavaScript value
@@ -405,26 +395,26 @@ instance MakeArgs () where
405395
406396-- | Test a JavaScript value to see if it is @undefined@
407397valIsUndefined :: ToJSVal value => value -> JSM Bool
408−valIsUndefined value = toJSVal value >>= isUndefinedIO
398+valIsUndefined value = toJSVal value >>= ghcjsPure . isUndefined
409399
410400-- | Convert a JSVal to a Maybe JSVal (converting null and undefined to Nothing)
411401maybeNullOrUndefined :: ToJSVal value => value -> JSM (Maybe JSVal)
412402maybeNullOrUndefined value = do
413403 rval <- toJSVal value
414− valIsNull rval >>= \case
404+ ghcjsPure (isNull rval) >>= \case
415405 True -> return Nothing
416406 _ ->
417− valIsUndefined rval >>= \case
407+ ghcjsPure (isUndefined rval) >>= \case
418408 True -> return Nothing
419409 _ -> return (Just rval)
420410
421411maybeNullOrUndefined' :: ToJSVal value => (JSVal -> JSM a) -> value -> JSM (Maybe a)
422412maybeNullOrUndefined' f value = do
423413 rval <- toJSVal value
424− valIsNull rval >>= \case
414+ ghcjsPure (isNull rval) >>= \case
425415 True -> return Nothing
426416 _ ->
427− valIsUndefined rval >>= \case
417+ ghcjsPure (isUndefined rval) >>= \case
428418 True -> return Nothing
429419 _ -> Just <$> f rval
430420
@@ -448,52 +438,49 @@ instance MakeArgs Bool where
448438----------- numbers ---------------
449439-- | Make a JavaScript number
450440valMakeNumber :: Double -> JSM JSVal
451−#ifdef ghcjs_HOST_OS
452−valMakeNumber n = toJSVal n
453−#else
454−valMakeNumber = sendLazyCommand . NumberToValue
455−#endif
441+valMakeNumber = toJSVal
442+{-# INLINE valMakeNumber #-}
456443
457444#ifndef ghcjs_HOST_OS
458445-- | Makes a JavaScript number
459446instance ToJSVal Double where
460− toJSVal = valMakeNumber
447+ toJSVal = numberToValue
461448 {-# INLINE toJSVal #-}
462449
463450instance ToJSVal Float where
464− toJSVal = valMakeNumber . realToFrac
451+ toJSVal = numberToValue . realToFrac
465452 {-# INLINE toJSVal #-}
466453
467454instance ToJSVal Word where
468− toJSVal = valMakeNumber . fromIntegral
455+ toJSVal = numberToValue . fromIntegral
469456 {-# INLINE toJSVal #-}
470457
471458instance ToJSVal Word8 where
472− toJSVal = valMakeNumber . fromIntegral
459+ toJSVal = numberToValue . fromIntegral
473460 {-# INLINE toJSVal #-}
474461
475462instance ToJSVal Word16 where
476− toJSVal = valMakeNumber . fromIntegral
463+ toJSVal = numberToValue . fromIntegral
477464 {-# INLINE toJSVal #-}
478465
479466instance ToJSVal Word32 where
480− toJSVal = valMakeNumber . fromIntegral
467+ toJSVal = numberToValue . fromIntegral
481468 {-# INLINE toJSVal #-}
482469
483470instance ToJSVal Int where
484− toJSVal = valMakeNumber . fromIntegral
471+ toJSVal = numberToValue . fromIntegral
485472 {-# INLINE toJSVal #-}
486473
487474instance ToJSVal Int8 where
488− toJSVal = valMakeNumber . fromIntegral
475+ toJSVal = numberToValue . fromIntegral
489476 {-# INLINE toJSVal #-}
490477
491478instance ToJSVal Int16 where
492− toJSVal = valMakeNumber . fromIntegral
479+ toJSVal = numberToValue . fromIntegral
493480 {-# INLINE toJSVal #-}
494481
495482instance ToJSVal Int32 where
496− toJSVal = valMakeNumber . fromIntegral
483+ toJSVal = numberToValue . fromIntegral
497484 {-# INLINE toJSVal #-}
498485#endif
499486
@@ -503,25 +490,18 @@ instance MakeArgs Double where
503490
504491-- | Make a JavaScript string from `Text`
505492valMakeText :: Text -> JSM JSVal
506−#ifdef ghcjs_HOST_OS
507−valMakeText = return . pToJSVal . textToJSString
508−#else
509−valMakeText text = valMakeString (textToStr text)
510−#endif
493+valMakeText = toJSVal . textToJSString
494+{-# INLINE valMakeText #-}
511495
512496-- | Make a JavaScript string from `JSString`
513497valMakeString :: JSString -> JSM JSVal
514−#ifdef ghcjs_HOST_OS
515−valMakeString = return . pToJSVal
516−#else
517−valMakeString s =
518− withJSString s $ sendLazyCommand . StringToValue
519−#endif
498+valMakeString = toJSVal
499+{-# INLINE valMakeString #-}
520500
521501#ifndef ghcjs_HOST_OS
522502-- | Makes a JavaScript string
523503instance ToJSVal Text where
524− toJSVal = valMakeText
504+ toJSVal = stringToValue . JSString
525505 {-# INLINE toJSVal #-}
526506instance FromJSVal Text where
527507 fromJSValUnchecked = valToText
@@ -537,7 +517,7 @@ instance MakeArgs Text where
537517#ifndef ghcjs_HOST_OS
538518-- | Makes a JavaScript string
539519instance ToJSVal JSString where
540− toJSVal = valMakeString
520+ toJSVal = stringToValue
541521 {-# INLINE toJSVal #-}
542522instance FromJSVal JSString where
543523 fromJSValUnchecked = valToStr
@@ -584,16 +564,12 @@ instance FromJSVal Char where
584564
585565-- | Make a JavaScript string from AESON `Value`
586566valMakeJSON :: Value -> JSM JSVal
587−#ifdef ghcjs_HOST_OS
588567valMakeJSON = toJSVal
589−#else
590−valMakeJSON = sendLazyCommand . JSONValueToValue
591−#endif
592568
593569#ifndef ghcjs_HOST_OS
594570-- | Makes a JSON value
595571instance ToJSVal Value where
596− toJSVal = valMakeJSON
572+ toJSVal = jsonValueToValue
597573 {-# INLINE toJSVal #-}
598574#endif
599575
@@ -644,17 +620,16 @@ foreign import javascript unsafe "$r = ($1 === undefined)?0:\
644620#else
645621deRefVal value = do
646622 v <- toJSVal value
647− withJSVal v $ \rval ->
648− sendCommand (DeRefVal rval) >>= \result -> return $
649− case result of
650− DeRefValResult 0 _ -> ValNull
651− DeRefValResult 1 _ -> ValUndefined
652− DeRefValResult 2 _ -> ValBool False
653− DeRefValResult 3 _ -> ValBool True
654− DeRefValResult (-1) s -> ValNumber (read (T.unpack s))
655− DeRefValResult (-2) s -> ValString s
656− DeRefValResult ref _ -> ValObject (Object (JSVal ref))
657− _ -> error "Unexpected result dereferencing JSaddle value"
623+ result <- N.deRefVal v
624+ return $ case result of
625+ DeRefValResult 0 _ -> ValNull
626+ DeRefValResult 1 _ -> ValUndefined
627+ DeRefValResult 2 _ -> ValBool False
628+ DeRefValResult 3 _ -> ValBool True
629+ DeRefValResult (-1) s -> ValNumber (read (T.unpack s))
630+ DeRefValResult (-2) s -> ValString s
631+ DeRefValResult (-3) _ -> ValObject (Object v)
632+ _ -> error "Unexpected result dereferencing JSaddle value"
658633#endif
659634
660635-- | Make a JavaScript value out of a 'JSValue' ADT.
@@ -713,10 +688,7 @@ strictEqual a b = do
713688#ifdef ghcjs_HOST_OS
714689 return $ jsvalueisstrictequal aval bval
715690#else
716− withJSVal aval $ \aref ->
717− withJSVal bval $ \bref -> do
718− ~(StrictEqualResult result) <- sendCommand $ StrictEqual aref bref
719− return result
691+ N.strictEqual aval bval
720692#endif
721693
722694#ifdef ghcjs_HOST_OS
@@ -734,10 +706,7 @@ instanceOf value constructor = do
734706#ifdef ghcjs_HOST_OS
735707 return $ js_isInstanceOf v c
736708#else
737− withJSVal v $ \rval ->
738− withObject c $ \c' -> do
739− ~(InstanceOfResult result) <- sendCommand $ InstanceOf rval c'
740− return result
709+ N.instanceOf v c
741710#endif
742711
743712
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−13
@@ -6,19 +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−
13−npm install ws
14−
159cabal update
1610cabal new-build 'jsaddle-warp:lib:jsaddle-warp' 'jsaddle-warp:test:test-tool'
17−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 .
18−
19−# update the cache
20−rm -rf .cabal
21−cp -a /root/.cabal ./
22−rm -rf .ghc
23−cp -a /root/.ghc ./
11+cd jsaddle-warp
12+GHC_PACKAGE_PATH=/opt/ghc/$GHCVER/lib/ghc-$GHCVER/package.conf.d:~/.cabal/store/ghc-$GHCVER/package.db:../dist-newstyle/packagedb/ghc-$GHCVER ../dist-newstyle/build/x86_64-linux/ghc-$GHCVER/jsaddle-warp-$JSADDLE_WARP_VERSION/t/test-tool/build/test-tool/test-tool ../jsaddle
2413
travis/trusty.Dockerfile+1−1
@@ -4,7 +4,7 @@ RUN apt-get update && \
44 apt-get -y install software-properties-common && \
55 add-apt-repository -y ppa:hvr/ghc && \
66 apt-get update && \
7− apt-get -y install happy-1.19.5 alex-3.1.7 nodejs npm
7+ apt-get -y install happy-1.19.5 alex-3.1.7 phantomjs
88
99RUN mkdir /build
1010WORKDIR /build
travis/vivid.Dockerfile+1−1
@@ -4,7 +4,7 @@ RUN apt-get update && \
44 apt-get -y install software-properties-common && \
55 add-apt-repository -y ppa:hvr/ghc && \
66 apt-get update && \
7− apt-get -y install happy-1.19.5 alex-3.1.7 nodejs npm
7+ apt-get -y install happy-1.19.5 alex-3.1.7 phantomjs
88
99RUN mkdir /build
1010WORKDIR /build
travis/wily.Dockerfile+1−1
@@ -4,7 +4,7 @@ RUN apt-get update && \
44 apt-get -y install software-properties-common && \
55 add-apt-repository -y ppa:hvr/ghc && \
66 apt-get update && \
7− apt-get -y install happy-1.19.5 alex-3.1.7 nodejs npm
7+ apt-get -y install happy-1.19.5 alex-3.1.7 phantomjs
88
99RUN mkdir /build
1010WORKDIR /build
travis/xenial.Dockerfile+1−1
@@ -4,7 +4,7 @@ RUN apt-get update && \
44 apt-get -y install software-properties-common && \
55 add-apt-repository -y ppa:hvr/ghc && \
66 apt-get update && \
7− apt-get -y install happy-1.19.5 alex-3.1.7 nodejs npm
7+ apt-get -y install happy-1.19.5 alex-3.1.7 phantomjs
88
99RUN mkdir /build
1010WORKDIR /build