on 9ea9b91 help sign in
91 files changed+983−7548
since splitsnapshots
unifiedsplit
.travis.yml+22−40 README.md+14−34 cabal.project+34−5 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+14−39 jsaddle-warp/src/Language/Javascript/JSaddle/Test.hs+12−13 jsaddle-warp/src/Language/Javascript/JSaddle/Warp.hs+4−3 jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs+40−287 jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets/Compat.hs−29 jsaddle-warp/tests/DocTest.hs+48−84 jsaddle-webkit2gtk/LICENSE−21 jsaddle-webkit2gtk/Setup.lhs−6 jsaddle-webkit2gtk/jsaddle-webkit2gtk.cabal−49 jsaddle-webkit2gtk/src/Language/Javascript/JSaddle/WebKitGTK.hs−193 jsaddle-webkitgtk/LICENSE−21 jsaddle-webkitgtk/Setup.lhs−6 jsaddle-webkitgtk/jsaddle-webkitgtk.cabal−44 jsaddle-webkitgtk/src/Language/Javascript/JSaddle/WebKitGTK.hs−230 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+10−79 jsaddle-wkwebview/default.nix−14 jsaddle-wkwebview/jsaddle-wkwebview.cabal+7−39 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+77 jsaddle-wkwebview/src/Language/Javascript/JSaddle/WKWebView/Internal.hs−174 jsaddle/jsaddle.cabal+17−61 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+36−37 jsaddle/src-ghc/GHCJS/Marshal/Internal.hs+32−66 jsaddle/src-ghc/GHCJS/Marshal/Pure.hs+6−5 jsaddle/src-ghc/GHCJS/Prim.hs−84 jsaddle/src-ghc/GHCJS/Prim/Internal.hs−68 jsaddle/src-ghc/GHCJS/Types.hs−60 jsaddle/src-ghc/JavaScript/Array/Internal.hs+20−33 jsaddle/src-ghc/JavaScript/Object.hs−10 jsaddle/src-ghc/JavaScript/Object/Internal.hs+22−26 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+6−5 jsaddle/src-ghc/JavaScript/Array.hs → jsaddle/src/Language/Javascript/JSaddle/Array.hs+23−36 jsaddle/src/Language/Javascript/JSaddle/Debug.hs−48 jsaddle/src/Language/Javascript/JSaddle/Evaluate.hs+7−3 jsaddle/src/Language/Javascript/JSaddle/Exception.hs+1−6 jsaddle/src/Language/Javascript/JSaddle/Foreign.hs+99 jsaddle/src/Language/Javascript/JSaddle/Helper.hs−30 jsaddle/src/Language/Javascript/JSaddle/Monad.hs+26−3 jsaddle/src/Language/Javascript/JSaddle/Native.hs+6−1 jsaddle/src/Language/Javascript/JSaddle/Native/Internal.hs+23−212 jsaddle/src/Language/Javascript/JSaddle/Null.hs−56 jsaddle/src/Language/Javascript/JSaddle/Object.hs+29−54 jsaddle/src/Language/Javascript/JSaddle/Run.hs+80−195 jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+117−253 jsaddle/src/Language/Javascript/JSaddle/Types.hs+47−262 jsaddle/src/Language/Javascript/JSaddle/Value.hs+87−57 nix/hix.nix−8 travis/build.sh+13−2 travis/trusty.Dockerfile+1−1 travis/vivid.Dockerfile+1−1 travis/wily.Dockerfile+1−1 travis/xenial.Dockerfile+1−1
.travis.yml+22−40
@@ -1,47 +1,29 @@
1−language: nix
2−nix: 2.2.2
1+sudo: required
2+services:
3+ - docker
34
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
5+cache:
6+ directories:
7+ - .cabal
8+ - .ghc
249
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
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
2915
30−script:
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
16+before_install:
17+ - docker build -t ghc -f travis/$OSVER.Dockerfile travis
4318
19+script:
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"
4425notifications:
4526 irc:
4627 channels: "irc.freenode.net#ghcjs"
47− email: true
28+ skip_join: true
29+ email: true
README.md+14−34
@@ -13,8 +13,7 @@ import Control.Monad.IO.Class (MonadIO(..))
1313import Control.Concurrent.MVar (takeMVar, putMVar, newEmptyMVar)
1414import Control.Lens ((^.))
1515import Language.Javascript.JSaddle
16− (jsg, js, js1, jss, fun, valToNumber, syncPoint)
17−import Language.Javascript.JSaddle.Warp (run)
16+ (run, jsg, js, js1, jss, fun, valToNumber, syncPoint)
1817
1918main = run 3709 $ do
2019 doc <- jsg "document"
@@ -80,7 +79,7 @@ main = run 3708 $ do
8079 appendChild newParagraph text
8180 appendChild body (Just newParagraph)
8281 return ()
83−
82+
8483 -- Make an exit button
8584 exitMVar <- liftIO newEmptyMVar
8685 Just exit <- createElement doc (Just "span")
@@ -103,31 +102,15 @@ When compiled with GHC this code will run a Warp web server you can connect to a
103102
104103## How does it work on GHC
105104
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.
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.
119107
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.
108+### Why use WebSockets?
122109
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.
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.
131114
132115### JSVal
133116
@@ -137,8 +120,8 @@ The first five keys `[0..4]` are
137120these values. Both the Haskell code and `jsaddle.js` can allocate new `JSVal` keys. The Haskell code allocates negative
138121keys and `jsaddle.js` allocates positive keys to avoid clashing.
139122
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
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
142125lazy execution of the JSaddle code.
143126
144127A finalizer is added on the Haskell code and an asynchronous `FreeJSVal` command is automatically sent to `jsaddle.js`
@@ -146,7 +129,7 @@ when the JSVal is no longer reachable. The `jsaddle.js` code then deletes the k
146129
147130### JSStrings
148131
149−These are haskell `Text` type and so reside on the native side of the WebSocket. If you want to avoid transferring large string values over the WebSocket use `toJSVal` to convert it to a `JSVal`.
132+These are haskell `Text` type and so reside on the native side of the WebSocket. If you want to make avoid transferring large string values over the WebSocket use `toJSVal` to conevt it to a `JSVal`.
150133
151134### Lazy Execution
152135
@@ -178,7 +161,7 @@ force all the pending asynchronous commands to be executed.
178161It 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.
179162
180163For the best performance you may want to write both JS FFI and JSaddle wrappers
181−for your JavaScript code. This is the approach taken by `ghcjs-dom`.
164+For your JavaScript code. This is the approach taken by recent versions of `ghcjs-dom`.
182165
183166For instance here is `getElementById` from the `ghcjs-dom-jsffi` (used by `ghcjs-dom` when compiled with GHCJS)
184167
@@ -213,10 +196,7 @@ JSaddle does not support exceptions well. When compiled with GHCJS an exception
213196at the point the exception is thrown.
214197
215198When using GHC the Haskell executions will probably continue for a while before the exception is received at all by the Haskell code
216−(because the lazy execution of the JS code). The exception will be thrown when the next synchronous command is executed.
199+(because the lazy execution of the JS code). The exception will be thrown when the the next synchronous command is executed.
217200When it reaches the synchronous command a haskell type JSException will be thrown (this may not be the thread that initiated the
218201command that caused the exception). You can use `syncPoint` and `syncAfter` to force the exception to be thrown.
219202There 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+34−5
@@ -1,10 +1,39 @@
1+flags: -overloaded-methods -overloaded-signals -overloaded-properties
2+
13packages:
24 jsaddle/
35 jsaddle-warp/
46 jsaddle-wkwebview/
5− jsaddle-webkit2gtk/
6− jsaddle-clib/
7−
8−constraints: haskell-gi-overloading == 0.0
97
10−allow-newer: websockets:random, splitmix:time, *:time, *:unix, *:process, stm:base
8+package gi-atk
9+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
10+package gi-cairo
11+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
12+package gi-gdk
13+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
14+package gi-gdkpixbuf
15+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
16+package gi-gio
17+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
18+package gi-glib
19+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
20+package gi-gobject
21+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
22+package gi-gtk
23+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
24+package gi-gtk-hs
25+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
26+package gi-gtkosxapplication
27+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
28+package gi-gtksource
29+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
30+package gi-javascriptcore
31+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
32+package gi-pango
33+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
34+package gi-soup
35+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
36+package gi-webkit
37+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
38+package gi-webkit2
39+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
jsaddle-clib/LICENSEdeleted−21
@@ -1,21 +0,0 @@
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.lhsdeleted−6
@@ -1,6 +0,0 @@
1−#!/usr/bin/runhaskell
2−> module Main where
3−> import Distribution.Simple
4−> main :: IO ()
5−> main = defaultMain
6−
jsaddle-clib/cbits/include/jsaddle.hdeleted−24
@@ -1,24 +0,0 @@
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.cabaldeleted−40
@@ -1,40 +0,0 @@
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.hsdeleted−157
@@ -1,157 +0,0 @@
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.hsdeleted−7
@@ -1,7 +0,0 @@
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.hscdeleted−67
@@ -1,67 +0,0 @@
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+14−39
@@ -1,5 +1,5 @@
11name: jsaddle-warp
2−version: 0.9.8.0
2+version: 0.7.0.0
33cabal-version: >=1.10
44build-type: Simple
55license: MIT
@@ -10,37 +10,32 @@ 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 JavaScript helper.
13+ drive a small JavaScipt 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
2120
2221library
2322
2423 if !impl(ghcjs -any)
2524 exposed-modules:
2625 Language.Javascript.JSaddle.WebSockets
27− other-modules:
28− Language.Javascript.JSaddle.WebSockets.Compat
2926 build-depends:
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,
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,
3732 text >=1.2.1.3 && <1.3,
38− time >=1.5.0.1 && <1.11,
33+ time >=1.5.0.1 && <1.7,
3934 transformers >=0.4.2.0 && <0.6,
4035 wai >=3.0.3.0 && <3.3,
4136 wai-websockets >=3.0.0.6 && <3.1,
42− warp >=3.1.2 && <3.4,
43− websockets >=0.9.5.0 && <0.13
37+ warp >=3.1.2 && <3.3,
38+ websockets >=0.9.5.0 && <0.10
4439 exposed-modules:
4540 Language.Javascript.JSaddle.Warp
4641 build-depends:
@@ -50,39 +45,19 @@ library
5045 ghc-options: -ferror-spans -Wall
5146
5247test-suite test-tool
53− if impl(ghcjs -any) || os(ios)
54− buildable: False
5548
56− build-depends:
49+ if !impl(ghcjs -any)
50+ build-depends:
5751 QuickCheck -any,
58− aeson -any,
5952 bytestring -any,
60− containers -any,
61− deepseq -any,
62− doctest >=0.10.1 && <0.19,
63− exceptions -any,
53+ doctest >=0.10.1 && <0.12,
6454 filepath >=1.4.0.0 && <1.5,
65− foreign-store -any,
66− ghc-prim -any,
67− http-types -any,
6855 jsaddle -any,
6956 jsaddle-warp -any,
7057 lens -any,
71− network -any,
7258 ref-tf -any,
7359 primitive -any,
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
60+ process >=1.2.3.0 && <1.5
8661 type: exitcode-stdio-1.0
8762 main-is: DocTest.hs
8863 build-depends:
jsaddle-warp/src/Language/Javascript/JSaddle/Test.hs+12−13
@@ -17,22 +17,21 @@ module Language.Javascript.JSaddle.Test (
1717 , listWindowProperties
1818) where
1919
20−import Prelude hiding((!!), catch)
2120import Control.Applicative
22−import Control.Concurrent (threadDelay, forkIO, ThreadId)
23−import Control.Concurrent.MVar
24− (tryTakeMVar, putMVar, takeMVar, newEmptyMVar, MVar)
25−import Control.Lens.Getter ((^.))
26−import Control.Monad (forever, forM)
27−import Control.Monad.IO.Class (MonadIO(..))
21+import Prelude hiding((!!), catch)
2822import 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 ((^.))
2928import Data.Monoid ((<>))
29+import Control.Concurrent.MVar
30+ (tryTakeMVar, putMVar, takeMVar, newEmptyMVar, MVar)
31+import System.IO.Unsafe (unsafePerformIO)
32+import Control.Concurrent (threadDelay, forkIO, ThreadId)
3033import Data.Text (Text)
31−import qualified Data.Text as T
32−import Language.Javascript.JSaddle
3334import Language.Javascript.JSaddle.Warp (run)
34−import System.IO.Unsafe (unsafePerformIO)
35−import System.Timeout (timeout)
3635
3736context :: MVar JSContextRef
3837context = unsafePerformIO newEmptyMVar
@@ -53,12 +52,12 @@ startServer =
5352
5453-- >>> testJSaddle $ ((global ^. js "console" . js "log") # ["Hello"])
5554testJSaddle :: ToJSVal val => JSM val -> IO ()
56−testJSaddle f = timeout 10000000 (do
55+testJSaddle f = do
5756 startServer
5857 c <- takeMVar context
5958 runReaderT (unJSM $ (f >>= valToText >>= liftIO . putStrLn . T.unpack)
6059 `catch` \ (JSException e) -> valToText e >>= liftIO . putStrLn . T.unpack) c
61− putMVar context c) >>= maybe (putStrLn "testJSaddle timed out") return
60+ putMVar context c
6261
6362debugLog :: String -> IO ()
6463debugLog _ = return ()
jsaddle-warp/src/Language/Javascript/JSaddle/Warp.hs+4−3
@@ -17,7 +17,8 @@ module Language.Javascript.JSaddle.Warp (
1717 -- * Running JSM over WebSockets
1818 run
1919#ifndef ghcjs_HOST_OS
20− , module Language.Javascript.JSaddle.WebSockets
20+ , jsaddleOr
21+ , jsaddleApp
2122#endif
2223) where
2324
@@ -28,7 +29,7 @@ import Network.WebSockets (defaultConnectionOptions)
2829
2930import Language.Javascript.JSaddle.Types (JSM)
3031import Language.Javascript.JSaddle.Run (syncPoint)
31−import Language.Javascript.JSaddle.WebSockets
32+import Language.Javascript.JSaddle.WebSockets (jsaddleOr, jsaddleApp)
3233#endif
3334
3435-- | Run the given 'JSM' action as the main entry point. Either directly
@@ -39,6 +40,6 @@ run _port = id
3940#else
4041run :: Int -> JSM () -> IO ()
4142run port f =
42− runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
43+ runSettings (setPort port (setTimeout 3600 defaultSettings)) $
4344 jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp
4445#endif
jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs+40−287
@@ -1,7 +1,5 @@
11{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−{-# LANGUAGE RecursiveDo #-}
53-----------------------------------------------------------------------------
64--
75-- Module : Language.Javascript.JSaddle.WebSockets
@@ -18,302 +16,57 @@ module Language.Javascript.JSaddle.WebSockets (
1816 -- * Running JSM over WebSockets
1917 jsaddleOr
2018 , jsaddleApp
21− , jsaddleWithAppOr
22− , jsaddleAppWithJs
23− , jsaddleAppWithJsOr
24− , jsaddleAppPartial
25− , jsaddleJs
26− , jsaddleJs'
27− , debug
28− , debugOr
29− , debugWrapper
3019) where
3120
32−import Control.Monad (when, void, forever)
33−import Control.Concurrent (killThread, forkIO, threadDelay)
34−import Control.Exception (handle, AsyncException, throwIO, fromException, finally)
21+import Control.Monad (forever)
22+import Control.Concurrent (forkIO)
3523
3624import Data.Monoid ((<>))
3725import Data.Aeson (encode, decode)
3826
39−import Network.Wai
40− (Middleware, lazyRequestBody, Application, Request, Response,
41− ResponseReceived)
27+import Network.Wai (Application)
4228import Network.WebSockets
43− (defaultConnectionOptions, ConnectionOptions(..), sendTextData,
44− receiveDataMessage, acceptRequest, ServerApp, sendPing)
29+ (ConnectionOptions(..), sendTextData, receiveDataMessage,
30+ acceptRequest, ServerApp)
31+import qualified Network.WebSockets as WS (DataMessage(..))
4532import Network.Wai.Handler.WebSockets (websocketsOr)
46−import Network.HTTP.Types (Status(..))
4733
48−import Language.Javascript.JSaddle.Types (JSM(..), JSContextRef(..))
34+import Language.Javascript.JSaddle.Types (JSM(..))
4935import qualified Network.Wai as W
50− (responseLBS, requestMethod, pathInfo, modifyResponse, responseStatus)
51−import qualified Data.Text as T (pack)
36+ (responseLBS, requestMethod, Application, pathInfo)
37+import Data.Text (Text)
5238import qualified Network.HTTP.Types as H
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"
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
10656 _ -> error "jsaddle WebSocket unexpected binary data"
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−
57+ start
14058
14159jsaddleApp :: Application
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
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"
jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets/Compat.hsdeleted−29
@@ -1,29 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−-----------------------------------------------------------------------------
3−--
4−-- Module : Language.Javascript.JSaddle.WebSockets.Compat
5−-- Copyright : (c) Hamish Mackenzie
6−-- License : MIT
7−--
8−-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
9−--
10−-- | This module is necessary to harmonize various versions of the websockets
11−-- package; we can't do this CPP inline in
12−-- Language.Javascript.JSaddle.WebSockets because that module uses multi-line
13−-- strings, which are incompatible with CPP
14−--
15−-----------------------------------------------------------------------------
16−module Language.Javascript.JSaddle.WebSockets.Compat where
17−
18−import Data.ByteString.Lazy (ByteString)
19−import qualified Network.WebSockets as WS (DataMessage(..))
20−
21−getTextMessageByteString :: WS.DataMessage -> Maybe ByteString
22−getTextMessageByteString msg = case msg of
23−#if MIN_VERSION_websockets(0,11,0)
24− (WS.Text t _) ->
25−#else
26− (WS.Text t) ->
27−#endif
28− Just t
29− _ -> Nothing
jsaddle-warp/tests/DocTest.hs+48−84
@@ -11,17 +11,15 @@ 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
15− (takeMVar, newEmptyMVar, forkIO, threadDelay, putMVar)
14+import Control.Concurrent (forkIO)
1615import Control.Monad (void)
17−import Control.Monad.IO.Class (MonadIO(..))
1816import Data.Monoid ((<>))
1917import System.Environment (getArgs)
20−import Test.WebDriver (runSession, defaultConfig, openPage, closeSession)
18+import Language.Javascript.JSaddle.Run.Files (jsaddleJs)
19+import qualified Data.ByteString.Lazy.Char8 as BS (unpack)
2120
2221main :: IO ()
2322main = do
24− putStrLn "Testing JSaddle"
2523 jsaddlePath <- getArgs >>= \case
2624 [arg] -> return arg
2725 _ -> do
@@ -29,84 +27,50 @@ main = do
2927 exitFailure
3028 hSetBuffering stdout LineBuffering
3129 hSetBuffering stderr LineBuffering
32− putStrLn "Checking for phantomjs"
33− node <- system "phantomjs --version" >>= \case
34− ExitSuccess -> return ()
30+ node <- system "nodejs --version" >>= \case
31+ ExitSuccess -> return "nodejs"
32+ _ -> return "node"
33+ system (node <> " --version") >>= \case
34+ ExitSuccess -> putStrLn "Node.js found"
3535 e -> do
36− putStrLn "phantomjs not found"
36+ putStrLn "Node.js not found"
3737 exitWith e
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
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+ "-i" <> jsaddlePath </> "jsaddle-warp/src",
61+ jsaddlePath </> "jsaddle-warp/src/Language/Javascript/JSaddle/Test.hs",
62+ "-i" <> jsaddlePath </> "jsaddle",
63+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle.hs",
64+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Arguments.hs",
65+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Classes.hs",
66+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Evaluate.hs",
67+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Exception.hs",
68+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Monad.hs",
69+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Native.hs",
70+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Object.hs",
71+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Properties.hs",
72+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Run.hs",
73+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs",
74+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/String.hs",
75+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Types.hs",
76+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Value.hs" ]
jsaddle-webkit2gtk/LICENSEdeleted−21
@@ -1,21 +0,0 @@
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-webkit2gtk/Setup.lhsdeleted−6
@@ -1,6 +0,0 @@
1−#!/usr/bin/runhaskell
2−> module Main where
3−> import Distribution.Simple
4−> main :: IO ()
5−> main = defaultMain
6−
jsaddle-webkit2gtk/jsaddle-webkit2gtk.cabaldeleted−49
@@ -1,49 +0,0 @@
1−name: jsaddle-webkit2gtk
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. When using GHC
12− the application is run using Warp and WebSockets to
13− drive a small JavaScipt helper.
14−category: Web, Javascript
15−author: Hamish Mackenzie
16−
17−source-repository head
18− type: git
19− location: https://github.com/ghcjs/jsaddle
20− subdir: jsaddle-webkit2gtk
21−
22−library
23− exposed-modules:
24− Language.Javascript.JSaddle.WebKitGTK
25− build-depends:
26− base <5
27− if !impl(ghcjs -any)
28− build-depends:
29− aeson >=0.8.0.2 && <1.6,
30− base <5,
31− bytestring >=0.10.6.0 && <0.11,
32− directory >=1.0.0.2 && <1.4,
33− gi-glib >=2.0.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,
41− text >=1.2.1.3 && <1.3,
42− webkit2gtk3-javascriptcore >=0.14.0.0 && <0.15
43− if !os(windows)
44− build-depends:
45− unix >=2.3.1.0 && <2.8
46− default-language: Haskell2010
47− hs-source-dirs: src
48− ghc-options: -ferror-spans -Wall
49−
jsaddle-webkit2gtk/src/Language/Javascript/JSaddle/WebKitGTK.hsdeleted−193
@@ -1,193 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE PatternSynonyms #-}
5−{-# LANGUAGE LambdaCase #-}
6−-----------------------------------------------------------------------------
7−--
8−-- Module : Language.Javascript.JSaddle.WebSockets
9−-- Copyright : (c) Hamish Mackenzie
10−-- License : MIT
11−--
12−-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
13−--
14−-- |
15−--
16−-----------------------------------------------------------------------------
17−module Language.Javascript.JSaddle.WebKitGTK (
18− -- * Running JSM in a WebView
19− run
20−#ifndef ghcjs_HOST_OS
21− , runInWebView
22−#endif
23− ) where
24−
25−#ifdef ghcjs_HOST_OS
26−
27−run :: IO () -> IO ()
28−run = id
29−{-# INLINE run #-}
30−
31−#else
32−
33−import Control.Monad (void)
34−import Control.Monad.IO.Class (MonadIO(..), MonadIO)
35−import Control.Concurrent (forkIO, yield)
36−
37−#ifndef mingw32_HOST_OS
38−import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch))
39−#endif
40−import System.Directory (getCurrentDirectory)
41−
42−import Data.Monoid ((<>))
43−import Data.ByteString.Lazy (toStrict, fromStrict)
44−import qualified Data.ByteString.Lazy as LB (ByteString)
45−import Data.Aeson (encode, decode)
46−import qualified Data.Text as T (pack)
47−import Data.Text.Encoding (decodeUtf8, encodeUtf8)
48−
49−import Data.GI.Base.BasicTypes (GObject)
50−import Data.GI.Base.Signals
51− (connectSignalFunPtr, SignalConnectMode(..), SignalConnectMode,
52− SignalHandlerId)
53−
54−import GI.GLib (timeoutAdd, idleAdd, pattern PRIORITY_HIGH, pattern PRIORITY_DEFAULT)
55−import qualified GI.Gtk as Gtk (main, init)
56−import GI.Gtk
57− (windowSetPosition, windowSetDefaultSize, windowNew,
58− scrolledWindowNew, Adjustment, containerAdd,
59− WindowType(..), WindowPosition(..), widgetDestroy,
60− widgetGetToplevel, widgetShowAll, onWidgetDestroy,
61− mainQuit)
62−import GI.Gio (Cancellable)
63−import GI.JavaScriptCore (valueToString)
64−import GI.WebKit2
65− (scriptDialogPromptSetText, scriptDialogPromptGetDefaultText,
66− scriptDialogGetMessage, scriptDialogGetDialogType,
67− onWebViewScriptDialog, WebView,
68− setSettingsEnableWriteConsoleMessagesToStdout,
69− setSettingsEnableJavascript, webViewNewWithUserContentManager,
70− userContentManagerNew,
71− userContentManagerRegisterScriptMessageHandler,
72− javascriptResultGetJsValue,
73− webViewGetUserContentManager,
74− mk_UserContentManagerScriptMessageReceivedCallback,
75− wrap_UserContentManagerScriptMessageReceivedCallback,
76− webViewRunJavascript, LoadEvent(..),
77− UserContentManagerScriptMessageReceivedCallback, webViewLoadHtml,
78− onWebViewLoadChanged, setSettingsEnableDeveloperExtras,
79− webViewSetSettings, webViewGetSettings, ScriptDialogType(..))
80−
81−import Language.Javascript.JSaddle (JSM, Results, Batch)
82−import Language.Javascript.JSaddle.Run (runJavaScript)
83−import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
84−
85−noAdjustment :: Maybe Adjustment
86−noAdjustment = Nothing
87−
88−noCancellable :: Maybe Cancellable
89−noCancellable = Nothing
90−
91−quitWebView :: WebView -> IO ()
92−quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv --TODO: Shouldn't this be postGUISync?
93− widgetDestroy w
94−
95−installQuitHandler :: WebView -> IO ()
96−#ifdef mingw32_HOST_OS
97−installQuitHandler wv = return () -- TODO: Maybe figure something out here for Windows users.
98−#else
99−installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) Nothing
100−#endif
101−
102−postGUIAsync :: IO () -> IO ()
103−postGUIAsync action =
104− void . idleAdd PRIORITY_DEFAULT $ action >> return False
105−
106−run :: JSM () -> IO ()
107−run main = do
108− _ <- Gtk.init Nothing
109− window <- windowNew WindowTypeToplevel
110− _ <- timeoutAdd PRIORITY_HIGH 10 (yield >> return True)
111− windowSetDefaultSize window 900 600
112− windowSetPosition window WindowPositionCenter
113− scrollWin <- scrolledWindowNew noAdjustment noAdjustment
114− contentManager <- userContentManagerNew
115− webView <- webViewNewWithUserContentManager contentManager
116− settings <- webViewGetSettings webView
117− -- setSettingsEnableUniversalAccessFromFileUris settings True
118− setSettingsEnableDeveloperExtras settings True
119− setSettingsEnableJavascript settings True
120− setSettingsEnableWriteConsoleMessagesToStdout settings True
121− webViewSetSettings webView settings
122− window `containerAdd` scrollWin
123− scrollWin `containerAdd` webView
124− _ <- onWidgetDestroy window mainQuit
125− widgetShowAll window
126− pwd <- getCurrentDirectory
127− void . onWebViewLoadChanged webView $ \case
128− LoadEventFinished -> runInWebView main webView
129− _ -> return ()
130− webViewLoadHtml webView "" . Just $ "file://" <> T.pack pwd <> "/index.html"
131− installQuitHandler webView
132− Gtk.main
133−
134−runInWebView :: JSM () -> WebView -> IO ()
135−runInWebView f webView = do
136− (processResults, syncResults, start) <- runJavaScript (\batch -> postGUIAsync $
137− webViewRunJavascript webView (decodeUtf8 . toStrict $ "runJSaddleBatch(" <> encode batch <> ");") noCancellable Nothing)
138− f
139−
140− addJSaddleHandler webView processResults syncResults
141− webViewRunJavascript webView (decodeUtf8 $ toStrict jsaddleJs) noCancellable . Just $
142− \_obj _asyncResult ->
143− void $ forkIO start
144−
145−onUserContentManagerScriptMessageReceived :: (GObject a, MonadIO m) => a -> UserContentManagerScriptMessageReceivedCallback -> m SignalHandlerId
146−onUserContentManagerScriptMessageReceived obj cb = liftIO $ connectUserContentManagerScriptMessageReceived obj cb SignalConnectBefore
147−
148−connectUserContentManagerScriptMessageReceived :: (GObject a, MonadIO m) =>
149− a -> UserContentManagerScriptMessageReceivedCallback -> SignalConnectMode -> m SignalHandlerId
150−connectUserContentManagerScriptMessageReceived obj cb after = liftIO $ do
151− let cb' = wrap_UserContentManagerScriptMessageReceivedCallback cb
152− cb'' <- mk_UserContentManagerScriptMessageReceivedCallback cb'
153− connectSignalFunPtr obj "script-message-received::jsaddle" cb'' after
154−#if MIN_VERSION_haskell_gi_base(0,23,0)
155− Nothing
156−#endif
157−
158−addJSaddleHandler :: WebView -> (Results -> IO ()) -> (Results -> IO Batch) -> IO ()
159−addJSaddleHandler webView processResult syncResults = do
160− manager <- webViewGetUserContentManager webView
161− _ <- onUserContentManagerScriptMessageReceived manager $ \result -> do
162− arg <- javascriptResultGetJsValue result
163− bs <- encodeUtf8 <$> valueToString arg
164− 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−
180− void $ userContentManagerRegisterScriptMessageHandler manager "jsaddle"
181−
182−jsaddleJs :: LB.ByteString
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/LICENSEdeleted−21
@@ -1,21 +0,0 @@
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-webkitgtk/Setup.lhsdeleted−6
@@ -1,6 +0,0 @@
1−#!/usr/bin/runhaskell
2−> module Main where
3−> import Distribution.Simple
4−> main :: IO ()
5−> main = defaultMain
6−
jsaddle-webkitgtk/jsaddle-webkitgtk.cabaldeleted−44
@@ -1,44 +0,0 @@
1−name: jsaddle-webkitgtk
2−version: 0.9.0.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. When using GHC
12− the application is run using Warp and WebSockets to
13− drive a small JavaScipt helper.
14−category: Web, Javascript
15−author: Hamish Mackenzie
16−
17−source-repository head
18− type: git
19− location: https://github.com/ghcjs/jsaddle
20− subdir: jsaddle-webkitgtk
21−
22−library
23− exposed-modules:
24− Language.Javascript.JSaddle.WebKitGTK
25− build-depends:
26− aeson >=0.8.0.2 && <1.3,
27− base <5,
28− bytestring >=0.10.6.0 && <0.11,
29− directory >=1.0.0.2 && <1.4,
30− gi-glib >=2.0.6 && <2.1,
31− gi-gtk >=3.0.6 && <3.1,
32− gi-webkit >=3.0.6 && <3.1,
33− gi-javascriptcore >=3.0.6 && <3.1,
34− haskell-gi-base >=0.20 && <0.21,
35− jsaddle >=0.9.0.0 && <0.10,
36− text >=1.2.1.3 && <1.3,
37− webkitgtk3-javascriptcore >=0.14.0.0 && <0.15
38− if !os(windows)
39− build-depends:
40− unix >=2.3.1.0 && <2.8
41− default-language: Haskell2010
42− hs-source-dirs: src
43− ghc-options: -ferror-spans -Wall
44−
jsaddle-webkitgtk/src/Language/Javascript/JSaddle/WebKitGTK.hsdeleted−230
@@ -1,230 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE PatternSynonyms #-}
5−{-# LANGUAGE LambdaCase #-}
6−-----------------------------------------------------------------------------
7−--
8−-- Module : Language.Javascript.JSaddle.WebSockets
9−-- Copyright : (c) Hamish Mackenzie
10−-- License : MIT
11−--
12−-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
13−--
14−-- |
15−--
16−-----------------------------------------------------------------------------
17−module Language.Javascript.JSaddle.WebKitGTK (
18− -- * Running JSM in a WebView
19− run
20−#ifndef ghcjs_HOST_OS
21− , runInWebView
22−#endif
23− ) where
24−
25−#ifdef ghcjs_HOST_OS
26−
27−run :: IO () -> IO ()
28−run = id
29−{-# INLINE run #-}
30−
31−#else
32−
33−import Control.Monad (when, void)
34−import qualified Control.Exception as E (catch)
35−import Control.Exception (SomeException(..))
36−import Control.Concurrent (forkIO, yield)
37−
38−#ifndef mingw32_HOST_OS
39−import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch))
40−#endif
41−import System.Directory (getCurrentDirectory)
42−
43−import Data.Monoid ((<>))
44−import Data.ByteString.Lazy (toStrict, fromStrict)
45−import qualified Data.ByteString.Lazy as LB (ByteString)
46−import Data.Aeson (encode, decode)
47−import Data.Text (Text)
48−import qualified Data.Text as T (unpack, pack)
49−import Data.Text.Foreign (useAsPtr, fromPtr)
50−import Data.Text.Encoding (decodeUtf8, encodeUtf8)
51−
52−import Foreign.Ptr (castPtr, nullPtr)
53−import Foreign.Marshal.Array (withArray, peekArray)
54−import Foreign.Storable (Storable(..))
55−import Foreign.Marshal.Alloc (alloca)
56−
57−import Data.GI.Base.ManagedPtr (withManagedPtr)
58−import GI.GLib
59− (timeoutAdd, idleAdd, pattern PRIORITY_HIGH, pattern PRIORITY_DEFAULT)
60−import qualified GI.Gtk as Gtk (main, init)
61−import GI.Gtk
62− (windowSetPosition, windowSetDefaultSize, windowNew, scrolledWindowNew,
63− noAdjustment, containerAdd, WindowType(..), WindowPosition(..),
64− widgetDestroy, widgetGetToplevel, widgetShowAll, onWidgetDestroy,
65− mainQuit)
66−import GI.JavaScriptCore.Structs.GlobalContext (GlobalContext(..))
67−import GI.WebKit
68− (WebView, webViewGetMainFrame, webFrameGetGlobalContext,
69− onWebInspectorInspectWebView, webViewGetInspector, webViewSetSettings,
70− setWebSettingsEnableDeveloperExtras,
71− setWebSettingsEnableUniversalAccessFromFileUris,
72− webViewGetSettings, webViewNew, onWebViewLoadFinished,
73− webViewLoadString)
74−
75−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
76− (JSValueRef, JSValueRefRef, JSObjectRef, JSContextRef,
77− jsevaluatescript, JSStringRef)
78−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
79− (jsstringretain, jsstringrelease, jsstringgetcharactersptr,
80− jsstringgetlength, jsstringcreatewithcharacters)
81−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
82− (jsobjectcallasfunction, JSCSize, jsobjectsetproperty,
83− jsobjectmakefunctionwithcallback, mkJSObjectCallAsFunctionCallback)
84−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSContextRef
85− (jscontextgetglobalobject)
86−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
87− (jsvalueprotect, jsvalueunprotect,
88− jsvaluetostringcopy, jsvaluemakestring, jsvaluemakeundefined)
89−
90−import Language.Javascript.JSaddle (JSM, Results)
91−import Language.Javascript.JSaddle.Run (runJavaScript)
92−import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
93−
94−quitWebView :: WebView -> IO ()
95−quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv --TODO: Shouldn't this be postGUISync?
96− widgetDestroy w
97−
98−installQuitHandler :: WebView -> IO ()
99−#ifdef mingw32_HOST_OS
100−installQuitHandler wv = return () -- TODO: Maybe figure something out here for Windows users.
101−#else
102−installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) Nothing
103−#endif
104−
105−postGUIAsync :: IO () -> IO ()
106−postGUIAsync action =
107− void . idleAdd PRIORITY_DEFAULT $ action >> return False
108−
109−withJSString :: Text -> (JSStringRef -> IO a) -> IO a
110−withJSString s f = do
111− jsstring <- useAsPtr s $ \p l -> jsstringcreatewithcharacters (castPtr p) (fromIntegral l)
112− _ <- jsstringretain jsstring
113− result <- f jsstring
114− jsstringrelease jsstring
115− return result
116−
117−withJSContextRef :: GlobalContext -> (JSContextRef -> IO a) -> IO a
118−withJSContextRef (GlobalContext ctx) f = withManagedPtr ctx (f . castPtr)
119−
120−valueToText :: JSContextRef -> JSValueRef -> IO Text
121−valueToText ctxRef s = do
122− jsstring <- jsvaluetostringcopy ctxRef s nullPtr
123− l <- jsstringgetlength jsstring
124− p <- jsstringgetcharactersptr jsstring
125− result <- fromPtr (castPtr p) (fromIntegral l)
126− jsstringrelease jsstring
127− return result
128−
129−check :: JSContextRef -> (JSValueRefRef -> IO a) -> IO a
130−check ctxRef f =
131− alloca $ \exceptionPtr -> do
132− poke exceptionPtr nullPtr
133− result <- f exceptionPtr
134− exception <- peek exceptionPtr
135− when (exception /= nullPtr) $ do
136− errorText <- valueToText ctxRef exception
137− error $ T.unpack errorText
138− return result
139−
140−eval :: JSContextRef -> Text -> IO JSValueRef
141−eval ctxRef script =
142− withJSString script $ \script' ->
143− check ctxRef $ jsevaluatescript ctxRef script' nullPtr nullPtr 0
144−
145−run :: JSM () -> IO ()
146−run main = do
147− _ <- Gtk.init Nothing
148− window <- windowNew WindowTypeToplevel
149− _ <- timeoutAdd PRIORITY_HIGH 10 (yield >> return True)
150− windowSetDefaultSize window 900 600
151− windowSetPosition window WindowPositionCenter
152− scrollWin <- scrolledWindowNew noAdjustment noAdjustment
153− webView <- webViewNew
154− settings <- webViewGetSettings webView
155− setWebSettingsEnableUniversalAccessFromFileUris settings True
156− setWebSettingsEnableDeveloperExtras settings True
157− webViewSetSettings webView settings
158− window `containerAdd` scrollWin
159− scrollWin `containerAdd` webView
160− _ <- onWidgetDestroy window mainQuit
161− widgetShowAll window
162− inspector <- webViewGetInspector webView
163− _ <- onWebInspectorInspectWebView inspector $ \_ -> do
164− inspectorWindow <- windowNew WindowTypeToplevel
165− windowSetDefaultSize inspectorWindow 900 600
166− inspectorScrollWin <- scrolledWindowNew noAdjustment noAdjustment
167− inspectorWebView <- webViewNew
168− inspectorWindow `containerAdd` inspectorScrollWin
169− inspectorScrollWin `containerAdd` inspectorWebView
170− widgetShowAll inspectorWindow
171− return inspectorWebView
172− pwd <- getCurrentDirectory
173− void . onWebViewLoadFinished webView $ \ _ ->
174− runInWebView main webView
175− webViewLoadString webView "" "text/html" "UTF-8" $ "file://" <> T.pack pwd <> "/"
176− installQuitHandler webView
177− Gtk.main
178−
179−runInWebView :: JSM () -> WebView -> IO ()
180−runInWebView f webView = do
181− ctx <- webViewGetMainFrame webView >>= webFrameGetGlobalContext
182− runJSaddleBatch <-
183− withJSContextRef ctx $ \ctxRef -> do
184− result <- eval ctxRef (decodeUtf8 $ toStrict jsaddleJs)
185− jsvalueprotect ctxRef result
186− return result
187−
188− (processResults, _, start) <- runJavaScript (\batch -> postGUIAsync $
189− withJSContextRef ctx $ \ctxRef ->
190− withJSString (decodeUtf8 . toStrict $ encode batch) $ \script -> do
191− val <- jsvaluemakestring ctxRef script
192− withArray [val] $ \args ->
193− void . check ctxRef $ jsobjectcallasfunction ctxRef runJSaddleBatch nullPtr 1 args
194− jsvalueunprotect ctxRef val)
195− f
196−
197− withJSContextRef ctx $ \ctxRef -> do
198− addJSaddleHandler ctxRef processResults
199− void $ forkIO start
200−
201−addJSaddleHandler :: JSContextRef -> (Results -> IO ()) -> IO ()
202−addJSaddleHandler ctxRef processResult = do
203− callback <- mkJSObjectCallAsFunctionCallback wrap
204− function <- jsobjectmakefunctionwithcallback ctxRef nullPtr callback
205− global <- jscontextgetglobalobject ctxRef
206− withJSString "jsaddleCallback" $ \propName ->
207− jsobjectsetproperty ctxRef global propName function 0 nullPtr
208− where
209− wrap :: JSContextRef -> JSObjectRef -> JSObjectRef -> JSCSize -> JSValueRefRef -> JSValueRefRef -> IO JSValueRef
210− wrap _ctx _fobj _this argc argv exception = do
211− [arg] <- peekArray (fromIntegral argc) argv
212− bs <- encodeUtf8 <$> valueToText ctxRef arg
213− mapM_ processResult (decode (fromStrict bs))
214− jsvaluemakeundefined ctxRef
215− `E.catch` \(e :: SomeException) -> do
216− withJSString (T.pack (show e)) (jsvaluemakestring ctxRef) >>= poke exception
217− jsvaluemakeundefined ctxRef
218−
219−jsaddleJs :: LB.ByteString
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.mdeleted−126
@@ -1,126 +0,0 @@
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.hdeleted−8
@@ -1,8 +0,0 @@
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.mdeleted−207
@@ -1,207 +0,0 @@
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.hdeleted−10
@@ -1,10 +0,0 @@
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.mdeleted−40
@@ -1,40 +0,0 @@
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+10−79
@@ -2,32 +2,26 @@
22#import <Foundation/Foundation.h>
33#import <WebKit/WebKit.h>
44
5−BOOL openApp(NSURL * url);
5+extern void jsaddleStart(HsStablePtr);
6+extern void jsaddleResult(HsStablePtr, const char * _Nonnull result);
67
7−@interface JSaddleHandler : NSObject<WKNavigationDelegate, WKScriptMessageHandler, WKUIDelegate>
8+@interface JSaddleHandler : NSObject<WKNavigationDelegate, WKScriptMessageHandler>
89
910@property (nonatomic, assign) HsStablePtr startHandler;
1011@property (nonatomic, assign) HsStablePtr resultHandler;
11−@property (nonatomic, assign) HsStablePtr syncHandler;
12−@property (nonatomic, assign) void (^completionHandler)(NSString *result);
1312
14−- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler syncHandler:(HsStablePtr)syncHandler;
13+- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler;
1514
1615@end
1716
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−
2217@implementation JSaddleHandler
2318
24−- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler syncHandler:(HsStablePtr)syncHandler
19+- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler
2520{
2621 self = [super init];
2722 if (self) {
2823 _startHandler = startHandler;
2924 _resultHandler = resultHandler;
30− _syncHandler = syncHandler;
3125 }
3226 return self;
3327}
@@ -43,82 +37,19 @@ extern void jsaddleSyncResult(HsStablePtr, JSaddleHandler *, const char * _Nonnu
4337 jsaddleResult(self.resultHandler, [s UTF8String]);
4438}
4539
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−
7240@end
7341
74−void addJSaddleHandler(WKWebView *webView, HsStablePtr startHandler, HsStablePtr resultHandler, HsStablePtr syncHandler) {
75− JSaddleHandler * handler = [[JSaddleHandler alloc] initHandler:startHandler resultHandler:resultHandler syncHandler:syncHandler];
42+void addJSaddleHandler(WKWebView *webView, HsStablePtr startHandler, HsStablePtr resultHandler) {
43+ JSaddleHandler * handler = [[JSaddleHandler alloc] initHandler:startHandler resultHandler:resultHandler];
7644 [[[webView configuration] userContentController] addScriptMessageHandler:handler name:@"jsaddle"];
77−#ifdef USE_UIKIT
78− webView.scrollView.bounces = NO;
79−#endif
8045 webView.navigationDelegate = handler;
81− webView.UIDelegate = handler;
8246}
8347
8448void evaluateJavaScript(WKWebView *webView, const char * _Nonnull js) {
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− });
49+ [webView evaluateJavaScript:[NSString stringWithCString:js encoding:NSUTF8StringEncoding] completionHandler:NULL];
10450}
10551
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];
52+void loadHTMLString(WKWebView *webView, const char * _Nonnull html) {
53+ [webView loadHTMLString:[NSString stringWithCString:html encoding:NSUTF8StringEncoding] baseURL:NULL];
11254}
11355
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.nixdeleted−14
@@ -1,14 +0,0 @@
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+7−39
@@ -1,5 +1,5 @@
11name: jsaddle-wkwebview
2−version: 0.9.8.0
2+version: 0.7.0.0
33cabal-version: >=1.10
44build-type: Simple
55license: MIT
@@ -14,10 +14,6 @@ description:
1414category: Web, Javascript
1515author: Hamish Mackenzie
1616
17−flag include-app-delegate
18− description: Include default AppDelegate C sources.
19− default: True
20−
2117source-repository head
2218 type: git
2319 location: https://github.com/ghcjs/jsaddle
@@ -26,40 +22,12 @@ library
2622 exposed-modules:
2723 Language.Javascript.JSaddle.WKWebView
2824 build-depends:
29− base <5
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
3029 default-language: Haskell2010
3130 hs-source-dirs: src
3231 ghc-options: -ferror-spans -Wall
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
32+ c-sources: cbits/WKWebView.m
33+
jsaddle-wkwebview/src-ghc/Language/Javascript/JSaddle/WKWebView.hsdeleted−219
@@ -1,219 +0,0 @@
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.hsdeleted−7
@@ -1,7 +0,0 @@
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.hsnew file+77
@@ -0,0 +1,77 @@
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.Run (runJavaScript)
21+import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
22+
23+newtype WKWebView = WKWebView (Ptr WKWebView)
24+
25+foreign export ccall jsaddleStart :: StablePtr (IO ()) -> IO ()
26+foreign export ccall jsaddleResult :: StablePtr (Result -> IO ()) -> CString -> IO ()
27+foreign import ccall addJSaddleHandler :: WKWebView -> StablePtr (IO ()) -> StablePtr (Result -> IO ()) -> IO ()
28+foreign import ccall loadHTMLString :: WKWebView -> CString -> IO ()
29+foreign import ccall evaluateJavaScript :: WKWebView -> CString -> IO ()
30+
31+jsaddleMain :: JSM () -> WKWebView -> IO ()
32+jsaddleMain f webView = do
33+ (processResult, start) <- runJavaScript (\batch ->
34+ useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");") $
35+ evaluateJavaScript webView)
36+ f
37+
38+ startHandler <- newStablePtr (void $ forkIO start)
39+ resultHandler <- newStablePtr processResult
40+ addJSaddleHandler webView startHandler resultHandler
41+
42+ useAsCString (toStrict indexHtml) $ loadHTMLString webView
43+ useAsCString (toStrict jsaddleJs) $ evaluateJavaScript webView
44+
45+jsaddleStart :: StablePtr (IO ()) -> IO ()
46+jsaddleStart ptrHandler = join (deRefStablePtr ptrHandler)
47+
48+jsaddleResult :: StablePtr (Result -> IO ()) -> CString -> IO ()
49+jsaddleResult ptrHandler s = do
50+ processResult <- deRefStablePtr ptrHandler
51+ result <- packCString s
52+ case decode (fromStrict result) of
53+ Nothing -> error $ "jsaddle WebSocket decode failed : " <> show result
54+ Just r -> processResult r
55+
56+jsaddleJs :: ByteString
57+jsaddleJs = ghcjsHelpers <> "\
58+ \runJSaddleBatch = (function() {\n\
59+ \ " <> initState <> "\n\
60+ \ return function(batch) {\n\
61+ \ " <> runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));") <> "\
62+ \ };\n\
63+ \})();\n\
64+ \"
65+
66+indexHtml :: ByteString
67+indexHtml =
68+ "<!DOCTYPE html>\n\
69+ \<html>\n\
70+ \<head>\n\
71+ \<title>JSaddle</title>\n\
72+ \</head>\n\
73+ \<body>\n\
74+ \</body>\n\
75+ \</html>"
76+
77+-- jsaddle
jsaddle-wkwebview/src/Language/Javascript/JSaddle/WKWebView/Internal.hsdeleted−174
@@ -1,174 +0,0 @@
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+17−61
@@ -1,5 +1,5 @@
11name: jsaddle
2−version: 0.9.8.0
2+version: 0.7.0.0
33cabal-version: >=1.10
44build-type: Simple
55license: MIT
@@ -10,22 +10,13 @@ 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 JavaScript helper.
13+ drive a small JavaScipt 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
2920
3021library
3122
@@ -36,67 +27,36 @@ library
3627 else
3728 build-depends:
3829 attoparsec >=0.11 && <0.14,
39− containers >=0.5.6.2 && <0.7,
30+ containers >=0.5.6.2 && <0.6,
4031 deepseq >=1.3 && < 1.5,
4132 filepath >=1.4.0.0 && <1.5,
4233 ghc-prim,
43− http-types >=0.8.6 && <0.13,
44− process >=1.2.3.0 && <1.7,
45− random >= 1.1 && < 1.3,
34+ http-types >=0.8.6 && <0.10,
35+ process >=1.2.3.0 && <1.5,
4636 ref-tf >=0.4.0.1 && <0.5,
4737 scientific >=0.3 && <0.4,
48− stm >=2.4.4 && <2.6,
49− time >=1.5.0.1 && <1.11,
38+ stm >=2.4.4 && <2.5,
39+ time >=1.5.0.1 && <1.7,
5040 unordered-containers >=0.2 && <0.3,
51− vector >=0.10 && <0.13,
52− unliftio-core >=0.1 && < 0.3
41+ vector >=0.10 && <0.12
5342 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
7043 GHCJS.Marshal
7144 GHCJS.Marshal.Internal
7245 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
8446 JavaScript.Array.Internal
85− JavaScript.Object
8647 JavaScript.Object.Internal
87− Language.Javascript.JSaddle.Debug
8848 Language.Javascript.JSaddle.Native
8949 Language.Javascript.JSaddle.Native.Internal
90− Language.Javascript.JSaddle.Null
9150 hs-source-dirs: src-ghc
9251 exposed-modules:
9352 Language.Javascript.JSaddle
53+ Language.Javascript.JSaddle.Array
9454 Language.Javascript.JSaddle.Arguments
9555 Language.Javascript.JSaddle.Classes
9656 Language.Javascript.JSaddle.Classes.Internal
9757 Language.Javascript.JSaddle.Evaluate
9858 Language.Javascript.JSaddle.Exception
99− Language.Javascript.JSaddle.Helper
59+ Language.Javascript.JSaddle.Foreign
10060 Language.Javascript.JSaddle.Marshal.String
10161 Language.Javascript.JSaddle.Monad
10262 Language.Javascript.JSaddle.Object
@@ -107,20 +67,16 @@ library
10767 Language.Javascript.JSaddle.Value
10868 Language.Javascript.JSaddle.Types
10969 build-depends:
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,
70+ aeson >=0.8.0.2 && <1.1,
71+ base <5,
11472 bytestring >=0.10.6.0 && <0.11,
115− exceptions >=0.8 && <0.11,
116− lens >=3.8.5 && <5.1,
117− primitive >=0.6.1.0 && <0.8,
73+ lens >=3.8.5 && <4.16,
74+ primitive >=0.6.1.0 && <0.7,
75+ template-haskell -any,
11876 text >=1.2.1.3 && <1.3,
11977 transformers >=0.4.2.0 && <0.6
12078 default-language: Haskell2010
12179 hs-source-dirs: src
12280 ghc-options: -ferror-spans -Wall
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
81+
82+
jsaddle/src-ghc/Data/JSString.hsdeleted−1404
@@ -1,1404 +0,0 @@
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.hsdeleted−1
@@ -1 +0,0 @@
1−module Data.JSString.Internal where
jsaddle/src-ghc/Data/JSString/Internal/Fusion.hsdeleted−127
@@ -1,127 +0,0 @@
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.hsdeleted−570
@@ -1,570 +0,0 @@
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.hsdeleted−92
@@ -1,92 +0,0 @@
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.hsdeleted−122
@@ -1,122 +0,0 @@
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.hsdeleted−11
@@ -1,11 +0,0 @@
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.hsdeleted−116
@@ -1,116 +0,0 @@
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.hsdeleted−52
@@ -1,52 +0,0 @@
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.hsdeleted−117
@@ -1,117 +0,0 @@
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.hsdeleted−11
@@ -1,11 +0,0 @@
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.hsdeleted−22
@@ -1,22 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−
3−module GHCJS.Concurrent ( OnBlocked(..)
4− , WouldBlockException(..)
5− ) where
6−
7−import GHCJS.Prim
8−
9−import Data.Data
10−
11−{- |
12− The runtime tries to run synchronous threads to completion. Sometimes it's
13− not possible to continue running a thread, for example when the thread
14− tries to take an empty 'MVar'. The runtime can then either throw a
15− 'WouldBlockException', aborting the blocking action, or continue the
16− thread asynchronously.
17− -}
18−
19−data OnBlocked = ContinueAsync -- ^ continue the thread asynchronously if blocked
20− | ThrowWouldBlock -- ^ throw 'WouldBlockException' if blocked
21− deriving (Data, Typeable, Enum, Show, Eq, Ord)
22−
jsaddle/src-ghc/GHCJS/Foreign.hsdeleted−64
@@ -1,64 +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−-- |
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.hsdeleted−67
@@ -1,67 +0,0 @@
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.hsdeleted−16
@@ -1,16 +0,0 @@
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+36−37
@@ -17,23 +17,19 @@ 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)
2120import Data.Word (Word8, Word16, Word32, Word)
2221
2322import GHC.Prim
2423
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)
31−import GHCJS.Marshal.Pure ()
32−
33−import JavaScript.Array (fromListIO)
34−import qualified JavaScript.Array as A (read)
35−
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)
3627import GHCJS.Marshal.Internal
28+import 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)
3733
3834instance FromJSVal JSVal where
3935 fromJSValUnchecked x = return x
@@ -46,62 +42,65 @@ instance FromJSVal () where
4642 fromJSVal = fromJSVal_pure
4743-- {-# INLINE fromJSVal #-}
4844instance FromJSVal Bool where
49− fromJSValUnchecked = ghcjsPure . isTruthy
45+ fromJSValUnchecked = valToBool
5046 {-# INLINE fromJSValUnchecked #-}
51− fromJSVal = fmap Just . ghcjsPure . isTruthy
47+ fromJSVal = fmap Just . valToBool
5248 {-# INLINE fromJSVal #-}
5349instance FromJSVal Int where
54− fromJSValUnchecked = fmap round . valueToNumber
50+ fromJSValUnchecked = fmap round . valToNumber
5551 {-# INLINE fromJSValUnchecked #-}
56− fromJSVal = fmap (Just . round) . valueToNumber
52+ fromJSVal = fmap (Just . round) . valToNumber
5753 {-# INLINE fromJSVal #-}
5854instance FromJSVal Int8 where
59− fromJSValUnchecked = fmap round . valueToNumber
55+ fromJSValUnchecked = fmap round . valToNumber
6056 {-# INLINE fromJSValUnchecked #-}
61− fromJSVal = fmap (Just . round) . valueToNumber
57+ fromJSVal = fmap (Just . round) . valToNumber
6258 {-# INLINE fromJSVal #-}
6359instance FromJSVal Int16 where
64− fromJSValUnchecked = fmap round . valueToNumber
60+ fromJSValUnchecked = fmap round . valToNumber
6561 {-# INLINE fromJSValUnchecked #-}
66− fromJSVal = fmap (Just . round) . valueToNumber
62+ fromJSVal = fmap (Just . round) . valToNumber
6763 {-# INLINE fromJSVal #-}
6864instance FromJSVal Int32 where
69− fromJSValUnchecked = fmap round . valueToNumber
65+ fromJSValUnchecked = fmap round . valToNumber
7066 {-# INLINE fromJSValUnchecked #-}
71− fromJSVal = fmap (Just . round) . valueToNumber
67+ fromJSVal = fmap (Just . round) . valToNumber
7268 {-# INLINE fromJSVal #-}
7369instance FromJSVal Word where
74− fromJSValUnchecked = fmap round . valueToNumber
70+ fromJSValUnchecked = fmap round . valToNumber
7571 {-# INLINE fromJSValUnchecked #-}
76− fromJSVal = fmap (Just . round) . valueToNumber
72+ fromJSVal = fmap (Just . round) . valToNumber
7773 {-# INLINE fromJSVal #-}
7874instance FromJSVal Word8 where
79− fromJSValUnchecked = fmap round . valueToNumber
75+ fromJSValUnchecked = fmap round . valToNumber
8076 {-# INLINE fromJSValUnchecked #-}
81− fromJSVal = fmap (Just . round) . valueToNumber
77+ fromJSVal = fmap (Just . round) . valToNumber
8278 {-# INLINE fromJSVal #-}
8379instance FromJSVal Word16 where
84− fromJSValUnchecked = fmap round . valueToNumber
80+ fromJSValUnchecked = fmap round . valToNumber
8581 {-# INLINE fromJSValUnchecked #-}
86− fromJSVal = fmap (Just . round) . valueToNumber
82+ fromJSVal = fmap (Just . round) . valToNumber
8783 {-# INLINE fromJSVal #-}
8884instance FromJSVal Word32 where
89− fromJSValUnchecked = fmap round . valueToNumber
85+ fromJSValUnchecked = fmap round . valToNumber
9086 {-# INLINE fromJSValUnchecked #-}
91− fromJSVal = fmap (Just . round) . valueToNumber
87+ fromJSVal = fmap (Just . round) . valToNumber
9288 {-# INLINE fromJSVal #-}
9389instance FromJSVal Float where
94− fromJSValUnchecked = fmap realToFrac . valueToNumber
90+ fromJSValUnchecked = fmap realToFrac . valToNumber
9591 {-# INLINE fromJSValUnchecked #-}
96− fromJSVal = fmap (Just . realToFrac) . valueToNumber
92+ fromJSVal = fmap (Just . realToFrac) . valToNumber
9793 {-# INLINE fromJSVal #-}
9894instance FromJSVal Double where
99− fromJSValUnchecked = valueToNumber
95+ fromJSValUnchecked = valToNumber
10096 {-# INLINE fromJSValUnchecked #-}
101− fromJSVal = fmap Just . valueToNumber
97+ fromJSVal = fmap Just . valToNumber
10298 {-# INLINE fromJSVal #-}
10399instance FromJSVal AE.Value where
104− fromJSVal r = Just <$> valueToJSONValue r
100+ fromJSVal r =
101+ withToJSVal r $ \rval -> do
102+ ValueToJSONValueResult result <- sendCommand (ValueToJSONValue rval)
103+ return $ Just result
105104 {-# INLINE fromJSVal #-}
106105instance (FromJSVal a, FromJSVal b) => FromJSVal (a,b) where
107106 fromJSVal r = runMaybeT $ (,) <$> jf r 0 <*> jf r 1
@@ -128,7 +127,7 @@ instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJ
128127jf :: FromJSVal a => JSVal -> Int -> MaybeT JSM a
129128jf r n = MaybeT $ do
130129 r' <- A.read n (SomeJSArray r)
131− ghcjsPure (isUndefined r) >>= \case
130+ isUndefinedIO r >>= \case
132131 True -> return Nothing
133132 False -> fromJSVal r'
134133
@@ -165,5 +164,5 @@ arr7 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSM JSVal
165164arr7 a b c d e f g = coerce <$> fromListIO [a,b,c,d,e,f,g]
166165
167166toJSVal_aeson :: AE.ToJSON a => a -> JSM JSVal
168−toJSVal_aeson = jsonValueToValue . AE.toJSON
167+toJSVal_aeson = valMakeJSON . AE.toJSON
169168
jsaddle/src-ghc/GHCJS/Marshal/Internal.hs+32−66
@@ -1,21 +1,21 @@
1−{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, DefaultSignatures,
1+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, DefaultSignatures,
22 TypeOperators, TupleSections, FlexibleContexts, FlexibleInstances,
33 LambdaCase
44 #-}
55
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
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+
1919import Control.Monad
2020
2121import Data.Data
@@ -25,17 +25,11 @@ import qualified Data.Text as T (pack)
2525
2626import GHC.Generics
2727
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−
34−import qualified JavaScript.Object.Internal as OI (Object(..), create, setProp, getProp)
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)
28+import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), MutableJSArray, JSString)
29+import Language.Javascript.JSaddle.Foreign (jsNull, jsTrue, isUndefinedIO)
3830import Language.Javascript.JSaddle.String (textToStr)
31+import qualified JavaScript.Object.Internal as OI (Object(..), create, setProp, getProp)
32+import qualified JavaScript.Array.Internal as AI (create, push, read, fromListIO, toListIO)
3933
4034data Purity = PureShared -- ^ conversion is pure even if the original value is shared
4135 | PureExclusive -- ^ conversion is pure if the we only convert once
@@ -55,53 +49,25 @@ class ToJSVal a where
5549 toJSValListOf :: [a] -> JSM JSVal
5650 toJSValListOf = fmap coerce . AI.fromListIO <=< mapM toJSVal
5751
58− -- default toJSVal :: PToJSVal a => a -> JSM (JSVal a)
59− -- toJSVal x = return (pToJSVal x)
60−
6152 default toJSVal :: (Generic a, GToJSVal (Rep a ())) => a -> JSM JSVal
6253 toJSVal = toJSVal_generic id
6354
64−fromJustWithStack :: JSadddleHasCallStack => Maybe a -> a
65−fromJustWithStack Nothing = error "fromJSValUnchecked: fromJSVal result was Nothing"
66−fromJustWithStack (Just x) = x
67−
6855class FromJSVal a where
6956 fromJSVal :: JSVal -> JSM (Maybe a)
7057
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
8158 fromJSValUnchecked :: JSVal -> JSM a
8259 fromJSValUnchecked = fmap fromJust . fromJSVal
83−#endif
8460 {-# INLINE fromJSValUnchecked #-}
8561
8662 fromJSValListOf :: JSVal -> JSM (Maybe [a])
8763 fromJSValListOf = fmap sequence . (mapM fromJSVal <=< AI.toListIO . coerce) -- fixme should check that it's an array
8864
89−#if MIN_VERSION_base(4,9,0) && defined(JSADDLE_HAS_CALL_STACK)
90− fromJSValUncheckedListOf :: JSadddleHasCallStack => JSVal -> JSM [a]
91−#else
9265 fromJSValUncheckedListOf :: JSVal -> JSM [a]
93−#endif
9466 fromJSValUncheckedListOf = mapM fromJSValUnchecked <=< AI.toListIO . coerce
9567
96− -- default fromJSVal :: PFromJSVal a => JSVal a -> JSM (Maybe a)
97− -- fromJSVal x = return (Just (pFromJSVal x))
98−
9968 default fromJSVal :: (Generic a, GFromJSVal (Rep a ())) => JSVal -> JSM (Maybe a)
10069 fromJSVal = fromJSVal_generic id
10170
102− -- default fromJSValUnchecked :: PFromJSVal a => a -> IO a
103− -- fromJSValUnchecked x = return (pFromJSVal x)
104−
10571-- -----------------------------------------------------------------------------
10672
10773class GToJSVal a where
@@ -126,8 +92,8 @@ instance (GToJSVal (a p), GToJSVal (b p)) => GToJSVal ((a :+: b) p) where
12692 gToJSVal f _ (L1 x) = gToJSVal f True x
12793 gToJSVal f _ (R1 x) = gToJSVal f True x
12894
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
95+instance (GToJSVal (a p)) => GToJSVal (M1 D c a p) where
96+ gToJSVal f b (M1 x) = gToJSVal f b x
13197
13298instance (Constructor c, GToJSVal (a p)) => GToJSVal (M1 C c a p) where
13399 gToJSVal f True m@(M1 x) = do
@@ -143,7 +109,7 @@ instance (GToJSArr (a p), GToJSArr (b p), GToJSProp (a p), GToJSProp (b p)) => G
143109 gToJSProp f obj' xy
144110 return obj'
145111 gToJSVal f False xy = do
146− arr@(AI.SomeJSArray arr') <- AI.create
112+ arr@(SomeJSArray arr') <- AI.create
147113 gToJSArr f arr xy
148114 return arr'
149115
@@ -167,10 +133,10 @@ instance GToJSVal (a p) => GToJSArr (M1 S c a p) where
167133 AI.push r a
168134
169135instance GToJSVal (V1 p) where
170− gToJSVal _ _ _ = return Prim.jsNull
136+ gToJSVal _ _ _ = return jsNull
171137
172138instance GToJSVal (U1 p) where
173− gToJSVal _ _ _ = return F.jsTrue
139+ gToJSVal _ _ _ = return jsTrue
174140
175141toJSVal_generic :: forall a . (Generic a, GToJSVal (Rep a ()))
176142 => (String -> String) -> a -> JSM JSVal
@@ -197,26 +163,26 @@ instance GFromJSVal (f p) => GFromJSVal (Rec1 f p) where
197163 gFromJSVal f b r = gFromJSVal f b r
198164
199165instance (GFromJSVal (a p), GFromJSVal (b p)) => GFromJSVal ((a :+: b) p) where
200− gFromJSVal f b r = do
166+ gFromJSVal f _b r = do
201167 l <- gFromJSVal f True r
202168 case l of
203169 Just x -> return (L1 <$> Just x)
204170 Nothing -> fmap R1 <$> gFromJSVal f True r
205171
206−instance (Datatype c, GFromJSVal (a p)) => GFromJSVal (M1 D c a p) where
172+instance GFromJSVal (a p) => GFromJSVal (M1 D c a p) where
207173 gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r
208174
209175instance forall c a p . (Constructor c, GFromJSVal (a p)) => GFromJSVal (M1 C c a p) where
210176 gFromJSVal f True r = do
211177 r' <- OI.getProp (packJSS . f $ conName (undefined :: M1 C c a p)) (OI.Object r)
212− ghcjsPure (isUndefined r') >>= \case
178+ isUndefinedIO r' >>= \case
213179 True -> return Nothing
214180 False -> fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r'
215181 gFromJSVal f _ r = fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r
216182
217183instance (GFromJSArr (a p), GFromJSArr (b p), GFromJSProp (a p), GFromJSProp (b p)) => GFromJSVal ((a :*: b) p) where
218184 gFromJSVal f True r = gFromJSProp f r
219− gFromJSVal f False r = fmap fst <$> gFromJSArr f (AI.SomeJSArray r) 0
185+ gFromJSVal f False r = fmap fst <$> gFromJSArr f (SomeJSArray r) 0
220186
221187instance GFromJSVal (a p) => GFromJSVal (M1 S c a p) where
222188 gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r
@@ -231,7 +197,7 @@ instance (GFromJSProp (a p), GFromJSProp (b p)) => GFromJSProp ((a :*: b) p) whe
231197instance forall c a p . (Selector c, GFromJSVal (a p)) => GFromJSProp (M1 S c a p) where
232198 gFromJSProp f o = do
233199 p <- OI.getProp (packJSS . f $ selName (undefined :: M1 S c a p)) (OI.Object o)
234− ghcjsPure (isUndefined p) >>= \case
200+ isUndefinedIO p >>= \case
235201 True -> return Nothing
236202 False -> fmap M1 <$> gFromJSVal f False p
237203
@@ -248,7 +214,7 @@ instance (GFromJSArr (a p), GFromJSArr (b p)) => GFromJSArr ((a :*: b) p) where
248214instance (GFromJSVal (a p)) => GFromJSArr (M1 S c a p) where
249215 gFromJSArr f o n = do
250216 r <- AI.read n o
251− ghcjsPure (isUndefined r) >>= \case
217+ isUndefinedIO r >>= \case
252218 True -> return Nothing
253219 False -> fmap ((,n+1) . M1) <$> gFromJSVal f False r
254220
@@ -265,15 +231,15 @@ fromJSVal_generic f x = fmap to <$> (gFromJSVal f False x :: JSM (Maybe (Rep a (
265231-- -----------------------------------------------------------------------------
266232
267233fromJSVal_pure :: PFromJSVal a => JSVal -> JSM (Maybe a)
268−fromJSVal_pure = return . Just . pFromJSVal
234+fromJSVal_pure x = return (Just (pFromJSVal x))
269235{-# INLINE fromJSVal_pure #-}
270236
271237fromJSValUnchecked_pure :: PFromJSVal a => JSVal -> JSM a
272−fromJSValUnchecked_pure = return . pFromJSVal
238+fromJSValUnchecked_pure x = return (pFromJSVal x)
273239{-# INLINE fromJSValUnchecked_pure #-}
274240
275241toJSVal_pure :: PToJSVal a => a -> JSM JSVal
276−toJSVal_pure = return . pToJSVal
242+toJSVal_pure x = return (pToJSVal x)
277243{-# INLINE toJSVal_pure #-}
278244
279245-- -----------------------------------------------------------------------------
jsaddle/src-ghc/GHCJS/Marshal/Pure.hs+6−5
@@ -1,11 +1,12 @@
11{-# OPTIONS_GHC -fno-warn-orphans #-}
2−module GHCJS.Marshal.Pure ( PFromJSVal(..)
3− , PToJSVal(..)
4− ) where
2+module GHCJS.Marshal.Pure
3+ ( PFromJSVal(..)
4+ , PToJSVal(..)
5+ ) where
56
6−import GHCJS.Types
7−import GHCJS.Foreign.Internal (jsFalse, jsTrue)
87import GHCJS.Marshal.Internal
8+import Language.Javascript.JSaddle.Types (JSVal(..))
9+import Language.Javascript.JSaddle.Foreign (jsFalse, jsTrue)
910
1011instance PFromJSVal JSVal where pFromJSVal = id
1112 {-# INLINE pFromJSVal #-}
jsaddle/src-ghc/GHCJS/Prim.hsdeleted−84
@@ -1,84 +0,0 @@
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.hsdeleted−68
@@ -1,68 +0,0 @@
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.hsdeleted−60
@@ -1,60 +0,0 @@
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-ghc/JavaScript/Array/Internal.hs+20−33
@@ -1,59 +1,46 @@
11{-# LANGUAGE OverloadedStrings #-}
22module JavaScript.Array.Internal
3− ( SomeJSArray(..)
4− , JSArray
5− , MutableJSArray
6− , STJSArray
7− , create
8− , fromList
3+ ( create
94 , fromListIO
10− , toList
115 , toListIO
12− , index
136 , read
147 , push
158 ) where
169
1710import Prelude hiding(read)
1811import Control.Monad (void)
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(..))
12+import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), MutableJSArray, Object(..), JSString(..))
2213import Language.Javascript.JSaddle.Native.Internal
23− (newArray, getPropertyByName, getPropertyAtIndex, callAsFunction, valueToNumber)
14+ (withObject, withJSVal, withJSString, withJSVals)
15+import Language.Javascript.JSaddle.Run
16+ (Command(..), Result(..), AsyncCommand(..), sendCommand, sendLazyCommand)
2417
2518create :: JSM MutableJSArray
26−create = SomeJSArray <$> newArray []
19+create = SomeJSArray <$> sendLazyCommand (NewArray [])
2720{-# INLINE create #-}
2821
29−fromList :: [JSVal] -> GHCJSPure (SomeJSArray m)
30−fromList = GHCJSPure . fromListIO
31−{-# INLINE fromList #-}
32−
3322fromListIO :: [JSVal] -> JSM (SomeJSArray m)
34−fromListIO xs = SomeJSArray <$> newArray xs
23+fromListIO xs = withJSVals xs $ \xs' -> SomeJSArray <$> sendLazyCommand (NewArray xs')
3524{-# INLINE fromListIO #-}
3625
37−toList :: SomeJSArray m -> GHCJSPure [JSVal]
38−toList = GHCJSPure . toListIO
39−{-# INLINE toList #-}
40−
4126toListIO :: SomeJSArray m -> JSM [JSVal]
42−toListIO (SomeJSArray x) = do
43− len <- getPropertyByName (JSString "length") (Object x) >>= valueToNumber
44− mapM (`getPropertyAtIndex` Object x) [0..round len - 1]
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]
4533{-# INLINE toListIO #-}
4634
47−index :: Int -> SomeJSArray m -> GHCJSPure JSVal
48−index n = GHCJSPure . read n
49−{-# INLINE index #-}
50−
5135read :: Int -> SomeJSArray m -> JSM JSVal
52−read n (SomeJSArray x) = getPropertyAtIndex n $ Object x
36+read n (SomeJSArray x) =
37+ withObject (Object x) $ \this -> sendLazyCommand $ GetPropertyAtIndex this n
5338{-# INLINE read #-}
5439
5540push :: JSVal -> MutableJSArray -> JSM ()
56−push e (SomeJSArray x) = void $ do
57− f <- getPropertyByName (JSString "push") (Object x)
58− void $ callAsFunction (Object f) (Object x) [e]
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']
5946{-# INLINE push #-}
jsaddle/src-ghc/JavaScript/Object.hsdeleted−10
@@ -1,10 +0,0 @@
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+22−26
@@ -7,47 +7,43 @@ module JavaScript.Object.Internal
77 , unsafeGetProp
88 , setProp
99 , unsafeSetProp
10−-- , isInstanceOf
10+-- , isInstanceOfIO
1111 ) where
1212
1313import Language.Javascript.JSaddle.Types (JSM, JSVal, Object(..), JSString)
1414import Language.Javascript.JSaddle.Native.Internal
15− (newEmptyObject, propertyNames, getPropertyByName, setPropertyByName)
15+ (withObject, withJSString, withJSVal, wrapJSString)
16+import Language.Javascript.JSaddle.Run
17+ (Command(..), AsyncCommand(..), Result(..), sendCommand, sendLazyCommand, sendAsyncCommand)
1618
17−-- | create an empty object
1819create :: JSM Object
19−create = newEmptyObject
20−{-# INLINE create #-}
21−
22−--allProps :: Object -> JSM JSArray
23−--allProps o = js_allProps o
24−--{-# INLINE allProps #-}
20+create = Object <$> sendLazyCommand NewEmptyObject
2521
2622listProps :: Object -> JSM [JSString]
27−listProps = propertyNames
23+listProps this =
24+ withObject this $ \rthis -> do
25+ PropertyNamesResult result <- sendCommand $ PropertyNames rthis
26+ mapM wrapJSString result
2827{-# INLINE listProps #-}
2928
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− -}
29+unsafeGetProp :: JSString -> Object -> JSM JSVal
30+unsafeGetProp name this =
31+ withObject this $ \rthis ->
32+ withJSString name $ sendLazyCommand . GetPropertyByName rthis
33+{-# INLINE unsafeGetProp #-}
34+
3535getProp :: JSString -> Object -> JSM JSVal
3636getProp = unsafeGetProp
3737{-# INLINE getProp #-}
3838
39−unsafeGetProp :: JSString -> Object -> JSM JSVal
40−unsafeGetProp = getPropertyByName
41−{-# INLINE unsafeGetProp #-}
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 #-}
4246
4347setProp :: JSString -> JSVal -> Object -> JSM ()
4448setProp = unsafeSetProp
4549{-# 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.hsdeleted−19
@@ -1,19 +0,0 @@
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.hsdeleted−51
@@ -1,51 +0,0 @@
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.hsdeleted−33
@@ -1,33 +0,0 @@
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.hsdeleted−6
@@ -1,6 +0,0 @@
1−module JavaScript.TypedArray.ArrayBuffer.Type where
2−
3−import GHCJS.Prim
4−
5−
6−
jsaddle/src-ghc/JavaScript/TypedArray/DataView/Internal.hsdeleted−147
@@ -1,147 +0,0 @@
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.hsdeleted−1
@@ -1 +0,0 @@
1−module JavaScript.TypedArray.Immutable where
jsaddle/src-ghc/JavaScript/TypedArray/Internal.hsdeleted−344
@@ -1,344 +0,0 @@
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.hsdeleted−121
@@ -1,121 +0,0 @@
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+6−5
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12-----------------------------------------------------------------------------
23--
34-- Module : Language.Javascript.JSaddle
@@ -9,7 +10,7 @@
910-- | This package provides an EDSL for calling JavaScript that
1011-- can be used both from GHCJS and GHC. When using GHC
1112-- the application is run using Warp and WebSockets to
12−-- drive a small JavaScript helper.
13+-- drive a small JavaScipt helper.
1314-----------------------------------------------------------------------------
1415
1516module Language.Javascript.JSaddle (
@@ -35,10 +36,10 @@ module Language.Javascript.JSaddle (
3536 --
3637 -- Where it makes sense code examples are given in two forms. One
3738 -- that uses 'eval' to run a purely JavaScript version and one that
38− -- uses more of the JSaddle EDSL feature being demonstrated.
39+ -- uses more of the JSaddle EDSL feature being demonstated.
3940
4041 -- * Calling Haskell from JavaScript
41− -- | You can call back into Haskell from JavaScript using 'fun' to
42+ -- | You can call back into haskell from JavaScript using 'fun' to
4243 -- convert a Haskell function in the JSM monad into a javascript
4344 -- value.
4445
@@ -52,8 +53,8 @@ module Language.Javascript.JSaddle (
5253 -- and the server will run the Haskell code. The JSaddle parts will
5354 -- be executed by sending commands back to the browser.
5455
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.
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.
5758 -- This improves the performance by reducing the number of round trips
5859 -- needed between the Haskell and JavaScript code.
5960
jsaddle/src-ghc/JavaScript/Array.hs → jsaddle/src/Language/Javascript/JSaddle/Array.hsrenamed+23−36
@@ -1,6 +1,17 @@
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 #-}
112-----------------------------------------------------------------------------
213--
3−-- Module : JavaScript.Array
14+-- Module : Language.Javascript.JSaddle.Object
415-- Copyright : (c) Hamish Mackenzie
516-- License : MIT
617--
@@ -9,19 +20,17 @@
920-- | Interface to JavaScript array
1021--
1122-----------------------------------------------------------------------------
12−module JavaScript.Array
23+
24+module Language.Javascript.JSaddle.Array
1325 ( SomeJSArray(..)
1426 , JSArray
1527 , MutableJSArray
1628 , create
1729 , length
1830 , lengthIO
19− , null
20− , fromList
31+ , nullIO
2132 , fromListIO
22− , toList
2333 , toListIO
24− , index, (!)
2534 , read
2635 , write
2736 , append
@@ -30,11 +39,8 @@ module JavaScript.Array
3039 , unshift
3140 , shift
3241 , reverse
33− , take
3442 , takeIO
35− , drop
3643 , dropIO
37− , slice
3844 , sliceIO
3945 , freeze
4046 , unsafeFreeze
@@ -42,34 +48,30 @@ module JavaScript.Array
4248 , unsafeThaw
4349 ) where
4450
45−import Prelude hiding (length, drop, read, take, reverse, null)
51+import Prelude hiding (read, reverse, null)
4652import Control.Monad (void)
4753import Language.Javascript.JSaddle.Types
4854 (JSM, JSVal, SomeJSArray(..), JSArray,
49− MutableJSArray, GHCJSPure(..))
55+ MutableJSArray)
5056import Control.Lens.Operators ((^.))
51−import Language.Javascript.JSaddle.Object (js2, js0, (<##), js1, js)
57+import Language.Javascript.JSaddle.Object (js2, js0, (##), js1, js)
5258import Language.Javascript.JSaddle.Value (valToNumber)
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 #-}
59+import JavaScript.Array.Internal (create, fromListIO, toListIO, read, push)
5860
5961lengthIO :: SomeJSArray m -> JSM Int
6062lengthIO (SomeJSArray x) = round <$> (x ^. js "length" >>= valToNumber)
6163{-# INLINE lengthIO #-}
6264
63−null :: SomeJSArray m -> GHCJSPure Bool
64−null = GHCJSPure . fmap (== 0) . lengthIO
65−{-# INLINE null #-}
65+nullIO :: SomeJSArray m -> JSM Bool
66+nullIO = fmap (== 0) . lengthIO
67+{-# INLINE nullIO #-}
6668
6769append :: SomeJSArray m -> SomeJSArray m -> JSM (SomeJSArray m1)
6870append (SomeJSArray x) (SomeJSArray y) = SomeJSArray <$> x ^. js1 "concat" y
6971{-# INLINE append #-}
7072
7173write :: Int -> JSVal -> MutableJSArray -> JSM ()
72−write n e (SomeJSArray x) = void $ (x <## n) e
74+write n e (SomeJSArray x) = void $ (x ## n) e
7375{-# INLINE write #-}
7476
7577pop :: MutableJSArray -> JSM JSVal
@@ -88,26 +90,14 @@ reverse :: MutableJSArray -> JSM ()
8890reverse (SomeJSArray x) = void $ x ^. js0 "reverse"
8991{-# INLINE reverse #-}
9092
91−take :: Int -> SomeJSArray m -> GHCJSPure (SomeJSArray m1)
92−take n = GHCJSPure . takeIO n
93−{-# INLINE take #-}
94−
9593takeIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1)
9694takeIO n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" (0::Int) n
9795{-# INLINE takeIO #-}
9896
99−drop :: Int -> SomeJSArray m -> GHCJSPure (SomeJSArray m1)
100−drop n = GHCJSPure . dropIO n
101−{-# INLINE drop #-}
102−
10397dropIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1)
10498dropIO n (SomeJSArray x) = SomeJSArray <$> x ^. js1 "slice1" n
10599{-# INLINE dropIO #-}
106100
107−slice :: Int -> Int -> JSArray -> GHCJSPure (SomeJSArray m1)
108−slice s n = GHCJSPure . sliceIO s n
109−{-# INLINE slice #-}
110−
111101sliceIO :: Int -> Int -> JSArray -> JSM (SomeJSArray m1)
112102sliceIO s n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" s n
113103{-# INLINE sliceIO #-}
@@ -128,7 +118,4 @@ unsafeThaw :: JSArray -> JSM MutableJSArray
128118unsafeThaw (SomeJSArray x) = pure (SomeJSArray x)
129119{-# INLINE unsafeThaw #-}
130120
131−(!) :: JSArray -> Int -> GHCJSPure JSVal
132−x ! n = GHCJSPure $ read n x
133−{-# INLINE (!) #-}
134121
jsaddle/src/Language/Javascript/JSaddle/Debug.hsdeleted−48
@@ -1,48 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−-----------------------------------------------------------------------------
4−--
5−-- Module : Language.Javascript.JSaddle.WebSockets
6−-- Copyright : (c) Hamish Mackenzie
7−-- License : MIT
8−--
9−-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.Javascript.JSaddle.Debug (
16− contexts
17− , addContext
18− , removeContext
19− , runOnAll
20− , runOnAll_
21−) where
22−
23−import Language.Javascript.JSaddle
24− (runJSM, askJSM, JSM, JSContextRef(..))
25−import Data.IORef (readIORef, atomicModifyIORef', newIORef, IORef)
26−import System.IO.Unsafe (unsafePerformIO)
27−import Data.Monoid ((<>))
28−import Control.Monad.IO.Class (MonadIO(..))
29−import Data.Int (Int64)
30−
31−contexts :: IORef [JSContextRef]
32−contexts = unsafePerformIO $ newIORef []
33−{-# NOINLINE contexts #-}
34−
35−addContext :: JSM ()
36−addContext = do
37− ctx <- askJSM
38− liftIO $ atomicModifyIORef' contexts $ \c -> (c <> [ctx], ())
39−
40−removeContext :: MonadIO m => Int64 -> m ()
41−removeContext cid =
42− liftIO $ atomicModifyIORef' contexts $ \c -> (filter ((/= cid) . contextId) c, ())
43−
44−runOnAll :: MonadIO m => JSM a -> m [a]
45−runOnAll f = liftIO (readIORef contexts) >>= mapM (runJSM f)
46−
47−runOnAll_ :: MonadIO m => JSM a -> m ()
48−runOnAll_ f = liftIO (readIORef contexts) >>= mapM_ (runJSM f)
jsaddle/src/Language/Javascript/JSaddle/Evaluate.hs+7−3
@@ -27,7 +27,9 @@ import Control.Monad.IO.Class (MonadIO(..))
2727import Language.Javascript.JSaddle.Types (JSString)
2828#else
2929import Language.Javascript.JSaddle.Native.Internal
30− (evaluateScript)
30+ (withJSString)
31+import Language.Javascript.JSaddle.Run
32+ (AsyncCommand(..), sendLazyCommand)
3133#endif
3234import Language.Javascript.JSaddle.Marshal.String (ToJSString(..))
3335import Language.Javascript.JSaddle.Monad (JSM)
@@ -50,8 +52,10 @@ eval :: (ToJSString script)
5052 -> JSM JSVal
5153#ifdef ghcjs_HOST_OS
5254eval script = liftIO $ js_eval (toJSString script)
53−foreign import javascript safe "$r = eval($1);"
55+foreign import javascript unsafe "$r = eval($1);"
5456 js_eval :: JSString -> IO JSVal
5557#else
56−eval = evaluateScript . toJSString
58+eval script = do
59+ let rscript = toJSString script
60+ withJSString rscript $ sendLazyCommand . EvaluateScript
5761#endif
jsaddle/src/Language/Javascript/JSaddle/Exception.hs+1−6
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE DeriveDataTypeable #-}
32-----------------------------------------------------------------------------
43--
@@ -18,11 +17,7 @@ module Language.Javascript.JSaddle.Exception (
1817) where
1918
2019import qualified Control.Exception as E (Exception)
21−#ifdef ghcjs_HOST_OS
22−import GHCJS.Prim (JSVal)
23−#else
24−import GHCJS.Prim.Internal (JSVal)
25−#endif
20+import Language.Javascript.JSaddle.Types (JSVal)
2621import Data.Typeable (Typeable)
2722
2823newtype JSException = JSException JSVal deriving (Typeable)
jsaddle/src/Language/Javascript/JSaddle/Foreign.hsnew file+99
@@ -0,0 +1,99 @@
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.hsdeleted−30
@@ -1,30 +0,0 @@
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+26−3
@@ -38,12 +38,13 @@ module Language.Javascript.JSaddle.Monad (
3838 , bracket
3939) where
4040
41+import Prelude hiding (read)
4142#ifndef ghcjs_HOST_OS
42−import Control.Monad.Trans.Reader (runReaderT, ask)
43+import Control.Monad.Trans.Reader (runReaderT, ask, ReaderT(..))
4344#endif
4445import Control.Monad.IO.Class (MonadIO(..))
45−import Control.Monad.Catch (catch, bracket)
46−import Language.Javascript.JSaddle.Types (JSM(..), MonadJSM, liftJSM, JSContextRef)
46+import qualified Control.Exception as E (Exception, catch, bracket)
47+import Language.Javascript.JSaddle.Types (JSM(..), MonadJSM, liftJSM, JSContextRef(..))
4748import Language.Javascript.JSaddle.Run (syncPoint, syncAfter, waitForAnimationFrame, nextAnimationFrame)
4849
4950-- | Gets the JavaScript context from the monad
@@ -65,3 +66,25 @@ runJSM f = liftIO . runReaderT (unJSM f)
6566-- | Alternative version of 'runJSM'
6667runJSaddle :: MonadIO m => JSContextRef -> JSM a -> m a
6768runJSaddle = 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+6−1
@@ -11,7 +11,12 @@
1111-----------------------------------------------------------------------------
1212
1313module Language.Javascript.JSaddle.Native (
14− module Language.Javascript.JSaddle.Native.Internal
14+ wrapJSVal
15+ , wrapJSString
16+ , withJSVal
17+ , withJSVals
18+ , withObject
19+ , withJSString
1520 , withToJSVal
1621) where
1722
jsaddle/src/Language/Javascript/JSaddle/Native/Internal.hs+23−212
@@ -1,6 +1,3 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE MagicHash #-}
3−{-# LANGUAGE UnboxedTuples #-}
41-----------------------------------------------------------------------------
52--
63-- Module : Language.Javascript.JSaddle.Native
@@ -20,234 +17,48 @@ module Language.Javascript.JSaddle.Native.Internal (
2017 , withJSVals
2118 , withObject
2219 , 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
4820) where
4921
22+import Control.Monad.Trans.Reader (ask)
5023import Control.Monad.IO.Class (MonadIO(..))
51−
52−import Data.Aeson (Value)
53−
5424import Language.Javascript.JSaddle.Types
55− (AsyncCommand(..), JSM(..), JSString(..), addCallback,
56− Object(..), JSVal(..), JSValueForSend(..), JSCallAsFunction,
25+ (JSContextRef(..), AsyncCommand(..), JSM(..), JSString(..),
26+ Object(..), JSVal(..), JSValueReceived(..), JSValueForSend(..),
5727 JSStringReceived(..), JSStringForSend(..), JSObjectForSend(..))
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#)
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
6640
6741wrapJSString :: MonadIO m => JSStringReceived -> m JSString
6842wrapJSString (JSStringReceived ref) = return $ JSString ref
6943
70−touchIORef :: IORef a -> IO ()
71−touchIORef (IORef (STRef r#)) = IO $ \s -> case touch# r# s of s' -> (# s', () #)
72−
7344withJSVal :: MonadIO m => JSVal -> (JSValueForSend -> m a) -> m a
74−withJSVal (JSVal ref) f = do
75− result <- (f . JSValueForSend) =<< liftIO (readIORef ref)
76− liftIO $ touchIORef ref
45+withJSVal v@(JSVal ref) f =
46+ do result <- f (JSValueForSend ref)
47+ liftIO $ touch v
7748 return result
7849
7950withJSVals :: MonadIO m => [JSVal] -> ([JSValueForSend] -> m a) -> m a
8051withJSVals v f =
81− do result <- f =<< mapM (\(JSVal ref) -> liftIO $ JSValueForSend <$> readIORef ref) v
82− liftIO $ mapM_ (\(JSVal ref) -> touchIORef ref) v
52+ do result <- f (map (\(JSVal ref) -> JSValueForSend ref) v)
53+ liftIO $ mapM_ touch v
8354 return result
8455
8556withObject :: MonadIO m => Object -> (JSObjectForSend -> m a) -> m a
8657withObject (Object o) f = withJSVal o (f . JSObjectForSend)
8758
8859withJSString :: MonadIO m => JSString -> (JSStringForSend -> m a) -> m a
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)
60+withJSString v@(JSString ref) f =
61+ do result <- f (JSStringForSend ref)
62+ liftIO $ touch v
20763 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 #-}
24764
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.hsdeleted−56
@@ -1,56 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−-----------------------------------------------------------------------------
4−--
5−-- Module : Language.Javascript.JSaddle.WebSockets
6−-- Copyright : (c) Hamish Mackenzie
7−-- License : MIT
8−--
9−-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.Javascript.JSaddle.Null (
16− run
17−) where
18−
19−import Language.Javascript.JSaddle.Types
20− (BatchResults(..), JSM, JSStringReceived(..), Batch(..),
21− Results(..), Result(..), Command(..))
22−import Control.Concurrent.Chan (readChan, writeChan, newChan)
23−import Language.Javascript.JSaddle.Run (runJavaScript)
24−import Control.Concurrent (forkIO)
25−import Control.Monad (forever)
26−import Data.Aeson (Value(..))
27−import Data.Maybe (mapMaybe)
28−
29−-- | This is for performance testing JSaddle code that does not need to
30−-- to read anything back from the JavaScript context.
31−-- Anthing that does try to read will get JS null, 0 or "" back (depending
32−-- on how the value is read).
33−run :: JSM () -> IO ()
34−run f = do
35− batches <- newChan
36− (processResult, _processSyncResult, start) <- runJavaScript (writeChan batches) f
37− _ <- forkIO $ forever $
38− readChan batches >>= \case
39− Batch commands _ batchNumber ->
40− processResult $ BatchResults batchNumber . Success [] $ mapMaybe (\case
41− Left _ -> Nothing
42− Right command -> Just $
43− case command of
44− DeRefVal _ -> DeRefValResult 0 ""
45− ValueToBool _ -> ValueToBoolResult False
46− ValueToNumber _ -> ValueToNumberResult 0
47− ValueToString _ -> ValueToStringResult (JSStringReceived "")
48− ValueToJSON _ -> ValueToJSONResult (JSStringReceived "null")
49− ValueToJSONValue _ -> ValueToJSONValueResult Null
50− IsNull _ -> IsNullResult True
51− IsUndefined _ -> IsUndefinedResult False
52− StrictEqual _ _ -> StrictEqualResult False
53− InstanceOf _ _ -> InstanceOfResult False
54− PropertyNames _ -> PropertyNamesResult []
55− Sync -> SyncResult) commands
56− start
jsaddle/src/Language/Javascript/JSaddle/Object.hs+29−54
@@ -66,7 +66,6 @@ module Language.Javascript.JSaddle.Object (
6666 -- * Calling Haskell From JavaScript
6767 , Function(..)
6868 , function
69− , asyncFunction
7069 , freeFunction
7170 , fun
7271 , JSCallAsFunction
@@ -103,7 +102,7 @@ import Data.Coerce (coerce)
103102#ifdef ghcjs_HOST_OS
104103import GHCJS.Types (nullRef)
105104import GHCJS.Foreign.Callback
106− (releaseCallback, syncCallback2, asyncCallback2, OnBlocked(..), Callback)
105+ (releaseCallback, syncCallback2, OnBlocked(..), Callback)
107106import GHCJS.Marshal (ToJSVal(..))
108107import JavaScript.Array (MutableJSArray)
109108import qualified JavaScript.Array as Array (toListIO, fromListIO)
@@ -114,15 +113,17 @@ import Language.Javascript.JSaddle.Types
114113 (JSString, Object(..),
115114 JSVal(..), JSCallAsFunction)
116115#else
116+import Data.Text (Text)
117117import GHCJS.Marshal.Internal (ToJSVal(..))
118118import Language.Javascript.JSaddle.Native
119− (newAsyncCallback, newSyncCallback, callAsFunction, callAsConstructor)
119+ (withJSVals, withObject)
120+import Language.Javascript.JSaddle.Run
121+ (AsyncCommand(..), sendLazyCommand)
120122import Language.Javascript.JSaddle.Monad (askJSM, JSM)
121123import Language.Javascript.JSaddle.Types
122− (JSValueForSend(..), AsyncCommand(..), JSString, Object(..),
123− SomeJSArray(..), JSVal(..), JSCallAsFunction, JSContextRef(..))
124+ (JSString, Object(..), SomeJSArray(..),
125+ JSVal(..), JSCallAsFunction, JSContextRef(..))
124126import JavaScript.Object.Internal (create, listProps)
125−import Language.Javascript.JSaddle.Run (sendAsyncCommand)
126127#endif
127128import JavaScript.Array.Internal (fromListIO)
128129import Language.Javascript.JSaddle.Value (valToObject)
@@ -132,8 +133,6 @@ import Language.Javascript.JSaddle.Arguments (MakeArgs(..))
132133import Control.Monad.IO.Class (MonadIO(..))
133134import Language.Javascript.JSaddle.Properties
134135import Control.Lens (IndexPreservingGetter, to)
135−import Data.IORef (newIORef, readIORef)
136−import System.IO.Unsafe (unsafePerformIO)
137136
138137-- $setup
139138-- >>> import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
@@ -281,7 +280,6 @@ jsgf name = global # name
281280-- > jsg0 name = jsgf name ()
282281--
283282-- >>> testJSaddle $ jsg0 "globalFunc" >>= valToText
284−-- A JavaScript exception was thrown! (may not reach Haskell code)
285283-- TypeError:...undefine...
286284jsg0 :: (ToJSString name) => name -> JSM JSVal
287285jsg0 name = jsgf name ()
@@ -439,16 +437,9 @@ newtype Function = Function {functionObject :: Object}
439437#endif
440438
441439
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−
447440-- ^ 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`).
450441function :: JSCallAsFunction -- ^ Haskell function to call
451− -> JSM Function -- ^ Returns a JavaScript function object that will
442+ -> JSM Function -- ^ Returns a JavaScript function object that will
452443 -- call the Haskell one when it is called
453444#ifdef ghcjs_HOST_OS
454445function f = do
@@ -456,26 +447,13 @@ function f = do
456447 rargs <- Array.toListIO (coerce args)
457448 f this this rargs -- TODO pass function object through
458449 Function callback <$> makeFunctionWithCallback callback
450+foreign import javascript unsafe "$r = function () { $1(this, arguments); }"
451+ makeFunctionWithCallback :: Callback (JSVal -> JSVal -> IO ()) -> IO Object
459452#else
460453function f = do
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
454+ object <- Object <$> sendLazyCommand NewCallback
455+ add <- addCallback <$> askJSM
456+ liftIO $ add object f
479457 return $ Function object
480458#endif
481459
@@ -484,16 +462,9 @@ freeFunction :: Function -> JSM ()
484462freeFunction (Function callback _) = liftIO $
485463 releaseCallback callback
486464#else
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))
465+freeFunction (Function object) = do
466+ free <- freeCallback <$> askJSM
467+ liftIO $ free object
497468#endif
498469
499470instance ToJSVal Function where
@@ -526,12 +497,13 @@ array args = do
526497 Object . coerce <$> fromListIO rargs
527498
528499-- | JavaScript's global object
500+global :: Object
529501#ifdef ghcjs_HOST_OS
530−foreign import javascript unsafe "$r = globalThis"
531− global :: Object
502+global = js_window
503+foreign import javascript unsafe "$r = window"
504+ js_window :: Object
532505#else
533−global :: Object
534−global = Object . JSVal . unsafePerformIO $ newIORef 4
506+global = Object (JSVal 4)
535507#endif
536508
537509-- | Get a list containing the property names present on a given object
@@ -556,12 +528,14 @@ objCallAsFunction :: MakeArgs args
556528objCallAsFunction f this args = do
557529 rargs <- makeArgs args >>= liftIO . Array.fromListIO
558530 liftIO $ js_apply f this rargs
559−foreign import javascript safe "$r = $1.apply($2, $3)"
531+foreign import javascript unsafe "$r = $1.apply($2, $3)"
560532 js_apply :: Object -> Object -> MutableJSArray -> IO JSVal
561533#else
562534objCallAsFunction f this args = do
563535 rargs <- makeArgs args
564− callAsFunction f this rargs
536+ withObject f $ \rfunction ->
537+ withObject this $ \rthis ->
538+ withJSVals rargs $ sendLazyCommand . CallAsFunction rfunction rthis
565539#endif
566540
567541-- | Call a JavaScript object as a constructor. Consider using 'new'.
@@ -576,7 +550,7 @@ objCallAsConstructor :: MakeArgs args
576550objCallAsConstructor f args = do
577551 rargs <- makeArgs args >>= liftIO . Array.fromListIO
578552 liftIO $ js_new f rargs
579−foreign import javascript safe "\
553+foreign import javascript unsafe "\
580554 switch($2.length) {\
581555 case 0 : $r = new $1(); break;\
582556 case 1 : $r = new $1($2[0]); break;\
@@ -603,7 +577,8 @@ foreign import javascript safe "\
603577#else
604578objCallAsConstructor f args = do
605579 rargs <- makeArgs args
606− callAsConstructor f rargs
580+ withObject f $ \rfunction ->
581+ withJSVals rargs $ sendLazyCommand . CallAsConstructor rfunction
607582#endif
608583
609584-- >>> testJSaddle $ strictEqual nullObject (eval "null")
@@ -612,5 +587,5 @@ nullObject :: Object
612587#ifdef ghcjs_HOST_OS
613588nullObject = Object nullRef
614589#else
615−nullObject = Object . JSVal . unsafePerformIO $ newIORef 0
590+nullObject = Object (JSVal 0)
616591#endif
jsaddle/src/Language/Javascript/JSaddle/Run.hs+80−195
@@ -1,9 +1,6 @@
1−{-# LANGUAGE BangPatterns #-}
21{-# LANGUAGE CPP #-}
32{-# LANGUAGE LambdaCase #-}
43{-# LANGUAGE OverloadedStrings #-}
5−{-# LANGUAGE MagicHash #-}
6−{-# LANGUAGE UnboxedTuples #-}
74-----------------------------------------------------------------------------
85--
96-- Module : Language.Javascript.JSaddle.Run
@@ -22,7 +19,6 @@ module Language.Javascript.JSaddle.Run (
2219 , syncAfter
2320 , waitForAnimationFrame
2421 , nextAnimationFrame
25− , enableLogging
2622#ifndef ghcjs_HOST_OS
2723 -- * Functions used to implement JSaddle using JSON messaging
2824 , runJavaScript
@@ -32,72 +28,56 @@ module Language.Javascript.JSaddle.Run (
3228 , sendCommand
3329 , sendLazyCommand
3430 , sendAsyncCommand
35− , wrapJSVal
3631#endif
3732) where
3833
3934#ifdef ghcjs_HOST_OS
40−import Language.Javascript.JSaddle.Types (JSM, syncPoint, syncAfter)
35+import Language.Javascript.JSaddle.Types (JSM)
4136import qualified JavaScript.Web.AnimationFrame as GHCJS
4237 (waitForAnimationFrame)
4338#else
44−import Control.Exception (throwIO, evaluate)
45−import Control.Monad (void, when, zipWithM_)
39+import Control.Exception (throwIO)
40+import Control.Monad (void, forever)
4641import Control.Monad.IO.Class (MonadIO(..))
4742import Control.Monad.Trans.Reader (ask, runReaderT)
48−import Control.Monad.STM (atomically)
49−import Control.Concurrent (forkIO, myThreadId)
43+import Control.Monad.STM (STM, atomically)
44+import Control.Concurrent (forkIO)
5045import Control.Concurrent.STM.TChan
5146 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
5247import Control.Concurrent.STM.TVar
53− (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
48+ (writeTVar, readTVar, readTVarIO, modifyTVar, newTVarIO)
5449import Control.Concurrent.MVar
55− (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)
50+ (MVar, MVar, putMVar, takeMVar, newEmptyMVar)
5651
57−import System.IO.Unsafe (unsafeInterleaveIO)
58−import System.Mem.Weak (addFinalizer)
59−import System.Random
60−
61−import GHC.Base (IO(..), mkWeak#)
62−import GHC.Conc (ThreadId(..))
6352import Data.Monoid ((<>))
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)
53+import qualified Data.Text as T (unpack)
54+import qualified Data.Map as M (lookup, delete, insert, empty)
6755import Data.Time.Clock (getCurrentTime,diffUTCTime)
68−import Data.IORef
69− (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)
7056
7157import Language.Javascript.JSaddle.Types
72− (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
73− Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand)
58+ (Command(..), AsyncCommand(..), Result(..), JSContextRef(..), JSVal(..),
59+ Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
7460import Language.Javascript.JSaddle.Exception (JSException(..))
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_)
61+import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
8262#endif
8363
84−#ifndef ghcjs_HOST_OS
85−#if MIN_VERSION_base(4,11,0)
86−currentBytesUsed = gcdetails_live_bytes . gc
64+-- | Forces execution of pending asyncronous code
65+syncPoint :: JSM ()
66+#ifdef ghcjs_HOST_OS
67+syncPoint = return ()
8768#else
88−getRTSStatsEnabled = getGCStatsEnabled
89−getRTSStats = getGCStats
90−#endif
69+syncPoint = void $ sendCommand Sync
9170#endif
9271
93−-- | Enable (or disable) JSaddle logging
94−enableLogging :: Bool -> JSM ()
72+-- | Forces execution of pending asyncronous code after performing `f`
73+syncAfter :: JSM a -> JSM a
9574#ifdef ghcjs_HOST_OS
96−enableLogging _ = return ()
75+syncAfter = id
9776#else
98−enableLogging v = do
99− f <- doEnableLogging <$> JSM ask
100− liftIO $ f v
77+syncAfter f = do
78+ result <- f
79+ syncPoint
80+ return result
10181#endif
10282
10383-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
@@ -125,12 +105,17 @@ nextAnimationFrame f = do
125105 syncAfter (f t)
126106
127107#ifndef ghcjs_HOST_OS
108+sendCommand :: Command -> JSM Result
109+sendCommand cmd = do
110+ s <- doSendCommand <$> JSM ask
111+ liftIO $ s cmd
112+
128113sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
129114sendLazyCommand cmd = do
130115 nextRefTVar <- nextRef <$> JSM ask
131116 n <- liftIO . atomically $ do
132117 n <- subtract 1 <$> readTVar nextRefTVar
133− writeTVar nextRefTVar $! n
118+ writeTVar nextRefTVar n
134119 return n
135120 s <- doSendAsyncCommand <$> JSM ask
136121 liftIO $ s (cmd $ JSValueForSend n)
@@ -141,171 +126,71 @@ sendAsyncCommand cmd = do
141126 s <- doSendAsyncCommand <$> JSM ask
142127 liftIO $ s cmd
143128
144−runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
129+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Result -> IO (), IO ())
145130runJavaScript sendBatch entryPoint = do
146− contextId' <- randomIO
147131 startTime' <- getCurrentTime
148− recvMVar <- newEmptyMVar
149− lastAsyncBatch <- newEmptyMVar
132+ recvChan <- newTChanIO
150133 commandChan <- newTChanIO
151134 callbacks <- newTVarIO M.empty
152135 nextRef' <- newTVarIO 0
153− finalizerThreads' <- newMVar S.empty
154− animationFrameHandlers' <- newMVar []
155− loggingEnabled <- newIORef False
156− liveRefs' <- newMVar S.empty
157136 let ctx = JSContextRef {
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
137+ startTime = startTime'
138+ , doSendCommand = \cmd -> do
139+ result <- newEmptyMVar
140+ atomically $ writeTChan commandChan (Right (cmd, result))
141+ takeMVar result >>= \case
142+ (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
143+ r -> return r
144+ , doSendAsyncCommand = atomically . writeTChan commandChan . Left
145+ , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar callbacks (M.insert val cb)
146+ , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar callbacks (M.delete val)
147+ , nextRef = nextRef'
148+ }
149+ let processResult = \case
181150 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
182− (Callback n br (JSValueReceived fNumber) f this a) -> do
183− putMVar recvMVar (n, br)
184− f' <- runReaderT (unJSM $ wrapJSVal f) ctx
151+ (Callback f this a) -> do
152+ f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
185153 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
186154 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
187− logInfo (("Call " <> show fNumber <> " ") <>)
188155 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
189156 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
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
157+ Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
158+ m -> atomically $ writeTChan recvChan m
159+ _ <- forkIO . forever $ readBatch commandChan >>= \case
160+ (batch, Just resultMVar) -> do
161+ sendBatch batch
162+ atomically (readTChan recvChan) >>= putMVar resultMVar
163+ (batch, Nothing) -> do
221164 sendBatch batch
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)
165+ atomically (readTChan recvChan) >>= \case
166+ SyncResult -> return ()
167+ ThrowJSValue e -> atomically (discardToSyncPoint commandChan) >>= (`putMVar` ThrowJSValue e)
168+ _ -> error "Unexpected result processing batch"
169+ return ()
170+ return (processResult, runReaderT (unJSM entryPoint) ctx)
239171 where
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
172+ readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, Maybe (MVar Result))
173+ readBatch chan = do
250174 first <- atomically $ readTChan chan -- We want at least one command to send
251− loop first ([], [])
175+ loop first []
252176 where
253− loop :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
254− loop (Left asyncCmd@(SyncWithAnimationFrame _)) (cmds, resultMVars) =
255− atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
256− loop (Right (syncCmd, resultMVar)) (cmds', resultMVars') = do
257− let cmds = Right syncCmd:cmds'
258− resultMVars = resultMVar:resultMVars'
177+ loop (Left asyncCmd@(SyncWithAnimationFrame _)) asyncCmds =
178+ atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (asyncCmd:asyncCmds)
179+ loop (Right (cmd, resultMVar)) asyncCmds =
180+ return (Batch (reverse asyncCmds) cmd False, Just resultMVar)
181+ loop (Left asyncCmd) asyncCmds' = do
182+ let asyncCmds = asyncCmd:asyncCmds'
259183 atomically (tryReadTChan chan) >>= \case
260− Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
261− Just cmd -> loop cmd (cmds, resultMVars)
262− loop (Left asyncCmd) (cmds', resultMVars) = do
263− let cmds = Left asyncCmd:cmds'
264− atomically (tryReadTChan chan) >>= \case
265− Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
266− Just cmd -> loop cmd (cmds, resultMVars)
184+ Nothing -> return (Batch (reverse asyncCmds) Sync False, Nothing)
185+ Just cmd -> loop cmd asyncCmds
267186 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
268− loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
269− loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =
270− return (Batch (reverse (Right Sync:cmds)) True nBatch, reverse (resultMVar:resultMVars))
271− loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
272− atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
273− loopAnimation (Left asyncCmd) (cmds, resultMVars) =
274− 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)
187+ loopAnimation (Right (cmd, resultMVar)) asyncCmds =
188+ return (Batch (reverse asyncCmds) cmd True, Just resultMVar)
189+ loopAnimation (Left asyncCmd) asyncCmds =
190+ atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (asyncCmd:asyncCmds)
191+ discardToSyncPoint :: TChan (Either AsyncCommand (Command, MVar Result)) -> STM (MVar Result)
192+ discardToSyncPoint chan =
193+ readTChan chan >>= \case
194+ Right (_, resultMVar) -> return resultMVar
195+ _ -> discardToSyncPoint chan
311196#endif
jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+117−253
@@ -13,6 +13,7 @@
1313
1414module Language.Javascript.JSaddle.Run.Files (
1515 indexHtml
16+ , jsaddleJs
1617 , initState
1718 , runBatch
1819 , ghcjsHelpers
@@ -30,54 +31,30 @@ indexHtml =
3031 \</head>\n\
3132 \<body>\n\
3233 \</body>\n\
33− \<script src=\"/jsaddle.js\"></script>\n\
34+ \<script src=\"jsaddle.js\"></script>\n\
3435 \</html>"
3536
3637initState :: ByteString
3738initState = "\
3839 \ 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, globalThis);\n\
44+ \ jsaddle_values.set(4, window);\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\
5046 \"
5147
52−runBatch :: (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString
53−runBatch send sendSync = "\
54− \ var runBatch = function(firstBatch, initialSyncDepth) {\n\
55− \ var processBatch = function(timestamp) {\n\
56− \ var batch = firstBatch;\n\
57− \ var callbacksToFree = [];\n\
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\
65− \ var nCommandsLength = batch[0].length;\n\
66− \ for (var nCommand = 0; nCommand != nCommandsLength; nCommand++) {\n\
67− \ var cmd = batch[0][nCommand];\n\
68− \ if (cmd.Left) {\n\
69− \ var d = cmd.Left;\n\
70− \ switch (d.tag) {\n\
48+runBatch :: (ByteString -> ByteString) -> ByteString
49+runBatch send = "\
50+ \ var processBatch = function(timestamp) {\n\
51+ \ try {\n\
52+ \ var nAsyncLength = batch[0].length;\n\
53+ \ for (var nAsync = 0; nAsync != nAsyncLength; nAsync++) {\n\
54+ \ var d = batch[0][nAsync];\n\
55+ \ switch (d.tag) {\n\
7156 \ case \"FreeRef\":\n\
72− \ var refsToFree = jsaddle_free.get(d.contents[0]) || [];\n\
73− \ refsToFree.push(d.contents[1]);\n\
74− \ jsaddle_free.set(d.contents[0], refsToFree);\n\
75− \ break;\n\
76− \ case \"FreeRefs\":\n\
77− \ var refsToFree = jsaddle_free.get(d.contents) || [];\n\
78− \ for(var nRef = 0; nRef != refsToFree.length; nRef++)\n\
79− \ jsaddle_values.delete(refsToFree[nRef]);\n\
80− \ jsaddle_free.delete(d.contents);\n\
57+ \ jsaddle_values.delete(d.contents);\n\
8158 \ break;\n\
8259 \ case \"SetPropertyByName\":\n\
8360 \ jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]);\n\
@@ -93,10 +70,6 @@ runBatch send sendSync = "\
9370 \ var n = d.contents[1];\n\
9471 \ jsaddle_values.set(n, d.contents[0]);\n\
9572 \ 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\
10073 \ case \"GetPropertyByName\":\n\
10174 \ var n = d.contents[2];\n\
10275 \ jsaddle_values.set(n, jsaddle_values.get(d.contents[0])[d.contents[1]]);\n\
@@ -113,12 +86,10 @@ runBatch send sendSync = "\
11386 \ var n = d.contents;\n\
11487 \ jsaddle_values.set(n, {});\n\
11588 \ break;\n\
116− \ case \"NewAsyncCallback\":\n\
89+ \ case \"NewCallback\":\n\
11790 \ (function() {\n\
11891 \ var nFunction = d.contents;\n\
119− \ var func = function() {\n\
120− \ var nFunctionInFunc = ++jsaddle_index;\n\
121− \ jsaddle_values.set(nFunctionInFunc, func);\n\
92+ \ jsaddle_values.set(nFunction, function() {\n\
12293 \ var nThis = ++jsaddle_index;\n\
12394 \ jsaddle_values.set(nThis, this);\n\
12495 \ var args = [];\n\
@@ -127,41 +98,8 @@ runBatch send sendSync = "\
12798 \ jsaddle_values.set(nArg, arguments[i]);\n\
12899 \ args[i] = nArg;\n\
129100 \ }\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\
101+ \ " <> send "{\"tag\": \"Callback\", \"contents\": [nFunction, nThis, args]}" <> "\n\
102+ \ })})();\n\
165103 \ break;\n\
166104 \ case \"CallAsFunction\":\n\
167105 \ var n = d.contents[3];\n\
@@ -204,137 +142,117 @@ runBatch send sendSync = "\
204142 \ jsaddle_values.set(n, d.contents[0].map(function(v){return jsaddle_values.get(v);}));\n\
205143 \ break;\n\
206144 \ case \"SyncWithAnimationFrame\":\n\
207− \ var n = d.contents;\n\
145+ \ var n = d.contents[0];\n\
208146 \ jsaddle_values.set(n, timestamp);\n\
209147 \ break;\n\
210− \ case \"StartSyncBlock\":\n\
211− \ syncDepth++;\n\
212− \ break;\n\
213− \ case \"EndSyncBlock\":\n\
214− \ syncDepth--;\n\
215− \ break;\n\
216148 \ default:\n\
217149 \ " <> send "{\"tag\": \"ProtocolError\", \"contents\": e.data}" <> "\n\
218150 \ return;\n\
151+ \ }\n\
219152 \ }\n\
220− \ } else {\n\
221− \ var d = cmd.Right;\n\
153+ \ var d = batch[1];\n\
222154 \ switch (d.tag) {\n\
223− \ case \"ValueToString\":\n\
224− \ var val = jsaddle_values.get(d.contents);\n\
225− \ var s = val === null ? \"null\" : val === undefined ? \"undefined\" : val.toString();\n\
226− \ results.push({\"tag\": \"ValueToStringResult\", \"contents\": s});\n\
227− \ break;\n\
228− \ case \"ValueToBool\":\n\
229− \ results.push({\"tag\": \"ValueToBoolResult\", \"contents\": jsaddle_values.get(d.contents) ? true : false});\n\
230− \ break;\n\
231− \ case \"ValueToNumber\":\n\
232− \ results.push({\"tag\": \"ValueToNumberResult\", \"contents\": Number(jsaddle_values.get(d.contents))});\n\
233− \ break;\n\
234− \ case \"ValueToJSON\":\n\
235− \ var s = jsaddle_values.get(d.contents) === undefined ? \"\" : JSON.stringify(jsaddle_values.get(d.contents));\n\
236− \ results.push({\"tag\": \"ValueToJSONResult\", \"contents\": s});\n\
237− \ break;\n\
238− \ case \"ValueToJSONValue\":\n\
239− \ results.push({\"tag\": \"ValueToJSONValueResult\", \"contents\": jsaddle_values.get(d.contents)});\n\
240− \ break;\n\
241− \ case \"DeRefVal\":\n\
242− \ var n = d.contents;\n\
243− \ var v = jsaddle_values.get(n);\n\
244− \ var c = (v === null ) ? [0, \"\"] :\n\
245− \ (v === undefined ) ? [1, \"\"] :\n\
246− \ (v === false ) ? [2, \"\"] :\n\
247− \ (v === true ) ? [3, \"\"] :\n\
248− \ (typeof v === \"number\") ? [-1, v.toString()] :\n\
249− \ (typeof v === \"string\") ? [-2, v]\n\
250− \ : [-3, \"\"];\n\
251− \ results.push({\"tag\": \"DeRefValResult\", \"contents\": c});\n\
252− \ break;\n\
253− \ case \"IsNull\":\n\
254− \ results.push({\"tag\": \"IsNullResult\", \"contents\": jsaddle_values.get(d.contents) === null});\n\
255− \ break;\n\
256− \ case \"IsUndefined\":\n\
257− \ results.push({\"tag\": \"IsUndefinedResult\", \"contents\": jsaddle_values.get(d.contents) === undefined});\n\
258− \ break;\n\
259− \ case \"InstanceOf\":\n\
260− \ results.push({\"tag\": \"InstanceOfResult\", \"contents\": jsaddle_values.get(d.contents[0]) instanceof jsaddle_values.get(d.contents[1])});\n\
261− \ break;\n\
262− \ case \"StrictEqual\":\n\
263− \ results.push({\"tag\": \"StrictEqualResult\", \"contents\": jsaddle_values.get(d.contents[0]) === jsaddle_values.get(d.contents[1])});\n\
264− \ break;\n\
265− \ case \"PropertyNames\":\n\
266− \ var result = [];\n\
267− \ for (name in jsaddle_values.get(d.contents)) { result.push(name); }\n\
268− \ results.push({\"tag\": \"PropertyNamesResult\", \"contents\": result});\n\
269− \ break;\n\
270− \ case \"Sync\":\n\
271− \ results.push({\"tag\": \"SyncResult\", \"contents\": []});\n\
272− \ break;\n\
273− \ default:\n\
274− \ results.push({\"tag\": \"ProtocolError\", \"contents\": e.data});\n\
275− \ }\n\
155+ \ case \"ValueToString\":\n\
156+ \ var val = jsaddle_values.get(d.contents);\n\
157+ \ var s = val === null ? \"null\" : val === undefined ? \"undefined\" : val.toString();\n\
158+ \ " <> send "{\"tag\": \"ValueToStringResult\", \"contents\": s}" <> "\n\
159+ \ break;\n\
160+ \ case \"ValueToBool\":\n\
161+ \ " <> send "{\"tag\": \"ValueToBoolResult\", \"contents\": jsaddle_values.get(d.contents) ? true : false}" <> "\n\
162+ \ break;\n\
163+ \ case \"ValueToNumber\":\n\
164+ \ " <> send "{\"tag\": \"ValueToNumberResult\", \"contents\": Number(jsaddle_values.get(d.contents))}" <> "\n\
165+ \ break;\n\
166+ \ case \"ValueToJSON\":\n\
167+ \ var s = jsaddle_values.get(d.contents) === undefined ? \"\" : JSON.stringify(jsaddle_values.get(d.contents));\n\
168+ \ " <> send "{\"tag\": \"ValueToJSONResult\", \"contents\": s}" <> "\n\
169+ \ break;\n\
170+ \ case \"ValueToJSONValue\":\n\
171+ \ " <> send "{\"tag\": \"ValueToJSONValueResult\", \"contents\": jsaddle_values.get(d.contents)}" <> "\n\
172+ \ break;\n\
173+ \ case \"DeRefVal\":\n\
174+ \ var n = d.contents;\n\
175+ \ var v = jsaddle_values.get(n);\n\
176+ \ var c = (v === null ) ? [0, \"\"] :\n\
177+ \ (v === undefined ) ? [1, \"\"] :\n\
178+ \ (v === false ) ? [2, \"\"] :\n\
179+ \ (v === true ) ? [3, \"\"] :\n\
180+ \ (typeof v === \"number\") ? [-1, v.toString()] :\n\
181+ \ (typeof v === \"string\") ? [-2, v]\n\
182+ \ : [n, \"\"];\n\
183+ \ " <> send "{\"tag\": \"DeRefValResult\", \"contents\": c}" <> "\n\
184+ \ break;\n\
185+ \ case \"IsNull\":\n\
186+ \ " <> send "{\"tag\": \"IsNullResult\", \"contents\": jsaddle_values.get(d.contents) === null}" <> "\n\
187+ \ break;\n\
188+ \ case \"IsUndefined\":\n\
189+ \ " <> send "{\"tag\": \"IsUndefinedResult\", \"contents\": jsaddle_values.get(d.contents) === undefined}" <> "\n\
190+ \ break;\n\
191+ \ case \"InstanceOf\":\n\
192+ \ " <> send "{\"tag\": \"InstanceOfResult\", \"contents\": jsaddle_values.get(d.contents[0]) instanceof jsaddle_values.get(d.contents[1])}" <> "\n\
193+ \ break;\n\
194+ \ case \"StrictEqual\":\n\
195+ \ " <> send "{\"tag\": \"StrictEqualResult\", \"contents\": jsaddle_values.get(d.contents[0]) === jsaddle_values.get(d.contents[1])}" <> "\n\
196+ \ break;\n\
197+ \ case \"PropertyNames\":\n\
198+ \ var result = [];\n\
199+ \ for (name in jsaddle_values.get(d.contents)) { result.push(name); }\n\
200+ \ " <> send "{\"tag\": \"PropertyNamesResult\", \"contents\": result}" <> "\n\
201+ \ break;\n\
202+ \ case \"Sync\":\n\
203+ \ " <> send "{\"tag\": \"SyncResult\", \"contents\": []}" <> "\n\
204+ \ break;\n\
205+ \ default:\n\
206+ \ " <> send "{\"tag\": \"ProtocolError\", \"contents\": e.data}" <> "\n\
207+ \ }\n\
208+ \ }\n\
209+ \ catch (err) {\n\
210+ \ var n = ++jsaddle_index;\n\
211+ \ jsaddle_values.set(n, err);\n\
212+ \ " <> send "{\"tag\": \"ThrowJSValue\", \"contents\": n}" <> "\n\
276213 \ }\n\
214+ \ };\n\
215+ \ if(batch[2]) {\n\
216+ \ window.requestAnimationFrame(processBatch);\n\
277217 \ }\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\
313− \ }\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\
218+ \ else {\n\
219+ \ processBatch(window.performance ? window.performance.now() : null);\n\
220+ \ }\n\
221+ \"
222+
223+-- Use this to generate this string for embedding
224+-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy
225+jsaddleJs :: ByteString
226+jsaddleJs = "\
227+ \if(typeof global !== \"undefined\") {\n\
228+ \ global.window = global;\n\
229+ \ global.WebSocket = require('ws');\n\
230+ \}\n\
231+ \\n\
232+ \var connect = function() {\n\
233+ \ var wsaddress =\n\
234+ \ typeof window.location === \"undefined\"\n\
235+ \ ? \"ws://localhost:3709/\"\n\
236+ \ : window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\");\n\
237+ \\n\
238+ \ var ws = new WebSocket(wsaddress);\n\
239+ \\n\
240+ \ ws.onopen = function(e) {\n\
241+ \ " <> initState <> "\
242+ \\n\
243+ \ ws.onmessage = function(e) {\n\
244+ \ var batch = JSON.parse(e.data);\n\
245+ \\n\
246+ \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));") <> "\
247+ \ };\n\
329248 \ };\n\
330− \ if(batch[1] && (initialSyncDepth || 0) === 0) {\n\
331− \ window.requestAnimationFrame(processBatch);\n\
332− \ }\n\
333− \ else {\n\
334− \ processBatch(window.performance ? window.performance.now() : null);\n\
335− \ }\n\
336− \ };\n\
337− \ runBatch(batch);\n\
249+ \ ws.onerror = function() {\n\
250+ \ setTimeout(connect, 1000);\n\
251+ \ };\n\
252+ \}\n\
253+ \\n\
254+ \ " <> ghcjsHelpers <> "\
255+ \connect();\n\
338256 \"
339257
340258ghcjsHelpers :: ByteString
@@ -405,58 +323,4 @@ ghcjsHelpers = "\
405323 \ }\n\
406324 \\n\
407325 \}\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\
462326 \"
jsaddle/src/Language/Javascript/JSaddle/Types.hs+47−262
@@ -1,20 +1,18 @@
11{-# LANGUAGE CPP #-}
22#ifdef ghcjs_HOST_OS
3+{-# LANGUAGE ConstraintKinds #-}
34{-# OPTIONS_GHC -Wno-dodgy-exports #-}
45#else
56{-# LANGUAGE TypeFamilies #-}
67{-# LANGUAGE UndecidableInstances #-}
78{-# LANGUAGE GeneralizedNewtypeDeriving #-}
89{-# LANGUAGE DeriveGeneric #-}
10+{-# LANGUAGE DefaultSignatures #-}
911{-# LANGUAGE DataKinds #-}
12+{-# LANGUAGE KindSignatures #-}
1013{-# LANGUAGE PolyKinds #-}
1114{-# LANGUAGE FlexibleContexts #-}
12−{-# LANGUAGE DefaultSignatures #-}
13−{-# LANGUAGE ImplicitParams #-}
1415#endif
15−{-# LANGUAGE ConstraintKinds #-}
16−{-# LANGUAGE KindSignatures #-}
17−{-# LANGUAGE AllowAmbiguousTypes #-}
1816-----------------------------------------------------------------------------
1917--
2018-- Module : Language.Javascript.JSaddle.Types
@@ -36,41 +34,18 @@ module Language.Javascript.JSaddle.Types (
3634 , MonadJSM(..)
3735 , liftJSM
3836
39− -- * Pure GHCJS functions
40− , GHCJSPure(..)
41− , ghcjsPure
42− , ghcjsPureMap
43− , ghcjsPureId
44−
4537 -- * JavaScript Value Types
4638 , JSVal(..)
47− , IsJSVal(..)
48− , jsval
4939 , SomeJSArray(..)
5040 , JSArray
5141 , MutableJSArray
52− , STJSArray
5342 , Object(..)
5443 , JSString(..)
5544 , Nullable(..)
5645 , JSCallAsFunction
5746
58− -- * Debugging
59− , JSadddleHasCallStack
60−
61− -- * Sync JSM
62− , syncPoint
63− , syncAfter
64−
65−#ifndef ghcjs_HOST_OS
66− , sendCommand
67−
6847 -- * JavaScript Context Commands
69− , MutabilityType(..)
70− , Mutable
71− , Immutable
72− , IsItMutable(..)
73− , Mutability
48+#ifndef ghcjs_HOST_OS
7449 , JSValueReceived(..)
7550 , JSValueForSend(..)
7651 , JSStringReceived(..)
@@ -80,8 +55,6 @@ module Language.Javascript.JSaddle.Types (
8055 , Command(..)
8156 , Batch(..)
8257 , Result(..)
83− , BatchResults(..)
84− , Results(..)
8558#endif
8659) where
8760
@@ -89,48 +62,26 @@ import Control.Monad.IO.Class (MonadIO(..))
8962#ifdef ghcjs_HOST_OS
9063import GHCJS.Types
9164import JavaScript.Object.Internal (Object(..))
92−import JavaScript.Array.Internal (SomeJSArray(..), JSArray, MutableJSArray, STJSArray)
65+import JavaScript.Array.Internal (SomeJSArray(..), JSArray, MutableJSArray)
9366import GHCJS.Nullable (Nullable(..))
9467#else
95−import GHCJS.Prim.Internal (JSVal(..), JSValueRef)
96−import Data.JSString.Internal.Type (JSString(..))
9768import Control.DeepSeq (NFData(..))
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(..))
69+import Control.Monad.Trans.Reader (ReaderT(..))
70+import Control.Monad.Trans.State.Lazy (StateT(..))
71+import qualified Control.Monad.Trans.State.Strict as Strict
72+ (StateT(..))
11273import Control.Monad.Trans.Class (MonadTrans(..))
11374import Control.Monad.Fix (MonadFix)
11475import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))
11576import Control.Concurrent.STM.TVar (TVar)
116−import Control.Concurrent.MVar (MVar)
77+import Data.Coerce (Coercible, coerce)
11778import Data.Int (Int64)
118−import Data.Set (Set)
11979import Data.Text (Text)
12080import Data.Time.Clock (UTCTime(..))
12181import Data.Typeable (Typeable)
122−import Data.Coerce (coerce, Coercible)
12382import Data.Aeson
12483 (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..), Value)
12584import 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)
13485#endif
13586
13687-- | Identifies a JavaScript execution context.
@@ -141,16 +92,12 @@ import GHC.Exts (Constraint)
14192type JSContextRef = ()
14293#else
14394data JSContextRef = JSContextRef {
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)
95+ startTime :: UTCTime
96+ , doSendCommand :: Command -> IO Result
97+ , doSendAsyncCommand :: AsyncCommand -> IO ()
98+ , addCallback :: Object -> JSCallAsFunction -> IO ()
99+ , freeCallback :: Object -> IO ()
100+ , nextRef :: TVar JSValueRef
154101}
155102#endif
156103
@@ -166,97 +113,9 @@ data JSContextRef = JSContextRef {
166113type JSM = IO
167114#else
168115newtype JSM a = JSM { unJSM :: ReaderT JSContextRef IO a }
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
116+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
211117#endif
212118
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
257−#endif
258−{-# INLINE ghcjsPureId #-}
259−
260119-- | The 'MonadJSM' is to 'JSM' what 'MonadIO' is to 'IO'.
261120-- When using GHCJS it is 'MonadIO'.
262121#ifdef ghcjs_HOST_OS
@@ -264,64 +123,21 @@ type MonadJSM = MonadIO
264123#else
265124class (Applicative m, MonadIO m) => MonadJSM m where
266125 liftJSM' :: JSM a -> m a
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' #-}
126+ {-# MINIMAL liftJSM' #-}
271127
272128instance MonadJSM JSM where
273129 liftJSM' = id
274130 {-# INLINE liftJSM' #-}
275131
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
132+instance MonadJSM m => MonadJSM (ReaderT e m) where
313133 liftJSM' = lift . liftJSM'
314134 {-# INLINE liftJSM' #-}
315135
316−instance (MonadJSM m) => MonadJSM (Strict.StateT s m) where
136+instance MonadJSM m => MonadJSM (StateT r m) where
317137 liftJSM' = lift . liftJSM'
318138 {-# INLINE liftJSM' #-}
319139
320−instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.WriterT w m) where
321− liftJSM' = lift . liftJSM'
322− {-# INLINE liftJSM' #-}
323−
324−instance (Monoid w, MonadJSM m) => MonadJSM (Strict.WriterT w m) where
140+instance MonadJSM m => MonadJSM (Strict.StateT r m) where
325141 liftJSM' = lift . liftJSM'
326142 {-# INLINE liftJSM' #-}
327143
@@ -356,15 +172,23 @@ type JSCallAsFunction = JSVal -- ^ Function object
356172 -- as an argument and invoke it from haskell.
357173
358174#ifndef ghcjs_HOST_OS
175+-- A reference to a particular JavaScript value inside the JavaScript context
176+type JSValueRef = Int64
177+
178+-- | See 'GHCJS.Prim.JSVal'
179+newtype JSVal = JSVal JSValueRef deriving(Show, ToJSON, FromJSON)
180+
181+instance NFData JSVal where
182+ rnf x = x `seq` ()
359183
360184class IsJSVal a where
361− jsval_ :: a -> GHCJSPure JSVal
185+ jsval_ :: a -> JSVal
362186
363− default jsval_ :: Coercible a JSVal => a -> GHCJSPure JSVal
364− jsval_ = GHCJSPure . return . coerce
187+ default jsval_ :: Coercible a JSVal => a -> JSVal
188+ jsval_ = coerce
365189 {-# INLINE jsval_ #-}
366190
367−jsval :: IsJSVal a => a -> GHCJSPure JSVal
191+jsval :: IsJSVal a => a -> JSVal
368192jsval = jsval_
369193{-# INLINE jsval #-}
370194
@@ -385,43 +209,38 @@ type family Mutability (a :: MutabilityType s) :: IsItMutable where
385209
386210newtype SomeJSArray (m :: MutabilityType s) = SomeJSArray JSVal
387211 deriving (Typeable)
388−instance IsJSVal (SomeJSArray m)
389212
390213-- | See 'JavaScript.Array.Internal.JSArray'
391214type JSArray = SomeJSArray Immutable
392215-- | See 'JavaScript.Array.Internal.MutableJSArray'
393216type MutableJSArray = SomeJSArray Mutable
394217
395−-- | See 'JavaScript.Array.Internal.STJSArray'
396−type STJSArray s = SomeJSArray (STMutable s)
397−
398218-- | See 'JavaScript.Object.Internal.Object'
399−newtype Object = Object JSVal
219+newtype Object = Object JSVal deriving(Show, ToJSON, FromJSON)
400220
401221-- | See 'GHCJS.Nullable.Nullable'
402222newtype Nullable a = Nullable a
403223
224+-- | See 'Data.JSString.Internal.Type'
225+newtype JSString = JSString Text deriving(Show, ToJSON, FromJSON)
226+
404227-- | Wrapper used when receiving a 'JSVal' from the JavaScript context
405228newtype JSValueReceived = JSValueReceived JSValueRef deriving(Show, ToJSON, FromJSON)
406229
407230-- | Wrapper used when sending a 'JSVal' to the JavaScript context
408−newtype JSValueForSend = JSValueForSend JSValueRef deriving(Show, ToJSON, FromJSON, Generic)
409−instance NFData JSValueForSend
231+newtype JSValueForSend = JSValueForSend JSValueRef deriving(Show, ToJSON, FromJSON)
410232
411233-- | Wrapper used when sending a 'Object' to the JavaScript context
412−newtype JSObjectForSend = JSObjectForSend JSValueForSend deriving(Show, ToJSON, FromJSON, Generic)
413−instance NFData JSObjectForSend
234+newtype JSObjectForSend = JSObjectForSend JSValueForSend deriving(Show, ToJSON, FromJSON)
414235
415236-- | Wrapper used when receiving a 'JSString' from the JavaScript context
416237newtype JSStringReceived = JSStringReceived Text deriving(Show, ToJSON, FromJSON)
417238
418239-- | Wrapper used when sending a 'JString' to the JavaScript context
419−newtype JSStringForSend = JSStringForSend Text deriving(Show, ToJSON, FromJSON, Generic)
420−instance NFData JSStringForSend
240+newtype JSStringForSend = JSStringForSend Text deriving(Show, ToJSON, FromJSON)
421241
422242-- | Command sent to a JavaScript context for execution asynchronously
423−data AsyncCommand = FreeRef Text JSValueForSend
424− | FreeRefs Text
243+data AsyncCommand = FreeRef JSValueForSend
425244 | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend
426245 | SetPropertyAtIndex JSObjectForSend Int JSValueForSend
427246 | StringToValue JSStringForSend JSValueForSend
@@ -432,23 +251,17 @@ data AsyncCommand = FreeRef Text JSValueForSend
432251 | CallAsFunction JSObjectForSend JSObjectForSend [JSValueForSend] JSValueForSend
433252 | CallAsConstructor JSObjectForSend [JSValueForSend] JSValueForSend
434253 | NewEmptyObject JSValueForSend
435− | NewAsyncCallback JSValueForSend
436− | NewSyncCallback JSValueForSend
437− | FreeCallback JSValueForSend
254+ | NewCallback JSValueForSend
438255 | NewArray [JSValueForSend] JSValueForSend
439256 | EvaluateScript JSStringForSend JSValueForSend
440257 | SyncWithAnimationFrame JSValueForSend
441− | StartSyncBlock
442− | EndSyncBlock
443− deriving (Show, Generic)
258+ deriving (Show, Generic)
444259
445260instance ToJSON AsyncCommand where
446261 toEncoding = genericToEncoding defaultOptions
447262
448263instance FromJSON AsyncCommand
449264
450−instance NFData AsyncCommand
451−
452265-- | Command sent to a JavaScript context for execution synchronously
453266data Command = DeRefVal JSValueForSend
454267 | ValueToBool JSValueForSend
@@ -469,10 +282,8 @@ instance ToJSON Command where
469282
470283instance FromJSON Command
471284
472−instance NFData Command
473−
474285-- | Batch of commands that can be sent together to the JavaScript context
475−data Batch = Batch [Either AsyncCommand Command] Bool Int
286+data Batch = Batch [AsyncCommand] Command Bool
476287 deriving (Show, Generic)
477288
478289instance ToJSON Batch where
@@ -480,8 +291,6 @@ instance ToJSON Batch where
480291
481292instance FromJSON Batch
482293
483−instance NFData Batch
484−
485294-- | Result of a 'Command' returned from the JavaScript context
486295data Result = DeRefValResult JSValueRef Text
487296 | ValueToBoolResult Bool
@@ -493,42 +302,18 @@ data Result = DeRefValResult JSValueRef Text
493302 | IsUndefinedResult Bool
494303 | StrictEqualResult Bool
495304 | InstanceOfResult Bool
305+ | Callback JSValueReceived JSValueReceived [JSValueReceived]
496306 | PropertyNamesResult [JSStringReceived]
497307 | ThrowJSValue JSValueReceived
308+ | ProtocolError Text
498309 | SyncResult
499− deriving (Show, Generic)
310+ deriving (Show, Generic)
500311
501312instance ToJSON Result where
502313 toEncoding = genericToEncoding defaultOptions
503314
504315instance FromJSON Result
505−
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]
518− | ProtocolError Text
519− deriving (Show, Generic)
520−
521−instance ToJSON Results where
522− toEncoding = genericToEncoding defaultOptions
523−
524−instance FromJSON Results
525316#endif
526317
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
533318
534319
jsaddle/src/Language/Javascript/JSaddle/Value.hs+87−57
@@ -45,7 +45,7 @@ module Language.Javascript.JSaddle.Value (
4545 , showJSValue
4646
4747 -- * Converting JavaScript values
48− , isTruthy
48+ , isTruthyIO
4949 , valToBool
5050 , valToNumber
5151 , valToStr
@@ -57,11 +57,11 @@ module Language.Javascript.JSaddle.Value (
5757 , val
5858 , jsNull
5959 , valNull
60− , isNull
60+ , isNullIO
6161 , valIsNull
6262 , jsUndefined
6363 , valUndefined
64− , isUndefined
64+ , isUndefinedIO
6565 , valIsUndefined
6666 , maybeNullOrUndefined
6767 , maybeNullOrUndefined'
@@ -84,31 +84,32 @@ 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)
8887
8988#ifdef ghcjs_HOST_OS
9089import Language.Javascript.JSaddle.Types
91− (Object(..), JSString(..), JSVal(..), ghcjsPure)
90+ (Object(..), JSString(..), JSVal(..))
9291import GHCJS.Marshal (ToJSVal(..))
92+import GHCJS.Marshal.Pure (pToJSVal)
93+import Data.JSString.Text (textToJSString)
9394#else
9495import Data.Char (chr, ord)
9596import Data.Word (Word, Word8, Word16, Word32)
9697import Data.Int (Int8, Int16, Int32)
9798import GHCJS.Marshal.Internal (ToJSVal(..), FromJSVal(..))
9899import Language.Javascript.JSaddle.Types
99− (Object(..), JSString(..), JSVal(..), ghcjsPure)
100+ (Object(..), JSString(..), JSVal(..), JSValueForSend(..))
100101import Language.Javascript.JSaddle.Native
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(..))
102+ (wrapJSString, withJSVal, withObject, withJSString, withToJSVal)
103+import Language.Javascript.JSaddle.Run
104+ (Command(..), AsyncCommand(..), Result(..), sendCommand,
105+ sendLazyCommand)
105106#endif
106107import Language.Javascript.JSaddle.Monad (JSM)
107108import Language.Javascript.JSaddle.Classes
108109 (MakeObject(..), MakeArgs(..))
109110import Language.Javascript.JSaddle.Marshal.String (ToJSString(..), FromJSString(..))
110111import Language.Javascript.JSaddle.String (strToText, textToStr)
111−import GHCJS.Foreign.Internal (jsTrue, jsFalse, jsNull, toJSBool, jsUndefined, isTruthy, isNull, isUndefined)
112+import Language.Javascript.JSaddle.Foreign (jsTrue, jsFalse, jsNull, toJSBool, jsUndefined, isTruthyIO, isNullIO, isUndefinedIO)
112113
113114-- $setup
114115-- >>> import Language.Javascript.JSaddle.Test (testJSaddle)
@@ -165,7 +166,7 @@ showJSValue (ValObject _) = "object"
165166-- >>> testJSaddle $ valToBool "1"
166167-- true
167168valToBool :: ToJSVal value => value -> JSM Bool
168−valToBool value = toJSVal value >>= ghcjsPure . isTruthy
169+valToBool value = toJSVal value >>= isTruthyIO
169170
170171-- | Given a JavaScript value get its numeric value.
171172-- May throw JSException.
@@ -191,7 +192,10 @@ valToNumber :: ToJSVal value => value -> JSM Double
191192valToNumber value = jsrefToNumber <$> toJSVal value
192193foreign import javascript unsafe "$r = Number($1);" jsrefToNumber :: JSVal -> Double
193194#else
194−valToNumber value = toJSVal value >>= valueToNumber
195+valToNumber value =
196+ withToJSVal value $ \rval -> do
197+ ValueToNumberResult result <- sendCommand (ValueToNumber rval)
198+ return result
195199#endif
196200
197201-- | Given a JavaScript value get its string value (as a JavaScript string).
@@ -218,7 +222,10 @@ valToStr :: ToJSVal value => value -> JSM JSString
218222valToStr value = jsrefToString <$> toJSVal value
219223foreign import javascript unsafe "$r = $1.toString();" jsrefToString :: JSVal -> JSString
220224#else
221−valToStr value = toJSVal value >>= valueToString
225+valToStr value =
226+ withToJSVal value $ \rval -> do
227+ ValueToStringResult result <- sendCommand (ValueToString rval)
228+ wrapJSString result
222229#endif
223230
224231-- | Given a JavaScript value get its string value (as a Haskell 'Text').
@@ -269,7 +276,10 @@ valToJSON :: ToJSVal value => value -> JSM JSString
269276valToJSON value = jsrefToJSON <$> toJSVal value
270277foreign import javascript unsafe "$r = $1 === undefined ? \"\" : JSON.stringify($1);" jsrefToJSON :: JSVal -> JSString
271278#else
272−valToJSON value = toJSVal value >>= valueToJSON
279+valToJSON value =
280+ withToJSVal value $ \rval -> do
281+ ValueToJSONResult result <- sendCommand (ValueToJSON rval)
282+ wrapJSString result
273283#endif
274284
275285-- | Given a JavaScript value get its object value.
@@ -295,7 +305,7 @@ valToObject :: ToJSVal value => value -> JSM Object
295305valToObject value = Object <$> toJSVal value
296306
297307instance MakeObject JSVal where
298− makeObject = return . Object
308+ makeObject = valToObject
299309
300310instance ToJSVal Object where
301311 toJSVal (Object r) = return r
@@ -346,16 +356,16 @@ instance ToJSVal a => ToJSVal (Maybe a) where
346356 {-# INLINE toJSVal #-}
347357instance FromJSVal a => FromJSVal (Maybe a) where
348358 fromJSValUnchecked x =
349− ghcjsPure (isUndefined x) >>= \case
359+ isUndefinedIO x >>= \case
350360 True -> return Nothing
351− False -> ghcjsPure (isNull x) >>= \case
361+ False -> isNullIO x >>= \case
352362 True -> return Nothing
353363 False -> fromJSVal x
354364 {-# INLINE fromJSValUnchecked #-}
355365 fromJSVal x =
356− ghcjsPure (isUndefined x) >>= \case
366+ isUndefinedIO x >>= \case
357367 True -> return (Just Nothing)
358− False -> ghcjsPure (isNull x) >>= \case
368+ False -> isNullIO x >>= \case
359369 True -> return (Just Nothing)
360370 False -> fmap (fmap Just) fromJSVal x
361371 {-# INLINE fromJSVal #-}
@@ -372,7 +382,7 @@ instance FromJSVal a => FromJSVal [a] where
372382
373383-- | Test a JavaScript value to see if it is @null@
374384valIsNull :: ToJSVal value => value -> JSM Bool
375−valIsNull value = toJSVal value >>= ghcjsPure . isNull
385+valIsNull value = toJSVal value >>= isNullIO
376386
377387----------- undefined ---------------
378388-- | An @undefined@ JavaScript value
@@ -395,26 +405,26 @@ instance MakeArgs () where
395405
396406-- | Test a JavaScript value to see if it is @undefined@
397407valIsUndefined :: ToJSVal value => value -> JSM Bool
398−valIsUndefined value = toJSVal value >>= ghcjsPure . isUndefined
408+valIsUndefined value = toJSVal value >>= isUndefinedIO
399409
400410-- | Convert a JSVal to a Maybe JSVal (converting null and undefined to Nothing)
401411maybeNullOrUndefined :: ToJSVal value => value -> JSM (Maybe JSVal)
402412maybeNullOrUndefined value = do
403413 rval <- toJSVal value
404− ghcjsPure (isNull rval) >>= \case
414+ valIsNull rval >>= \case
405415 True -> return Nothing
406416 _ ->
407− ghcjsPure (isUndefined rval) >>= \case
417+ valIsUndefined rval >>= \case
408418 True -> return Nothing
409419 _ -> return (Just rval)
410420
411421maybeNullOrUndefined' :: ToJSVal value => (JSVal -> JSM a) -> value -> JSM (Maybe a)
412422maybeNullOrUndefined' f value = do
413423 rval <- toJSVal value
414− ghcjsPure (isNull rval) >>= \case
424+ valIsNull rval >>= \case
415425 True -> return Nothing
416426 _ ->
417− ghcjsPure (isUndefined rval) >>= \case
427+ valIsUndefined rval >>= \case
418428 True -> return Nothing
419429 _ -> Just <$> f rval
420430
@@ -438,49 +448,52 @@ instance MakeArgs Bool where
438448----------- numbers ---------------
439449-- | Make a JavaScript number
440450valMakeNumber :: Double -> JSM JSVal
441−valMakeNumber = toJSVal
442−{-# INLINE valMakeNumber #-}
451+#ifdef ghcjs_HOST_OS
452+valMakeNumber n = toJSVal n
453+#else
454+valMakeNumber = sendLazyCommand . NumberToValue
455+#endif
443456
444457#ifndef ghcjs_HOST_OS
445458-- | Makes a JavaScript number
446459instance ToJSVal Double where
447− toJSVal = numberToValue
460+ toJSVal = valMakeNumber
448461 {-# INLINE toJSVal #-}
449462
450463instance ToJSVal Float where
451− toJSVal = numberToValue . realToFrac
464+ toJSVal = valMakeNumber . realToFrac
452465 {-# INLINE toJSVal #-}
453466
454467instance ToJSVal Word where
455− toJSVal = numberToValue . fromIntegral
468+ toJSVal = valMakeNumber . fromIntegral
456469 {-# INLINE toJSVal #-}
457470
458471instance ToJSVal Word8 where
459− toJSVal = numberToValue . fromIntegral
472+ toJSVal = valMakeNumber . fromIntegral
460473 {-# INLINE toJSVal #-}
461474
462475instance ToJSVal Word16 where
463− toJSVal = numberToValue . fromIntegral
476+ toJSVal = valMakeNumber . fromIntegral
464477 {-# INLINE toJSVal #-}
465478
466479instance ToJSVal Word32 where
467− toJSVal = numberToValue . fromIntegral
480+ toJSVal = valMakeNumber . fromIntegral
468481 {-# INLINE toJSVal #-}
469482
470483instance ToJSVal Int where
471− toJSVal = numberToValue . fromIntegral
484+ toJSVal = valMakeNumber . fromIntegral
472485 {-# INLINE toJSVal #-}
473486
474487instance ToJSVal Int8 where
475− toJSVal = numberToValue . fromIntegral
488+ toJSVal = valMakeNumber . fromIntegral
476489 {-# INLINE toJSVal #-}
477490
478491instance ToJSVal Int16 where
479− toJSVal = numberToValue . fromIntegral
492+ toJSVal = valMakeNumber . fromIntegral
480493 {-# INLINE toJSVal #-}
481494
482495instance ToJSVal Int32 where
483− toJSVal = numberToValue . fromIntegral
496+ toJSVal = valMakeNumber . fromIntegral
484497 {-# INLINE toJSVal #-}
485498#endif
486499
@@ -490,18 +503,25 @@ instance MakeArgs Double where
490503
491504-- | Make a JavaScript string from `Text`
492505valMakeText :: Text -> JSM JSVal
493−valMakeText = toJSVal . textToJSString
494−{-# INLINE valMakeText #-}
506+#ifdef ghcjs_HOST_OS
507+valMakeText = return . pToJSVal . textToJSString
508+#else
509+valMakeText text = valMakeString (textToStr text)
510+#endif
495511
496512-- | Make a JavaScript string from `JSString`
497513valMakeString :: JSString -> JSM JSVal
498−valMakeString = toJSVal
499−{-# INLINE valMakeString #-}
514+#ifdef ghcjs_HOST_OS
515+valMakeString = return . pToJSVal
516+#else
517+valMakeString s =
518+ withJSString s $ sendLazyCommand . StringToValue
519+#endif
500520
501521#ifndef ghcjs_HOST_OS
502522-- | Makes a JavaScript string
503523instance ToJSVal Text where
504− toJSVal = stringToValue . JSString
524+ toJSVal = valMakeText
505525 {-# INLINE toJSVal #-}
506526instance FromJSVal Text where
507527 fromJSValUnchecked = valToText
@@ -517,7 +537,7 @@ instance MakeArgs Text where
517537#ifndef ghcjs_HOST_OS
518538-- | Makes a JavaScript string
519539instance ToJSVal JSString where
520− toJSVal = stringToValue
540+ toJSVal = valMakeString
521541 {-# INLINE toJSVal #-}
522542instance FromJSVal JSString where
523543 fromJSValUnchecked = valToStr
@@ -564,12 +584,16 @@ instance FromJSVal Char where
564584
565585-- | Make a JavaScript string from AESON `Value`
566586valMakeJSON :: Value -> JSM JSVal
587+#ifdef ghcjs_HOST_OS
567588valMakeJSON = toJSVal
589+#else
590+valMakeJSON = sendLazyCommand . JSONValueToValue
591+#endif
568592
569593#ifndef ghcjs_HOST_OS
570594-- | Makes a JSON value
571595instance ToJSVal Value where
572− toJSVal = jsonValueToValue
596+ toJSVal = valMakeJSON
573597 {-# INLINE toJSVal #-}
574598#endif
575599
@@ -620,16 +644,16 @@ foreign import javascript unsafe "$r = ($1 === undefined)?0:\
620644#else
621645deRefVal value = do
622646 v <- toJSVal 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"
647+ withJSVal v $ \rval ->
648+ sendCommand (DeRefVal rval) >>= \case
649+ DeRefValResult 0 _ -> return ValNull
650+ DeRefValResult 1 _ -> return ValUndefined
651+ DeRefValResult 2 _ -> return $ ValBool False
652+ DeRefValResult 3 _ -> return $ ValBool True
653+ DeRefValResult (-1) s -> return $ ValNumber (read (T.unpack s))
654+ DeRefValResult (-2) s -> return $ ValString s
655+ DeRefValResult ref _ -> return $ ValObject (Object (JSVal ref))
656+ _ -> error "Unexpected result dereferencing JSaddle value"
633657#endif
634658
635659-- | Make a JavaScript value out of a 'JSValue' ADT.
@@ -688,7 +712,10 @@ strictEqual a b = do
688712#ifdef ghcjs_HOST_OS
689713 return $ jsvalueisstrictequal aval bval
690714#else
691− N.strictEqual aval bval
715+ withJSVal aval $ \aref ->
716+ withJSVal bval $ \bref -> do
717+ StrictEqualResult result <- sendCommand $ StrictEqual aref bref
718+ return result
692719#endif
693720
694721#ifdef ghcjs_HOST_OS
@@ -706,7 +733,10 @@ instanceOf value constructor = do
706733#ifdef ghcjs_HOST_OS
707734 return $ js_isInstanceOf v c
708735#else
709− N.instanceOf v c
736+ withJSVal v $ \rval ->
737+ withObject c $ \c' -> do
738+ InstanceOfResult result <- sendCommand $ InstanceOf rval c'
739+ return result
710740#endif
711741
712742
nix/hix.nixdeleted−8
@@ -1,8 +0,0 @@
1−{pkgs, ...}:
2−{ modules = [({pkgs, ...}: {
3− packages.webkit2gtk3-javascriptcore.components.library.doHaddock = false;
4− })];
5− shell.buildInputs = [ pkgs.nodejs ];
6− shell.tools.cabal = {};
7− shell.crossPlatforms = p: [ p.ghcjs ];
8−}
travis/build.sh+13−2
@@ -6,8 +6,19 @@ 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+
915cabal update
1016cabal new-build 'jsaddle-warp:lib:jsaddle-warp' 'jsaddle-warp:test:test-tool'
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
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 ./
1324
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 phantomjs
7+ apt-get -y install happy-1.19.5 alex-3.1.7 nodejs npm
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 phantomjs
7+ apt-get -y install happy-1.19.5 alex-3.1.7 nodejs npm
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 phantomjs
7+ apt-get -y install happy-1.19.5 alex-3.1.7 nodejs npm
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 phantomjs
7+ apt-get -y install happy-1.19.5 alex-3.1.7 nodejs npm
88
99RUN mkdir /build
1010WORKDIR /build