on master help sign in
.travis.yml+40−22
since splitsnapshots
unifiedsplit
@@ -1,29 +1,47 @@
1−sudo: required
1+language: nix
2−services:
2+nix: 2.2.2
3− - docker
4
3
5−cache:
4+jobs:
6− directories:
5+ include:
7− - .cabal
6+ - stage: Build
8− - .ghc
7+ env: OS=linux GHCVER=ghc865
8+ - stage: Build
9+ env: OS=linux GHCVER=ghc881
10+ - env: OS=macos GHCVER=ghc865
11+ os: osx
12+ # Fix OSX, see https://travis-ci.community/t/cannot-use-nix-support-on-osx/2927
13+ language: generic
14+ before_install:
15+ - curl https://nixos.org/nix/install | sh
16+ - source /Users/travis/.nix-profile/etc/profile.d/nix.sh
17+ - env: OS=macos GHCVER=ghc881
18+ os: osx
19+ # Fix OSX, see https://travis-ci.community/t/cannot-use-nix-support-on-osx/2927
20+ language: generic
21+ before_install:
22+ - curl https://nixos.org/nix/install | sh
23+ - source /Users/travis/.nix-profile/etc/profile.d/nix.sh
9
24
10−env:
25+install:
11−# - CABALVER=1.24 GHCVER=7.10.3 OSVER=xenial
26+- sudo mkdir -p /etc/nix
12− - CABALVER=1.24 GHCVER=8.0.1 OSVER=xenial
27+- echo "substituters = https://cache.nixos.org https://hydra.iohk.io" | sudo tee -a /etc/nix/nix.conf > /dev/null
13− - CABALVER=1.24 GHCVER=7.10.3 OSVER=trusty
28+- echo "trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=" | sudo tee -a /etc/nix/nix.conf > /dev/null
14− - CABALVER=1.24 GHCVER=8.0.1 OSVER=trusty
15−
16−before_install:
17− - docker build -t ghc -f travis/$OSVER.Dockerfile travis
18
29
19script:
30script:
20− - docker run -v `pwd`:/build ghc
31+- nix-build --argstr haskellCompiler $GHCVER -A hsPkgs.jsaddle.components.library
21− sh -x -c "
32+- nix-build --argstr haskellCompiler $GHCVER -A hsPkgs.jsaddle-warp.components.library
22− apt-get install -y cabal-install-$CABALVER ghc-$GHCVER &&
33+- nix-build --argstr haskellCompiler $GHCVER -A hsPkgs.jsaddle-clib.components.library
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 &&
34+- |
24− ./travis/build.sh"
35+ if [ "$OS" == "macos" ]; then
36+ nix-build --argstr haskellCompiler $GHCVER -A hsPkgs.jsaddle-wkwebview.components.library
37+ fi
38+# TODO try to find how to get working webkitgtk with nix on macOS
39+- |
40+ if [ "$OS" != "macos" ]; then
41+ nix-build --argstr haskellCompiler $GHCVER -A hsPkgs.jsaddle-webkit2gtk.components.library
42+ fi
43+
25notifications:
44notifications:
26 irc:
45 irc:
27 channels: "irc.freenode.net#ghcjs"
46 channels: "irc.freenode.net#ghcjs"
28− skip_join: true
29− email: true
47+ email: true
README.md+34−14
@@ -13,7 +13,8 @@ import Control.Monad.IO.Class (MonadIO(..))
13import Control.Concurrent.MVar (takeMVar, putMVar, newEmptyMVar)
13import Control.Concurrent.MVar (takeMVar, putMVar, newEmptyMVar)
14import Control.Lens ((^.))
14import Control.Lens ((^.))
15import Language.Javascript.JSaddle
15import Language.Javascript.JSaddle
16− (run, jsg, js, js1, jss, fun, valToNumber, syncPoint)
16+ (jsg, js, js1, jss, fun, valToNumber, syncPoint)
17+import Language.Javascript.JSaddle.Warp (run)
17
18
18main = run 3709 $ do
19main = run 3709 $ do
19 doc <- jsg "document"
20 doc <- jsg "document"
@@ -79,7 +80,7 @@ main = run 3708 $ do
79 appendChild newParagraph text
80 appendChild newParagraph text
80 appendChild body (Just newParagraph)
81 appendChild body (Just newParagraph)
81 return ()
82 return ()
82−
83+
83 -- Make an exit button
84 -- Make an exit button
84 exitMVar <- liftIO newEmptyMVar
85 exitMVar <- liftIO newEmptyMVar
85 Just exit <- createElement doc (Just "span")
86 Just exit <- createElement doc (Just "span")
@@ -102,15 +103,31 @@ When compiled with GHC this code will run a Warp web server you can connect to a
102
103
103## How does it work on GHC
104## How does it work on GHC
104
105
105−As of version 0.5 it runs a small warp server that provides [index.html](https://github.com/ghcjs/jsaddle/blob/master/data/index.html) and
106+There are a number of different JSaddle runners to choose from
106−[jsaddle.js](https://github.com/ghcjs/jsaddle/blob/master/data/jsaddle.js). The [jsaddle.js](https://github.com/ghcjs/jsaddle/blob/master/data/jsaddle.js) code connects to the server using WebSockets and processes JSON commands from the server and sends the result back over the same WebSocket.
107+
108+* [jsaddle-warp](https://hackage.haskell.org/package/jsaddle-warp) - runs JSaddle in a warp server with a web browser connected to it.
109+* [jsaddle-webkit2gtk](https://hackage.haskell.org/package/jsaddle-webkit2gtk) - runs JSaddle in a WebKitGTK window.
110+* [jsaddle-wkwebview](https://hackage.haskell.org/package/jsaddle-wkwebview) - runs JSaddle in a WKWebView on iOS or macOS.
111+* [jsaddle-clib](https://hackage.haskell.org/package/jsaddle-clib) - C interface used to run JSaddle on Android using JNI.
112+
113+In all of these cases a web control or browser of some sort is used. An
114+[HTML file](./jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs#L24)
115+and a [small JavaScript command interpreter](./jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs#L340)
116+are loaded into it. Then the native GHC compiled JSaddle code runs. In order to interact with the browser
117+it sends commands to the JavaScript command interpreter. The mechanism for sending the commands differs
118+for the different runners, but they are always combined into batches and encoded in JSON.
107
119
108−### Why use WebSockets?
120+Haskell callbacks from JavaScript are supported by sending JSON back from the command interpreter. These can be synchronous (blocking the
121+JavaScript thread until the Haskell callback completes) or asynchronous.
109
122
123+### Why use a JavaScript command interpreter?
124+
125+Older versions of JSaddle relied on the WebKit1 interface to WebKitGTK and JavaScriptCore that is only supported in older versions of
110−Older versions relied on WebKitGTK and JavaScriptCore, but in WekKit2 the interface JSaddle used is only available to WebKit Extensions
126+WebKitGTK. With the newer WebKit2 interface this level of access is only available to WebKit Extensions.
111−so most of the benefits of this interface are lost (extensions are not in the same process as Gtk and RPC would have been needed).
112−The general advice for people migrating from WebKit1 to WebKit2 seems to be to use JavaScript. There is an interface in WebKit2
127+The general advice for people migrating from WebKit1 to WebKit2 seems to be to use JavaScript.
113−to send JavaScript code from the host application, but it does not seem to provide any advantages over the WebSockets approach.
128+
129+As a bonus we have been able to support a number of different platforms with the JavaScript command interpreter and it should
130+be easy to support more in the future.
114
131
115### JSVal
132### JSVal
116
133
@@ -120,8 +137,8 @@ The first five keys `[0..4]` are
120these values. Both the Haskell code and `jsaddle.js` can allocate new `JSVal` keys. The Haskell code allocates negative
137these values. Both the Haskell code and `jsaddle.js` can allocate new `JSVal` keys. The Haskell code allocates negative
121keys and `jsaddle.js` allocates positive keys to avoid clashing.
138keys and `jsaddle.js` allocates positive keys to avoid clashing.
122
139
123−The haskell code will not know the value of the to go with the key, but it will include it in commands to the server
140+The haskell code will not know the value to go with the key, but it will include it in commands to the server
124−that are sort of "hey call this function and and put the result in the map with this key"). This allows for the
141+that are sort of "hey call this function and put the result in the map with this key"). This allows for the
125lazy execution of the JSaddle code.
142lazy execution of the JSaddle code.
126
143
127A finalizer is added on the Haskell code and an asynchronous `FreeJSVal` command is automatically sent to `jsaddle.js`
144A finalizer is added on the Haskell code and an asynchronous `FreeJSVal` command is automatically sent to `jsaddle.js`
@@ -129,7 +146,7 @@ when the JSVal is no longer reachable. The `jsaddle.js` code then deletes the k
129
146
130### JSStrings
147### JSStrings
131
148
132−These are haskell `Text` type and so reside on the native side of the WebSocket. If you want to make avoid transferring large string values over the WebSocket use `toJSVal` to conevt it to a `JSVal`.
149+These are haskell `Text` type and so reside on the native side of the WebSocket. If you want to avoid transferring large string values over the WebSocket use `toJSVal` to convert it to a `JSVal`.
133
150
134### Lazy Execution
151### Lazy Execution
135
152
@@ -161,7 +178,7 @@ force all the pending asynchronous commands to be executed.
161It uses a handful of JS FFI calls to execute JavaScript functions indirectly. This indirection will be small compared to the overhead of the WebSockets approach (used when JSaddle is compiled with GHC), but it will be significant compared to hand crafted JS FFI calls.
178It uses a handful of JS FFI calls to execute JavaScript functions indirectly. This indirection will be small compared to the overhead of the WebSockets approach (used when JSaddle is compiled with GHC), but it will be significant compared to hand crafted JS FFI calls.
162
179
163For the best performance you may want to write both JS FFI and JSaddle wrappers
180For the best performance you may want to write both JS FFI and JSaddle wrappers
164−For your JavaScript code. This is the approach taken by recent versions of `ghcjs-dom`.
181+for your JavaScript code. This is the approach taken by `ghcjs-dom`.
165
182
166For instance here is `getElementById` from the `ghcjs-dom-jsffi` (used by `ghcjs-dom` when compiled with GHCJS)
183For instance here is `getElementById` from the `ghcjs-dom-jsffi` (used by `ghcjs-dom` when compiled with GHCJS)
167
184
@@ -196,7 +213,10 @@ JSaddle does not support exceptions well. When compiled with GHCJS an exception
196at the point the exception is thrown.
213at the point the exception is thrown.
197
214
198When using GHC the Haskell executions will probably continue for a while before the exception is received at all by the Haskell code
215When using GHC the Haskell executions will probably continue for a while before the exception is received at all by the Haskell code
199−(because the lazy execution of the JS code). The exception will be thrown when the the next synchronous command is executed.
216+(because the lazy execution of the JS code). The exception will be thrown when the next synchronous command is executed.
200When it reaches the synchronous command a haskell type JSException will be thrown (this may not be the thread that initiated the
217When it reaches the synchronous command a haskell type JSException will be thrown (this may not be the thread that initiated the
201command that caused the exception). You can use `syncPoint` and `syncAfter` to force the exception to be thrown.
218command that caused the exception). You can use `syncPoint` and `syncAfter` to force the exception to be thrown.
202There are `JSM` versions of `catch` and `bracket` that also include a `syncPoint` call.
219There are `JSM` versions of `catch` and `bracket` that also include a `syncPoint` call.
220+
221+## Building with Stack
222+The `jsaddle-webkit2gtk` runner can be difficult to build with stack. See [this issue](https://github.com/ghcjs/jsaddle/issues/38#issuecomment-331392995) if you get stuck.
cabal.project+5−34
@@ -1,39 +1,10 @@
1−flags: -overloaded-methods -overloaded-signals -overloaded-properties
2−
3packages:
1packages:
4 jsaddle/
2 jsaddle/
5 jsaddle-warp/
3 jsaddle-warp/
6 jsaddle-wkwebview/
4 jsaddle-wkwebview/
5+ jsaddle-webkit2gtk/
6+ jsaddle-clib/
7+
8+constraints: haskell-gi-overloading == 0.0
7
9
8−package gi-atk
10+allow-newer: websockets:random, splitmix:time, *:time, *:unix, *:process, stm:base
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/LICENSEnew file+21
@@ -0,0 +1,21 @@
1+Copyright (c) 2010-2012 Hamish Mackenzie, Victor Nazarov, Luite Stegeman
2+
3+Permission is hereby granted, free of charge, to any person obtaining
4+a copy of this software and associated documentation files (the
5+"Software"), to deal in the Software without restriction, including
6+without limitation the rights to use, copy, modify, merge, publish,
7+distribute, sublicense, and/or sell copies of the Software, and to
8+permit persons to whom the Software is furnished to do so, subject to
9+the following conditions:
10+
11+The above copyright notice and this permission notice shall be
12+included in all copies or substantial portions of the Software.
13+
14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
17+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
18+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
19+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
20+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21+
jsaddle-clib/Setup.lhsnew file+6
@@ -0,0 +1,6 @@
1+#!/usr/bin/runhaskell
2+> module Main where
3+> import Distribution.Simple
4+> main :: IO ()
5+> main = defaultMain
6+
jsaddle-clib/cbits/include/jsaddle.hnew file+24
@@ -0,0 +1,24 @@
1+#ifndef JSADDLE_H
2+#define JSADDLE_H
3+
4+typedef struct native_callbacks {
5+ void (* jsaddleStart) ();
6+ void (* jsaddleResult) (char *);
7+ char * (* jsaddleSyncResult) (char *);
8+ char * jsaddleJsData;
9+ char * jsaddleHtmlData;
10+} native_callbacks;
11+
12+typedef struct app_callbacks {
13+ void (* mainActivity_onCreate) ();
14+ void (* mainActivity_onStart) ();
15+ void (* mainActivity_onResume) ();
16+ void (* mainActivity_onPause) ();
17+ void (* mainActivity_onStop) ();
18+ void (* mainActivity_onDestroy) ();
19+ void (* mainActivity_onRestart) ();
20+ void (* mainActivity_onNewIntent) (char *, char *);
21+ void (* firebaseInstanceIdService_sendRegistrationToServer) (char *);
22+} app_callbacks;
23+
24+#endif
jsaddle-clib/jsaddle-clib.cabalnew file+40
@@ -0,0 +1,40 @@
1+name: jsaddle-clib
2+version: 0.9.8.0
3+cabal-version: >=1.10
4+build-type: Simple
5+license: MIT
6+license-file: LICENSE
7+maintainer: Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
8+synopsis: Interface for JavaScript that works with GHCJS and GHC
9+description:
10+ This package provides an EDSL for calling JavaScript that
11+ can be used both from GHCJS and GHC.
12+category: Web, Javascript
13+author: Hamish Mackenzie
14+
15+source-repository head
16+ type: git
17+ location: https://github.com/ghcjs/jsaddle
18+
19+library
20+ exposed-modules:
21+ Language.Javascript.JSaddle.CLib
22+ Language.Javascript.JSaddle.CLib.Internal
23+ build-depends:
24+ aeson >=0.8.0.2 && <1.6,
25+ base <5,
26+ base-compat >=0.9.0 && <0.12,
27+ bytestring >=0.10.6.0 && <0.11,
28+ jsaddle >= 0.9.0.0 && <0.10,
29+ data-default,
30+ text
31+ default-language: Haskell2010
32+ hs-source-dirs: src
33+ Include-dirs: cbits/include
34+ Includes: jsaddle.h
35+ Install-includes: jsaddle.h
36+ ghc-options: -ferror-spans -Wall
37+ if impl(ghcjs)
38+ hs-source-dirs: src-ghcjs
39+ else
40+ hs-source-dirs: src-ghc
jsaddle-clib/src-ghc/Language/Javascript/JSaddle/CLib.hsnew file+157
@@ -0,0 +1,157 @@
1+{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}
2+module Language.Javascript.JSaddle.CLib
3+ ( jsaddleInit
4+ , NativeCallbacks (..)
5+ , AppCallbacks (..)
6+ , AppConfig (..)
7+ , pokeAppConfig
8+ , appConfigToAppCallbacks
9+ ) where
10+
11+import Prelude ()
12+import Prelude.Compat
13+
14+import Control.Monad (void)
15+import Control.Concurrent (forkIO)
16+
17+import Data.Aeson (encode, decode)
18+import Data.ByteString (useAsCString, packCString)
19+import Data.ByteString.Char8 (unpack)
20+import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)
21+import Data.Default (def, Default)
22+import Data.Text (Text)
23+import qualified Data.Text.Encoding as T
24+
25+import Foreign.C.String (CString, newCString)
26+import Foreign.Ptr (FunPtr, Ptr)
27+import Foreign.Storable (poke)
28+import Foreign.Marshal.Utils (new)
29+
30+import Language.Javascript.JSaddle (JSM)
31+import Language.Javascript.JSaddle.Run (runJavaScript)
32+import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
33+
34+import Language.Javascript.JSaddle.CLib.Internal
35+
36+foreign import ccall safe "dynamic"
37+ mkCallback :: FunPtr (CString -> IO ()) -> CString -> IO ()
38+
39+foreign import ccall safe "wrapper"
40+ wrapStartCallback :: IO () -> IO (FunPtr (IO ()))
41+
42+foreign import ccall safe "wrapper"
43+ wrapMessageCallback :: (CString -> IO ()) -> IO (FunPtr (CString -> IO ()))
44+
45+foreign import ccall safe "wrapper"
46+ wrapMessageCallback2 :: (CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> IO ()))
47+
48+foreign import ccall safe "wrapper"
49+ wrapSyncCallback :: (CString -> IO CString) -> IO (FunPtr (CString -> IO CString))
50+
51+jsaddleInit :: JSM () -> FunPtr (CString -> IO ()) -> IO (Ptr NativeCallbacks)
52+jsaddleInit jsm evaluateJavascriptAsyncPtr = do
53+ let evaluateJavascriptAsync = mkCallback evaluateJavascriptAsyncPtr
54+ (processResult, processSyncResult, start) <- runJavaScript (\batch ->
55+ useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");")
56+ evaluateJavascriptAsync) jsm
57+ jsaddleStartPtr <- wrapStartCallback $ void $ forkIO start
58+ jsaddleResultPtr <- wrapMessageCallback $ \s -> do
59+ result <- decode . fromStrict <$> packCString s
60+ case result of
61+ Nothing -> error $ "jsaddle message decode failed: " <> show result
62+ Just r -> processResult r
63+ jsaddleSyncResultPtr <- wrapSyncCallback $ \s -> do
64+ result <- decode . fromStrict <$> packCString s
65+ case result of
66+ Nothing -> error $ "jsaddle message decode failed: " <> show result
67+ Just r -> newCString =<< unpack . toStrict . encode <$> processSyncResult r
68+ jsaddleJsPtr <- newCString $ unpack $ toStrict jsaddleJs
69+ jsaddleHtmlPtr <- newCString $ unpack $ toStrict indexHtml
70+ new NativeCallbacks
71+ { _nativeCallbacks_jsaddleStart = jsaddleStartPtr
72+ , _nativeCallbacks_jsaddleResult = jsaddleResultPtr
73+ , _nativeCallbacks_jsaddleSyncResult = jsaddleSyncResultPtr
74+ , _nativeCallbacks_jsaddleJsData = jsaddleJsPtr
75+ , _nativeCallbacks_jsaddleHtmlData = jsaddleHtmlPtr
76+ }
77+
78+data AppConfig = AppConfig
79+ { _appConfig_mainActivityOnCreate :: IO ()
80+ , _appConfig_mainActivityOnStart :: IO ()
81+ , _appConfig_mainActivityOnResume :: IO ()
82+ , _appConfig_mainActivityOnPause :: IO ()
83+ , _appConfig_mainActivityOnStop :: IO ()
84+ , _appConfig_mainActivityOnDestroy :: IO ()
85+ , _appConfig_mainActivityOnRestart :: IO ()
86+ , _appConfig_mainActivityOnNewIntent :: (Text -> Text -> IO ())
87+ , _appConfig_firebaseInstanceIdServiceSendRegistrationToServer :: Text -> IO ()
88+ }
89+
90+instance Default AppConfig where
91+ def = AppConfig
92+ { _appConfig_mainActivityOnCreate = return ()
93+ , _appConfig_mainActivityOnStart = return ()
94+ , _appConfig_mainActivityOnResume = return ()
95+ , _appConfig_mainActivityOnPause = return ()
96+ , _appConfig_mainActivityOnStop = return ()
97+ , _appConfig_mainActivityOnDestroy = return ()
98+ , _appConfig_mainActivityOnRestart = return ()
99+ , _appConfig_mainActivityOnNewIntent = \_ _ -> return ()
100+ , _appConfig_firebaseInstanceIdServiceSendRegistrationToServer = \_ -> return ()
101+ }
102+
103+appConfigToAppCallbacks :: AppConfig -> IO AppCallbacks
104+appConfigToAppCallbacks c = do
105+ create <- wrapStartCallback $ _appConfig_mainActivityOnCreate c
106+ start <- wrapStartCallback $ _appConfig_mainActivityOnStart c
107+ resume <- wrapStartCallback $ _appConfig_mainActivityOnResume c
108+ pause <- wrapStartCallback $ _appConfig_mainActivityOnPause c
109+ stop <- wrapStartCallback $ _appConfig_mainActivityOnStop c
110+ destroy <- wrapStartCallback $ _appConfig_mainActivityOnDestroy c
111+ restart <- wrapStartCallback $ _appConfig_mainActivityOnRestart c
112+ newIntent <- wrapMessageCallback2 $ \intentAction intentData -> do
113+ intentAction' <- fromUtf8CString intentAction
114+ intentData' <- fromUtf8CString intentData
115+ _appConfig_mainActivityOnNewIntent c intentAction' intentData'
116+ firebaseRegPtr <- wrapMessageCallback $ \token -> do
117+ token' <- fromUtf8CString token
118+ _appConfig_firebaseInstanceIdServiceSendRegistrationToServer c token'
119+ return $ AppCallbacks
120+ { _appCallbacks_mainActivity_onCreate = create
121+ , _appCallbacks_mainActivity_onStart = start
122+ , _appCallbacks_mainActivity_onResume = resume
123+ , _appCallbacks_mainActivity_onPause = pause
124+ , _appCallbacks_mainActivity_onStop = stop
125+ , _appCallbacks_mainActivity_onDestroy = destroy
126+ , _appCallbacks_mainActivity_onRestart = restart
127+ , _appCallbacks_mainActivity_onNewIntent = newIntent
128+ , _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer = firebaseRegPtr
129+ }
130+
131+fromUtf8CString :: CString -> IO Text
132+fromUtf8CString = fmap T.decodeUtf8 . packCString
133+
134+pokeAppConfig :: Ptr AppCallbacks -> AppConfig -> IO ()
135+pokeAppConfig ptr cfg = poke ptr =<< appConfigToAppCallbacks cfg
136+
137+jsaddleJs :: ByteString
138+jsaddleJs = ghcjsHelpers <> "\
139+ \runJSaddleBatch = (function() {\n\
140+ \ " <> initState <> "\n\
141+ \ return function(batch) {\n\
142+ \ " <> runBatch (\a -> "jsaddle.postMessage(JSON.stringify(" <> a <> "));")
143+ (Just (\a -> "JSON.parse(jsaddle.syncMessage(JSON.stringify(" <> a <> ")))")) <> "\
144+ \ };\n\
145+ \})();\n\
146+ \jsaddle.postReady();\n"
147+
148+indexHtml :: ByteString
149+indexHtml =
150+ "<!DOCTYPE html>\n\
151+ \<html>\n\
152+ \<head>\n\
153+ \<title>JSaddle</title>\n\
154+ \</head>\n\
155+ \<body>\n\
156+ \</body>\n\
157+ \</html>"
jsaddle-clib/src-ghcjs/Language/Javascript/JSaddle/CLib.hsnew file+7
@@ -0,0 +1,7 @@
1+module Language.Javascript.JSaddle.CLib
2+ ( run
3+ ) where
4+
5+run :: IO () -> IO ()
6+run = id
7+{-# INLINE run #-}
jsaddle-clib/src/Language/Javascript/JSaddle/CLib/Internal.hscnew file+67
@@ -0,0 +1,67 @@
1+{-# LANGUAGE ForeignFunctionInterface #-}
2+module Language.Javascript.JSaddle.CLib.Internal where
3+
4+import Foreign
5+import Foreign.C
6+
7+#include "jsaddle.h"
8+
9+data NativeCallbacks = NativeCallbacks
10+ { _nativeCallbacks_jsaddleStart :: !(FunPtr (IO ())) -- void (jsaddleStart *)()
11+ , _nativeCallbacks_jsaddleResult :: !(FunPtr (CString -> IO ())) -- void (jsaddleResult *)(char *)
12+ , _nativeCallbacks_jsaddleSyncResult :: !(FunPtr (CString -> IO CString)) -- char * (jsaddleSyncResult *)(char *)
13+ , _nativeCallbacks_jsaddleJsData :: !CString -- char * jsaddleJsData
14+ , _nativeCallbacks_jsaddleHtmlData :: !CString -- char * jsaddleHtmlData
15+ }
16+
17+instance Storable NativeCallbacks where
18+ sizeOf _ = #{size native_callbacks}
19+ alignment _ = #{alignment native_callbacks}
20+ poke p nc = do
21+ #{poke native_callbacks, jsaddleStart} p $ _nativeCallbacks_jsaddleStart nc
22+ #{poke native_callbacks, jsaddleResult} p $ _nativeCallbacks_jsaddleResult nc
23+ #{poke native_callbacks, jsaddleSyncResult} p $ _nativeCallbacks_jsaddleSyncResult nc
24+ #{poke native_callbacks, jsaddleJsData} p $ _nativeCallbacks_jsaddleJsData nc
25+ #{poke native_callbacks, jsaddleHtmlData} p $ _nativeCallbacks_jsaddleHtmlData nc
26+ peek p = NativeCallbacks
27+ <$> #{peek native_callbacks, jsaddleStart} p
28+ <*> #{peek native_callbacks, jsaddleResult} p
29+ <*> #{peek native_callbacks, jsaddleSyncResult} p
30+ <*> #{peek native_callbacks, jsaddleJsData} p
31+ <*> #{peek native_callbacks, jsaddleHtmlData} p
32+
33+data AppCallbacks = AppCallbacks
34+ { _appCallbacks_mainActivity_onCreate :: !(FunPtr (IO ()))
35+ , _appCallbacks_mainActivity_onStart :: !(FunPtr (IO ()))
36+ , _appCallbacks_mainActivity_onResume :: !(FunPtr (IO ()))
37+ , _appCallbacks_mainActivity_onPause :: !(FunPtr (IO ()))
38+ , _appCallbacks_mainActivity_onStop :: !(FunPtr (IO ()))
39+ , _appCallbacks_mainActivity_onDestroy :: !(FunPtr (IO ()))
40+ , _appCallbacks_mainActivity_onRestart :: !(FunPtr (IO ()))
41+ , _appCallbacks_mainActivity_onNewIntent :: !(FunPtr (CString -> CString -> IO ()))
42+ , _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer :: !(FunPtr (CString -> IO ()))
43+ }
44+
45+instance Storable AppCallbacks where
46+ sizeOf _ = #{size app_callbacks}
47+ alignment _ = #{alignment app_callbacks}
48+ poke p nc = do
49+ #{poke app_callbacks, mainActivity_onCreate} p $ _appCallbacks_mainActivity_onCreate nc
50+ #{poke app_callbacks, mainActivity_onStart} p $ _appCallbacks_mainActivity_onStart nc
51+ #{poke app_callbacks, mainActivity_onResume} p $ _appCallbacks_mainActivity_onResume nc
52+ #{poke app_callbacks, mainActivity_onPause} p $ _appCallbacks_mainActivity_onPause nc
53+ #{poke app_callbacks, mainActivity_onStop} p $ _appCallbacks_mainActivity_onStop nc
54+ #{poke app_callbacks, mainActivity_onDestroy} p $ _appCallbacks_mainActivity_onDestroy nc
55+ #{poke app_callbacks, mainActivity_onRestart} p $ _appCallbacks_mainActivity_onRestart nc
56+ #{poke app_callbacks, mainActivity_onNewIntent} p $ _appCallbacks_mainActivity_onNewIntent nc
57+ #{poke app_callbacks, firebaseInstanceIdService_sendRegistrationToServer} p $ _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer nc
58+ peek p = AppCallbacks
59+ <$> #{peek app_callbacks, mainActivity_onCreate} p
60+ <*> #{peek app_callbacks, mainActivity_onStart} p
61+ <*> #{peek app_callbacks, mainActivity_onResume} p
62+ <*> #{peek app_callbacks, mainActivity_onPause} p
63+ <*> #{peek app_callbacks, mainActivity_onStop} p
64+ <*> #{peek app_callbacks, mainActivity_onDestroy} p
65+ <*> #{peek app_callbacks, mainActivity_onRestart} p
66+ <*> #{peek app_callbacks, mainActivity_onNewIntent} p
67+ <*> #{peek app_callbacks, firebaseInstanceIdService_sendRegistrationToServer} p
jsaddle-warp/jsaddle-warp.cabal+39−14
@@ -1,5 +1,5 @@
1name: jsaddle-warp
1name: jsaddle-warp
2−version: 0.7.0.0
2+version: 0.9.8.0
3cabal-version: >=1.10
3cabal-version: >=1.10
4build-type: Simple
4build-type: Simple
5license: MIT
5license: MIT
@@ -10,32 +10,37 @@ description:
10 This package provides an EDSL for calling JavaScript that
10 This package provides an EDSL for calling JavaScript that
11 can be used both from GHCJS and GHC. When using GHC
11 can be used both from GHCJS and GHC. When using GHC
12 the application is run using Warp and WebSockets to
12 the application is run using Warp and WebSockets to
13− drive a small JavaScipt helper.
13+ drive a small JavaScript helper.
14category: Web, Javascript
14category: Web, Javascript
15author: Hamish Mackenzie
15author: Hamish Mackenzie
16
16
17source-repository head
17source-repository head
18 type: git
18 type: git
19 location: https://github.com/ghcjs/jsaddle
19 location: https://github.com/ghcjs/jsaddle
20+ subdir: jsaddle-warp
20
21
21library
22library
22
23
23 if !impl(ghcjs -any)
24 if !impl(ghcjs -any)
24 exposed-modules:
25 exposed-modules:
25 Language.Javascript.JSaddle.WebSockets
26 Language.Javascript.JSaddle.WebSockets
27+ other-modules:
28+ Language.Javascript.JSaddle.WebSockets.Compat
26 build-depends:
29 build-depends:
27− aeson >=0.8.0.2 && <1.1,
30+ aeson >=0.8.0.2 && <1.6,
31+ bytestring >=0.10.6.0 && <0.11,
28− containers >=0.5.6.2 && <0.6,
32+ containers >=0.5.6.2 && <0.7,
33+ foreign-store >=0.2 && <0.3,
29− http-types >=0.8.6 && <0.10,
34+ http-types >=0.8.6 && <0.13,
30− jsaddle >=0.7.0.0 && <0.8,
35+ jsaddle >=0.9.4.0 && <0.10,
31− stm >=2.4.4 && <2.5,
36+ stm >=2.4.4 && <2.6,
32 text >=1.2.1.3 && <1.3,
37 text >=1.2.1.3 && <1.3,
33− time >=1.5.0.1 && <1.7,
38+ time >=1.5.0.1 && <1.11,
34 transformers >=0.4.2.0 && <0.6,
39 transformers >=0.4.2.0 && <0.6,
35 wai >=3.0.3.0 && <3.3,
40 wai >=3.0.3.0 && <3.3,
36 wai-websockets >=3.0.0.6 && <3.1,
41 wai-websockets >=3.0.0.6 && <3.1,
37− warp >=3.1.2 && <3.3,
42+ warp >=3.1.2 && <3.4,
38− websockets >=0.9.5.0 && <0.10
43+ websockets >=0.9.5.0 && <0.13
39 exposed-modules:
44 exposed-modules:
40 Language.Javascript.JSaddle.Warp
45 Language.Javascript.JSaddle.Warp
41 build-depends:
46 build-depends:
@@ -45,19 +50,39 @@ library
45 ghc-options: -ferror-spans -Wall
50 ghc-options: -ferror-spans -Wall
46
51
47test-suite test-tool
52test-suite test-tool
53+ if impl(ghcjs -any) || os(ios)
54+ buildable: False
48
55
49− if !impl(ghcjs -any)
50− build-depends:
56+ build-depends:
51 QuickCheck -any,
57 QuickCheck -any,
58+ aeson -any,
52 bytestring -any,
59 bytestring -any,
60+ containers -any,
61+ deepseq -any,
53− doctest >=0.10.1 && <0.12,
62+ doctest >=0.10.1 && <0.19,
63+ exceptions -any,
54 filepath >=1.4.0.0 && <1.5,
64 filepath >=1.4.0.0 && <1.5,
65+ foreign-store -any,
66+ ghc-prim -any,
67+ http-types -any,
55 jsaddle -any,
68 jsaddle -any,
56 jsaddle-warp -any,
69 jsaddle-warp -any,
57 lens -any,
70 lens -any,
71+ network -any,
58 ref-tf -any,
72 ref-tf -any,
59 primitive -any,
73 primitive -any,
60− process >=1.2.3.0 && <1.5
74+ process >=1.2.3.0 && <1.7,
75+ random -any,
76+ stm -any,
77+ text -any,
78+ time -any,
79+ transformers -any,
80+ unliftio-core -any,
81+ wai -any,
82+ wai-websockets -any,
83+ warp -any,
84+ webdriver >=0.8.4 && <0.10,
85+ websockets -any
61 type: exitcode-stdio-1.0
86 type: exitcode-stdio-1.0
62 main-is: DocTest.hs
87 main-is: DocTest.hs
63 build-depends:
88 build-depends:
jsaddle-warp/src/Language/Javascript/JSaddle/Test.hs+13−12
@@ -17,21 +17,22 @@ module Language.Javascript.JSaddle.Test (
17 , listWindowProperties
17 , listWindowProperties
18) where
18) where
19
19
20−import Control.Applicative
21import Prelude hiding((!!), catch)
20import Prelude hiding((!!), catch)
22−import Control.Monad.Trans.Reader (runReaderT)
21+import Control.Applicative
23−import Language.Javascript.JSaddle
22+import Control.Concurrent (threadDelay, forkIO, ThreadId)
24−import qualified Data.Text as T
25−import Control.Monad.IO.Class (MonadIO(..))
26−import Control.Monad (forever, forM)
27−import Control.Lens.Getter ((^.))
28−import Data.Monoid ((<>))
29import Control.Concurrent.MVar
23import Control.Concurrent.MVar
30 (tryTakeMVar, putMVar, takeMVar, newEmptyMVar, MVar)
24 (tryTakeMVar, putMVar, takeMVar, newEmptyMVar, MVar)
31−import System.IO.Unsafe (unsafePerformIO)
25+import Control.Lens.Getter ((^.))
32−import Control.Concurrent (threadDelay, forkIO, ThreadId)
26+import Control.Monad (forever, forM)
27+import Control.Monad.IO.Class (MonadIO(..))
28+import Control.Monad.Trans.Reader (runReaderT)
29+import Data.Monoid ((<>))
33import Data.Text (Text)
30import Data.Text (Text)
31+import qualified Data.Text as T
32+import Language.Javascript.JSaddle
34import Language.Javascript.JSaddle.Warp (run)
33import Language.Javascript.JSaddle.Warp (run)
34+import System.IO.Unsafe (unsafePerformIO)
35+import System.Timeout (timeout)
35
36
36context :: MVar JSContextRef
37context :: MVar JSContextRef
37context = unsafePerformIO newEmptyMVar
38context = unsafePerformIO newEmptyMVar
@@ -52,12 +53,12 @@ startServer =
52
53
53-- >>> testJSaddle $ ((global ^. js "console" . js "log") # ["Hello"])
54-- >>> testJSaddle $ ((global ^. js "console" . js "log") # ["Hello"])
54testJSaddle :: ToJSVal val => JSM val -> IO ()
55testJSaddle :: ToJSVal val => JSM val -> IO ()
55−testJSaddle f = do
56+testJSaddle f = timeout 10000000 (do
56 startServer
57 startServer
57 c <- takeMVar context
58 c <- takeMVar context
58 runReaderT (unJSM $ (f >>= valToText >>= liftIO . putStrLn . T.unpack)
59 runReaderT (unJSM $ (f >>= valToText >>= liftIO . putStrLn . T.unpack)
59 `catch` \ (JSException e) -> valToText e >>= liftIO . putStrLn . T.unpack) c
60 `catch` \ (JSException e) -> valToText e >>= liftIO . putStrLn . T.unpack) c
60− putMVar context c
61+ putMVar context c) >>= maybe (putStrLn "testJSaddle timed out") return
61
62
62debugLog :: String -> IO ()
63debugLog :: String -> IO ()
63debugLog _ = return ()
64debugLog _ = return ()
jsaddle-warp/src/Language/Javascript/JSaddle/Warp.hs+3−4
@@ -17,8 +17,7 @@ module Language.Javascript.JSaddle.Warp (
17 -- * Running JSM over WebSockets
17 -- * Running JSM over WebSockets
18 run
18 run
19#ifndef ghcjs_HOST_OS
19#ifndef ghcjs_HOST_OS
20− , jsaddleOr
20+ , module Language.Javascript.JSaddle.WebSockets
21− , jsaddleApp
22#endif
21#endif
23) where
22) where
24
23
@@ -29,7 +28,7 @@ import Network.WebSockets (defaultConnectionOptions)
29
28
30import Language.Javascript.JSaddle.Types (JSM)
29import Language.Javascript.JSaddle.Types (JSM)
31import Language.Javascript.JSaddle.Run (syncPoint)
30import Language.Javascript.JSaddle.Run (syncPoint)
32−import Language.Javascript.JSaddle.WebSockets (jsaddleOr, jsaddleApp)
31+import Language.Javascript.JSaddle.WebSockets
33#endif
32#endif
34
33
35-- | Run the given 'JSM' action as the main entry point. Either directly
34-- | Run the given 'JSM' action as the main entry point. Either directly
@@ -40,6 +39,6 @@ run _port = id
40#else
39#else
41run :: Int -> JSM () -> IO ()
40run :: Int -> JSM () -> IO ()
42run port f =
41run port f =
43− runSettings (setPort port (setTimeout 3600 defaultSettings)) $
42+ runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
44 jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp
43 jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp
45#endif
44#endif
jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs+287−40
@@ -1,5 +1,7 @@
1{-# LANGUAGE LambdaCase #-}
1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE RecursiveDo #-}
3-----------------------------------------------------------------------------
5-----------------------------------------------------------------------------
4--
6--
5-- Module : Language.Javascript.JSaddle.WebSockets
7-- Module : Language.Javascript.JSaddle.WebSockets
@@ -16,57 +18,302 @@ module Language.Javascript.JSaddle.WebSockets (
16 -- * Running JSM over WebSockets
18 -- * Running JSM over WebSockets
17 jsaddleOr
19 jsaddleOr
18 , jsaddleApp
20 , jsaddleApp
21+ , jsaddleWithAppOr
22+ , jsaddleAppWithJs
23+ , jsaddleAppWithJsOr
24+ , jsaddleAppPartial
25+ , jsaddleJs
26+ , jsaddleJs'
27+ , debug
28+ , debugOr
29+ , debugWrapper
19) where
30) where
20
31
21−import Control.Monad (forever)
32+import Control.Monad (when, void, forever)
22−import Control.Concurrent (forkIO)
33+import Control.Concurrent (killThread, forkIO, threadDelay)
34+import Control.Exception (handle, AsyncException, throwIO, fromException, finally)
23
35
24import Data.Monoid ((<>))
36import Data.Monoid ((<>))
25import Data.Aeson (encode, decode)
37import Data.Aeson (encode, decode)
26
38
27−import Network.Wai (Application)
39+import Network.Wai
40+ (Middleware, lazyRequestBody, Application, Request, Response,
41+ ResponseReceived)
28import Network.WebSockets
42import Network.WebSockets
29− (ConnectionOptions(..), sendTextData, receiveDataMessage,
43+ (defaultConnectionOptions, ConnectionOptions(..), sendTextData,
30− acceptRequest, ServerApp)
44+ receiveDataMessage, acceptRequest, ServerApp, sendPing)
31−import qualified Network.WebSockets as WS (DataMessage(..))
32import Network.Wai.Handler.WebSockets (websocketsOr)
45import Network.Wai.Handler.WebSockets (websocketsOr)
46+import Network.HTTP.Types (Status(..))
33
47
34−import Language.Javascript.JSaddle.Types (JSM(..))
48+import Language.Javascript.JSaddle.Types (JSM(..), JSContextRef(..))
35import qualified Network.Wai as W
49import qualified Network.Wai as W
36− (responseLBS, requestMethod, Application, pathInfo)
50+ (responseLBS, requestMethod, pathInfo, modifyResponse, responseStatus)
37−import Data.Text (Text)
51+import qualified Data.Text as T (pack)
38import qualified Network.HTTP.Types as H
52import qualified Network.HTTP.Types as H
39− (status403, status200, status405)
53+ (status403, status200)
40−import Language.Javascript.JSaddle.Run (runJavaScript)
54+import Language.Javascript.JSaddle.Run (syncPoint, runJavaScript)
41−import Language.Javascript.JSaddle.Run.Files (indexHtml, jsaddleJs)
55+import Language.Javascript.JSaddle.Run.Files (indexHtml, runBatch, ghcjsHelpers, initState)
42−
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+
43−jsaddleOr :: ConnectionOptions -> JSM () -> Application -> Application
77+jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application
44−jsaddleOr opts entryPoint = websocketsOr opts wsApp
78+jsaddleOr opts entryPoint otherApp = do
45− where
79+ syncHandlers <- newIORef M.empty
80+ asyncHandlers <- newIORef M.empty
46− wsApp :: ServerApp
81+ let wsApp :: ServerApp
47− wsApp pending_conn = do
82+ wsApp pending_conn = do
48− conn <- acceptRequest pending_conn
83+ conn <- acceptRequest pending_conn
84+ initMsg <- receiveDataMessage conn
85+ case getTextMessageByteString initMsg of
86+ Just "" -> do
49− (processResult, start) <- runJavaScript (sendTextData conn . encode) entryPoint
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 ->
50− _ <- forkIO . forever $
99+ forever $
51− receiveDataMessage conn >>= \case
100+ receiveDataMessage conn >>= \msg -> case getTextMessageByteString msg of
52− (WS.Text t) ->
101+ Just t ->
53− case decode t of
102+ case decode t of
54− Nothing -> error $ "jsaddle WebSocket decode failed : " <> show t
103+ Nothing -> error $ "jsaddle Results decode failed : " <> show t
55− Just r -> processResult r
104+ Just r -> processResult r
105+ _ -> error "jsaddle WebSocket unexpected binary data"
56 _ -> error "jsaddle WebSocket unexpected binary data"
106 _ -> error "jsaddle WebSocket unexpected binary data"
57− start
107+
108+ -- Based on Network.WebSocket.forkPingThread
109+ waitTillClosed conn = ignore `handle` go 1
110+ where
111+ go :: Int -> IO ()
112+ go i = do
113+ threadDelay (10 * 1000 * 1000)
114+ sendPing conn (T.pack $ show i)
115+ go (i + 1)
116+
117+ ignore e = case fromException e of
118+ Just async -> throwIO (async :: AsyncException)
119+ Nothing -> return ()
120+
121+ syncHandler :: Application
122+ syncHandler req sendResponse = case (W.requestMethod req, W.pathInfo req) of
123+ ("POST", ["sync", syncKey]) -> do
124+ body <- lazyRequestBody req
125+ case decode body of
126+ Nothing -> error $ "jsaddle sync message decode failed : " <> show body
127+ Just result ->
128+ M.lookup syncKey <$> readIORef syncHandlers >>= \case
129+ Nothing -> error "jsaddle missing sync message handler"
130+ Just handler -> do
131+ next <- encode <$> handler result
132+ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] next
133+ (method, _) -> (catch404 otherApp) req sendResponse
134+ where catch404 = W.modifyResponse $ \resp ->
135+ case (method, W.responseStatus resp) of
136+ ("GET", Status 404 _) -> indexResponse
137+ _ -> resp
138+ return $ websocketsOr opts wsApp syncHandler
139+
58
140
59jsaddleApp :: Application
141jsaddleApp :: Application
60−jsaddleApp req = jsaddleAppPieces (W.pathInfo req) req
142+jsaddleApp = jsaddleAppWithJs $ jsaddleJs False
61−
143+
62−jsaddleAppPieces :: [Text] -> W.Application
144+jsaddleAppWithJs :: ByteString -> Application
63−jsaddleAppPieces _ req sendResponse
145+jsaddleAppWithJs js req sendResponse =
64− | W.requestMethod req `notElem` ["GET", "HEAD"] = sendResponse $ W.responseLBS
146+ jsaddleAppWithJsOr js
65− H.status405
66− [("Content-Type", "text/plain")]
147+ (\_ _ -> sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")
67− "Only GET or HEAD is supported"
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
68−jsaddleAppPieces [] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
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
69−jsaddleAppPieces ["jsaddle.js"] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs
169+ ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] js
70−jsaddleAppPieces _rawPieces _req sendResponse = sendResponse $ W.responseLBS H.status403
170+ _ -> Nothing
71− [ ("Content-Type", "text/plain")
171+
72− ] "Forbidden"
172+jsaddleJs :: Bool -> ByteString
173+jsaddleJs = jsaddleJs' Nothing
174+
175+-- Use this to generate this string for embedding
176+-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy
177+jsaddleJs' :: Maybe ByteString -> Bool -> ByteString
178+jsaddleJs' jsaddleUri refreshOnLoad = "\
179+ \if(typeof global !== \"undefined\" && typeof require === \"function\") {\n\
180+ \ global.window = global;\n\
181+ \ global.WebSocket = require('ws');\n\
182+ \}\n\
183+ \\n\
184+ \var connect = function() {\n\
185+ \ var wsaddress = "
186+ <> maybe "window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\")"
187+ (\ s -> "\"ws" <> s <> "\"")
188+ (jsaddleUri >>= LBS.stripPrefix "http")
189+ <> ";\n\
190+ \\n\
191+ \ var ws0 = new WebSocket(wsaddress);\n\
192+ \ var syncKey = \"\";\n\
193+ \\n\
194+ \ ws0.onopen = function(e) {\n\
195+ \ ws0.send(\"\");\n\
196+ \ var initialResults = [];\n\
197+ \ var ws = {send: function(m) {initialResults.push(m);}};\n\
198+ \ " <> initState <> "\n\
199+ \\n\
200+ \ ws0.onmessage = function(e) {\n\
201+ \ var batch = JSON.parse(e.data);\n\
202+ \ if(inCallback > 0) {\n\
203+ \ asyncBatch = batch;\n\
204+ \ return;\n\
205+ \ }\n\
206+ \ if(typeof batch === \"string\") {\n\
207+ \ syncKey = batch;\n\
208+ \ var ws1 = new WebSocket(wsaddress);\n\
209+ \ ws1.onopen = function(e) {\n\
210+ \ ws1.send(syncKey);\n\
211+ \ initialResults.forEach(function(m){ ws1.send(m); });\n\
212+ \ initialResults = null;\n\
213+ \ ws = ws1;\n\
214+ \ }\n" <>
215+ (if refreshOnLoad
216+ then " var xhr = new XMLHttpRequest();\n\
217+ \ xhr.open('POST', '/reload/'+syncKey, true);\n\
218+ \ xhr.onreadystatechange = function() {\n\
219+ \ if(xhr.readyState === XMLHttpRequest.DONE && xhr.status === 200)\n\
220+ \ setTimeout(function(){window.location.reload();}, 100);\n\
221+ \ };\n\
222+ \ xhr.send();\n"
223+ else "") <>
224+ " return;\n\
225+ \ }\n\
226+ \\n\
227+ \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));")
228+ (Just (\a -> "(function(){\n\
229+ \ var xhr = new XMLHttpRequest();\n\
230+ \ xhr.open('POST', '" <> fromMaybe "" jsaddleUri <> "/sync/'+syncKey, false);\n\
231+ \ xhr.setRequestHeader(\"Content-type\", \"application/json\");\n\
232+ \ xhr.send(JSON.stringify(" <> a <> "));\n\
233+ \ return JSON.parse(xhr.response);})()")) <> "\
234+ \ };\n\
235+ \ };\n\
236+ \ ws0.onerror = function() {\n\
237+ \ setTimeout(connect, 1000);\n\
238+ \ };\n\
239+ \}\n\
240+ \\n\
241+ \ " <> ghcjsHelpers <> "\
242+ \connect();\n\
243+ \"
244+
245+-- | Start or restart the server.
246+-- To run this as part of every :reload use
247+-- > :def! reload (const $ return "::reload\nLanguage.Javascript.JSaddle.Warp.debug 3708 SomeMainModule.someMainFunction")
248+debug :: Int -> JSM () -> IO ()
249+debug port f = do
250+ debugWrapper $ \withRefresh registerContext ->
251+ runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
252+ jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJs $ jsaddleJs True)
253+ putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"
254+
255+debugOr :: Int -> JSM () -> Application -> IO ()
256+debugOr port f b = do
257+ debugWrapper $ \withRefresh registerContext ->
258+ runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
259+ jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJsOr (jsaddleJs True) b)
260+ putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"
261+
262+refreshMiddleware :: ((Response -> IO ResponseReceived) -> IO ResponseReceived) -> Middleware
263+refreshMiddleware refresh otherApp req sendResponse = case (W.requestMethod req, W.pathInfo req) of
264+ ("POST", ["reload", _syncKey]) -> refresh sendResponse
265+ _ -> otherApp req sendResponse
266+
267+debugWrapper :: (Middleware -> JSM () -> IO ()) -> IO ()
268+debugWrapper run = do
269+ reloadMVar <- newEmptyMVar
270+ reloadDoneMVars <- newMVar []
271+ contexts <- newMVar []
272+ let refresh sendResponse = do
273+ reloadDone <- newEmptyMVar
274+ modifyMVar_ reloadDoneMVars (return . (reloadDone:))
275+ readMVar reloadMVar
276+ r <- sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] ("reload" :: ByteString)
277+ putMVar reloadDone ()
278+ return r
279+ start :: Int -> IO (IO Int)
280+ start expectedConnections = do
281+ serverDone <- newEmptyMVar
282+ ready <- newEmptyMVar
283+ let registerContext :: JSM ()
284+ registerContext = do
285+ uuid <- contextId <$> askJSM
286+ browsersConnected <- liftIO $ modifyMVar contexts (\ctxs -> return (uuid:ctxs, length ctxs + 1))
287+ addContext
288+ when (browsersConnected == expectedConnections) . void . liftIO $ tryPutMVar ready ()
289+ thread <- forkIO $
290+ finally (run (refreshMiddleware refresh) registerContext)
291+ (putMVar serverDone ())
292+ _ <- forkIO $ threadDelay 10000000 >> void (tryPutMVar ready ())
293+ when (expectedConnections /= 0) $ takeMVar ready
294+ return $ do
295+ putMVar reloadMVar ()
296+ ctxs <- takeMVar contexts
297+ mapM_ removeContext ctxs
298+ takeMVar reloadDoneMVars >>= mapM_ takeMVar
299+ tryTakeMVar serverDone >>= \case
300+ Nothing -> do
301+ killThread thread
302+ takeMVar serverDone
303+ Just _ -> return ()
304+ return $ length ctxs
305+ restarter :: MVar (Int -> IO (IO Int)) -> IO Int -> IO ()
306+ restarter mvar stop = do
307+ start' <- takeMVar mvar
308+ n <- stop
309+ start' n >>= restarter mvar
310+ lookupStore storeId >>= \case
311+ Nothing -> do
312+ restartMVar <- newMVar start
313+ void . forkIO $ restarter restartMVar (return 0)
314+ void $ writeStore (Store storeId) restartMVar
315+ Just shutdownStore -> do
316+ restartMVar :: MVar (Int -> IO (IO Int)) <- readStore shutdownStore
317+ void $ tryTakeMVar restartMVar
318+ putMVar restartMVar start
319+ where storeId = 354
jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets/Compat.hsnew file+29
@@ -0,0 +1,29 @@
1+{-# LANGUAGE CPP #-}
2+-----------------------------------------------------------------------------
3+--
4+-- Module : Language.Javascript.JSaddle.WebSockets.Compat
5+-- Copyright : (c) Hamish Mackenzie
6+-- License : MIT
7+--
8+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
9+--
10+-- | This module is necessary to harmonize various versions of the websockets
11+-- package; we can't do this CPP inline in
12+-- Language.Javascript.JSaddle.WebSockets because that module uses multi-line
13+-- strings, which are incompatible with CPP
14+--
15+-----------------------------------------------------------------------------
16+module Language.Javascript.JSaddle.WebSockets.Compat where
17+
18+import Data.ByteString.Lazy (ByteString)
19+import qualified Network.WebSockets as WS (DataMessage(..))
20+
21+getTextMessageByteString :: WS.DataMessage -> Maybe ByteString
22+getTextMessageByteString msg = case msg of
23+#if MIN_VERSION_websockets(0,11,0)
24+ (WS.Text t _) ->
25+#else
26+ (WS.Text t) ->
27+#endif
28+ Just t
29+ _ -> Nothing
jsaddle-warp/tests/DocTest.hs+84−48
@@ -11,15 +11,17 @@ import System.IO (stderr, BufferMode(..), stdout, hSetBuffering)
11import System.FilePath ((</>))
11import System.FilePath ((</>))
12import System.Exit (exitFailure, exitWith, ExitCode(..))
12import System.Exit (exitFailure, exitWith, ExitCode(..))
13import System.Process (readProcess, system)
13import System.Process (readProcess, system)
14−import Control.Concurrent (forkIO)
14+import Control.Concurrent
15+ (takeMVar, newEmptyMVar, forkIO, threadDelay, putMVar)
15import Control.Monad (void)
16import Control.Monad (void)
17+import Control.Monad.IO.Class (MonadIO(..))
16import Data.Monoid ((<>))
18import Data.Monoid ((<>))
17import System.Environment (getArgs)
19import System.Environment (getArgs)
18−import Language.Javascript.JSaddle.Run.Files (jsaddleJs)
20+import Test.WebDriver (runSession, defaultConfig, openPage, closeSession)
19−import qualified Data.ByteString.Lazy.Char8 as BS (unpack)
20
21
21main :: IO ()
22main :: IO ()
22main = do
23main = do
24+ putStrLn "Testing JSaddle"
23 jsaddlePath <- getArgs >>= \case
25 jsaddlePath <- getArgs >>= \case
24 [arg] -> return arg
26 [arg] -> return arg
25 _ -> do
27 _ -> do
@@ -27,50 +29,84 @@ main = do
27 exitFailure
29 exitFailure
28 hSetBuffering stdout LineBuffering
30 hSetBuffering stdout LineBuffering
29 hSetBuffering stderr LineBuffering
31 hSetBuffering stderr LineBuffering
32+ putStrLn "Checking for phantomjs"
30− node <- system "nodejs --version" >>= \case
33+ node <- system "phantomjs --version" >>= \case
31− ExitSuccess -> return "nodejs"
34+ ExitSuccess -> return ()
32− _ -> return "node"
33− system (node <> " --version") >>= \case
34− ExitSuccess -> putStrLn "Node.js found"
35 e -> do
35 e -> do
36− putStrLn "Node.js not found"
36+ putStrLn "phantomjs not found"
37 exitWith e
37 exitWith e
38+ putStrLn "Starting phantomjs"
38− forkIO . void $ readProcess node ["--harmony"] (BS.unpack jsaddleJs) >>= putStr
39+ forkIO . void $ readProcess "phantomjs" ["--webdriver=4444"] "" >>= putStr
40+ threadDelay 5000000
41+ putStrLn "Running Tests"
42+ done <- newEmptyMVar
43+ forkIO $ do
39− doctest [
44+ liftIO $ doctest [
40− "-hide-all-packages",
45+ "-hide-all-packages",
41− "-package=base-" ++ VERSION_base,
46+ "-package=base-" ++ VERSION_base,
42− "-package=lens-" ++ VERSION_lens,
47+ "-package=lens-" ++ VERSION_lens,
43− "-package=text-" ++ VERSION_text,
48+ "-package=text-" ++ VERSION_text,
44− "-package=bytestring-" ++ VERSION_bytestring,
49+ "-package=bytestring-" ++ VERSION_bytestring,
45− "-package=transformers-" ++ VERSION_transformers,
50+ "-package=transformers-" ++ VERSION_transformers,
46− "-package=websockets-" ++ VERSION_websockets,
51+ "-package=websockets-" ++ VERSION_websockets,
47− "-package=primitive-" ++ VERSION_primitive,
52+ "-package=primitive-" ++ VERSION_primitive,
48− "-package=aeson-" ++ VERSION_aeson,
53+ "-package=aeson-" ++ VERSION_aeson,
49− "-package=websockets-" ++ VERSION_websockets,
54+ "-package=websockets-" ++ VERSION_websockets,
50− "-package=wai-" ++ VERSION_wai,
55+ "-package=wai-" ++ VERSION_wai,
51− "-package=wai-websockets-" ++ VERSION_wai_websockets,
56+ "-package=wai-websockets-" ++ VERSION_wai_websockets,
52− "-package=warp-" ++ VERSION_warp,
57+ "-package=warp-" ++ VERSION_warp,
53− "-package=http-types-" ++ VERSION_http_types,
58+ "-package=http-types-" ++ VERSION_http_types,
54− "-package=stm-" ++ VERSION_stm,
59+ "-package=stm-" ++ VERSION_stm,
55− "-package=time-" ++ VERSION_time,
60+ "-package=time-" ++ VERSION_time,
56− "-package=containers-" ++ VERSION_containers,
61+ "-package=containers-" ++ VERSION_containers,
57− "-package=process-" ++ VERSION_process,
62+ "-package=process-" ++ VERSION_process,
58− "-package=filepath-" ++ VERSION_filepath,
63+ "-package=filepath-" ++ VERSION_filepath,
59− "-package=ref-tf-" ++ VERSION_ref_tf,
64+ "-package=ref-tf-" ++ VERSION_ref_tf,
60− "-i" <> jsaddlePath </> "jsaddle-warp/src",
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",
61− jsaddlePath </> "jsaddle-warp/src/Language/Javascript/JSaddle/Test.hs",
73+ "src/Language/Javascript/JSaddle/Test.hs",
62− "-i" <> jsaddlePath </> "jsaddle",
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",
63− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle.hs",
89+ jsaddlePath </> "src/Language/Javascript/JSaddle.hs",
64− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Arguments.hs",
90+ jsaddlePath </> "src/Language/Javascript/JSaddle/Arguments.hs",
91+ jsaddlePath </> "src/Language/Javascript/JSaddle/Classes.hs",
65− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Classes.hs",
92+ jsaddlePath </> "src/Language/Javascript/JSaddle/Classes/Internal.hs",
93+ jsaddlePath </> "src/Language/Javascript/JSaddle/Debug.hs",
66− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Evaluate.hs",
94+ jsaddlePath </> "src/Language/Javascript/JSaddle/Evaluate.hs",
67− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Exception.hs",
95+ jsaddlePath </> "src/Language/Javascript/JSaddle/Exception.hs",
68− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Monad.hs",
96+ jsaddlePath </> "src/Language/Javascript/JSaddle/Monad.hs",
97+ jsaddlePath </> "src/Language/Javascript/JSaddle/Marshal/String.hs",
69− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Native.hs",
98+ jsaddlePath </> "src/Language/Javascript/JSaddle/Native.hs",
99+ jsaddlePath </> "src/Language/Javascript/JSaddle/Native/Internal.hs",
70− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Object.hs",
100+ jsaddlePath </> "src/Language/Javascript/JSaddle/Object.hs",
71− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Properties.hs",
101+ jsaddlePath </> "src/Language/Javascript/JSaddle/Properties.hs",
72− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Run.hs",
102+ jsaddlePath </> "src/Language/Javascript/JSaddle/Run.hs",
73− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs",
103+ jsaddlePath </> "src/Language/Javascript/JSaddle/Run/Files.hs",
74− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/String.hs",
104+ jsaddlePath </> "src/Language/Javascript/JSaddle/String.hs",
75− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Types.hs",
105+ jsaddlePath </> "src/Language/Javascript/JSaddle/Types.hs",
76− jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Value.hs" ]
106+ jsaddlePath </> "src/Language/Javascript/JSaddle/Value.hs" ]
107+ putMVar done ()
108+ threadDelay 5000000
109+ runSession defaultConfig $ do
110+ openPage "http://127.0.0.1:3709"
111+ liftIO $ takeMVar done
112+ closeSession
jsaddle-webkit2gtk/LICENSEnew file+21
@@ -0,0 +1,21 @@
1+Copyright (c) 2010-2012 Hamish Mackenzie, Victor Nazarov, Luite Stegeman
2+
3+Permission is hereby granted, free of charge, to any person obtaining
4+a copy of this software and associated documentation files (the
5+"Software"), to deal in the Software without restriction, including
6+without limitation the rights to use, copy, modify, merge, publish,
7+distribute, sublicense, and/or sell copies of the Software, and to
8+permit persons to whom the Software is furnished to do so, subject to
9+the following conditions:
10+
11+The above copyright notice and this permission notice shall be
12+included in all copies or substantial portions of the Software.
13+
14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
17+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
18+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
19+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
20+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21+
jsaddle-webkit2gtk/Setup.lhsnew file+6
@@ -0,0 +1,6 @@
1+#!/usr/bin/runhaskell
2+> module Main where
3+> import Distribution.Simple
4+> main :: IO ()
5+> main = defaultMain
6+
jsaddle-webkit2gtk/jsaddle-webkit2gtk.cabalnew file+49
@@ -0,0 +1,49 @@
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.hsnew file+193
@@ -0,0 +1,193 @@
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/LICENSEnew file+21
@@ -0,0 +1,21 @@
1+Copyright (c) 2010-2012 Hamish Mackenzie, Victor Nazarov, Luite Stegeman
2+
3+Permission is hereby granted, free of charge, to any person obtaining
4+a copy of this software and associated documentation files (the
5+"Software"), to deal in the Software without restriction, including
6+without limitation the rights to use, copy, modify, merge, publish,
7+distribute, sublicense, and/or sell copies of the Software, and to
8+permit persons to whom the Software is furnished to do so, subject to
9+the following conditions:
10+
11+The above copyright notice and this permission notice shall be
12+included in all copies or substantial portions of the Software.
13+
14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
17+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
18+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
19+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
20+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21+
jsaddle-webkitgtk/Setup.lhsnew file+6
@@ -0,0 +1,6 @@
1+#!/usr/bin/runhaskell
2+> module Main where
3+> import Distribution.Simple
4+> main :: IO ()
5+> main = defaultMain
6+
jsaddle-webkitgtk/jsaddle-webkitgtk.cabalnew file+44
@@ -0,0 +1,44 @@
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.hsnew file+230
@@ -0,0 +1,230 @@
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.mnew file+126
@@ -0,0 +1,126 @@
1+#include "HsFFI.h"
2+#import <Cocoa/Cocoa.h>
3+#import <WebKit/WebKit.h>
4+
5+extern void callIO(HsStablePtr);
6+extern bool callWithCStringReturningBool(const char * _Nonnull, HsStablePtr);
7+extern void callWithCString(const char * _Nonnull, HsStablePtr);
8+extern void callWithWebView(WKWebView *, HsStablePtr);
9+
10+@interface AppDelegate : NSObject <NSApplicationDelegate>
11+@property (nonatomic, assign) IBOutlet NSWindow *window;
12+@property (nonatomic, assign) HsStablePtr handler;
13+
14+- (instancetype)initApp:(HsStablePtr)handler progName:(NSString *)progName;
15+@end
16+
17+HsStablePtr global_willFinishLaunchingWithOptions = 0;
18+HsStablePtr global_didFinishLaunchingWithOptions = 0;
19+HsStablePtr global_applicationUniversalLink = 0;
20+HsStablePtr global_applicationOpenFile = 0;
21+uint64_t global_developerExtrasEnabled = 1;
22+
23+@implementation AppDelegate
24+
25+- (void)applicationWillTerminate:(NSNotification *)aNotification {
26+ // Insert code here to tear down your application
27+}
28+
29+-(id)initApp:(HsStablePtr)handler progName:(NSString *)progName {
30+ self = [super init];
31+ if (self) {
32+ _handler = handler;
33+ NSRect contentSize = NSMakeRect(0.0, 500.0, 1000.0, 700.0);
34+ // TODO replace with once nix has newer Cocoa NSUInteger windowStyleMask = NSWindowStyleMaskTitled | NSWindowStyleMaskResizable | NSWindowStyleMaskClosable | NSWindowStyleMaskMiniaturizable;
35+ NSUInteger windowStyleMask = NSTitledWindowMask | NSResizableWindowMask | NSClosableWindowMask | NSMiniaturizableWindowMask;
36+ _window = [[NSWindow alloc] initWithContentRect:contentSize styleMask:windowStyleMask backing:NSBackingStoreBuffered defer:YES];
37+ _window.backgroundColor = [NSColor whiteColor];
38+ _window.title = progName;
39+ }
40+ return self;
41+}
42+
43+-(BOOL)application:(NSApplication *)sender openFile:(NSString *)filename {
44+ bool b = callWithCStringReturningBool([filename UTF8String], global_applicationOpenFile);
45+ return b ? YES : NO;
46+}
47+
48+-(void)applicationWillFinishLaunching:(NSNotification *)notification {
49+ WKWebViewConfiguration *theConfiguration = [[WKWebViewConfiguration alloc] init];
50+ if (global_developerExtrasEnabled) {
51+ [theConfiguration.preferences setValue:@YES forKey:@"developerExtrasEnabled"];
52+ }
53+ WKWebView *webView = [[WKWebView alloc] initWithFrame: [_window.contentView frame] configuration:theConfiguration];
54+ [_window setContentView:webView];
55+ callWithWebView(webView, _handler);
56+ callIO(global_willFinishLaunchingWithOptions);
57+ // Listen to URL events
58+ NSAppleEventManager *manager = [NSAppleEventManager sharedAppleEventManager];
59+ [manager
60+ setEventHandler:self
61+ andSelector:@selector(applicationUniversalLink:)
62+ forEventClass:kInternetEventClass
63+ andEventID:kAEGetURL];
64+}
65+
66+- (void)applicationUniversalLink:(NSAppleEventDescriptor *)event {
67+ NSString *url = [[event paramDescriptorForKeyword:keyDirectObject] stringValue];
68+ callWithCString([url UTF8String], global_applicationUniversalLink);
69+}
70+
71+-(void)applicationDidFinishLaunching:(NSNotification *)notification {
72+ [_window orderFrontRegardless];
73+ [_window center];
74+ [NSApp activateIgnoringOtherApps:YES];
75+ callIO(global_didFinishLaunchingWithOptions);
76+}
77+
78+-(BOOL) applicationShouldTerminateAfterLastWindowClosed:(NSApplication *)app {
79+ return YES;
80+}
81+
82+@end
83+
84+void runInWKWebView(HsStablePtr handler,
85+ const char * _Nonnull progName,
86+ HsStablePtr hs_willFinishLaunchingWithOptions,
87+ HsStablePtr hs_didFinishLaunchingWithOptions,
88+ HsStablePtr hs_applicationDidBecomeActive,
89+ HsStablePtr hs_applicationWillResignActive,
90+ HsStablePtr hs_applicationDidEnterBackground,
91+ HsStablePtr hs_applicationWillEnterForeground,
92+ HsStablePtr hs_applicationWillTerminate,
93+ HsStablePtr hs_applicationSignificantTimeChange,
94+ HsStablePtr hs_applicationUniversalLink,
95+ const uint64_t hs_requestAuthorizationWithOptions,
96+ const uint64_t hs_requestAuthorizationOptionBadge,
97+ const uint64_t hs_requestAuthorizationOptionSound,
98+ const uint64_t hs_requestAuthorizationOptionAlert,
99+ const uint64_t hs_requestAuthorizationOptionCarPlay,
100+ const uint64_t hs_registerForRemoteNotifications,
101+ HsStablePtr hs_didRegisterForRemoteNotificationsWithDeviceToken,
102+ HsStablePtr hs_didFailToRegisterForRemoteNotificationsWithError,
103+ const uint64_t hs_developerExtrasEnabled,
104+ HsStablePtr hs_applicationOpenFile) {
105+ @autoreleasepool {
106+ global_willFinishLaunchingWithOptions = hs_willFinishLaunchingWithOptions;
107+ global_didFinishLaunchingWithOptions = hs_didFinishLaunchingWithOptions;
108+ global_applicationUniversalLink = hs_applicationUniversalLink;
109+ global_applicationOpenFile = hs_applicationOpenFile;
110+ global_developerExtrasEnabled = hs_developerExtrasEnabled;
111+ NSApplication *application = [NSApplication sharedApplication];
112+ AppDelegate *appDelegate = [[AppDelegate alloc] initApp:handler progName:[NSString stringWithCString:progName encoding:NSUTF8StringEncoding]];
113+ [application setDelegate:appDelegate];
114+ const char * _Nonnull argv [] = {"", 0};
115+ [application setActivationPolicy:NSApplicationActivationPolicyRegular];
116+ [application
117+ performSelectorOnMainThread:@selector(run)
118+ withObject:nil
119+ waitUntilDone:YES];
120+ }
121+}
122+
123+BOOL openApp(NSURL * url) {
124+ NSWorkspace *workspace = [NSWorkspace sharedWorkspace];
125+ return [workspace openURL:url];
126+}
jsaddle-wkwebview/cbits-uikit/AppDelegate.hnew file+8
@@ -0,0 +1,8 @@
1+#include "HsFFI.h"
2+#import <UIKit/UIKit.h>
3+
4+@interface AppDelegate : UIResponder <UIApplicationDelegate>
5+
6+@property (nonatomic, assign) UIWindow *window;
7+
8+@end
jsaddle-wkwebview/cbits-uikit/AppDelegate.mnew file+207
@@ -0,0 +1,207 @@
1+#import "AppDelegate.h"
2+#import "ViewController.h"
3+#import <UserNotifications/UserNotifications.h>
4+#import <stdint.h>
5+
6+extern void callIO(HsStablePtr);
7+extern void callWithCString(const char * _Nonnull, HsStablePtr);
8+extern void callWithCIntCString(int n, const char * _Nonnull, HsStablePtr);
9+
10+@interface AppDelegate ()
11+
12+@end
13+
14+HsStablePtr globalHandler = 0;
15+HsStablePtr global_willFinishLaunchingWithOptions = 0;
16+HsStablePtr global_didFinishLaunchingWithOptions = 0;
17+HsStablePtr global_applicationDidBecomeActive = 0;
18+HsStablePtr global_applicationWillResignActive = 0;
19+HsStablePtr global_applicationDidEnterBackground = 0;
20+HsStablePtr global_applicationWillEnterForeground = 0;
21+HsStablePtr global_applicationWillTerminate = 0;
22+HsStablePtr global_applicationSignificantTimeChange = 0;
23+HsStablePtr global_applicationUniversalLink = 0;
24+HsStablePtr global_applicationDidReceiveRemoteNotification = 0;
25+uint64_t global_requestAuthorizationWithOptions = 0;
26+uint64_t global_requestAuthorizationOptionBadge = 0;
27+uint64_t global_requestAuthorizationOptionSound = 0;
28+uint64_t global_requestAuthorizationOptionAlert = 0;
29+uint64_t global_requestAuthorizationOptionCarPlay = 0;
30+uint64_t global_registerForRemoteNotifications = 0;
31+HsStablePtr global_didRegisterForRemoteNotificationsWithDeviceToken = 0;
32+HsStablePtr global_didFailToRegisterForRemoteNotificationsWithError = 0;
33+
34+@implementation AppDelegate
35+
36+- (BOOL)application:(UIApplication *)application willFinishLaunchingWithOptions:(NSDictionary *)launchOptions {
37+ // Tells the delegate that the launch process has begun but that state restoration has not yet occurred.
38+ callIO(global_willFinishLaunchingWithOptions);
39+ return YES;
40+}
41+
42+- (BOOL)application:(UIApplication *)application didFinishLaunchingWithOptions:(NSDictionary *)launchOptions {
43+ // Tells the delegate that the launch process is almost done and the app is almost ready to run.
44+ self.window = [[UIWindow alloc] initWithFrame:[[UIScreen mainScreen] bounds]];
45+ // Override point for customization after application launch.
46+ self.window.rootViewController = [[ViewController alloc] initWithHandler:globalHandler];
47+ self.window.backgroundColor = [UIColor whiteColor];
48+ [self.window makeKeyAndVisible];
49+ UNUserNotificationCenter* center = [UNUserNotificationCenter currentNotificationCenter];
50+ center.delegate = self;
51+ if (global_requestAuthorizationWithOptions) {
52+ UNAuthorizationOptions options = (UNAuthorizationOptions)0;
53+ if (global_requestAuthorizationOptionBadge) {
54+ options = options | UNAuthorizationOptionBadge;
55+ }
56+ if (global_requestAuthorizationOptionSound) {
57+ options = options | UNAuthorizationOptionSound;
58+ }
59+ if (global_requestAuthorizationOptionAlert) {
60+ options = options | UNAuthorizationOptionAlert;
61+ }
62+ if (global_requestAuthorizationOptionCarPlay) {
63+ options = options | UNAuthorizationOptionCarPlay;
64+ }
65+ [center requestAuthorizationWithOptions:(options)
66+ completionHandler:^(BOOL granted, NSError * _Nullable error) {
67+ // Handler used to alter application behavior based on types of notifications authorized
68+ }];
69+ if (global_registerForRemoteNotifications) {
70+ [application registerForRemoteNotifications];
71+ }
72+ }
73+ callIO(global_didFinishLaunchingWithOptions);
74+ return YES;
75+}
76+
77+- (void)applicationWillResignActive:(UIApplication *)application {
78+ // Sent when the application is about to move from active to inactive state. This can occur for certain types of temporary interruptions (such as an incoming phone call or SMS message) or when the user quits the application and it begins the transition to the background state.
79+ // Use this method to pause ongoing tasks, disable timers, and invalidate graphics rendering callbacks. Games should use this method to pause the game.
80+ callIO(global_applicationWillResignActive);
81+}
82+
83+
84+- (void)applicationDidEnterBackground:(UIApplication *)application {
85+ // Use this method to release shared resources, save user data, invalidate timers, and store enough application state information to restore your application to its current state in case it is terminated later.
86+ // If your application supports background execution, this method is called instead of applicationWillTerminate: when the user quits.
87+ callIO(global_applicationDidEnterBackground);
88+}
89+
90+
91+- (void)applicationWillEnterForeground:(UIApplication *)application {
92+ // Called as part of the transition from the background to the active state; here you can undo many of the changes made on entering the background.
93+ callIO(global_applicationWillEnterForeground);
94+}
95+
96+
97+- (void)applicationDidBecomeActive:(UIApplication *)application {
98+ // Restart any tasks that were paused (or not yet started) while the application was inactive. If the application was previously in the background, optionally refresh the user interface.
99+ callIO(global_applicationDidBecomeActive);
100+}
101+
102+
103+- (void)applicationWillTerminate:(UIApplication *)application {
104+ // Called when the application is about to terminate. Save data if appropriate. See also applicationDidEnterBackground:.
105+ callIO(global_applicationWillTerminate);
106+}
107+
108+- (void)application:(UIApplication *)application didRegisterForRemoteNotificationsWithDeviceToken:(NSData *)deviceToken {
109+ // Tells the delegate that the app successfully registered with Apple Push Notification service (APNs).
110+ NSString *deviceTokenString = [deviceToken base64EncodedStringWithOptions: 0];
111+ callWithCString([deviceTokenString UTF8String], global_didRegisterForRemoteNotificationsWithDeviceToken);
112+}
113+
114+- (void)application:(UIApplication *)application didReceiveRemoteNotification:(NSDictionary *)userInfo fetchCompletionHandler:(void (^)(UIBackgroundFetchResult result))completionHandler {
115+ // Sent when the application receives remote notifications in the foreground or background
116+ // TODO Allow a configurable CString -> IO () to be passed into AppDelegateConfig
117+ if ([userInfo valueForKeyPath:@"aps.badge"] != nil) {
118+ [UIApplication sharedApplication].applicationIconBadgeNumber=[[[userInfo objectForKey:@"aps"] objectForKey:@"badge"] intValue];
119+ }
120+ NSError *error;
121+ NSData *jsonData = [NSJSONSerialization dataWithJSONObject:userInfo options:0 error:&error];
122+ if (jsonData) {
123+ NSString *jsonString = [[NSString alloc] initWithData:jsonData encoding:NSUTF8StringEncoding];
124+ callWithCIntCString((int) application.applicationState, [jsonString UTF8String], global_applicationDidReceiveRemoteNotification);
125+ } else {
126+ NSLog(@"jsaddle-wkwebview didReceiveRemoteNotification handler: error while serialising push notification as JSON");
127+ }
128+ completionHandler(UIBackgroundFetchResultNewData);
129+}
130+
131+- (void)application:(UIApplication *)application didFailToRegisterForRemoteNotificationsWithError:(NSError *)error {
132+ // Sent to the delegate when Apple Push Notification service cannot successfully complete the registration process.
133+ NSString *errorString = [error localizedDescription];
134+ callWithCString([errorString UTF8String], global_didFailToRegisterForRemoteNotificationsWithError);
135+}
136+
137+- (void)applicationSignificantTimeChange:(UIApplication *)application {
138+ // Tells the delegate when there is a significant change in the time.
139+ callIO(global_applicationSignificantTimeChange);
140+}
141+
142+- (BOOL)application:(UIApplication *)application continueUserActivity:(NSUserActivity *)userActivity restorationHandler:(void (^)(NSArray *restorableObjects))restorationHandler {
143+ // TODO: Reroute universal links when they're clicked in-app.
144+ // https://developer.apple.com/reference/webkit/wknavigationdelegate/1455643-webview?language=objc
145+ if ([userActivity.activityType isEqualToString:NSUserActivityTypeBrowsingWeb] && userActivity.webpageURL) {
146+ callWithCString([userActivity.webpageURL.absoluteString UTF8String], global_applicationUniversalLink);
147+ return YES;
148+ }
149+ return NO;
150+}
151+
152+@end
153+
154+void runInWKWebView(HsStablePtr handler,
155+ const char * _Nonnull progName,
156+ HsStablePtr hs_willFinishLaunchingWithOptions,
157+ HsStablePtr hs_didFinishLaunchingWithOptions,
158+ HsStablePtr hs_applicationDidBecomeActive,
159+ HsStablePtr hs_applicationWillResignActive,
160+ HsStablePtr hs_applicationDidEnterBackground,
161+ HsStablePtr hs_applicationWillEnterForeground,
162+ HsStablePtr hs_applicationWillTerminate,
163+ HsStablePtr hs_applicationSignificantTimeChange,
164+ HsStablePtr hs_applicationUniversalLink,
165+ HsStablePtr hs_applicationDidReceiveRemoteNotification,
166+ const uint64_t hs_requestAuthorizationWithOptions,
167+ const uint64_t hs_requestAuthorizationOptionBadge,
168+ const uint64_t hs_requestAuthorizationOptionSound,
169+ const uint64_t hs_requestAuthorizationOptionAlert,
170+ const uint64_t hs_requestAuthorizationOptionCarPlay,
171+ const uint64_t hs_registerForRemoteNotifications,
172+ HsStablePtr hs_didRegisterForRemoteNotificationsWithDeviceToken,
173+ HsStablePtr hs_didFailToRegisterForRemoteNotificationsWithError,
174+ const uint64_t hs_developerExtrasEnabled) {
175+ @autoreleasepool {
176+ globalHandler = handler;
177+ global_willFinishLaunchingWithOptions = hs_willFinishLaunchingWithOptions;
178+ global_didFinishLaunchingWithOptions = hs_didFinishLaunchingWithOptions;
179+ global_applicationDidBecomeActive = hs_applicationDidBecomeActive;
180+ global_applicationWillResignActive = hs_applicationWillResignActive;
181+ global_applicationDidEnterBackground = hs_applicationDidEnterBackground;
182+ global_applicationWillEnterForeground = hs_applicationWillEnterForeground;
183+ global_applicationWillTerminate = hs_applicationWillTerminate;
184+ global_applicationSignificantTimeChange = hs_applicationSignificantTimeChange;
185+ global_applicationUniversalLink = hs_applicationUniversalLink;
186+ global_applicationDidReceiveRemoteNotification = hs_applicationDidReceiveRemoteNotification;
187+ global_requestAuthorizationWithOptions = hs_requestAuthorizationWithOptions;
188+ global_requestAuthorizationOptionBadge = hs_requestAuthorizationOptionBadge;
189+ global_requestAuthorizationOptionSound = hs_requestAuthorizationOptionSound;
190+ global_requestAuthorizationOptionAlert = hs_requestAuthorizationOptionAlert;
191+ global_requestAuthorizationOptionCarPlay = hs_requestAuthorizationOptionCarPlay;
192+ global_registerForRemoteNotifications = hs_registerForRemoteNotifications;
193+ global_didRegisterForRemoteNotificationsWithDeviceToken = hs_didRegisterForRemoteNotificationsWithDeviceToken;
194+ global_didFailToRegisterForRemoteNotificationsWithError = hs_didFailToRegisterForRemoteNotificationsWithError;
195+ const char * _Nonnull argv [] = {"", 0};
196+ UIApplicationMain(0, argv, nil, NSStringFromClass([AppDelegate class]));
197+ }
198+}
199+
200+BOOL openApp(NSURL * url) {
201+ UIApplication *app = [UIApplication sharedApplication];
202+ if ([app canOpenURL:url]) {
203+ [app openURL:url];
204+ return true;
205+ }
206+ return false;
207+}
jsaddle-wkwebview/cbits-uikit/ViewController.hnew file+10
@@ -0,0 +1,10 @@
1+#include "HsFFI.h"
2+#import <UIKit/UIKit.h>
3+#import <WebKit/WebKit.h>
4+
5+@interface ViewController : UIViewController
6+@property (nonatomic, assign) HsStablePtr handler;
7+@property (nonatomic, assign) WKWebView *webView;
8+
9+- (instancetype)initWithHandler:(HsStablePtr)handler;
10+@end
jsaddle-wkwebview/cbits-uikit/ViewController.mnew file+40
@@ -0,0 +1,40 @@
1+#import "ViewController.h"
2+
3+extern void callWithWebView(WKWebView *, HsStablePtr);
4+
5+@interface ViewController ()
6+
7+@end
8+
9+@implementation ViewController
10+
11+-(id)initWithHandler:(HsStablePtr)handler {
12+ self = [super init];
13+ if (self) {
14+ _handler = handler;
15+ }
16+ return self;
17+}
18+
19+- (void)loadView {
20+ [super loadView];
21+ // WKWebViewConfiguration *theConfiguration = [[WKWebViewConfiguration alloc] init];
22+ // [theConfiguration.preferences setValue:@YES forKey:@"developerExtrasEnabled"];
23+ _webView = [[WKWebView alloc] init];
24+ _webView.autoresizingMask = UIViewAutoresizingFlexibleWidth | UIViewAutoresizingFlexibleHeight;
25+ self.view = _webView;
26+}
27+
28+- (void)viewDidLoad {
29+ [super viewDidLoad];
30+ callWithWebView(_webView, _handler);
31+}
32+
33+
34+- (void)didReceiveMemoryWarning {
35+ [super didReceiveMemoryWarning];
36+ // Dispose of any resources that can be recreated.
37+}
38+
39+
40+@end
jsaddle-wkwebview/cbits/WKWebView.m+79−10
@@ -2,26 +2,32 @@
2#import <Foundation/Foundation.h>
2#import <Foundation/Foundation.h>
3#import <WebKit/WebKit.h>
3#import <WebKit/WebKit.h>
4
4
5−extern void jsaddleStart(HsStablePtr);
5+BOOL openApp(NSURL * url);
6−extern void jsaddleResult(HsStablePtr, const char * _Nonnull result);
7
6
8−@interface JSaddleHandler : NSObject<WKNavigationDelegate, WKScriptMessageHandler>
7+@interface JSaddleHandler : NSObject<WKNavigationDelegate, WKScriptMessageHandler, WKUIDelegate>
9
8
10@property (nonatomic, assign) HsStablePtr startHandler;
9@property (nonatomic, assign) HsStablePtr startHandler;
11@property (nonatomic, assign) HsStablePtr resultHandler;
10@property (nonatomic, assign) HsStablePtr resultHandler;
11+@property (nonatomic, assign) HsStablePtr syncHandler;
12+@property (nonatomic, assign) void (^completionHandler)(NSString *result);
12
13
13−- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler;
14+- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler syncHandler:(HsStablePtr)syncHandler;
14
15
15@end
16@end
16
17
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+
17@implementation JSaddleHandler
22@implementation JSaddleHandler
18
23
19−- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler
24+- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler syncHandler:(HsStablePtr)syncHandler
20{
25{
21 self = [super init];
26 self = [super init];
22 if (self) {
27 if (self) {
23 _startHandler = startHandler;
28 _startHandler = startHandler;
24 _resultHandler = resultHandler;
29 _resultHandler = resultHandler;
30+ _syncHandler = syncHandler;
25 }
31 }
26 return self;
32 return self;
27}
33}
@@ -37,19 +43,82 @@ extern void jsaddleResult(HsStablePtr, const char * _Nonnull result);
37 jsaddleResult(self.resultHandler, [s UTF8String]);
43 jsaddleResult(self.resultHandler, [s UTF8String]);
38}
44}
39
45
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+
40@end
72@end
41
73
42−void addJSaddleHandler(WKWebView *webView, HsStablePtr startHandler, HsStablePtr resultHandler) {
74+void addJSaddleHandler(WKWebView *webView, HsStablePtr startHandler, HsStablePtr resultHandler, HsStablePtr syncHandler) {
43− JSaddleHandler * handler = [[JSaddleHandler alloc] initHandler:startHandler resultHandler:resultHandler];
75+ JSaddleHandler * handler = [[JSaddleHandler alloc] initHandler:startHandler resultHandler:resultHandler syncHandler:syncHandler];
44 [[[webView configuration] userContentController] addScriptMessageHandler:handler name:@"jsaddle"];
76 [[[webView configuration] userContentController] addScriptMessageHandler:handler name:@"jsaddle"];
77+#ifdef USE_UIKIT
78+ webView.scrollView.bounces = NO;
79+#endif
45 webView.navigationDelegate = handler;
80 webView.navigationDelegate = handler;
81+ webView.UIDelegate = handler;
46}
82}
47
83
48void evaluateJavaScript(WKWebView *webView, const char * _Nonnull js) {
84void evaluateJavaScript(WKWebView *webView, const char * _Nonnull js) {
49− [webView evaluateJavaScript:[NSString stringWithCString:js encoding:NSUTF8StringEncoding] completionHandler:NULL];
85+ NSString *jsString = [[NSString alloc] initWithCString:js encoding:NSUTF8StringEncoding];
86+ dispatch_async(dispatch_get_main_queue(), ^{
87+ [webView evaluateJavaScript:jsString completionHandler:NULL];
88+ [jsString release];
89+ });
90+}
91+
92+void completeSync(JSaddleHandler *handler, const char * _Nonnull s) {
93+ NSString *string = [[NSString alloc] initWithCString:s encoding:NSUTF8StringEncoding];
94+ handler.completionHandler(string);
95+ handler.completionHandler = NULL;
96+}
97+
98+void loadHTMLStringWithBaseURL(WKWebView *webView, const char * _Nonnull html, const char * _Nonnull url) {
99+ NSString *htmlString = [NSString stringWithCString:html encoding:NSUTF8StringEncoding];
100+ NSURL *baseURL = [NSURL URLWithString:[[NSString alloc] initWithCString:url encoding:NSUTF8StringEncoding]];
101+ dispatch_async(dispatch_get_main_queue(), ^{
102+ [webView loadHTMLString:htmlString baseURL:baseURL];
103+ });
50}
104}
51
105
52−void loadHTMLString(WKWebView *webView, const char * _Nonnull html) {
106+const char * mainBundleResourcePathC() {
53− [webView loadHTMLString:[NSString stringWithCString:html encoding:NSUTF8StringEncoding] baseURL:NULL];
107+ NSBundle *main = [NSBundle mainBundle];
108+ if(!main) return NULL;
109+ NSString *path = main.resourcePath;
110+ if(!path) return NULL;
111+ return [path UTF8String];
54}
112}
55
113
114+void loadBundleFile(WKWebView *webView, const char * _Nonnull file, const char * _Nonnull allowing) {
115+ NSBundle *main = [NSBundle mainBundle];
116+ if(main) {
117+ NSString *path = main.resourcePath;
118+ if(path) {
119+ NSURL *fileUrl = [NSURL fileURLWithPath:[NSString stringWithFormat: @"%@/%@", path, [NSString stringWithCString:file encoding:NSUTF8StringEncoding]]];
120+ NSURL *allowingUrl = [NSURL fileURLWithPath:[NSString stringWithFormat: @"%@/%@", path, [NSString stringWithCString:allowing encoding:NSUTF8StringEncoding]]];
121+ [webView loadFileURL:fileUrl allowingReadAccessToURL:allowingUrl];
122+ }
123+ }
124+}
jsaddle-wkwebview/default.nixnew file+14
@@ -0,0 +1,14 @@
1+{ filterSource ? (x: x) }:
2+self: super:
3+let
4+ pkgs = self.callPackage ({pkgs}: pkgs) {};
5+ inherit (pkgs) lib;
6+in
7+with pkgs.haskell.lib;
8+overrideCabal (self.callCabal2nix "jsaddle-wkwebview" (filterSource ./.) {}) (drv: {
9+ libraryFrameworkDepends = (drv.libraryFrameworkDepends or []) ++
10+ (if pkgs.stdenv.hostPlatform.useiOSPrebuilt then [
11+ "${pkgs.buildPackages.darwin.xcode}/Contents/Developer/Platforms/${pkgs.stdenv.hostPlatform.xcodePlatform}.platform/Developer/SDKs/${pkgs.stdenv.hostPlatform.xcodePlatform}.sdk/System"
12+ ] else (with pkgs.buildPackages.darwin.apple_sdk.frameworks; [ Cocoa WebKit ]));
13+ buildDepends = lib.optional (!pkgs.stdenv.hostPlatform.useiOSPrebuilt) [ pkgs.buildPackages.darwin.cf-private ];
14+})
jsaddle-wkwebview/jsaddle-wkwebview.cabal+39−7
@@ -1,5 +1,5 @@
1name: jsaddle-wkwebview
1name: jsaddle-wkwebview
2−version: 0.7.0.0
2+version: 0.9.8.0
3cabal-version: >=1.10
3cabal-version: >=1.10
4build-type: Simple
4build-type: Simple
5license: MIT
5license: MIT
@@ -14,6 +14,10 @@ description:
14category: Web, Javascript
14category: Web, Javascript
15author: Hamish Mackenzie
15author: Hamish Mackenzie
16
16
17+flag include-app-delegate
18+ description: Include default AppDelegate C sources.
19+ default: True
20+
17source-repository head
21source-repository head
18 type: git
22 type: git
19 location: https://github.com/ghcjs/jsaddle
23 location: https://github.com/ghcjs/jsaddle
@@ -22,12 +26,40 @@ library
22 exposed-modules:
26 exposed-modules:
23 Language.Javascript.JSaddle.WKWebView
27 Language.Javascript.JSaddle.WKWebView
24 build-depends:
28 build-depends:
25− aeson >=0.8.0.2 && <1.1,
26− base <5,
29+ base <5
27− bytestring >=0.10.6.0 && <0.11,
28− jsaddle >= 0.7.0.0 && <0.8
29 default-language: Haskell2010
30 default-language: Haskell2010
30 hs-source-dirs: src
31 hs-source-dirs: src
31 ghc-options: -ferror-spans -Wall
32 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:
32− c-sources: cbits/WKWebView.m
51+ cbits/WKWebView.m
33−
52+ cc-options: -Wno-everything
53+ if os(ios)
54+ frameworks: UIKit, UserNotifications
55+ if flag(include-app-delegate)
56+ c-sources:
57+ cbits-uikit/AppDelegate.m
58+ cbits-uikit/ViewController.m
59+ cpp-options: -DUSE_UIKIT
60+ else
61+ frameworks: Cocoa
62+ if flag(include-app-delegate)
63+ c-sources:
64+ cbits-cocoa/AppDelegate.m
65+ cpp-options: -DUSE_COCOA
jsaddle-wkwebview/src-ghc/Language/Javascript/JSaddle/WKWebView.hsnew file+219
@@ -0,0 +1,219 @@
1+module Language.Javascript.JSaddle.WKWebView
2+ ( jsaddleMain
3+ , jsaddleMainHTMLWithBaseURL
4+ , jsaddleMainFile
5+ , WKWebView(..)
6+ , run
7+ , run'
8+ , runWithAppConfig
9+ , runHTMLWithBaseURL
10+ , runFile
11+ , mainBundleResourcePath
12+ , ApplicationState (..)
13+ , AppDelegateConfig (..)
14+ , AppDelegateNotificationConfig (..)
15+ , AuthorizationOption (..)
16+ ) where
17+
18+import Data.ByteString (ByteString)
19+import Data.Default (Default, def)
20+import Data.Set (Set)
21+import qualified Data.Set as Set
22+import Data.Word
23+import Foreign.Marshal.Utils (fromBool)
24+import Language.Javascript.JSaddle.WKWebView.Internal
25+ (jsaddleMain, jsaddleMainHTMLWithBaseURL, jsaddleMainFile, WKWebView(..), mainBundleResourcePath)
26+import System.Environment (getProgName)
27+import Foreign.C.String (CString, withCString)
28+import Foreign.C.Types (CBool, CInt)
29+import Foreign.StablePtr (StablePtr, newStablePtr)
30+import Language.Javascript.JSaddle (JSM)
31+
32+foreign import ccall runInWKWebView
33+ :: StablePtr (WKWebView -> IO ())
34+ -> CString
35+ -> StablePtr (IO ()) -- willFinishLaunchingWithOptions
36+ -> StablePtr (IO ()) -- didFinishLaunchingWithOptions
37+ -> StablePtr (IO ()) -- applicationDidBecomeActive
38+ -> StablePtr (IO ()) -- applicationWillResignActive
39+ -> StablePtr (IO ()) -- applicationDidEnterBackground
40+ -> StablePtr (IO ()) -- applicationWillEnterForeground
41+ -> StablePtr (IO ()) -- applicationWillTerminate
42+ -> StablePtr (IO ()) -- applicationSignificantTimeChange
43+ -> StablePtr (CString -> IO ()) -- applicationUniversalLink
44+ -> StablePtr (CInt -> CString -> IO ()) -- applicationDidReceiveRemoteNotification
45+ -> Word64 -- whether to run requestAuthorizationWithOptions
46+ -> Word64 -- Ask for Badge authorization
47+ -> Word64 -- Ask for Sound authorization
48+ -> Word64 -- Ask for Alert authorization
49+ -> Word64 -- Ask for CarPlay authorization
50+ -> Word64 -- registerForRemoteNotifications
51+ -> StablePtr (CString -> IO ()) -- didRegisterForRemoteNotificationsWithDeviceToken
52+ -> StablePtr (CString -> IO ()) -- didFailToRegisterForRemoteNotificationsWithError
53+ -> Word64 -- developerExtrasEnabled
54+ -> StablePtr (CString -> IO CBool) -- applicationOpenFile
55+ -> IO ()
56+
57+data AppDelegateConfig = AppDelegateConfig
58+ { _appDelegateConfig_willFinishLaunchingWithOptions :: IO ()
59+ , _appDelegateConfig_didFinishLaunchingWithOptions :: IO ()
60+ , _appDelegateConfig_applicationDidBecomeActive :: IO ()
61+ , _appDelegateConfig_applicationWillResignActive :: IO ()
62+ , _appDelegateConfig_applicationDidEnterBackground :: IO ()
63+ , _appDelegateConfig_applicationWillEnterForeground :: IO ()
64+ , _appDelegateConfig_applicationWillTerminate :: IO ()
65+ , _appDelegateConfig_applicationSignificantTimeChange :: IO ()
66+ , _appDelegateConfig_applicationUniversalLink :: CString -> IO ()
67+ -- ^ Called when the app is launched from a URL. 'CString' contains the URL.
68+ --
69+ -- The Core Foundation plist key CFBundleURLTypes controls which URL schemes
70+ -- the app should respond to.
71+ , _appDelegateConfig_applicationDidReceiveRemoteNotification :: ApplicationState -> CString -> IO ()
72+ -- ^ Called when the application receives a remote notification.
73+ -- 'ApplicationState' is the current state of the app.
74+ -- The 'CString' JSON-encoded user info contained in the notification.
75+ -- For more information see https://developer.apple.com/documentation/uikit/uiapplicationdelegate/1623117-application?language=objc
76+ , _appDelegateConfig_appDelegateNotificationConfig :: AppDelegateNotificationConfig
77+ , _appDelegateConfig_developerExtrasEnabled :: Bool
78+ -- ^ Allow devtools in the app. Defaults to 'True'
79+ , _appDelegateConfig_applicationOpenFile :: CString -> IO Bool
80+ -- ^ Called when the app is launched by opening a file. 'CString' contains
81+ -- the file path. Return value is 'True' if the file was successfully
82+ -- opened. Defaults to ignoring the file and returning 'False'.
83+ --
84+ -- The Core Foundation plist key CFBundleDocumentTypes controls which file
85+ -- types should be associated with the app.
86+ }
87+
88+instance Default AppDelegateConfig where
89+ def = AppDelegateConfig
90+ { _appDelegateConfig_willFinishLaunchingWithOptions = return ()
91+ , _appDelegateConfig_didFinishLaunchingWithOptions = return ()
92+ , _appDelegateConfig_applicationDidBecomeActive = return ()
93+ , _appDelegateConfig_applicationWillResignActive = return ()
94+ , _appDelegateConfig_applicationDidEnterBackground = return ()
95+ , _appDelegateConfig_applicationWillEnterForeground = return ()
96+ , _appDelegateConfig_applicationWillTerminate = return ()
97+ , _appDelegateConfig_applicationSignificantTimeChange = return ()
98+ , _appDelegateConfig_applicationUniversalLink = \_ -> return ()
99+ , _appDelegateConfig_applicationDidReceiveRemoteNotification = \_ _ -> return ()
100+ , _appDelegateConfig_appDelegateNotificationConfig = def
101+ , _appDelegateConfig_developerExtrasEnabled = True
102+ , _appDelegateConfig_applicationOpenFile = \_ -> return False
103+ }
104+
105+data AuthorizationOption = AuthorizationOption_Badge
106+ | AuthorizationOption_Sound
107+ | AuthorizationOption_Alert
108+ | AuthorizationOption_CarPlay
109+ deriving (Show, Read, Eq, Ord)
110+
111+data ApplicationState = ApplicationState_Active
112+ | ApplicationState_Inactive
113+ | ApplicationState_Background
114+ | ApplicationState_Unknown CInt
115+ deriving (Show, Read, Eq, Ord)
116+
117+data AppDelegateNotificationConfig = AppDelegateNotificationConfig
118+ { _appDelegateNotificationConfig_requestAuthorizationWithOptions :: Maybe (Set AuthorizationOption)
119+ , _appDelegateNotificationConfig_registerForRemoteNotifications :: Bool
120+ , _appDelegateNotificationConfig_didRegisterForRemoteNotificationsWithDeviceToken :: CString -> IO ()
121+ , _appDelegateNotificationConfig_didFailToRegisterForRemoteNotificationsWithError :: CString -> IO ()
122+ }
123+
124+instance Default AppDelegateNotificationConfig where
125+ def = AppDelegateNotificationConfig
126+ { _appDelegateNotificationConfig_requestAuthorizationWithOptions = Nothing
127+ , _appDelegateNotificationConfig_registerForRemoteNotifications = False
128+ , _appDelegateNotificationConfig_didRegisterForRemoteNotificationsWithDeviceToken = \_ -> return ()
129+ , _appDelegateNotificationConfig_didFailToRegisterForRemoteNotificationsWithError = \_ -> return ()
130+ }
131+
132+
133+-- | Run JSaddle in a WKWebView
134+run :: JSM () -> IO ()
135+run f = run' def (jsaddleMain f)
136+
137+-- | Run JSaddle in a WKWebView
138+runWithAppConfig :: AppDelegateConfig -> JSM () -> IO ()
139+runWithAppConfig cfg = run' cfg . jsaddleMain
140+
141+-- | Run JSaddle in a WKWebView first loading the specified file
142+-- from the mainBundle (relative to the resourcePath).
143+runFile
144+ :: ByteString -- ^ The file to navigate to.
145+ -> ByteString -- ^ The path to allow read access to.
146+ -> AppDelegateConfig
147+ -> JSM ()
148+ -> IO ()
149+runFile url allowing cfg = run' cfg . jsaddleMainFile url allowing
150+
151+-- | Run JSaddle in a WKWebView first loading the specified html
152+-- as though it came from the specified URL
153+-- (calls WKWebKit function loadHTMLString).
154+runHTMLWithBaseURL
155+ :: ByteString -- ^ HTML to load.
156+ -> ByteString -- ^ pretend it came from this URL.
157+ -> AppDelegateConfig
158+ -> JSM ()
159+ -> IO ()
160+runHTMLWithBaseURL url allowing cfg = run' cfg . jsaddleMainHTMLWithBaseURL url allowing
161+
162+run' :: AppDelegateConfig
163+ -> (WKWebView -> IO ())
164+ -> IO ()
165+run' cfg main = do
166+ handler <- newStablePtr main
167+ progName <- getProgName
168+
169+ -- AppDelegate callbacks
170+ willFinishLaunchingWithOptions <- newStablePtr $ _appDelegateConfig_willFinishLaunchingWithOptions cfg
171+ didFinishLaunchingWithOptions <- newStablePtr $ _appDelegateConfig_didFinishLaunchingWithOptions cfg
172+ applicationDidBecomeActive <- newStablePtr $ _appDelegateConfig_applicationDidBecomeActive cfg
173+ applicationWillResignActive <- newStablePtr $ _appDelegateConfig_applicationWillResignActive cfg
174+ applicationDidEnterBackground <- newStablePtr $ _appDelegateConfig_applicationDidEnterBackground cfg
175+ applicationWillEnterForeground <- newStablePtr $ _appDelegateConfig_applicationWillEnterForeground cfg
176+ applicationWillTerminate <- newStablePtr $ _appDelegateConfig_applicationWillTerminate cfg
177+ applicationSignificantTimeChange <- newStablePtr $ _appDelegateConfig_applicationSignificantTimeChange cfg
178+ applicationUniversalLink <- newStablePtr $ _appDelegateConfig_applicationUniversalLink cfg
179+ applicationDidReceiveRemoteNotification <- newStablePtr $ \n s -> do
180+ let appState = case n of
181+ 0 -> ApplicationState_Active
182+ 1 -> ApplicationState_Inactive
183+ 2 -> ApplicationState_Background
184+ _ -> ApplicationState_Unknown n
185+ _appDelegateConfig_applicationDidReceiveRemoteNotification cfg appState s
186+ applicationOpenFile <- newStablePtr $ fmap fromBool . _appDelegateConfig_applicationOpenFile cfg
187+
188+ -- AppDelegate notification configuration
189+ let ncfg = _appDelegateConfig_appDelegateNotificationConfig cfg
190+ (requestAuthorizationWithOptions, authorizationOptions) =
191+ case _appDelegateNotificationConfig_requestAuthorizationWithOptions ncfg of
192+ Nothing -> (False, Set.empty)
193+ Just opts -> (True, opts)
194+ registerForRemoteNotifications = _appDelegateNotificationConfig_registerForRemoteNotifications ncfg
195+ didRegisterForRemoteNotificationsWithDeviceToken <- newStablePtr $ _appDelegateNotificationConfig_didRegisterForRemoteNotificationsWithDeviceToken ncfg
196+ didFailToRegisterForRemoteNotificationsWithError <- newStablePtr $ _appDelegateNotificationConfig_didFailToRegisterForRemoteNotificationsWithError ncfg
197+ withCString progName $ \pn -> runInWKWebView
198+ handler
199+ pn
200+ willFinishLaunchingWithOptions
201+ didFinishLaunchingWithOptions
202+ applicationDidBecomeActive
203+ applicationWillResignActive
204+ applicationDidEnterBackground
205+ applicationWillEnterForeground
206+ applicationWillTerminate
207+ applicationSignificantTimeChange
208+ applicationUniversalLink
209+ applicationDidReceiveRemoteNotification
210+ (fromBool requestAuthorizationWithOptions)
211+ (fromBool $ Set.member AuthorizationOption_Badge authorizationOptions)
212+ (fromBool $ Set.member AuthorizationOption_Sound authorizationOptions)
213+ (fromBool $ Set.member AuthorizationOption_Alert authorizationOptions)
214+ (fromBool $ Set.member AuthorizationOption_CarPlay authorizationOptions)
215+ (fromBool registerForRemoteNotifications)
216+ didRegisterForRemoteNotificationsWithDeviceToken
217+ didFailToRegisterForRemoteNotificationsWithError
218+ (fromBool $ _appDelegateConfig_developerExtrasEnabled cfg)
219+ applicationOpenFile
jsaddle-wkwebview/src-ghcjs/Language/Javascript/JSaddle/WKWebView.hsnew file+7
@@ -0,0 +1,7 @@
1+module Language.Javascript.JSaddle.WKWebView
2+ ( run
3+ ) where
4+
5+run :: IO () -> IO ()
6+run = id
7+{-# INLINE run #-}
jsaddle-wkwebview/src/Language/Javascript/JSaddle/WKWebView.hsdeleted−77
@@ -1,77 +0,0 @@
1−{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}
2−module Language.Javascript.JSaddle.WKWebView
3− ( jsaddleMain
4− , WKWebView(..)
5− ) where
6−
7−import Control.Monad (void, join)
8−import Control.Concurrent (forkIO)
9−
10−import Data.Monoid ((<>))
11−import Data.ByteString (useAsCString, packCString)
12−import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)
13−import Data.Aeson (encode, decode)
14−
15−import Foreign.C.String (CString)
16−import Foreign.Ptr (Ptr)
17−import Foreign.StablePtr (StablePtr, newStablePtr, deRefStablePtr)
18−
19−import Language.Javascript.JSaddle (Result, JSM)
20−import Language.Javascript.JSaddle.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.hsnew file+174
@@ -0,0 +1,174 @@
1+{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}
2+module Language.Javascript.JSaddle.WKWebView.Internal
3+ ( jsaddleMain
4+ , jsaddleMainHTMLWithBaseURL
5+ , jsaddleMainFile
6+ , WKWebView(..)
7+ , mainBundleResourcePath
8+ ) where
9+
10+import Control.Monad (void, join)
11+import Control.Concurrent (forkIO, forkOS)
12+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
13+
14+import Data.Monoid ((<>))
15+import Data.ByteString (useAsCString, packCString)
16+import qualified Data.ByteString as BS (ByteString)
17+import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)
18+import Data.Aeson (encode, decode)
19+import qualified Data.Text as T (pack)
20+import Data.Text.Encoding (encodeUtf8)
21+
22+import Foreign.C.String (CString)
23+import Foreign.C.Types (CBool(..), CInt(..))
24+import Foreign.Ptr (Ptr, nullPtr)
25+import Foreign.StablePtr (StablePtr, newStablePtr, deRefStablePtr)
26+
27+import Language.Javascript.JSaddle (Results, Batch, JSM)
28+import Language.Javascript.JSaddle.Run (runJavaScript)
29+import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
30+
31+import System.Directory (getCurrentDirectory)
32+
33+newtype WKWebView = WKWebView (Ptr WKWebView)
34+newtype JSaddleHandler = JSaddleHandler (Ptr JSaddleHandler)
35+
36+foreign export ccall jsaddleStart :: StablePtr (IO ()) -> IO ()
37+foreign export ccall jsaddleResult :: StablePtr (Results -> IO ()) -> CString -> IO ()
38+foreign export ccall jsaddleSyncResult :: StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()
39+foreign export ccall callWithWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()
40+foreign export ccall callWithCIntCString :: CInt -> CString -> StablePtr (CInt -> CString -> IO ()) -> IO ()
41+foreign export ccall callWithCString :: CString -> StablePtr (CString -> IO ()) -> IO ()
42+foreign export ccall callWithCStringReturningBool :: CString -> StablePtr (CString -> IO CBool) -> IO CBool
43+foreign export ccall callIO :: StablePtr (IO ()) -> IO ()
44+foreign import ccall addJSaddleHandler :: WKWebView -> StablePtr (IO ()) -> StablePtr (Results -> IO ()) -> StablePtr (Results -> IO Batch) -> IO ()
45+foreign import ccall loadHTMLStringWithBaseURL :: WKWebView -> CString -> CString -> IO ()
46+foreign import ccall loadBundleFile :: WKWebView -> CString -> CString -> IO ()
47+foreign import ccall evaluateJavaScript :: WKWebView -> CString -> IO ()
48+foreign import ccall completeSync :: JSaddleHandler -> CString -> IO ()
49+foreign import ccall mainBundleResourcePathC :: IO CString
50+
51+-- | Run JSaddle in WKWebView
52+jsaddleMain :: JSM () -> WKWebView -> IO ()
53+jsaddleMain f webView = do
54+ pwd <- getCurrentDirectory
55+ let baseURL = encodeUtf8 $ "file://" <> T.pack pwd <> "/index.html"
56+ jsaddleMainHTMLWithBaseURL (toStrict indexHtml) baseURL f webView
57+
58+-- | Run JSaddle in WKWebView with initial html and base url
59+jsaddleMainHTMLWithBaseURL
60+ :: BS.ByteString -- ^ HTML
61+ -> BS.ByteString -- ^ Base URL
62+ -> JSM ()
63+ -> WKWebView
64+ -> IO ()
65+jsaddleMainHTMLWithBaseURL initialHTML baseURL f webView =
66+ jsaddleMain' f webView $
67+ useAsCString baseURL $ \url ->
68+ useAsCString initialHTML $ \html ->
69+ loadHTMLStringWithBaseURL webView html url
70+
71+-- | Run JSaddle in a WKWebView first loading the specified file
72+-- from the mainBundle (relative to the resourcePath).
73+jsaddleMainFile :: BS.ByteString -- ^ The file to navigate to.
74+ -> BS.ByteString -- ^ The path to allow read access to.
75+ -> JSM () -> WKWebView -> IO ()
76+jsaddleMainFile url allowing f webView =
77+ jsaddleMain' f webView $
78+ useAsCString url $ \u ->
79+ useAsCString allowing $ \a ->
80+ loadBundleFile webView u a
81+
82+jsaddleMain' :: JSM () -> WKWebView -> IO () -> IO ()
83+jsaddleMain' f webView loadHtml = do
84+ ready <- newEmptyMVar
85+
86+ (processResult, syncResult, start) <- runJavaScript (\batch ->
87+ useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");") $
88+ evaluateJavaScript webView)
89+ f
90+
91+ startHandler <- newStablePtr (putMVar ready ())
92+ resultHandler <- newStablePtr processResult
93+ syncResultHandler <- newStablePtr syncResult
94+ addJSaddleHandler webView startHandler resultHandler syncResultHandler
95+ loadHtml
96+ void . forkOS $ do
97+ takeMVar ready
98+ useAsCString (toStrict jsaddleJs) (evaluateJavaScript webView) >> void (forkIO start)
99+
100+jsaddleStart :: StablePtr (IO ()) -> IO ()
101+jsaddleStart ptrHandler = join (deRefStablePtr ptrHandler)
102+
103+jsaddleResult :: StablePtr (Results -> IO ()) -> CString -> IO ()
104+jsaddleResult ptrHandler s = do
105+ processResult <- deRefStablePtr ptrHandler
106+ result <- packCString s
107+ case decode (fromStrict result) of
108+ Nothing -> error $ "jsaddle Results decode failed : " <> show result
109+ Just r -> processResult r
110+
111+jsaddleSyncResult :: StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()
112+jsaddleSyncResult ptrHandler jsaddleHandler s = do
113+ syncProcessResult <- deRefStablePtr ptrHandler
114+ result <- packCString s
115+ case decode (fromStrict result) of
116+ Nothing -> error $ "jsaddle Results decode failed : " <> show result
117+ Just r -> do -- void . forkIO $ do
118+ batch <- syncProcessResult r
119+ useAsCString (toStrict $ encode batch) $
120+ completeSync jsaddleHandler
121+
122+callWithWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()
123+callWithWebView webView ptrF = do
124+ f <- deRefStablePtr ptrF
125+ f webView
126+
127+callWithCString :: CString -> StablePtr (CString -> IO ()) -> IO ()
128+callWithCString c fptr = do
129+ f <- deRefStablePtr fptr
130+ f c
131+
132+callWithCIntCString :: CInt -> CString -> StablePtr (CInt -> CString -> IO ()) -> IO ()
133+callWithCIntCString n s fptr = do
134+ f <- deRefStablePtr fptr
135+ f n s
136+
137+callWithCStringReturningBool :: CString -> StablePtr (CString -> IO CBool) -> IO CBool
138+callWithCStringReturningBool c fptr = do
139+ f <- deRefStablePtr fptr
140+ f c
141+
142+callIO :: StablePtr (IO ()) -> IO ()
143+callIO ptr = do
144+ f <- deRefStablePtr ptr
145+ f
146+
147+jsaddleJs :: ByteString
148+jsaddleJs = ghcjsHelpers <> "\
149+ \runJSaddleBatch = (function() {\n\
150+ \ " <> initState <> "\n\
151+ \ return function(batch) {\n\
152+ \ " <> runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));\n")
153+ (Just (\a -> "JSON.parse(window.prompt(\"JSaddleSync\", JSON.stringify(" <> a <> ")))")) <> "\
154+ \ };\n\
155+ \})();\n\
156+ \"
157+
158+indexHtml :: ByteString
159+indexHtml =
160+ "<!DOCTYPE html>\n\
161+ \<html>\n\
162+ \<head>\n\
163+ \<title>JSaddle</title>\n\
164+ \</head>\n\
165+ \<body>\n\
166+ \</body>\n\
167+ \</html>"
168+
169+mainBundleResourcePath :: IO (Maybe BS.ByteString)
170+mainBundleResourcePath = do
171+ bs <- mainBundleResourcePathC
172+ if bs == nullPtr
173+ then return Nothing
174+ else Just <$> packCString bs
jsaddle/jsaddle.cabal+61−17
@@ -1,5 +1,5 @@
1name: jsaddle
1name: jsaddle
2−version: 0.7.0.0
2+version: 0.9.8.0
3cabal-version: >=1.10
3cabal-version: >=1.10
4build-type: Simple
4build-type: Simple
5license: MIT
5license: MIT
@@ -10,13 +10,22 @@ description:
10 This package provides an EDSL for calling JavaScript that
10 This package provides an EDSL for calling JavaScript that
11 can be used both from GHCJS and GHC. When using GHC
11 can be used both from GHCJS and GHC. When using GHC
12 the application is run using Warp and WebSockets to
12 the application is run using Warp and WebSockets to
13− drive a small JavaScipt helper.
13+ drive a small JavaScript helper.
14category: Web, Javascript
14category: Web, Javascript
15author: Hamish Mackenzie
15author: Hamish Mackenzie
16
16
17source-repository head
17source-repository head
18 type: git
18 type: git
19 location: https://github.com/ghcjs/jsaddle
19 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
20
29
21library
30library
22
31
@@ -27,36 +36,67 @@ library
27 else
36 else
28 build-depends:
37 build-depends:
29 attoparsec >=0.11 && <0.14,
38 attoparsec >=0.11 && <0.14,
30− containers >=0.5.6.2 && <0.6,
39+ containers >=0.5.6.2 && <0.7,
31 deepseq >=1.3 && < 1.5,
40 deepseq >=1.3 && < 1.5,
32 filepath >=1.4.0.0 && <1.5,
41 filepath >=1.4.0.0 && <1.5,
33 ghc-prim,
42 ghc-prim,
34− http-types >=0.8.6 && <0.10,
43+ http-types >=0.8.6 && <0.13,
35− process >=1.2.3.0 && <1.5,
44+ process >=1.2.3.0 && <1.7,
45+ random >= 1.1 && < 1.3,
36 ref-tf >=0.4.0.1 && <0.5,
46 ref-tf >=0.4.0.1 && <0.5,
37 scientific >=0.3 && <0.4,
47 scientific >=0.3 && <0.4,
38− stm >=2.4.4 && <2.5,
48+ stm >=2.4.4 && <2.6,
39− time >=1.5.0.1 && <1.7,
49+ time >=1.5.0.1 && <1.11,
40 unordered-containers >=0.2 && <0.3,
50 unordered-containers >=0.2 && <0.3,
41− vector >=0.10 && <0.12
51+ vector >=0.10 && <0.13,
52+ unliftio-core >=0.1 && < 0.3
42 exposed-modules:
53 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
43 GHCJS.Marshal
70 GHCJS.Marshal
44 GHCJS.Marshal.Internal
71 GHCJS.Marshal.Internal
45 GHCJS.Marshal.Pure
72 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
46 JavaScript.Array.Internal
84 JavaScript.Array.Internal
85+ JavaScript.Object
47 JavaScript.Object.Internal
86 JavaScript.Object.Internal
87+ Language.Javascript.JSaddle.Debug
48 Language.Javascript.JSaddle.Native
88 Language.Javascript.JSaddle.Native
49 Language.Javascript.JSaddle.Native.Internal
89 Language.Javascript.JSaddle.Native.Internal
90+ Language.Javascript.JSaddle.Null
50 hs-source-dirs: src-ghc
91 hs-source-dirs: src-ghc
51 exposed-modules:
92 exposed-modules:
52 Language.Javascript.JSaddle
93 Language.Javascript.JSaddle
53− Language.Javascript.JSaddle.Array
54 Language.Javascript.JSaddle.Arguments
94 Language.Javascript.JSaddle.Arguments
55 Language.Javascript.JSaddle.Classes
95 Language.Javascript.JSaddle.Classes
56 Language.Javascript.JSaddle.Classes.Internal
96 Language.Javascript.JSaddle.Classes.Internal
57 Language.Javascript.JSaddle.Evaluate
97 Language.Javascript.JSaddle.Evaluate
58 Language.Javascript.JSaddle.Exception
98 Language.Javascript.JSaddle.Exception
59− Language.Javascript.JSaddle.Foreign
99+ Language.Javascript.JSaddle.Helper
60 Language.Javascript.JSaddle.Marshal.String
100 Language.Javascript.JSaddle.Marshal.String
61 Language.Javascript.JSaddle.Monad
101 Language.Javascript.JSaddle.Monad
62 Language.Javascript.JSaddle.Object
102 Language.Javascript.JSaddle.Object
@@ -67,16 +107,20 @@ library
67 Language.Javascript.JSaddle.Value
107 Language.Javascript.JSaddle.Value
68 Language.Javascript.JSaddle.Types
108 Language.Javascript.JSaddle.Types
69 build-depends:
109 build-depends:
70− aeson >=0.8.0.2 && <1.1,
110+ aeson >=0.11.3.0 && <1.6,
71− base <5,
111+ base >=4.9 && <5,
112+ base-compat >=0.9.0 && <0.12,
113+ base64-bytestring >=1.0.0.1 && <1.2,
72 bytestring >=0.10.6.0 && <0.11,
114 bytestring >=0.10.6.0 && <0.11,
115+ exceptions >=0.8 && <0.11,
73− lens >=3.8.5 && <4.16,
116+ lens >=3.8.5 && <5.1,
74− primitive >=0.6.1.0 && <0.7,
117+ primitive >=0.6.1.0 && <0.8,
75− template-haskell -any,
76 text >=1.2.1.3 && <1.3,
118 text >=1.2.1.3 && <1.3,
77 transformers >=0.4.2.0 && <0.6
119 transformers >=0.4.2.0 && <0.6
78 default-language: Haskell2010
120 default-language: Haskell2010
79 hs-source-dirs: src
121 hs-source-dirs: src
80 ghc-options: -ferror-spans -Wall
122 ghc-options: -ferror-spans -Wall
81−
123+ if flag(check-unchecked)
82−
124+ cpp-options: -DCHECK_UNCHECKED
125+ if flag(call-stacks) || flag(check-unchecked)
126+ cpp-options: -DJSADDLE_HAS_CALL_STACK
jsaddle/src-ghc/Data/JSString.hsnew file+1404
@@ -0,0 +1,1404 @@
1+{-# LANGUAGE MagicHash, BangPatterns, UnboxedTuples, TypeFamilies
2+ #-}
3+{-# OPTIONS_GHC -fno-warn-orphans #-}
4+{-| Manipulation of JavaScript strings, API and fusion implementation
5+ based on Data.Text by Tom Harper, Duncan Coutts, Bryan O'Sullivan e.a.
6+ -}
7+module Data.JSString ( JSString
8+
9+ -- * Creation and elimination
10+ , pack
11+ , unpack, unpack'
12+ , singleton
13+ , empty
14+
15+ -- * Basic interface
16+ , cons
17+ , snoc
18+ , append
19+ , uncons
20+ , head
21+ , last
22+ , tail
23+ , init
24+ , null
25+ , length
26+ , compareLength
27+
28+ -- * Transformations
29+ , map
30+ , intercalate
31+ , intersperse
32+ , transpose
33+ , reverse
34+ , replace
35+
36+ -- ** Case conversion
37+ , toCaseFold
38+ , toLower
39+ , toUpper
40+ , toTitle
41+
42+ -- ** Justification
43+ , justifyLeft
44+ , justifyRight
45+ , center
46+
47+ -- * Folds
48+ , foldl
49+ , foldl'
50+ , foldl1
51+ , foldl1'
52+ , foldr
53+ , foldr1
54+
55+ -- ** Special folds
56+ , concat
57+ , concatMap
58+ , any
59+ , all
60+ , maximum
61+ , minimum
62+
63+ -- * Construction
64+
65+ -- ** Scans
66+ , scanl
67+ , scanl1
68+ , scanr
69+ , scanr1
70+
71+ -- ** Accumulating maps
72+ , mapAccumL
73+ , mapAccumR
74+
75+ -- ** Generation and unfolding
76+ , replicate
77+ , unfoldr
78+ , unfoldrN
79+
80+ -- * Substrings
81+
82+ -- ** Breaking strings
83+ , take
84+ , takeEnd
85+ , drop
86+ , dropEnd
87+ , takeWhile
88+ , dropWhile
89+ , dropWhileEnd
90+ , dropAround
91+ , strip
92+ , stripStart
93+ , stripEnd
94+ , splitAt
95+ , breakOn
96+ , breakOnEnd
97+ , break
98+ , span
99+ , group
100+ , group'
101+ , groupBy
102+ , inits
103+ , tails
104+
105+ -- ** Breaking into many substrings
106+ , splitOn, splitOn'
107+ , split
108+ , chunksOf, chunksOf'
109+
110+ -- ** Breaking into lines and words
111+ , lines, lines'
112+ , words, words'
113+ , unlines
114+ , unwords
115+
116+ -- * Predicates
117+ , isPrefixOf
118+ , isSuffixOf
119+ , isInfixOf
120+
121+ -- ** View patterns
122+ , stripPrefix
123+ , stripSuffix
124+ , commonPrefixes
125+
126+ -- * Searching
127+ , filter
128+ , breakOnAll, breakOnAll'
129+ , find
130+ , partition
131+
132+ -- * Indexing
133+ , index
134+ , findIndex
135+ , count
136+
137+ -- * Zipping
138+ , zip
139+ , zipWith
140+ ) where
141+
142+import Prelude
143+ ( Char, Bool(..), Int, Maybe(..), String, Eq(..), Ord(..), Ordering(..), (++)
144+ , Read(..), Show(..), (&&), (||), (+), (-), (.), ($), ($!), (>>)
145+ , not, seq, return, otherwise, quot)
146+import qualified Prelude as P
147+
148+import Control.DeepSeq (NFData(..))
149+import Data.Char (isSpace)
150+import Data.Coerce (coerce)
151+import qualified Data.List as L
152+import Data.Data
153+import qualified Data.Text as T
154+import qualified Data.Text.Internal.Fusion as TF
155+import qualified Data.Text.Internal.Fusion.Common as TF
156+
157+import GHC.Exts
158+ ( Int#, (+#), (-#), (>=#), (>#), isTrue#, chr#, Char(..)
159+ , Int(..), Addr#, tagToEnum#)
160+import qualified GHC.Exts as Exts
161+import qualified GHC.CString as GHC
162+
163+import Unsafe.Coerce
164+
165+import GHCJS.Prim (JSVal)
166+
167+import Data.JSString.Internal.Type
168+import Data.JSString.Internal.Fusion (stream, unstream)
169+import qualified Data.JSString.Internal.Fusion as S
170+import qualified Data.JSString.Internal.Fusion.Common as S
171+
172+instance Exts.IsList JSString where
173+ type Item JSString = Char
174+ fromList = pack
175+ toList = unpack
176+
177+-- -----------------------------------------------------------------------------
178+-- * Conversion to/from 'JSString'
179+
180+-- | /O(n)/ Convert a 'String' into a 'JSString'. Subject to
181+-- fusion.
182+pack :: String -> JSString
183+pack = coerce T.pack
184+{-# INLINE [1] pack #-}
185+
186+{-# RULES
187+"JSSTRING pack -> fused" [~1] forall x.
188+ pack x = unstream (S.map safe (S.streamList x))
189+"JSSTRING pack -> unfused" [1] forall x.
190+ unstream (S.map safe (S.streamList x)) = pack x
191+ #-}
192+
193+-- | /O(n)/ Convert a 'JSString' into a 'String'. Subject to fusion.
194+unpack :: JSString -> String
195+unpack = S.unstreamList . stream
196+{-# INLINE [1] unpack #-}
197+
198+unpack' :: JSString -> String
199+unpack' = coerce T.unpack
200+{-# INLINE unpack' #-}
201+
202+-- | /O(n)/ Convert a literal string into a JSString. Subject to fusion.
203+unpackCString# :: Addr# -> JSString
204+unpackCString# = coerce T.unpackCString#
205+{-# NOINLINE unpackCString# #-}
206+
207+{-# RULES "JSSTRING literal" forall a.
208+ unstream (S.map safe (S.streamList (GHC.unpackCString# a)))
209+ = unpackCString# a #-}
210+
211+{-# RULES "JSSTRING literal UTF8" forall a.
212+ unstream (S.map safe (S.streamList (GHC.unpackCStringUtf8# a)))
213+ = unpackCString# a #-}
214+
215+{-# RULES "JSSTRING empty literal"
216+ unstream (S.map safe (S.streamList []))
217+ = empty_ #-}
218+
219+{-# RULES "JSSTRING singleton literal" forall a.
220+ unstream (S.map safe (S.streamList [a]))
221+ = singleton a #-}
222+
223+
224+-- | /O(1)/ Convert a character into a 'JSString'. Subject to fusion.
225+-- Performs replacement on invalid scalar values.
226+singleton :: Char -> JSString
227+singleton = coerce T.singleton
228+{-# INLINE [1] singleton #-}
229+
230+{-# RULES
231+"JSSTRING singleton -> fused" [~1] forall a.
232+ singleton a = unstream (S.singleton (safe a))
233+"JSSTRING singleton -> unfused" [1] forall a.
234+ unstream (S.singleton (safe a)) = singleton a
235+ #-}
236+
237+-- This is intended to reduce inlining bloat.
238+-- singleton_ :: Char -> Text
239+-- singleton_ c = js_singleton c
240+
241+-- Text (A.run x) 0 len
242+-- where x :: ST s (A.MArray s)
243+-- x = do arr <- A.new len
244+-- _ <- unsafeWrite arr 0 d
245+-- return arr
246+-- len | d < '\x10000' = 1
247+-- x | otherwise = 2
248+-- d = safe c
249+-- {-# NOINLINE singleton_ #-}
250+
251+-- -----------------------------------------------------------------------------
252+-- * Basic functions
253+
254+-- | /O(n)/ Adds a character to the front of a 'JSString'. This function
255+-- is more costly than its 'List' counterpart because it requires
256+-- copying a new array. Subject to fusion. Performs replacement on
257+-- invalid scalar values.
258+cons :: Char -> JSString -> JSString
259+cons = coerce T.cons
260+{-# INLINE [1] cons #-}
261+
262+{-# RULES
263+"JSSTRING cons -> fused" [~1] forall c x.
264+ cons c x = unstream (S.cons (safe c) (stream x))
265+"JSSTRING cons -> unfused" [1] forall c x.
266+ unstream (S.cons (safe c) (stream x)) = cons c x
267+ #-}
268+
269+infixr 5 `cons`
270+
271+-- | /O(n)/ Adds a character to the end of a 'JSString'. This copies the
272+-- entire array in the process, unless fused. Subject to fusion.
273+-- Performs replacement on invalid scalar values.
274+snoc :: JSString -> Char -> JSString
275+snoc = coerce T.snoc
276+ -- unstream (S.snoc (stream t) (safe c))
277+{-# INLINE [1] snoc #-}
278+
279+{-# RULES
280+"JSSTRING snoc -> fused" [~1] forall x c.
281+ snoc x c = unstream (S.snoc (stream x) (safe c))
282+"JSSTRING snoc -> unfused" [1] forall x c.
283+ unstream (S.snoc (stream x) (safe c)) = snoc x c
284+ #-}
285+
286+-- | /O(n)/ Appends one 'JSString' to the other by copying both of them
287+-- into a new 'JSString'. Subject to fusion.
288+append :: JSString -> JSString -> JSString
289+append = coerce T.append
290+{-# INLINE [1] append #-}
291+
292+{-# RULES
293+"JSSTRING append -> fused" [~1] forall x1 x2.
294+ append x1 x2 = unstream (S.append (stream x1) (stream x2))
295+"JSSTRING append -> unfused" [1] forall x1 x2.
296+ unstream (S.append (stream x1) (stream x2)) = append x1 x2
297+ #-}
298+
299+-- | /O(1)/ Returns the first character of a 'JSString', which must be
300+-- non-empty. Subject to fusion.
301+head :: JSString -> Char
302+head = coerce T.head
303+{-# INLINE [1] head #-}
304+
305+{-# RULES
306+"JSSTRING head -> fused" [~1] forall x.
307+ head x = S.head (stream x)
308+"JSSTRING head -> unfused" [1] forall x.
309+ S.head (stream x) = head x
310+ #-}
311+
312+
313+-- | /O(1)/ Returns the first character and rest of a 'JSString', or
314+-- 'Nothing' if empty. Subject to fusion.
315+uncons :: JSString -> Maybe (Char, JSString)
316+uncons = coerce T.uncons
317+{-# INLINE [1] uncons #-}
318+
319+-- | Lifted from Control.Arrow and specialized.
320+second :: (b -> c) -> (a,b) -> (a,c)
321+second f (a, b) = (a, f b)
322+
323+-- | /O(1)/ Returns the last character of a 'JSString', which must be
324+-- non-empty. Subject to fusion.
325+last :: JSString -> Char
326+last = coerce T.last
327+{-# INLINE [1] last #-}
328+
329+{-# RULES
330+"JSSTRING last -> fused" [~1] forall x.
331+ last x = S.last (stream x)
332+"JSSTRING last -> unfused" [1] forall x.
333+ S.last (stream x) = last x
334+ #-}
335+
336+-- | /O(1)/ Returns all characters after the head of a 'JSString', which
337+-- must be non-empty. Subject to fusion.
338+tail :: JSString -> JSString
339+tail = coerce T.tail
340+{-# INLINE [1] tail #-}
341+
342+{-# RULES
343+"JSSTRING tail -> fused" [~1] forall x.
344+ tail x = unstream (S.tail (stream x))
345+"JSSTRING tail -> unfused" [1] forall x.
346+ unstream (S.tail (stream x)) = tail x
347+ #-}
348+
349+-- | /O(1)/ Returns all but the last character of a 'JSString', which must
350+-- be non-empty. Subject to fusion.
351+init :: JSString -> JSString
352+init = coerce T.init
353+{-# INLINE [1] init #-}
354+
355+{-# RULES
356+"JSSTRING init -> fused" [~1] forall t.
357+ init t = unstream (S.init (stream t))
358+"JSSTRING init -> unfused" [1] forall t.
359+ unstream (S.init (stream t)) = init t
360+ #-}
361+
362+-- | /O(1)/ Tests whether a 'JSString' is empty or not. Subject to
363+-- fusion.
364+null :: JSString -> Bool
365+null = coerce T.null
366+{-# INLINE [1] null #-}
367+
368+{-# RULES
369+"JSSTRING null -> fused" [~1] forall t.
370+ null t = S.null (stream t)
371+"JSSTRING null -> unfused" [1] forall t.
372+ S.null (stream t) = null t
373+ #-}
374+
375+-- | /O(n)/ Returns the number of characters in a 'JSString'.
376+-- Subject to fusion.
377+length :: JSString -> Int
378+length = coerce T.length
379+{-# INLINE [1] length #-}
380+
381+{-# RULES
382+"JSSTRING length -> fused" [~1] forall x.
383+ length x = S.length (stream x)
384+"JSSTRING length -> unfused" [1] forall x.
385+ S.length (stream x) = length x
386+ #-}
387+
388+-- | /O(n)/ Compare the count of characters in a 'JSString' to a number.
389+-- Subject to fusion.
390+--
391+-- This function gives the same answer as comparing against the result
392+-- of 'length', but can short circuit if the count of characters is
393+-- greater than the number, and hence be more efficient.
394+compareLength :: JSString -> Int -> Ordering
395+compareLength = coerce T.compareLength
396+{-# INLINE [1] compareLength #-}
397+
398+{-# RULES
399+"JSSTRING compareN/length -> compareLength" [~1] forall t n.
400+ compare (length t) n = compareLength t n
401+ #-}
402+
403+{-# RULES
404+"JSSTRING ==N/length -> compareLength/==EQ" [~1] forall t n.
405+ (==) (length t) n = compareLength t n == EQ
406+ #-}
407+
408+{-# RULES
409+"JSSTRING /=N/length -> compareLength//=EQ" [~1] forall t n.
410+ (/=) (length t) n = compareLength t n /= EQ
411+ #-}
412+
413+{-# RULES
414+"JSSTRING <N/length -> compareLength/==LT" [~1] forall t n.
415+ (<) (length t) n = compareLength t n == LT
416+ #-}
417+
418+{-# RULES
419+"JSSTRING <=N/length -> compareLength//=GT" [~1] forall t n.
420+ (<=) (length t) n = compareLength t n /= GT
421+ #-}
422+
423+{-# RULES
424+"JSSTRING >N/length -> compareLength/==GT" [~1] forall t n.
425+ (>) (length t) n = compareLength t n == GT
426+ #-}
427+
428+{-# RULES
429+"JSSTRING >=N/length -> compareLength//=LT" [~1] forall t n.
430+ (>=) (length t) n = compareLength t n /= LT
431+ #-}
432+
433+-- -----------------------------------------------------------------------------
434+-- * Transformations
435+-- | /O(n)/ 'map' @f@ @t@ is the 'JSString' obtained by applying @f@ to
436+-- each element of @t@. Subject to fusion. Performs replacement on
437+-- invalid scalar values.
438+map :: (Char -> Char) -> JSString -> JSString
439+map = coerce T.map
440+{-# INLINE [1] map #-}
441+
442+-- | /O(n)/ The 'intercalate' function takes a 'JSString' and a list of
443+-- 'JSString's and concatenates the list after interspersing the first
444+-- argument between each element of the list.
445+intercalate :: JSString -> [JSString] -> JSString
446+intercalate = coerce T.intercalate
447+{-# INLINE [1] intercalate #-}
448+
449+-- | /O(n)/ The 'intersperse' function takes a character and places it
450+-- between the characters of a 'JSString'. Subject to fusion. Performs
451+-- replacement on invalid scalar values.
452+intersperse :: Char -> JSString -> JSString
453+intersperse = coerce T.intersperse
454+{-# INLINE [1] intersperse #-}
455+
456+{-# RULES
457+"JSSTRING intersperse -> fused" [~1] forall c x.
458+ intersperse c x = unstream (S.intersperse (safe c) (stream x))
459+"JSSTRING intersperse -> unfused" [1] forall c x.
460+ unstream (S.intersperse (safe c) (stream x)) = intersperse c x
461+ #-}
462+
463+-- | /O(n)/ Reverse the characters of a string. Subject to fusion.
464+reverse :: JSString -> JSString
465+reverse = coerce T.reverse
466+{-# INLINE [1] reverse #-}
467+
468+{-# RULES
469+"JSSTRING reverse -> fused" [~1] forall x.
470+ reverse x = S.reverse (stream x)
471+"JSSTRING reverse -> unfused" [1] forall x.
472+ S.reverse (stream x) = reverse x
473+ #-}
474+
475+-- | /O(m+n)/ Replace every non-overlapping occurrence of @needle@ in
476+-- @haystack@ with @replacement@.
477+--
478+-- This function behaves as though it was defined as follows:
479+--
480+-- @
481+-- replace needle replacement haystack =
482+-- 'intercalate' replacement ('splitOn' needle haystack)
483+-- @
484+--
485+-- As this suggests, each occurrence is replaced exactly once. So if
486+-- @needle@ occurs in @replacement@, that occurrence will /not/ itself
487+-- be replaced recursively:
488+--
489+-- > replace "oo" "foo" "oo" == "foo"
490+--
491+-- In cases where several instances of @needle@ overlap, only the
492+-- first one will be replaced:
493+--
494+-- > replace "ofo" "bar" "ofofo" == "barfo"
495+--
496+-- In (unlikely) bad cases, this function's time complexity degrades
497+-- towards /O(n*m)/.
498+replace :: JSString
499+ -- ^ @needle@ to search for. If this string is empty, an
500+ -- error will occur.
501+ -> JSString
502+ -- ^ @replacement@ to replace @needle@ with.
503+ -> JSString
504+ -- ^ @haystack@ in which to search.
505+ -> JSString
506+replace = coerce T.replace
507+{-# INLINE replace #-}
508+
509+-- ----------------------------------------------------------------------------
510+-- ** Case conversions (folds)
511+
512+-- $case
513+--
514+-- When case converting 'JSString' values, do not use combinators like
515+-- @map toUpper@ to case convert each character of a string
516+-- individually, as this gives incorrect results according to the
517+-- rules of some writing systems. The whole-string case conversion
518+-- functions from this module, such as @toUpper@, obey the correct
519+-- case conversion rules. As a result, these functions may map one
520+-- input character to two or three output characters. For examples,
521+-- see the documentation of each function.
522+--
523+-- /Note/: In some languages, case conversion is a locale- and
524+-- context-dependent operation. The case conversion functions in this
525+-- module are /not/ locale sensitive. Programs that require locale
526+-- sensitivity should use appropriate versions of the
527+-- <http://hackage.haskell.org/package/text-icu-0.6.3.7/docs/Data-Text-ICU.html#g:4 case mapping functions from the text-icu package >.
528+
529+-- | /O(n)/ Convert a string to folded case. Subject to fusion.
530+--
531+-- This function is mainly useful for performing caseless (also known
532+-- as case insensitive) string comparisons.
533+--
534+-- A string @x@ is a caseless match for a string @y@ if and only if:
535+--
536+-- @toCaseFold x == toCaseFold y@
537+--
538+-- The result string may be longer than the input string, and may
539+-- differ from applying 'toLower' to the input string. For instance,
540+-- the Armenian small ligature \"&#xfb13;\" (men now, U+FB13) is case
541+-- folded to the sequence \"&#x574;\" (men, U+0574) followed by
542+-- \"&#x576;\" (now, U+0576), while the Greek \"&#xb5;\" (micro sign,
543+-- U+00B5) is case folded to \"&#x3bc;\" (small letter mu, U+03BC)
544+-- instead of itself.
545+toCaseFold :: JSString -> JSString
546+toCaseFold = coerce T.toCaseFold
547+{-# INLINE [0] toCaseFold #-}
548+
549+-- | /O(n)/ Convert a string to lower case, using simple case
550+-- conversion. Subject to fusion.
551+--
552+-- The result string may be longer than the input string. For
553+-- instance, \"&#x130;\" (Latin capital letter I with dot above,
554+-- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069)
555+-- followed by \" &#x307;\" (combining dot above, U+0307).
556+toLower :: JSString -> JSString
557+toLower = coerce T.toLower
558+{-# INLINE [1] toLower #-}
559+
560+{-# RULES
561+"JSSTRING toLower -> fused" [~1] forall x.
562+ toLower x = unstream (S.toLower (stream x))
563+"JSSTRING toLower -> unfused" [1] forall x.
564+ unstream (S.toLower (stream x)) = toLower x
565+ #-}
566+
567+-- | /O(n)/ Convert a string to upper case, using simple case
568+-- conversion. Subject to fusion.
569+--
570+-- The result string may be longer than the input string. For
571+-- instance, the German \"&#xdf;\" (eszett, U+00DF) maps to the
572+-- two-letter sequence \"SS\".
573+toUpper :: JSString -> JSString
574+toUpper = coerce T.toUpper
575+{-# INLINE [1] toUpper #-}
576+
577+{-# RULES
578+"JSSTRING toUpper -> fused" [~1] forall x.
579+ toUpper x = unstream (S.toUpper(stream x))
580+"JSSTRING toUpper -> unfused" [1] forall x.
581+ unstream (S.toUpper (stream x)) = toUpper x
582+ #-}
583+
584+-- | /O(n)/ Convert a string to title case, using simple case
585+-- conversion. Subject to fusion.
586+--
587+-- The first letter of the input is converted to title case, as is
588+-- every subsequent letter that immediately follows a non-letter.
589+-- Every letter that immediately follows another letter is converted
590+-- to lower case.
591+--
592+-- The result string may be longer than the input string. For example,
593+-- the Latin small ligature &#xfb02; (U+FB02) is converted to the
594+-- sequence Latin capital letter F (U+0046) followed by Latin small
595+-- letter l (U+006C).
596+--
597+-- /Note/: this function does not take language or culture specific
598+-- rules into account. For instance, in English, different style
599+-- guides disagree on whether the book name \"The Hill of the Red
600+-- Fox\" is correctly title cased&#x2014;but this function will
601+-- capitalize /every/ word.
602+toTitle :: JSString -> JSString
603+toTitle = coerce T.toTitle
604+{-# INLINE toTitle #-}
605+
606+-- | /O(n)/ Left-justify a string to the given length, using the
607+-- specified fill character on the right. Subject to fusion.
608+-- Performs replacement on invalid scalar values.
609+--
610+-- Examples:
611+--
612+-- > justifyLeft 7 'x' "foo" == "fooxxxx"
613+-- > justifyLeft 3 'x' "foobar" == "foobar"
614+justifyLeft :: Int -> Char -> JSString -> JSString
615+justifyLeft = coerce T.justifyLeft
616+{-# INLINE [1] justifyLeft #-}
617+
618+{-# RULES
619+"JSSTRING justifyLeft -> fused" [~1] forall k c t.
620+ justifyLeft k c t = unstream (S.justifyLeftI k c (stream t))
621+"JSSTRING justifyLeft -> unfused" [1] forall k c t.
622+ unstream (S.justifyLeftI k c (stream t)) = justifyLeft k c t
623+ #-}
624+
625+-- | /O(n)/ Right-justify a string to the given length, using the
626+-- specified fill character on the left. Performs replacement on
627+-- invalid scalar values.
628+--
629+-- Examples:
630+--
631+-- > justifyRight 7 'x' "bar" == "xxxxbar"
632+-- > justifyRight 3 'x' "foobar" == "foobar"
633+justifyRight :: Int -> Char -> JSString -> JSString
634+justifyRight = coerce T.justifyRight
635+{-# INLINE justifyRight #-}
636+
637+-- | /O(n)/ Center a string to the given length, using the specified
638+-- fill character on either side. Performs replacement on invalid
639+-- scalar values.
640+--
641+-- Examples:
642+--
643+-- > center 8 'x' "HS" = "xxxHSxxx"
644+center :: Int -> Char -> JSString -> JSString
645+center = coerce T.center
646+{-# INLINE center #-}
647+
648+-- | /O(n)/ The 'transpose' function transposes the rows and columns
649+-- of its 'JSString' argument. Note that this function uses 'pack',
650+-- 'unpack', and the list version of transpose, and is thus not very
651+-- efficient.
652+transpose :: [JSString] -> [JSString]
653+transpose = coerce T.transpose
654+
655+-- -----------------------------------------------------------------------------
656+-- * Reducing 'JSString's (folds)
657+
658+-- | /O(n)/ 'foldl', applied to a binary operator, a starting value
659+-- (typically the left-identity of the operator), and a 'JSString',
660+-- reduces the 'JSString' using the binary operator, from left to right.
661+-- Subject to fusion.
662+foldl :: (a -> Char -> a) -> a -> JSString -> a
663+foldl f = coerce (T.foldl f)
664+{-# INLINE foldl #-}
665+
666+-- | /O(n)/ A strict version of 'foldl'. Subject to fusion.
667+foldl' :: (a -> Char -> a) -> a -> JSString -> a
668+foldl' f = coerce (T.foldl' f)
669+{-# INLINE foldl' #-}
670+
671+-- | /O(n)/ A variant of 'foldl' that has no starting value argument,
672+-- and thus must be applied to a non-empty 'JSString'. Subject to fusion.
673+foldl1 :: (Char -> Char -> Char) -> JSString -> Char
674+foldl1 = coerce T.foldl1
675+{-# INLINE foldl1 #-}
676+
677+-- | /O(n)/ A strict version of 'foldl1'. Subject to fusion.
678+foldl1' :: (Char -> Char -> Char) -> JSString -> Char
679+foldl1' = coerce T.foldl1'
680+{-# INLINE foldl1' #-}
681+
682+-- | /O(n)/ 'foldr', applied to a binary operator, a starting value
683+-- (typically the right-identity of the operator), and a 'JSString',
684+-- reduces the 'JSString' using the binary operator, from right to left.
685+-- Subject to fusion.
686+foldr :: (Char -> a -> a) -> a -> JSString -> a
687+foldr f = coerce (T.foldr f)
688+{-# INLINE foldr #-}
689+
690+-- | /O(n)/ A variant of 'foldr' that has no starting value argument,
691+-- and thus must be applied to a non-empty 'JSString'. Subject to
692+-- fusion.
693+foldr1 :: (Char -> Char -> Char) -> JSString -> Char
694+foldr1 = coerce T.foldr1
695+{-# INLINE foldr1 #-}
696+
697+-- -----------------------------------------------------------------------------
698+-- ** Special folds
699+
700+-- | /O(n)/ Concatenate a list of 'JSString's.
701+concat :: [JSString] -> JSString
702+concat = coerce T.concat
703+
704+-- | /O(n)/ Map a function over a 'JSString' that results in a 'JSString', and
705+-- concatenate the results.
706+concatMap :: (Char -> JSString) -> JSString -> JSString
707+concatMap = coerce T.concatMap
708+{-# INLINE concatMap #-}
709+
710+-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the
711+-- 'JSString' @t@ satisifes the predicate @p@. Subject to fusion.
712+any :: (Char -> Bool) -> JSString -> Bool
713+any = coerce T.any
714+{-# INLINE any #-}
715+
716+-- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the
717+-- 'JSString' @t@ satisify the predicate @p@. Subject to fusion.
718+all :: (Char -> Bool) -> JSString -> Bool
719+all = coerce T.all
720+{-# INLINE all #-}
721+
722+-- | /O(n)/ 'maximum' returns the maximum value from a 'JSString', which
723+-- must be non-empty. Subject to fusion.
724+maximum :: JSString -> Char
725+maximum = coerce T.maximum
726+{-# INLINE maximum #-}
727+
728+-- | /O(n)/ 'minimum' returns the minimum value from a 'JSString', which
729+-- must be non-empty. Subject to fusion.
730+minimum :: JSString -> Char
731+minimum = coerce T.minimum
732+{-# INLINE minimum #-}
733+
734+-- -----------------------------------------------------------------------------
735+-- * Building 'JSString's
736+
737+-- | /O(n)/ 'scanl' is similar to 'foldl', but returns a list of
738+-- successive reduced values from the left. Subject to fusion.
739+-- Performs replacement on invalid scalar values.
740+--
741+-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
742+--
743+-- Note that
744+--
745+-- > last (scanl f z xs) == foldl f z xs.
746+scanl :: (Char -> Char -> Char) -> Char -> JSString -> JSString
747+scanl = coerce T.scanl
748+{-# INLINE scanl #-}
749+
750+-- | /O(n)/ 'scanl1' is a variant of 'scanl' that has no starting
751+-- value argument. Subject to fusion. Performs replacement on
752+-- invalid scalar values.
753+--
754+-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
755+scanl1 :: (Char -> Char -> Char) -> JSString -> JSString
756+scanl1 = coerce T.scanl1
757+{-# INLINE scanl1 #-}
758+
759+-- | /O(n)/ 'scanr' is the right-to-left dual of 'scanl'. Performs
760+-- replacement on invalid scalar values.
761+--
762+-- > scanr f v == reverse . scanl (flip f) v . reverse
763+scanr :: (Char -> Char -> Char) -> Char -> JSString -> JSString
764+scanr = coerce T.scanr
765+{-# INLINE scanr #-}
766+
767+-- | /O(n)/ 'scanr1' is a variant of 'scanr' that has no starting
768+-- value argument. Subject to fusion. Performs replacement on
769+-- invalid scalar values.
770+scanr1 :: (Char -> Char -> Char) -> JSString -> JSString
771+scanr1 = coerce T.scanr1
772+{-# INLINE scanr1 #-}
773+
774+-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a
775+-- function to each element of a 'JSString', passing an accumulating
776+-- parameter from left to right, and returns a final 'JSString'. Performs
777+-- replacement on invalid scalar values.
778+mapAccumL :: (a -> Char -> (a,Char)) -> a -> JSString -> (a, JSString)
779+mapAccumL f = coerce (T.mapAccumL f)
780+{-# INLINE mapAccumL #-}
781+
782+-- | The 'mapAccumR' function behaves like a combination of 'map' and
783+-- a strict 'foldr'; it applies a function to each element of a
784+-- 'JSString', passing an accumulating parameter from right to left, and
785+-- returning a final value of this accumulator together with the new
786+-- 'JSString'.
787+-- Performs replacement on invalid scalar values.
788+mapAccumR :: (a -> Char -> (a,Char)) -> a -> JSString -> (a, JSString)
789+mapAccumR f = coerce (T.mapAccumR f)
790+{-# INLINE mapAccumR #-}
791+
792+-- -----------------------------------------------------------------------------
793+-- ** Generating and unfolding 'JSString's
794+
795+-- | /O(n*m)/ 'replicate' @n@ @t@ is a 'JSString' consisting of the input
796+-- @t@ repeated @n@ times.
797+replicate :: Int -> JSString -> JSString
798+replicate = coerce T.replicate
799+{-# INLINE [1] replicate #-}
800+
801+-- | /O(n)/, where @n@ is the length of the result. The 'unfoldr'
802+-- function is analogous to the List 'L.unfoldr'. 'unfoldr' builds a
803+-- 'JSString' from a seed value. The function takes the element and
804+-- returns 'Nothing' if it is done producing the 'JSString', otherwise
805+-- 'Just' @(a,b)@. In this case, @a@ is the next 'Char' in the
806+-- string, and @b@ is the seed value for further production. Subject
807+-- to fusion. Performs replacement on invalid scalar values.
808+unfoldr :: (a -> Maybe (Char,a)) -> a -> JSString
809+unfoldr f = coerce (T.unfoldr f)
810+{-# INLINE unfoldr #-}
811+
812+-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a 'JSString' from a seed
813+-- value. However, the length of the result should be limited by the
814+-- first argument to 'unfoldrN'. This function is more efficient than
815+-- 'unfoldr' when the maximum length of the result is known and
816+-- correct, otherwise its performance is similar to 'unfoldr'. Subject
817+-- to fusion. Performs replacement on invalid scalar values.
818+unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> JSString
819+unfoldrN n f = coerce (T.unfoldrN n f)
820+{-# INLINE unfoldrN #-}
821+
822+-- -----------------------------------------------------------------------------
823+-- * Substrings
824+
825+-- | /O(n)/ 'take' @n@, applied to a 'JSString', returns the prefix of the
826+-- 'JSString' of length @n@, or the 'JSString' itself if @n@ is greater than
827+-- the length of the JSString. Subject to fusion.
828+take :: Int -> JSString -> JSString
829+take = coerce T.take
830+{-# INLINE [1] take #-}
831+{-
832+iterN :: Int -> JSString -> Int
833+iterN n t@(Text _arr _off len) = loop 0 0
834+ where loop !i !cnt
835+ | i >= len || cnt >= n = i
836+ | otherwise = loop (i+d) (cnt+1)
837+ where d = iter_ t i
838+-}
839+{-# RULES
840+"JSSTRING take -> fused" [~1] forall n t.
841+ take n t = unstream (S.take n (stream t))
842+"JSSTRING take -> unfused" [1] forall n t.
843+ unstream (S.take n (stream t)) = take n t
844+ #-}
845+
846+-- | /O(n)/ 'takeEnd' @n@ @t@ returns the suffix remaining after
847+-- taking @n@ characters from the end of @t@.
848+--
849+-- Examples:
850+--
851+-- > takeEnd 3 "foobar" == "bar"
852+takeEnd :: Int -> JSString -> JSString
853+takeEnd = coerce T.takeEnd
854+
855+-- | /O(n)/ 'drop' @n@, applied to a 'JSString', returns the suffix of the
856+-- 'JSString' after the first @n@ characters, or the empty 'JSString' if @n@
857+-- is greater than the length of the 'JSString'. Subject to fusion.
858+drop :: Int -> JSString -> JSString
859+drop = coerce T.drop
860+{-# INLINE [1] drop #-}
861+
862+{-# RULES
863+"JSSTRING drop -> fused" [~1] forall n t.
864+ drop n t = unstream (S.drop n (stream t))
865+"JSSTRING drop -> unfused" [1] forall n t.
866+ unstream (S.drop n (stream t)) = drop n t
867+ #-}
868+
869+-- | /O(n)/ 'dropEnd' @n@ @t@ returns the prefix remaining after
870+-- dropping @n@ characters from the end of @t@.
871+--
872+-- Examples:
873+--
874+-- > dropEnd 3 "foobar" == "foo"
875+dropEnd :: Int -> JSString -> JSString
876+dropEnd = coerce T.dropEnd
877+
878+-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'JSString',
879+-- returns the longest prefix (possibly empty) of elements that
880+-- satisfy @p@. Subject to fusion.
881+takeWhile :: (Char -> Bool) -> JSString -> JSString
882+takeWhile = coerce T.takeWhile
883+{-# INLINE [1] takeWhile #-}
884+
885+{-# RULES
886+"TEXT takeWhile -> fused" [~1] forall p t.
887+ takeWhile p t = unstream (S.takeWhile p (stream t))
888+"TEXT takeWhile -> unfused" [1] forall p t.
889+ unstream (S.takeWhile p (stream t)) = takeWhile p t
890+ #-}
891+
892+-- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after
893+-- 'takeWhile' @p@ @t@. Subject to fusion.
894+dropWhile :: (Char -> Bool) -> JSString -> JSString
895+dropWhile = coerce T.dropWhile
896+{-# INLINE [1] dropWhile #-}
897+
898+{-# RULES
899+"TEXT dropWhile -> fused" [~1] forall p t.
900+ dropWhile p t = unstream (S.dropWhile p (stream t))
901+"TEXT dropWhile -> unfused" [1] forall p t.
902+ unstream (S.dropWhile p (stream t)) = dropWhile p t
903+ #-}
904+
905+-- | /O(n)/ 'dropWhileEnd' @p@ @t@ returns the prefix remaining after
906+-- dropping characters that fail the predicate @p@ from the end of
907+-- @t@. Subject to fusion.
908+-- Examples:
909+--
910+-- > dropWhileEnd (=='.') "foo..." == "foo"
911+dropWhileEnd :: (Char -> Bool) -> JSString -> JSString
912+dropWhileEnd = coerce T.dropWhileEnd
913+{-# INLINE [1] dropWhileEnd #-}
914+
915+{-# RULES
916+"TEXT dropWhileEnd -> fused" [~1] forall p t.
917+ dropWhileEnd p t = S.reverse (S.dropWhile p (S.reverseStream t))
918+"TEXT dropWhileEnd -> unfused" [1] forall p t.
919+ S.reverse (S.dropWhile p (S.reverseStream t)) = dropWhileEnd p t
920+ #-}
921+
922+-- | /O(n)/ 'dropAround' @p@ @t@ returns the substring remaining after
923+-- dropping characters that fail the predicate @p@ from both the
924+-- beginning and end of @t@. Subject to fusion.
925+dropAround :: (Char -> Bool) -> JSString -> JSString
926+dropAround = coerce T.dropAround
927+{-# INLINE [1] dropAround #-}
928+
929+-- | /O(n)/ Remove leading white space from a string. Equivalent to:
930+--
931+-- > dropWhile isSpace
932+stripStart :: JSString -> JSString
933+stripStart = coerce T.stripStart
934+{-# INLINE [1] stripStart #-}
935+
936+-- | /O(n)/ Remove trailing white space from a string. Equivalent to:
937+--
938+-- > dropWhileEnd isSpace
939+stripEnd :: JSString -> JSString
940+stripEnd = coerce T.stripEnd
941+{-# INLINE [1] stripEnd #-}
942+
943+-- | /O(n)/ Remove leading and trailing white space from a string.
944+-- Equivalent to:
945+--
946+-- > dropAround isSpace
947+strip :: JSString -> JSString
948+strip = coerce T.strip
949+{-# INLINE [1] strip #-}
950+
951+-- | /O(n)/ 'splitAt' @n t@ returns a pair whose first element is a
952+-- prefix of @t@ of length @n@, and whose second is the remainder of
953+-- the string. It is equivalent to @('take' n t, 'drop' n t)@.
954+splitAt :: Int -> JSString -> (JSString, JSString)
955+splitAt = coerce T.splitAt
956+{-# INLINE splitAt #-}
957+
958+-- | /O(n)/ 'span', applied to a predicate @p@ and text @t@, returns
959+-- a pair whose first element is the longest prefix (possibly empty)
960+-- of @t@ of elements that satisfy @p@, and whose second is the
961+-- remainder of the list.
962+span :: (Char -> Bool) -> JSString -> (JSString, JSString)
963+span = coerce T.span
964+{-# INLINE span #-}
965+
966+-- | /O(n)/ 'break' is like 'span', but the prefix returned is
967+-- over elements that fail the predicate @p@.
968+break :: (Char -> Bool) -> JSString -> (JSString, JSString)
969+break = coerce T.break
970+{-# INLINE break #-}
971+
972+-- | /O(n)/ Group characters in a string according to a predicate.
973+groupBy :: (Char -> Char -> Bool) -> JSString -> [JSString]
974+groupBy = coerce T.groupBy
975+
976+-- | /O(n)/ Group characters in a string by equality.
977+group :: JSString -> [JSString]
978+group = coerce T.group
979+{-# INLINE group #-}
980+
981+group' :: JSString -> [JSString]
982+group' = coerce T.group
983+{-# INLINE group' #-}
984+
985+-- | /O(n^2)/ Return all initial segments of the given 'JSString', shortest
986+-- first.
987+inits :: JSString -> [JSString]
988+inits = coerce T.inits
989+
990+-- | /O(n^2)/ Return all final segments of the given 'JSString', longest
991+-- first.
992+tails :: JSString -> [JSString]
993+tails = coerce T.tails
994+
995+-- $split
996+--
997+-- Splitting functions in this library do not perform character-wise
998+-- copies to create substrings; they just construct new 'JSString's that
999+-- are slices of the original.
1000+
1001+-- | /O(m+n)/ Break a 'JSString' into pieces separated by the first 'JSString'
1002+-- argument (which cannot be empty), consuming the delimiter. An empty
1003+-- delimiter is invalid, and will cause an error to be raised.
1004+--
1005+-- Examples:
1006+--
1007+-- > splitOn "\r\n" "a\r\nb\r\nd\r\ne" == ["a","b","d","e"]
1008+-- > splitOn "aaa" "aaaXaaaXaaaXaaa" == ["","X","X","X",""]
1009+-- > splitOn "x" "x" == ["",""]
1010+--
1011+-- and
1012+--
1013+-- > intercalate s . splitOn s == id
1014+-- > splitOn (singleton c) == split (==c)
1015+--
1016+-- (Note: the string @s@ to split on above cannot be empty.)
1017+--
1018+-- In (unlikely) bad cases, this function's time complexity degrades
1019+-- towards /O(n*m)/.
1020+splitOn :: JSString
1021+ -- ^ String to split on. If this string is empty, an error
1022+ -- will occur.
1023+ -> JSString
1024+ -- ^ Input text.
1025+ -> [JSString]
1026+splitOn = coerce T.splitOn
1027+{-# INLINE [1] splitOn #-}
1028+
1029+-- RULES
1030+-- "JSSTRING splitOn/singleton -> split/==" [~1] forall c t.
1031+-- splitOn (singleton c) t = split (==c) t
1032+--
1033+
1034+splitOn' :: JSString
1035+ -- ^ String to split on. If this string is empty, an error
1036+ -- will occur.
1037+ -> JSString
1038+ -- ^ Input text.
1039+ -> [JSString]
1040+splitOn' = coerce T.splitOn
1041+{-# NOINLINE splitOn' #-}
1042+--- {-# INLINE [1] splitOn' #-}
1043+
1044+-- | /O(n)/ Splits a 'JSString' into components delimited by separators,
1045+-- where the predicate returns True for a separator element. The
1046+-- resulting components do not contain the separators. Two adjacent
1047+-- separators result in an empty component in the output. eg.
1048+--
1049+-- > split (=='a') "aabbaca" == ["","","bb","c",""]
1050+-- > split (=='a') "" == [""]
1051+split :: (Char -> Bool) -> JSString -> [JSString]
1052+split = coerce T.split
1053+{-# INLINE split #-}
1054+
1055+-- | /O(n)/ Splits a 'JSString' into components of length @k@. The last
1056+-- element may be shorter than the other chunks, depending on the
1057+-- length of the input. Examples:
1058+--
1059+-- > chunksOf 3 "foobarbaz" == ["foo","bar","baz"]
1060+-- > chunksOf 4 "haskell.org" == ["hask","ell.","org"]
1061+chunksOf :: Int -> JSString -> [JSString]
1062+chunksOf = coerce T.chunksOf
1063+{-# INLINE chunksOf #-}
1064+
1065+-- | /O(n)/ Splits a 'JSString' into components of length @k@. The last
1066+-- element may be shorter than the other chunks, depending on the
1067+-- length of the input. Examples:
1068+--
1069+-- > chunksOf 3 "foobarbaz" == ["foo","bar","baz"]
1070+-- > chunksOf 4 "haskell.org" == ["hask","ell.","org"]
1071+chunksOf' :: Int -> JSString -> [JSString]
1072+chunksOf' = coerce T.chunksOf
1073+{-# INLINE chunksOf' #-}
1074+
1075+-- ----------------------------------------------------------------------------
1076+-- * Searching
1077+
1078+-------------------------------------------------------------------------------
1079+-- ** Searching with a predicate
1080+
1081+-- | /O(n)/ The 'find' function takes a predicate and a 'JSString', and
1082+-- returns the first element matching the predicate, or 'Nothing' if
1083+-- there is no such element.
1084+find :: (Char -> Bool) -> JSString -> Maybe Char
1085+find = coerce T.find
1086+{-# INLINE find #-}
1087+
1088+-- | /O(n)/ The 'partition' function takes a predicate and a 'JSString',
1089+-- and returns the pair of 'JSString's with elements which do and do not
1090+-- satisfy the predicate, respectively; i.e.
1091+--
1092+-- > partition p t == (filter p t, filter (not . p) t)
1093+partition :: (Char -> Bool) -> JSString -> (JSString, JSString)
1094+partition = coerce T.partition
1095+{-# INLINE partition #-}
1096+
1097+-- | /O(n)/ 'filter', applied to a predicate and a 'JSString',
1098+-- returns a 'JSString' containing those characters that satisfy the
1099+-- predicate.
1100+filter :: (Char -> Bool) -> JSString -> JSString
1101+filter = coerce T.filter
1102+{-# INLINE filter #-}
1103+
1104+-- | /O(n+m)/ Find the first instance of @needle@ (which must be
1105+-- non-'null') in @haystack@. The first element of the returned tuple
1106+-- is the prefix of @haystack@ before @needle@ is matched. The second
1107+-- is the remainder of @haystack@, starting with the match.
1108+--
1109+-- Examples:
1110+--
1111+-- > breakOn "::" "a::b::c" ==> ("a", "::b::c")
1112+-- > breakOn "/" "foobar" ==> ("foobar", "")
1113+--
1114+-- Laws:
1115+--
1116+-- > append prefix match == haystack
1117+-- > where (prefix, match) = breakOn needle haystack
1118+--
1119+-- If you need to break a string by a substring repeatedly (e.g. you
1120+-- want to break on every instance of a substring), use 'breakOnAll'
1121+-- instead, as it has lower startup overhead.
1122+--
1123+-- In (unlikely) bad cases, this function's time complexity degrades
1124+-- towards /O(n*m)/.
1125+breakOn :: JSString -> JSString -> (JSString, JSString)
1126+breakOn = coerce T.breakOn
1127+{-# INLINE breakOn #-}
1128+
1129+-- | /O(n+m)/ Similar to 'breakOn', but searches from the end of the
1130+-- string.
1131+--
1132+-- The first element of the returned tuple is the prefix of @haystack@
1133+-- up to and including the last match of @needle@. The second is the
1134+-- remainder of @haystack@, following the match.
1135+--
1136+-- > breakOnEnd "::" "a::b::c" ==> ("a::b::", "c")
1137+breakOnEnd :: JSString -> JSString -> (JSString, JSString)
1138+breakOnEnd = coerce T.breakOnEnd
1139+{-# INLINE breakOnEnd #-}
1140+
1141+-- | /O(n+m)/ Find all non-overlapping instances of @needle@ in
1142+-- @haystack@. Each element of the returned list consists of a pair:
1143+--
1144+-- * The entire string prior to the /k/th match (i.e. the prefix)
1145+--
1146+-- * The /k/th match, followed by the remainder of the string
1147+--
1148+-- Examples:
1149+--
1150+-- > breakOnAll "::" ""
1151+-- > ==> []
1152+-- > breakOnAll "/" "a/b/c/"
1153+-- > ==> [("a", "/b/c/"), ("a/b", "/c/"), ("a/b/c", "/")]
1154+--
1155+-- In (unlikely) bad cases, this function's time complexity degrades
1156+-- towards /O(n*m)/.
1157+--
1158+-- The @needle@ parameter may not be empty.
1159+breakOnAll :: JSString -- ^ @needle@ to search for
1160+ -> JSString -- ^ @haystack@ in which to search
1161+ -> [(JSString, JSString)]
1162+breakOnAll = coerce T.breakOnAll
1163+{-# INLINE breakOnAll #-}
1164+
1165+breakOnAll' :: JSString -- ^ @needle@ to search for
1166+ -> JSString -- ^ @haystack@ in which to search
1167+ -> [(JSString, JSString)]
1168+breakOnAll' = coerce T.breakOnAll
1169+{-# INLINE breakOnAll' #-}
1170+
1171+-------------------------------------------------------------------------------
1172+-- ** Indexing 'JSString's
1173+
1174+-- $index
1175+--
1176+-- If you think of a 'JSString' value as an array of 'Char' values (which
1177+-- it is not), you run the risk of writing inefficient code.
1178+--
1179+-- An idiom that is common in some languages is to find the numeric
1180+-- offset of a character or substring, then use that number to split
1181+-- or trim the searched string. With a 'JSString' value, this approach
1182+-- would require two /O(n)/ operations: one to perform the search, and
1183+-- one to operate from wherever the search ended.
1184+--
1185+-- For example, suppose you have a string that you want to split on
1186+-- the substring @\"::\"@, such as @\"foo::bar::quux\"@. Instead of
1187+-- searching for the index of @\"::\"@ and taking the substrings
1188+-- before and after that index, you would instead use @breakOnAll \"::\"@.
1189+
1190+-- | /O(n)/ 'JSString' index (subscript) operator, starting from 0.
1191+index :: JSString -> Int -> Char
1192+index = coerce T.index
1193+{-# INLINE index #-}
1194+
1195+-- | /O(n)/ The 'findIndex' function takes a predicate and a 'JSString'
1196+-- and returns the index of the first element in the 'JSString' satisfying
1197+-- the predicate. Subject to fusion.
1198+findIndex :: (Char -> Bool) -> JSString -> Maybe Int
1199+findIndex = coerce T.findIndex
1200+{-# INLINE findIndex #-}
1201+
1202+-- | /O(n+m)/ The 'count' function returns the number of times the
1203+-- query string appears in the given 'JSString'. An empty query string is
1204+-- invalid, and will cause an error to be raised.
1205+--
1206+-- In (unlikely) bad cases, this function's time complexity degrades
1207+-- towards /O(n*m)/.
1208+count :: JSString -> JSString -> Int
1209+count = coerce T.count
1210+{-# INLINE [1] count #-}
1211+
1212+-- RULES
1213+-- "JSSTRING count/singleton -> countChar" [~1] forall c t.
1214+-- count (singleton c) t = countChar c t
1215+--
1216+
1217+-------------------------------------------------------------------------------
1218+-- * Zipping
1219+
1220+-- | /O(n)/ 'zip' takes two 'JSString's and returns a list of
1221+-- corresponding pairs of bytes. If one input 'JSString' is short,
1222+-- excess elements of the longer 'JSString' are discarded. This is
1223+-- equivalent to a pair of 'unpack' operations.
1224+zip :: JSString -> JSString -> [(Char,Char)]
1225+zip = coerce T.zip
1226+{-# INLINE [0] zip #-}
1227+
1228+-- | /O(n)/ 'zipWith' generalises 'zip' by zipping with the function
1229+-- given as the first argument, instead of a tupling function.
1230+-- Performs replacement on invalid scalar values.
1231+zipWith :: (Char -> Char -> Char) -> JSString -> JSString -> JSString
1232+zipWith = coerce T.zipWith
1233+{-# INLINE [0] zipWith #-}
1234+
1235+-- | /O(n)/ Breaks a 'JSString' up into a list of words, delimited by 'Char's
1236+-- representing white space.
1237+words :: JSString -> [JSString]
1238+words = coerce T.words
1239+{-# INLINE words #-}
1240+
1241+-- fixme: strict words' that allocates the whole list in one go
1242+words' :: JSString -> [JSString]
1243+words' = coerce T.words
1244+{-# INLINE words' #-}
1245+
1246+-- | /O(n)/ Breaks a 'JSString' up into a list of 'JSString's at
1247+-- newline 'Char's. The resulting strings do not contain newlines.
1248+lines :: JSString -> [JSString]
1249+lines = coerce T.lines
1250+{-# INLINE lines #-}
1251+
1252+lines' :: JSString -> [JSString]
1253+lines' = coerce T.lines
1254+{-# INLINE lines' #-}
1255+
1256+{-
1257+-- | /O(n)/ Portably breaks a 'JSString' up into a list of 'JSString's at line
1258+-- boundaries.
1259+--
1260+-- A line boundary is considered to be either a line feed, a carriage
1261+-- return immediately followed by a line feed, or a carriage return.
1262+-- This accounts for both Unix and Windows line ending conventions,
1263+-- and for the old convention used on Mac OS 9 and earlier.
1264+lines' :: Text -> [Text]
1265+lines' ps | null ps = []
1266+ | otherwise = h : case uncons t of
1267+ Nothing -> []
1268+ Just (c,t')
1269+ | c == '\n' -> lines t'
1270+ | c == '\r' -> case uncons t' of
1271+ Just ('\n',t'') -> lines t''
1272+ _ -> lines t'
1273+ where (h,t) = span notEOL ps
1274+ notEOL c = c /= '\n' && c /= '\r'
1275+
1276+-}
1277+
1278+-- | /O(n)/ Joins lines, after appending a terminating newline to
1279+-- each.
1280+unlines :: [JSString] -> JSString
1281+unlines = coerce T.unlines
1282+{-# INLINE unlines #-}
1283+
1284+-- | /O(n)/ Joins words using single space characters.
1285+unwords :: [JSString] -> JSString
1286+unwords = coerce T.unwords
1287+{-# INLINE unwords #-}
1288+
1289+-- | /O(n)/ The 'isPrefixOf' function takes two 'JSString's and returns
1290+-- 'True' iff the first is a prefix of the second. Subject to fusion.
1291+isPrefixOf :: JSString -> JSString -> Bool
1292+isPrefixOf = coerce T.isPrefixOf
1293+{-# INLINE [1] isPrefixOf #-}
1294+
1295+{-# RULES
1296+"JSSTRING isPrefixOf -> fused" [~1] forall x y.
1297+ isPrefixOf x y = S.isPrefixOf (stream x) (stream y)
1298+"JSSTRING isPrefixOf -> unfused" [1] forall x y.
1299+ S.isPrefixOf (stream x) (stream y) = isPrefixOf x y
1300+ #-}
1301+
1302+-- | /O(n)/ The 'isSuffixOf' function takes two 'JSString's and returns
1303+-- 'True' iff the first is a suffix of the second.
1304+isSuffixOf :: JSString -> JSString -> Bool
1305+isSuffixOf = coerce T.isSuffixOf
1306+{-# INLINE isSuffixOf #-}
1307+
1308+-- | The 'isInfixOf' function takes two 'JSString's and returns
1309+-- 'True' iff the first is contained, wholly and intact, anywhere
1310+-- within the second.
1311+--
1312+-- Complexity depends on how the JavaScript engine implements
1313+-- String.prototype.find.
1314+isInfixOf :: JSString -> JSString -> Bool
1315+isInfixOf = coerce T.isInfixOf
1316+{-# INLINE [1] isInfixOf #-}
1317+
1318+{-# RULES
1319+"JSSTRING isInfixOf/singleton -> S.elem/S.stream" [~1] forall n h.
1320+ isInfixOf (singleton n) h = S.elem n (S.stream h)
1321+ #-}
1322+
1323+-------------------------------------------------------------------------------
1324+-- * View patterns
1325+
1326+-- | /O(n)/ Return the suffix of the second string if its prefix
1327+-- matches the entire first string.
1328+--
1329+-- Examples:
1330+--
1331+-- > stripPrefix "foo" "foobar" == Just "bar"
1332+-- > stripPrefix "" "baz" == Just "baz"
1333+-- > stripPrefix "foo" "quux" == Nothing
1334+--
1335+-- This is particularly useful with the @ViewPatterns@ extension to
1336+-- GHC, as follows:
1337+--
1338+-- > {-# LANGUAGE ViewPatterns #-}
1339+-- > import Data.Text as T
1340+-- >
1341+-- > fnordLength :: JSString -> Int
1342+-- > fnordLength (stripPrefix "fnord" -> Just suf) = T.length suf
1343+-- > fnordLength _ = -1
1344+stripPrefix :: JSString -> JSString -> Maybe JSString
1345+stripPrefix = coerce T.stripPrefix
1346+{-# INLINE stripPrefix #-}
1347+
1348+-- | /O(n)/ Find the longest non-empty common prefix of two strings
1349+-- and return it, along with the suffixes of each string at which they
1350+-- no longer match.
1351+--
1352+-- If the strings do not have a common prefix or either one is empty,
1353+-- this function returns 'Nothing'.
1354+--
1355+-- Examples:
1356+--
1357+-- > commonPrefixes "foobar" "fooquux" == Just ("foo","bar","quux")
1358+-- > commonPrefixes "veeble" "fetzer" == Nothing
1359+-- > commonPrefixes "" "baz" == Nothing
1360+commonPrefixes :: JSString -> JSString -> Maybe (JSString,JSString,JSString)
1361+commonPrefixes = coerce T.commonPrefixes
1362+{-# INLINE commonPrefixes #-}
1363+
1364+-- | /O(n)/ Return the prefix of the second string if its suffix
1365+-- matches the entire first string.
1366+--
1367+-- Examples:
1368+--
1369+-- > stripSuffix "bar" "foobar" == Just "foo"
1370+-- > stripSuffix "" "baz" == Just "baz"
1371+-- > stripSuffix "foo" "quux" == Nothing
1372+--
1373+-- This is particularly useful with the @ViewPatterns@ extension to
1374+-- GHC, as follows:
1375+--
1376+-- > {-# LANGUAGE ViewPatterns #-}
1377+-- > import Data.Text as T
1378+-- >
1379+-- > quuxLength :: Text -> Int
1380+-- > quuxLength (stripSuffix "quux" -> Just pre) = T.length pre
1381+-- > quuxLength _ = -1
1382+stripSuffix :: JSString -> JSString -> Maybe JSString
1383+stripSuffix = coerce T.stripSuffix
1384+{-# INLINE stripSuffix #-}
1385+
1386+---- | Add a list of non-negative numbers. Errors out on overflow.
1387+--sumP :: String -> [Int] -> Int
1388+--sumP fun = go 0
1389+-- where go !a (x:xs)
1390+-- | ax >= 0 = go ax xs
1391+-- | otherwise = overflowError fun
1392+-- where ax = a + x
1393+-- go a _ = a
1394+--
1395+--emptyError :: String -> a
1396+--emptyError fun = P.error $ "Data.JSString." ++ fun ++ ": empty input"
1397+--
1398+--overflowError :: String -> a
1399+--overflowError fun = P.error $ "Data.JSString." ++ fun ++ ": size overflow"
1400+--
1401+--charWidth :: Int# -> Int#
1402+--charWidth cp | isTrue# (cp >=# 0x10000#) = 2#
1403+-- | otherwise = 1#
1404+--{-# INLINE charWidth #-}
jsaddle/src-ghc/Data/JSString/Internal.hsnew file+1
@@ -0,0 +1 @@
1+module Data.JSString.Internal where
jsaddle/src-ghc/Data/JSString/Internal/Fusion.hsnew file+127
@@ -0,0 +1,127 @@
1+{-# LANGUAGE BangPatterns, MagicHash
2+ #-}
3+module Data.JSString.Internal.Fusion ( -- * Types
4+ Stream(..)
5+ , Step(..)
6+
7+ -- * Creation and elimination
8+ , stream
9+ , unstream
10+ , reverseStream
11+
12+ , length
13+
14+ -- * Transformations
15+ , reverse
16+
17+ -- * Construction
18+ -- ** Scans
19+ , reverseScanr
20+
21+ -- ** Accumulating maps
22+ , mapAccumL
23+
24+ -- ** Generation and unfolding
25+ , unfoldrN
26+
27+ -- * Indexing
28+ , index
29+ , findIndex
30+ , countChar
31+ ) where
32+
33+--import GHC.Exts (Char(..), Int(..), chr#, Int#, isTrue#, (-#), (+#), (>=#))
34+
35+import Prelude hiding (length, reverse)
36+import qualified Data.Text.Internal.Fusion as T
37+--import Data.Char
38+import Data.Coerce (coerce)
39+
40+import Data.JSString.Internal.Type (JSString(..))
41+--import qualified Data.JSString.Internal.Type as I
42+import Data.JSString.Internal.Fusion.Types
43+import qualified Data.JSString.Internal.Fusion.Common as S
44+
45+--import System.IO.Unsafe
46+
47+--import GHCJS.Prim
48+
49+default (Int)
50+
51+-- | /O(n)/ Convert a 'JSString' into a 'Stream Char'.
52+stream :: JSString -> Stream Char
53+stream = coerce T.stream
54+{-# INLINE [0] stream #-}
55+
56+-- | /O(n)/ Convert a 'JSString' into a 'Stream Char', but iterate
57+-- backwards.
58+reverseStream :: JSString -> Stream Char
59+reverseStream = coerce T.reverseStream
60+{-# INLINE [0] reverseStream #-}
61+
62+-- | /O(n)/ Convert a 'Stream Char' into a 'JSString'.
63+unstream :: Stream Char -> JSString
64+unstream = coerce T.unstream
65+{-# INLINE [0] unstream #-}
66+{-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-}
67+
68+
69+-- ----------------------------------------------------------------------------
70+-- * Basic stream functions
71+
72+--runJSString :: ((a -> IO a) -> IO a) -> a
73+--runJSString f = unsafePerformIO (f pure)
74+
75+length :: Stream Char -> Int
76+length = S.lengthI
77+{-# INLINE[0] length #-}
78+
79+-- | /O(n)/ Reverse the characters of a string.
80+reverse :: Stream Char -> JSString
81+reverse = coerce T.reverse
82+{-# INLINE [0] reverse #-}
83+
84+-- | /O(n)/ Perform the equivalent of 'scanr' over a list, only with
85+-- the input and result reversed.
86+reverseScanr :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char
87+reverseScanr = coerce T.reverseScanr
88+{-# INLINE reverseScanr #-}
89+
90+-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a stream from a seed
91+-- value. However, the length of the result is limited by the
92+-- first argument to 'unfoldrN'. This function is more efficient than
93+-- 'unfoldr' when the length of the result is known.
94+unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Stream Char
95+unfoldrN n = S.unfoldrNI n
96+{-# INLINE [0] unfoldrN #-}
97+
98+-------------------------------------------------------------------------------
99+-- ** Indexing streams
100+
101+-- | /O(n)/ stream index (subscript) operator, starting from 0.
102+index :: Stream Char -> Int -> Char
103+index = S.indexI
104+{-# INLINE [0] index #-}
105+
106+-- | The 'findIndex' function takes a predicate and a stream and
107+-- returns the index of the first element in the stream
108+-- satisfying the predicate.
109+findIndex :: (Char -> Bool) -> Stream Char -> Maybe Int
110+findIndex = S.findIndexI
111+{-# INLINE [0] findIndex #-}
112+
113+-- | /O(n)/ The 'count' function returns the number of times the query
114+-- element appears in the given stream.
115+countChar :: Char -> Stream Char -> Int
116+countChar = S.countCharI
117+{-# INLINE [0] countChar #-}
118+
119+-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a
120+-- function to each element of a 'Text', passing an accumulating
121+-- parameter from left to right, and returns a final 'JSString'.
122+mapAccumL :: (a -> Char -> (a, Char)) -> a -> Stream Char -> (a, JSString)
123+mapAccumL a b c = coerce (T.mapAccumL a b c)
124+{-# INLINE [0] mapAccumL #-}
125+
126+-------------------------------------------------------------------------------
127+
jsaddle/src-ghc/Data/JSString/Internal/Fusion/CaseMapping.hsnew file+570
@@ -0,0 +1,570 @@
1+{-# LANGUAGE Rank2Types #-}
2+-- AUTOMATICALLY GENERATED - DO NOT EDIT
3+-- Generated by scripts/SpecialCasing.hs
4+-- CaseFolding-6.3.0.txt
5+-- Date: 2012-12-20, 22:14:35 GMT [MD]
6+-- SpecialCasing-6.3.0.txt
7+-- Date: 2013-05-08, 13:54:51 GMT [MD]
8+
9+module Data.JSString.Internal.Fusion.CaseMapping where
10+import Data.Char
11+import Data.JSString.Internal.Fusion.Types
12+
13+upperMapping :: forall s. Char -> s -> Step (CC s) Char
14+{-# INLINE upperMapping #-}
15+-- LATIN SMALL LETTER SHARP S
16+upperMapping '\x00df' s = Yield '\x0053' (CC s '\x0053' '\x0000')
17+-- LATIN SMALL LIGATURE FF
18+upperMapping '\xfb00' s = Yield '\x0046' (CC s '\x0046' '\x0000')
19+-- LATIN SMALL LIGATURE FI
20+upperMapping '\xfb01' s = Yield '\x0046' (CC s '\x0049' '\x0000')
21+-- LATIN SMALL LIGATURE FL
22+upperMapping '\xfb02' s = Yield '\x0046' (CC s '\x004c' '\x0000')
23+-- LATIN SMALL LIGATURE FFI
24+upperMapping '\xfb03' s = Yield '\x0046' (CC s '\x0046' '\x0049')
25+-- LATIN SMALL LIGATURE FFL
26+upperMapping '\xfb04' s = Yield '\x0046' (CC s '\x0046' '\x004c')
27+-- LATIN SMALL LIGATURE LONG S T
28+upperMapping '\xfb05' s = Yield '\x0053' (CC s '\x0054' '\x0000')
29+-- LATIN SMALL LIGATURE ST
30+upperMapping '\xfb06' s = Yield '\x0053' (CC s '\x0054' '\x0000')
31+-- ARMENIAN SMALL LIGATURE ECH YIWN
32+upperMapping '\x0587' s = Yield '\x0535' (CC s '\x0552' '\x0000')
33+-- ARMENIAN SMALL LIGATURE MEN NOW
34+upperMapping '\xfb13' s = Yield '\x0544' (CC s '\x0546' '\x0000')
35+-- ARMENIAN SMALL LIGATURE MEN ECH
36+upperMapping '\xfb14' s = Yield '\x0544' (CC s '\x0535' '\x0000')
37+-- ARMENIAN SMALL LIGATURE MEN INI
38+upperMapping '\xfb15' s = Yield '\x0544' (CC s '\x053b' '\x0000')
39+-- ARMENIAN SMALL LIGATURE VEW NOW
40+upperMapping '\xfb16' s = Yield '\x054e' (CC s '\x0546' '\x0000')
41+-- ARMENIAN SMALL LIGATURE MEN XEH
42+upperMapping '\xfb17' s = Yield '\x0544' (CC s '\x053d' '\x0000')
43+-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE
44+upperMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000')
45+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
46+upperMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301')
47+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
48+upperMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301')
49+-- LATIN SMALL LETTER J WITH CARON
50+upperMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000')
51+-- LATIN SMALL LETTER H WITH LINE BELOW
52+upperMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000')
53+-- LATIN SMALL LETTER T WITH DIAERESIS
54+upperMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000')
55+-- LATIN SMALL LETTER W WITH RING ABOVE
56+upperMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000')
57+-- LATIN SMALL LETTER Y WITH RING ABOVE
58+upperMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000')
59+-- LATIN SMALL LETTER A WITH RIGHT HALF RING
60+upperMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000')
61+-- GREEK SMALL LETTER UPSILON WITH PSILI
62+upperMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000')
63+-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA
64+upperMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300')
65+-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA
66+upperMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301')
67+-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI
68+upperMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342')
69+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI
70+upperMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000')
71+-- GREEK SMALL LETTER ETA WITH PERISPOMENI
72+upperMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000')
73+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA
74+upperMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300')
75+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA
76+upperMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301')
77+-- GREEK SMALL LETTER IOTA WITH PERISPOMENI
78+upperMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000')
79+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI
80+upperMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342')
81+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA
82+upperMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300')
83+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA
84+upperMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301')
85+-- GREEK SMALL LETTER RHO WITH PSILI
86+upperMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000')
87+-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI
88+upperMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000')
89+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI
90+upperMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342')
91+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI
92+upperMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000')
93+-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI
94+upperMapping '\x1f80' s = Yield '\x1f08' (CC s '\x0399' '\x0000')
95+-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI
96+upperMapping '\x1f81' s = Yield '\x1f09' (CC s '\x0399' '\x0000')
97+-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI
98+upperMapping '\x1f82' s = Yield '\x1f0a' (CC s '\x0399' '\x0000')
99+-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI
100+upperMapping '\x1f83' s = Yield '\x1f0b' (CC s '\x0399' '\x0000')
101+-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI
102+upperMapping '\x1f84' s = Yield '\x1f0c' (CC s '\x0399' '\x0000')
103+-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI
104+upperMapping '\x1f85' s = Yield '\x1f0d' (CC s '\x0399' '\x0000')
105+-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
106+upperMapping '\x1f86' s = Yield '\x1f0e' (CC s '\x0399' '\x0000')
107+-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
108+upperMapping '\x1f87' s = Yield '\x1f0f' (CC s '\x0399' '\x0000')
109+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI
110+upperMapping '\x1f88' s = Yield '\x1f08' (CC s '\x0399' '\x0000')
111+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI
112+upperMapping '\x1f89' s = Yield '\x1f09' (CC s '\x0399' '\x0000')
113+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI
114+upperMapping '\x1f8a' s = Yield '\x1f0a' (CC s '\x0399' '\x0000')
115+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI
116+upperMapping '\x1f8b' s = Yield '\x1f0b' (CC s '\x0399' '\x0000')
117+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI
118+upperMapping '\x1f8c' s = Yield '\x1f0c' (CC s '\x0399' '\x0000')
119+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI
120+upperMapping '\x1f8d' s = Yield '\x1f0d' (CC s '\x0399' '\x0000')
121+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
122+upperMapping '\x1f8e' s = Yield '\x1f0e' (CC s '\x0399' '\x0000')
123+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
124+upperMapping '\x1f8f' s = Yield '\x1f0f' (CC s '\x0399' '\x0000')
125+-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI
126+upperMapping '\x1f90' s = Yield '\x1f28' (CC s '\x0399' '\x0000')
127+-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI
128+upperMapping '\x1f91' s = Yield '\x1f29' (CC s '\x0399' '\x0000')
129+-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI
130+upperMapping '\x1f92' s = Yield '\x1f2a' (CC s '\x0399' '\x0000')
131+-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI
132+upperMapping '\x1f93' s = Yield '\x1f2b' (CC s '\x0399' '\x0000')
133+-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI
134+upperMapping '\x1f94' s = Yield '\x1f2c' (CC s '\x0399' '\x0000')
135+-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI
136+upperMapping '\x1f95' s = Yield '\x1f2d' (CC s '\x0399' '\x0000')
137+-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
138+upperMapping '\x1f96' s = Yield '\x1f2e' (CC s '\x0399' '\x0000')
139+-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
140+upperMapping '\x1f97' s = Yield '\x1f2f' (CC s '\x0399' '\x0000')
141+-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI
142+upperMapping '\x1f98' s = Yield '\x1f28' (CC s '\x0399' '\x0000')
143+-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI
144+upperMapping '\x1f99' s = Yield '\x1f29' (CC s '\x0399' '\x0000')
145+-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI
146+upperMapping '\x1f9a' s = Yield '\x1f2a' (CC s '\x0399' '\x0000')
147+-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI
148+upperMapping '\x1f9b' s = Yield '\x1f2b' (CC s '\x0399' '\x0000')
149+-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI
150+upperMapping '\x1f9c' s = Yield '\x1f2c' (CC s '\x0399' '\x0000')
151+-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI
152+upperMapping '\x1f9d' s = Yield '\x1f2d' (CC s '\x0399' '\x0000')
153+-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
154+upperMapping '\x1f9e' s = Yield '\x1f2e' (CC s '\x0399' '\x0000')
155+-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
156+upperMapping '\x1f9f' s = Yield '\x1f2f' (CC s '\x0399' '\x0000')
157+-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI
158+upperMapping '\x1fa0' s = Yield '\x1f68' (CC s '\x0399' '\x0000')
159+-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI
160+upperMapping '\x1fa1' s = Yield '\x1f69' (CC s '\x0399' '\x0000')
161+-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI
162+upperMapping '\x1fa2' s = Yield '\x1f6a' (CC s '\x0399' '\x0000')
163+-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI
164+upperMapping '\x1fa3' s = Yield '\x1f6b' (CC s '\x0399' '\x0000')
165+-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI
166+upperMapping '\x1fa4' s = Yield '\x1f6c' (CC s '\x0399' '\x0000')
167+-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI
168+upperMapping '\x1fa5' s = Yield '\x1f6d' (CC s '\x0399' '\x0000')
169+-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
170+upperMapping '\x1fa6' s = Yield '\x1f6e' (CC s '\x0399' '\x0000')
171+-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
172+upperMapping '\x1fa7' s = Yield '\x1f6f' (CC s '\x0399' '\x0000')
173+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI
174+upperMapping '\x1fa8' s = Yield '\x1f68' (CC s '\x0399' '\x0000')
175+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI
176+upperMapping '\x1fa9' s = Yield '\x1f69' (CC s '\x0399' '\x0000')
177+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI
178+upperMapping '\x1faa' s = Yield '\x1f6a' (CC s '\x0399' '\x0000')
179+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI
180+upperMapping '\x1fab' s = Yield '\x1f6b' (CC s '\x0399' '\x0000')
181+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI
182+upperMapping '\x1fac' s = Yield '\x1f6c' (CC s '\x0399' '\x0000')
183+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI
184+upperMapping '\x1fad' s = Yield '\x1f6d' (CC s '\x0399' '\x0000')
185+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
186+upperMapping '\x1fae' s = Yield '\x1f6e' (CC s '\x0399' '\x0000')
187+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
188+upperMapping '\x1faf' s = Yield '\x1f6f' (CC s '\x0399' '\x0000')
189+-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI
190+upperMapping '\x1fb3' s = Yield '\x0391' (CC s '\x0399' '\x0000')
191+-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI
192+upperMapping '\x1fbc' s = Yield '\x0391' (CC s '\x0399' '\x0000')
193+-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI
194+upperMapping '\x1fc3' s = Yield '\x0397' (CC s '\x0399' '\x0000')
195+-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI
196+upperMapping '\x1fcc' s = Yield '\x0397' (CC s '\x0399' '\x0000')
197+-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI
198+upperMapping '\x1ff3' s = Yield '\x03a9' (CC s '\x0399' '\x0000')
199+-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI
200+upperMapping '\x1ffc' s = Yield '\x03a9' (CC s '\x0399' '\x0000')
201+-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI
202+upperMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0399' '\x0000')
203+-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI
204+upperMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0399' '\x0000')
205+-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI
206+upperMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0399' '\x0000')
207+-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI
208+upperMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0399' '\x0000')
209+-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI
210+upperMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0399' '\x0000')
211+-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI
212+upperMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0399' '\x0000')
213+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI
214+upperMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0399')
215+-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI
216+upperMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0399')
217+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI
218+upperMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0399')
219+upperMapping c s = Yield (toUpper c) (CC s '\0' '\0')
220+lowerMapping :: forall s. Char -> s -> Step (CC s) Char
221+{-# INLINE lowerMapping #-}
222+-- LATIN CAPITAL LETTER I WITH DOT ABOVE
223+lowerMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000')
224+lowerMapping c s = Yield (toLower c) (CC s '\0' '\0')
225+titleMapping :: forall s. Char -> s -> Step (CC s) Char
226+{-# INLINE titleMapping #-}
227+-- LATIN SMALL LETTER SHARP S
228+titleMapping '\x00df' s = Yield '\x0053' (CC s '\x0073' '\x0000')
229+-- LATIN SMALL LIGATURE FF
230+titleMapping '\xfb00' s = Yield '\x0046' (CC s '\x0066' '\x0000')
231+-- LATIN SMALL LIGATURE FI
232+titleMapping '\xfb01' s = Yield '\x0046' (CC s '\x0069' '\x0000')
233+-- LATIN SMALL LIGATURE FL
234+titleMapping '\xfb02' s = Yield '\x0046' (CC s '\x006c' '\x0000')
235+-- LATIN SMALL LIGATURE FFI
236+titleMapping '\xfb03' s = Yield '\x0046' (CC s '\x0066' '\x0069')
237+-- LATIN SMALL LIGATURE FFL
238+titleMapping '\xfb04' s = Yield '\x0046' (CC s '\x0066' '\x006c')
239+-- LATIN SMALL LIGATURE LONG S T
240+titleMapping '\xfb05' s = Yield '\x0053' (CC s '\x0074' '\x0000')
241+-- LATIN SMALL LIGATURE ST
242+titleMapping '\xfb06' s = Yield '\x0053' (CC s '\x0074' '\x0000')
243+-- ARMENIAN SMALL LIGATURE ECH YIWN
244+titleMapping '\x0587' s = Yield '\x0535' (CC s '\x0582' '\x0000')
245+-- ARMENIAN SMALL LIGATURE MEN NOW
246+titleMapping '\xfb13' s = Yield '\x0544' (CC s '\x0576' '\x0000')
247+-- ARMENIAN SMALL LIGATURE MEN ECH
248+titleMapping '\xfb14' s = Yield '\x0544' (CC s '\x0565' '\x0000')
249+-- ARMENIAN SMALL LIGATURE MEN INI
250+titleMapping '\xfb15' s = Yield '\x0544' (CC s '\x056b' '\x0000')
251+-- ARMENIAN SMALL LIGATURE VEW NOW
252+titleMapping '\xfb16' s = Yield '\x054e' (CC s '\x0576' '\x0000')
253+-- ARMENIAN SMALL LIGATURE MEN XEH
254+titleMapping '\xfb17' s = Yield '\x0544' (CC s '\x056d' '\x0000')
255+-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE
256+titleMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000')
257+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
258+titleMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301')
259+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
260+titleMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301')
261+-- LATIN SMALL LETTER J WITH CARON
262+titleMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000')
263+-- LATIN SMALL LETTER H WITH LINE BELOW
264+titleMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000')
265+-- LATIN SMALL LETTER T WITH DIAERESIS
266+titleMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000')
267+-- LATIN SMALL LETTER W WITH RING ABOVE
268+titleMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000')
269+-- LATIN SMALL LETTER Y WITH RING ABOVE
270+titleMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000')
271+-- LATIN SMALL LETTER A WITH RIGHT HALF RING
272+titleMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000')
273+-- GREEK SMALL LETTER UPSILON WITH PSILI
274+titleMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000')
275+-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA
276+titleMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300')
277+-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA
278+titleMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301')
279+-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI
280+titleMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342')
281+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI
282+titleMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000')
283+-- GREEK SMALL LETTER ETA WITH PERISPOMENI
284+titleMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000')
285+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA
286+titleMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300')
287+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA
288+titleMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301')
289+-- GREEK SMALL LETTER IOTA WITH PERISPOMENI
290+titleMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000')
291+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI
292+titleMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342')
293+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA
294+titleMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300')
295+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA
296+titleMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301')
297+-- GREEK SMALL LETTER RHO WITH PSILI
298+titleMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000')
299+-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI
300+titleMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000')
301+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI
302+titleMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342')
303+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI
304+titleMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000')
305+-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI
306+titleMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0345' '\x0000')
307+-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI
308+titleMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0345' '\x0000')
309+-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI
310+titleMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0345' '\x0000')
311+-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI
312+titleMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0345' '\x0000')
313+-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI
314+titleMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0345' '\x0000')
315+-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI
316+titleMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0345' '\x0000')
317+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI
318+titleMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0345')
319+-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI
320+titleMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0345')
321+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI
322+titleMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0345')
323+titleMapping c s = Yield (toTitle c) (CC s '\0' '\0')
324+foldMapping :: forall s. Char -> s -> Step (CC s) Char
325+{-# INLINE foldMapping #-}
326+-- MICRO SIGN
327+foldMapping '\x00b5' s = Yield '\x03bc' (CC s '\x0000' '\x0000')
328+-- LATIN SMALL LETTER SHARP S
329+foldMapping '\x00df' s = Yield '\x0073' (CC s '\x0073' '\x0000')
330+-- LATIN CAPITAL LETTER I WITH DOT ABOVE
331+foldMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000')
332+-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE
333+foldMapping '\x0149' s = Yield '\x02bc' (CC s '\x006e' '\x0000')
334+-- LATIN SMALL LETTER LONG S
335+foldMapping '\x017f' s = Yield '\x0073' (CC s '\x0000' '\x0000')
336+-- LATIN SMALL LETTER J WITH CARON
337+foldMapping '\x01f0' s = Yield '\x006a' (CC s '\x030c' '\x0000')
338+-- COMBINING GREEK YPOGEGRAMMENI
339+foldMapping '\x0345' s = Yield '\x03b9' (CC s '\x0000' '\x0000')
340+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
341+foldMapping '\x0390' s = Yield '\x03b9' (CC s '\x0308' '\x0301')
342+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
343+foldMapping '\x03b0' s = Yield '\x03c5' (CC s '\x0308' '\x0301')
344+-- GREEK SMALL LETTER FINAL SIGMA
345+foldMapping '\x03c2' s = Yield '\x03c3' (CC s '\x0000' '\x0000')
346+-- GREEK BETA SYMBOL
347+foldMapping '\x03d0' s = Yield '\x03b2' (CC s '\x0000' '\x0000')
348+-- GREEK THETA SYMBOL
349+foldMapping '\x03d1' s = Yield '\x03b8' (CC s '\x0000' '\x0000')
350+-- GREEK PHI SYMBOL
351+foldMapping '\x03d5' s = Yield '\x03c6' (CC s '\x0000' '\x0000')
352+-- GREEK PI SYMBOL
353+foldMapping '\x03d6' s = Yield '\x03c0' (CC s '\x0000' '\x0000')
354+-- GREEK KAPPA SYMBOL
355+foldMapping '\x03f0' s = Yield '\x03ba' (CC s '\x0000' '\x0000')
356+-- GREEK RHO SYMBOL
357+foldMapping '\x03f1' s = Yield '\x03c1' (CC s '\x0000' '\x0000')
358+-- GREEK LUNATE EPSILON SYMBOL
359+foldMapping '\x03f5' s = Yield '\x03b5' (CC s '\x0000' '\x0000')
360+-- ARMENIAN SMALL LIGATURE ECH YIWN
361+foldMapping '\x0587' s = Yield '\x0565' (CC s '\x0582' '\x0000')
362+-- GEORGIAN CAPITAL LETTER YN
363+foldMapping '\x10c7' s = Yield '\x2d27' (CC s '\x0000' '\x0000')
364+-- GEORGIAN CAPITAL LETTER AEN
365+foldMapping '\x10cd' s = Yield '\x2d2d' (CC s '\x0000' '\x0000')
366+-- LATIN SMALL LETTER H WITH LINE BELOW
367+foldMapping '\x1e96' s = Yield '\x0068' (CC s '\x0331' '\x0000')
368+-- LATIN SMALL LETTER T WITH DIAERESIS
369+foldMapping '\x1e97' s = Yield '\x0074' (CC s '\x0308' '\x0000')
370+-- LATIN SMALL LETTER W WITH RING ABOVE
371+foldMapping '\x1e98' s = Yield '\x0077' (CC s '\x030a' '\x0000')
372+-- LATIN SMALL LETTER Y WITH RING ABOVE
373+foldMapping '\x1e99' s = Yield '\x0079' (CC s '\x030a' '\x0000')
374+-- LATIN SMALL LETTER A WITH RIGHT HALF RING
375+foldMapping '\x1e9a' s = Yield '\x0061' (CC s '\x02be' '\x0000')
376+-- LATIN SMALL LETTER LONG S WITH DOT ABOVE
377+foldMapping '\x1e9b' s = Yield '\x1e61' (CC s '\x0000' '\x0000')
378+-- LATIN CAPITAL LETTER SHARP S
379+foldMapping '\x1e9e' s = Yield '\x0073' (CC s '\x0073' '\x0000')
380+-- GREEK SMALL LETTER UPSILON WITH PSILI
381+foldMapping '\x1f50' s = Yield '\x03c5' (CC s '\x0313' '\x0000')
382+-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA
383+foldMapping '\x1f52' s = Yield '\x03c5' (CC s '\x0313' '\x0300')
384+-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA
385+foldMapping '\x1f54' s = Yield '\x03c5' (CC s '\x0313' '\x0301')
386+-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI
387+foldMapping '\x1f56' s = Yield '\x03c5' (CC s '\x0313' '\x0342')
388+-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI
389+foldMapping '\x1f80' s = Yield '\x1f00' (CC s '\x03b9' '\x0000')
390+-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI
391+foldMapping '\x1f81' s = Yield '\x1f01' (CC s '\x03b9' '\x0000')
392+-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI
393+foldMapping '\x1f82' s = Yield '\x1f02' (CC s '\x03b9' '\x0000')
394+-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI
395+foldMapping '\x1f83' s = Yield '\x1f03' (CC s '\x03b9' '\x0000')
396+-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI
397+foldMapping '\x1f84' s = Yield '\x1f04' (CC s '\x03b9' '\x0000')
398+-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI
399+foldMapping '\x1f85' s = Yield '\x1f05' (CC s '\x03b9' '\x0000')
400+-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
401+foldMapping '\x1f86' s = Yield '\x1f06' (CC s '\x03b9' '\x0000')
402+-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
403+foldMapping '\x1f87' s = Yield '\x1f07' (CC s '\x03b9' '\x0000')
404+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI
405+foldMapping '\x1f88' s = Yield '\x1f00' (CC s '\x03b9' '\x0000')
406+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI
407+foldMapping '\x1f89' s = Yield '\x1f01' (CC s '\x03b9' '\x0000')
408+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI
409+foldMapping '\x1f8a' s = Yield '\x1f02' (CC s '\x03b9' '\x0000')
410+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI
411+foldMapping '\x1f8b' s = Yield '\x1f03' (CC s '\x03b9' '\x0000')
412+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI
413+foldMapping '\x1f8c' s = Yield '\x1f04' (CC s '\x03b9' '\x0000')
414+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI
415+foldMapping '\x1f8d' s = Yield '\x1f05' (CC s '\x03b9' '\x0000')
416+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
417+foldMapping '\x1f8e' s = Yield '\x1f06' (CC s '\x03b9' '\x0000')
418+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
419+foldMapping '\x1f8f' s = Yield '\x1f07' (CC s '\x03b9' '\x0000')
420+-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI
421+foldMapping '\x1f90' s = Yield '\x1f20' (CC s '\x03b9' '\x0000')
422+-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI
423+foldMapping '\x1f91' s = Yield '\x1f21' (CC s '\x03b9' '\x0000')
424+-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI
425+foldMapping '\x1f92' s = Yield '\x1f22' (CC s '\x03b9' '\x0000')
426+-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI
427+foldMapping '\x1f93' s = Yield '\x1f23' (CC s '\x03b9' '\x0000')
428+-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI
429+foldMapping '\x1f94' s = Yield '\x1f24' (CC s '\x03b9' '\x0000')
430+-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI
431+foldMapping '\x1f95' s = Yield '\x1f25' (CC s '\x03b9' '\x0000')
432+-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
433+foldMapping '\x1f96' s = Yield '\x1f26' (CC s '\x03b9' '\x0000')
434+-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
435+foldMapping '\x1f97' s = Yield '\x1f27' (CC s '\x03b9' '\x0000')
436+-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI
437+foldMapping '\x1f98' s = Yield '\x1f20' (CC s '\x03b9' '\x0000')
438+-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI
439+foldMapping '\x1f99' s = Yield '\x1f21' (CC s '\x03b9' '\x0000')
440+-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI
441+foldMapping '\x1f9a' s = Yield '\x1f22' (CC s '\x03b9' '\x0000')
442+-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI
443+foldMapping '\x1f9b' s = Yield '\x1f23' (CC s '\x03b9' '\x0000')
444+-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI
445+foldMapping '\x1f9c' s = Yield '\x1f24' (CC s '\x03b9' '\x0000')
446+-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI
447+foldMapping '\x1f9d' s = Yield '\x1f25' (CC s '\x03b9' '\x0000')
448+-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
449+foldMapping '\x1f9e' s = Yield '\x1f26' (CC s '\x03b9' '\x0000')
450+-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
451+foldMapping '\x1f9f' s = Yield '\x1f27' (CC s '\x03b9' '\x0000')
452+-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI
453+foldMapping '\x1fa0' s = Yield '\x1f60' (CC s '\x03b9' '\x0000')
454+-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI
455+foldMapping '\x1fa1' s = Yield '\x1f61' (CC s '\x03b9' '\x0000')
456+-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI
457+foldMapping '\x1fa2' s = Yield '\x1f62' (CC s '\x03b9' '\x0000')
458+-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI
459+foldMapping '\x1fa3' s = Yield '\x1f63' (CC s '\x03b9' '\x0000')
460+-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI
461+foldMapping '\x1fa4' s = Yield '\x1f64' (CC s '\x03b9' '\x0000')
462+-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI
463+foldMapping '\x1fa5' s = Yield '\x1f65' (CC s '\x03b9' '\x0000')
464+-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
465+foldMapping '\x1fa6' s = Yield '\x1f66' (CC s '\x03b9' '\x0000')
466+-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
467+foldMapping '\x1fa7' s = Yield '\x1f67' (CC s '\x03b9' '\x0000')
468+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI
469+foldMapping '\x1fa8' s = Yield '\x1f60' (CC s '\x03b9' '\x0000')
470+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI
471+foldMapping '\x1fa9' s = Yield '\x1f61' (CC s '\x03b9' '\x0000')
472+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI
473+foldMapping '\x1faa' s = Yield '\x1f62' (CC s '\x03b9' '\x0000')
474+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI
475+foldMapping '\x1fab' s = Yield '\x1f63' (CC s '\x03b9' '\x0000')
476+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI
477+foldMapping '\x1fac' s = Yield '\x1f64' (CC s '\x03b9' '\x0000')
478+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI
479+foldMapping '\x1fad' s = Yield '\x1f65' (CC s '\x03b9' '\x0000')
480+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
481+foldMapping '\x1fae' s = Yield '\x1f66' (CC s '\x03b9' '\x0000')
482+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
483+foldMapping '\x1faf' s = Yield '\x1f67' (CC s '\x03b9' '\x0000')
484+-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI
485+foldMapping '\x1fb2' s = Yield '\x1f70' (CC s '\x03b9' '\x0000')
486+-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI
487+foldMapping '\x1fb3' s = Yield '\x03b1' (CC s '\x03b9' '\x0000')
488+-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI
489+foldMapping '\x1fb4' s = Yield '\x03ac' (CC s '\x03b9' '\x0000')
490+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI
491+foldMapping '\x1fb6' s = Yield '\x03b1' (CC s '\x0342' '\x0000')
492+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI
493+foldMapping '\x1fb7' s = Yield '\x03b1' (CC s '\x0342' '\x03b9')
494+-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI
495+foldMapping '\x1fbc' s = Yield '\x03b1' (CC s '\x03b9' '\x0000')
496+-- GREEK PROSGEGRAMMENI
497+foldMapping '\x1fbe' s = Yield '\x03b9' (CC s '\x0000' '\x0000')
498+-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI
499+foldMapping '\x1fc2' s = Yield '\x1f74' (CC s '\x03b9' '\x0000')
500+-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI
501+foldMapping '\x1fc3' s = Yield '\x03b7' (CC s '\x03b9' '\x0000')
502+-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI
503+foldMapping '\x1fc4' s = Yield '\x03ae' (CC s '\x03b9' '\x0000')
504+-- GREEK SMALL LETTER ETA WITH PERISPOMENI
505+foldMapping '\x1fc6' s = Yield '\x03b7' (CC s '\x0342' '\x0000')
506+-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI
507+foldMapping '\x1fc7' s = Yield '\x03b7' (CC s '\x0342' '\x03b9')
508+-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI
509+foldMapping '\x1fcc' s = Yield '\x03b7' (CC s '\x03b9' '\x0000')
510+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA
511+foldMapping '\x1fd2' s = Yield '\x03b9' (CC s '\x0308' '\x0300')
512+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA
513+foldMapping '\x1fd3' s = Yield '\x03b9' (CC s '\x0308' '\x0301')
514+-- GREEK SMALL LETTER IOTA WITH PERISPOMENI
515+foldMapping '\x1fd6' s = Yield '\x03b9' (CC s '\x0342' '\x0000')
516+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI
517+foldMapping '\x1fd7' s = Yield '\x03b9' (CC s '\x0308' '\x0342')
518+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA
519+foldMapping '\x1fe2' s = Yield '\x03c5' (CC s '\x0308' '\x0300')
520+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA
521+foldMapping '\x1fe3' s = Yield '\x03c5' (CC s '\x0308' '\x0301')
522+-- GREEK SMALL LETTER RHO WITH PSILI
523+foldMapping '\x1fe4' s = Yield '\x03c1' (CC s '\x0313' '\x0000')
524+-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI
525+foldMapping '\x1fe6' s = Yield '\x03c5' (CC s '\x0342' '\x0000')
526+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI
527+foldMapping '\x1fe7' s = Yield '\x03c5' (CC s '\x0308' '\x0342')
528+-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI
529+foldMapping '\x1ff2' s = Yield '\x1f7c' (CC s '\x03b9' '\x0000')
530+-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI
531+foldMapping '\x1ff3' s = Yield '\x03c9' (CC s '\x03b9' '\x0000')
532+-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI
533+foldMapping '\x1ff4' s = Yield '\x03ce' (CC s '\x03b9' '\x0000')
534+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI
535+foldMapping '\x1ff6' s = Yield '\x03c9' (CC s '\x0342' '\x0000')
536+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI
537+foldMapping '\x1ff7' s = Yield '\x03c9' (CC s '\x0342' '\x03b9')
538+-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI
539+foldMapping '\x1ffc' s = Yield '\x03c9' (CC s '\x03b9' '\x0000')
540+-- COPTIC CAPITAL LETTER BOHAIRIC KHEI
541+foldMapping '\x2cf2' s = Yield '\x2cf3' (CC s '\x0000' '\x0000')
542+-- LATIN CAPITAL LETTER C WITH BAR
543+foldMapping '\xa792' s = Yield '\xa793' (CC s '\x0000' '\x0000')
544+-- LATIN CAPITAL LETTER H WITH HOOK
545+foldMapping '\xa7aa' s = Yield '\x0266' (CC s '\x0000' '\x0000')
546+-- LATIN SMALL LIGATURE FF
547+foldMapping '\xfb00' s = Yield '\x0066' (CC s '\x0066' '\x0000')
548+-- LATIN SMALL LIGATURE FI
549+foldMapping '\xfb01' s = Yield '\x0066' (CC s '\x0069' '\x0000')
550+-- LATIN SMALL LIGATURE FL
551+foldMapping '\xfb02' s = Yield '\x0066' (CC s '\x006c' '\x0000')
552+-- LATIN SMALL LIGATURE FFI
553+foldMapping '\xfb03' s = Yield '\x0066' (CC s '\x0066' '\x0069')
554+-- LATIN SMALL LIGATURE FFL
555+foldMapping '\xfb04' s = Yield '\x0066' (CC s '\x0066' '\x006c')
556+-- LATIN SMALL LIGATURE LONG S T
557+foldMapping '\xfb05' s = Yield '\x0073' (CC s '\x0074' '\x0000')
558+-- LATIN SMALL LIGATURE ST
559+foldMapping '\xfb06' s = Yield '\x0073' (CC s '\x0074' '\x0000')
560+-- ARMENIAN SMALL LIGATURE MEN NOW
561+foldMapping '\xfb13' s = Yield '\x0574' (CC s '\x0576' '\x0000')
562+-- ARMENIAN SMALL LIGATURE MEN ECH
563+foldMapping '\xfb14' s = Yield '\x0574' (CC s '\x0565' '\x0000')
564+-- ARMENIAN SMALL LIGATURE MEN INI
565+foldMapping '\xfb15' s = Yield '\x0574' (CC s '\x056b' '\x0000')
566+-- ARMENIAN SMALL LIGATURE VEW NOW
567+foldMapping '\xfb16' s = Yield '\x057e' (CC s '\x0576' '\x0000')
568+-- ARMENIAN SMALL LIGATURE MEN XEH
569+foldMapping '\xfb17' s = Yield '\x0574' (CC s '\x056d' '\x0000')
570+foldMapping c s = Yield (toLower c) (CC s '\0' '\0')
jsaddle/src-ghc/Data/JSString/Internal/Fusion/Common.hsnew file+92
@@ -0,0 +1,92 @@
1+{-# LANGUAGE BangPatterns, MagicHash, RankNTypes #-}
2+
3+module Data.JSString.Internal.Fusion.Common ( -- * Creation and elimination
4+ singleton
5+ , streamList
6+ , unstreamList
7+ , streamCString#
8+
9+ -- * Basic interface
10+ , cons
11+ , snoc
12+ , append
13+ , head
14+ , uncons
15+ , last
16+ , tail
17+ , init
18+ , null
19+ , lengthI
20+ , compareLengthI
21+ , isSingleton
22+
23+ -- * Transformations
24+ , map
25+ , intercalate
26+ , intersperse
27+
28+ -- ** Case conversion
29+ -- $case
30+ , toCaseFold
31+ , toLower
32+ , toTitle
33+ , toUpper
34+
35+ -- ** Justification
36+ , justifyLeftI
37+
38+ -- * Folds
39+ , foldl
40+ , foldl'
41+ , foldl1
42+ , foldl1'
43+ , foldr
44+ , foldr1
45+
46+ -- ** Special folds
47+ , concat
48+ , concatMap
49+ , any
50+ , all
51+ , maximum
52+ , minimum
53+
54+ -- * Construction
55+ -- ** Scans
56+ , scanl
57+
58+ -- ** Accumulating maps
59+ -- , mapAccumL
60+
61+ -- ** Generation and unfolding
62+ , replicateCharI
63+ , replicateI
64+ , unfoldr
65+ , unfoldrNI
66+
67+ -- * Substrings
68+ -- ** Breaking strings
69+ , take
70+ , drop
71+ , takeWhile
72+ , dropWhile
73+
74+ -- * Predicates
75+ , isPrefixOf
76+
77+ -- * Searching
78+ , elem
79+ , filter
80+
81+ -- * Indexing
82+ , findBy
83+ , indexI
84+ , findIndexI
85+ , countCharI
86+
87+ -- * Zipping and unzipping
88+ , zipWith
89+ ) where
90+
91+import Data.Text.Internal.Fusion.Common
92+import Prelude ()
jsaddle/src-ghc/Data/JSString/Internal/Fusion/Types.hsnew file+122
@@ -0,0 +1,122 @@
1+{-# LANGUAGE BangPatterns, ExistentialQuantification #-}
2+-- |
3+-- Module : Data.Text.Internal.Fusion.Types
4+-- Copyright : (c) Tom Harper 2008-2009,
5+-- (c) Bryan O'Sullivan 2009,
6+-- (c) Duncan Coutts 2009,
7+-- (c) Jasper Van der Jeugt 2011
8+--
9+-- License : BSD-style
10+-- Maintainer : bos@serpentine.com
11+-- Stability : experimental
12+-- Portability : GHC
13+--
14+-- /Warning/: this is an internal module, and does not have a stable
15+-- API or name. Functions in this module may not check or enforce
16+-- preconditions expected by public modules. Use at your own risk!
17+--
18+-- Core stream fusion functionality for text.
19+
20+module Data.JSString.Internal.Fusion.Types
21+ (
22+ CC(..)
23+-- , M(..)
24+-- , M8
25+ , PairS(..)
26+ , RS(..)
27+ , Step(..)
28+ , Stream(..)
29+-- , Switch(..)
30+ , empty
31+ ) where
32+
33+import Data.Text.Internal.Fusion.Types
34+-- import Data.Text.Internal.Fusion.Size
35+-- import Data.Word (Word8)
36+
37+---- | Specialised tuple for case conversion.
38+--data CC s = CC !s {-# UNPACK #-} !Char {-# UNPACK #-} !Char
39+--
40+---- | Specialised, strict Maybe-like type.
41+--data M a = N
42+-- | J !a
43+--
44+--type M8 = M Word8
45+--
46+---- Restreaming state.
47+--data RS s
48+-- = RS0 !s
49+-- | RS1 !s {-# UNPACK #-} !Word8
50+-- | RS2 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
51+-- | RS3 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
52+--
53+--infixl 2 :*:
54+--data PairS a b = !a :*: !b
55+-- -- deriving (Eq, Ord, Show)
56+--
57+---- | Allow a function over a stream to switch between two states.
58+--data Switch = S1 | S2
59+--
60+--data Step s a = Done
61+-- | Skip !s
62+-- | Yield !a !s
63+--
64+--{-
65+--instance (Show a) => Show (Step s a)
66+-- where show Done = "Done"
67+-- show (Skip _) = "Skip"
68+-- show (Yield x _) = "Yield " ++ show x
69+---}
70+--
71+--instance (Eq a) => Eq (Stream a) where
72+-- (==) = eq
73+--
74+--instance (Ord a) => Ord (Stream a) where
75+-- compare = cmp
76+--
77+---- The length hint in a Stream has two roles. If its value is zero,
78+---- we trust it, and treat the stream as empty. Otherwise, we treat it
79+---- as a hint: it should usually be accurate, so we use it when
80+---- unstreaming to decide what size array to allocate. However, the
81+---- unstreaming functions must be able to cope with the hint being too
82+---- small or too large.
83+--
84+--data Stream a =
85+-- forall s. Stream
86+-- (s -> Step s a) -- stepper function
87+-- !s -- current state
88+--
89+---- | /O(n)/ Determines if two streams are equal.
90+--eq :: (Eq a) => Stream a -> Stream a -> Bool
91+--eq (Stream next1 s1) (Stream next2 s2) = loop (next1 s1) (next2 s2)
92+-- where
93+-- loop Done Done = True
94+-- loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
95+-- loop (Skip s1') x2 = loop (next1 s1') x2
96+-- loop x1 (Skip s2') = loop x1 (next2 s2')
97+-- loop Done _ = False
98+-- loop _ Done = False
99+-- loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
100+-- loop (next1 s1') (next2 s2')
101+--{-# INLINE [0] eq #-}
102+--
103+--cmp :: (Ord a) => Stream a -> Stream a -> Ordering
104+--cmp (Stream next1 s1) (Stream next2 s2) = loop (next1 s1) (next2 s2)
105+-- where
106+-- loop Done Done = EQ
107+-- loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
108+-- loop (Skip s1') x2 = loop (next1 s1') x2
109+-- loop x1 (Skip s2') = loop x1 (next2 s2')
110+-- loop Done _ = LT
111+-- loop _ Done = GT
112+-- loop (Yield x1 s1') (Yield x2 s2') =
113+-- case compare x1 x2 of
114+-- EQ -> loop (next1 s1') (next2 s2')
115+-- other -> other
116+--{-# INLINE [0] cmp #-}
117+--
118+---- | The empty stream.
119+--empty :: Stream a
120+--empty = Stream next ()
121+-- where next _ = Done
122+--{-# INLINE [0] empty #-}
jsaddle/src-ghc/Data/JSString/Internal/Search.hsnew file+11
@@ -0,0 +1,11 @@
1+module Data.JSString.Internal.Search ( indices
2+ ) where
3+
4+import Data.Coerce (coerce)
5+
6+import Data.JSString.Internal.Type (JSString(..))
7+
8+import qualified Data.Text.Internal.Search as T
9+
10+indices :: JSString -> JSString -> [Int]
11+indices = coerce T.indices
jsaddle/src-ghc/Data/JSString/Internal/Type.hsnew file+116
@@ -0,0 +1,116 @@
1+{-# LANGUAGE DeriveDataTypeable, UnboxedTuples, MagicHash,
2+ BangPatterns, GeneralizedNewtypeDeriving #-}
3+{-# OPTIONS_HADDOCK not-home #-}
4+module Data.JSString.Internal.Type ( JSString(..)
5+ , empty
6+ , empty_
7+ , safe
8+ , firstf
9+ ) where
10+
11+ {-
12+ -- * Construction
13+ , text
14+ , textP
15+ -- * Safety
16+ , safe
17+ -- * Code that must be here for accessibility
18+ , empty
19+ , empty_
20+ -- * Utilities
21+ , firstf
22+ -- * Checked multiplication
23+ , mul
24+ , mul32
25+ , mul64
26+ -- * Debugging
27+ , showText
28+
29+ ) where
30+-}
31+import Control.DeepSeq
32+
33+import Data.Coerce (coerce)
34+import Data.Text (Text)
35+import qualified Data.Text as T (empty)
36+import Data.String (IsString)
37+import Data.Aeson (ToJSON(..), FromJSON(..))
38+import Data.Data (Data)
39+-- import Data.Text.Internal.Unsafe.Char (ord)
40+import Data.Typeable (Typeable)
41+import Data.Semigroup (Semigroup)
42+import GHC.Exts (Char(..), ord#, andI#, (/=#), isTrue#)
43+
44+-- | A wrapper around a JavaScript string
45+newtype JSString = JSString Text deriving(Show, Read, IsString, Semigroup, Monoid, Ord, Eq, Data, ToJSON, FromJSON, Typeable)
46+
47+instance NFData JSString where rnf !_ = ()
48+
49+-- | /O(1)/ The empty 'JSString'.
50+empty :: JSString
51+empty = coerce T.empty
52+{-# INLINE [1] empty #-}
53+
54+-- | A non-inlined version of 'empty'.
55+empty_ :: JSString
56+empty_ = coerce T.empty
57+{-# NOINLINE empty_ #-}
58+
59+safe :: Char -> Char
60+safe c@(C# cc)
61+ | isTrue# (andI# (ord# cc) 0x1ff800# /=# 0xd800#) = c
62+ | otherwise = '\xfffd'
63+{-# INLINE [0] safe #-}
64+
65+
66+-- | Apply a function to the first element of an optional pair.
67+firstf :: (a -> c) -> Maybe (a,b) -> Maybe (c,b)
68+firstf f (Just (a, b)) = Just (f a, b)
69+firstf _ Nothing = Nothing
70+
71+{-
72+-- | Checked multiplication. Calls 'error' if the result would
73+-- overflow.
74+mul :: Int -> Int -> Int
75+#if WORD_SIZE_IN_BITS == 64
76+mul a b = fromIntegral $ fromIntegral a `mul64` fromIntegral b
77+#else
78+mul a b = fromIntegral $ fromIntegral a `mul32` fromIntegral b
79+#endif
80+{-# INLINE mul #-}
81+infixl 7 `mul`
82+
83+-- | Checked multiplication. Calls 'error' if the result would
84+-- overflow.
85+mul64 :: Int64 -> Int64 -> Int64
86+mul64 a b
87+ | a >= 0 && b >= 0 = mul64_ a b
88+ | a >= 0 = -mul64_ a (-b)
89+ | b >= 0 = -mul64_ (-a) b
90+ | otherwise = mul64_ (-a) (-b)
91+{-# INLINE mul64 #-}
92+infixl 7 `mul64`
93+
94+mul64_ :: Int64 -> Int64 -> Int64
95+mul64_ a b
96+ | ahi > 0 && bhi > 0 = error "overflow"
97+ | top > 0x7fffffff = error "overflow"
98+ | total < 0 = error "overflow"
99+ | otherwise = total
100+ where (# ahi, alo #) = (# a `shiftR` 32, a .&. 0xffffffff #)
101+ (# bhi, blo #) = (# b `shiftR` 32, b .&. 0xffffffff #)
102+ top = ahi * blo + alo * bhi
103+ total = (top `shiftL` 32) + alo * blo
104+{-# INLINE mul64_ #-}
105+
106+-- | Checked multiplication. Calls 'error' if the result would
107+-- overflow.
108+mul32 :: Int32 -> Int32 -> Int32
109+mul32 a b = case fromIntegral a * fromIntegral b of
110+ ab | ab < min32 || ab > max32 -> error "overflow"
111+ | otherwise -> fromIntegral ab
112+ where min32 = -0x80000000 :: Int64
113+ max32 = 0x7fffffff
114+{-# INLINE mul32 #-}
115+infixl 7 `mul32`
116+-}
jsaddle/src-ghc/Data/JSString/Text.hsnew file+52
@@ -0,0 +1,52 @@
1+{- | Conversion between 'Data.Text.Text' and 'Data.JSString.JSString' -}
2+
3+module Data.JSString.Text
4+ ( textToJSString
5+ , textFromJSString
6+ , lazyTextToJSString
7+ , lazyTextFromJSString
8+ , textFromJSVal
9+ , lazyTextFromJSVal
10+ ) where
11+
12+import GHCJS.Prim.Internal (JSVal)
13+
14+import Data.Coerce (coerce)
15+import qualified Data.Text as T
16+import qualified Data.Text.Lazy as TL
17+
18+import Data.JSString.Internal.Type
19+
20+import Language.Javascript.JSaddle.Types (JSM, GHCJSPure(..))
21+import Language.Javascript.JSaddle.Native.Internal
22+ (valueToString)
23+
24+textToJSString :: T.Text -> JSString
25+textToJSString = coerce
26+{-# INLINE textToJSString #-}
27+
28+textFromJSString :: JSString -> T.Text
29+textFromJSString = coerce
30+{-# INLINE textFromJSString #-}
31+
32+lazyTextToJSString :: TL.Text -> JSString
33+lazyTextToJSString = coerce . TL.toStrict
34+{-# INLINE lazyTextToJSString #-}
35+
36+lazyTextFromJSString :: JSString -> TL.Text
37+lazyTextFromJSString = TL.fromStrict . coerce
38+{-# INLINE lazyTextFromJSString #-}
39+
40+-- | returns the empty Text if not a string
41+textFromJSVal :: JSVal -> GHCJSPure T.Text
42+textFromJSVal j = GHCJSPure $ textFromJSString <$> valToJSString j
43+{-# INLINE textFromJSVal #-}
44+
45+-- | returns the empty Text if not a string
46+lazyTextFromJSVal :: JSVal -> GHCJSPure TL.Text
47+lazyTextFromJSVal j = GHCJSPure $ lazyTextFromJSString <$> valToJSString j
48+{-# INLINE lazyTextFromJSVal #-}
49+
50+valToJSString :: JSVal -> JSM JSString
51+valToJSString = valueToString
52+{-# INLINE valToJSString #-}
jsaddle/src-ghc/GHCJS/Buffer.hsnew file+117
@@ -0,0 +1,117 @@
1+module GHCJS.Buffer
2+ ( Buffer
3+ , MutableBuffer
4+ , create
5+ , createFromArrayBuffer
6+ , thaw, freeze, clone
7+ -- * JavaScript properties
8+ , byteLength
9+ , getArrayBuffer
10+ , getUint8Array
11+ , getUint16Array
12+ , getInt32Array
13+ , getDataView
14+ , getFloat32Array
15+ , getFloat64Array
16+ -- * bytestring
17+ , toByteString, fromByteString
18+ ) where
19+
20+import GHCJS.Buffer.Types
21+
22+import Control.Lens.Operators ((^.))
23+
24+import Data.ByteString (ByteString)
25+import qualified Data.ByteString as BS
26+import qualified Data.ByteString.Base64 as B64 (encode, decode)
27+import Data.Text.Encoding (encodeUtf8, decodeUtf8)
28+
29+import qualified JavaScript.TypedArray.Internal.Types as I
30+import JavaScript.TypedArray.ArrayBuffer.Internal (SomeArrayBuffer(..))
31+import JavaScript.TypedArray.DataView.Internal (SomeDataView(..))
32+
33+import GHCJS.Marshal (FromJSVal(..))
34+import Language.Javascript.JSaddle.Types (JSM, GHCJSPure(..), ghcjsPure)
35+import Language.Javascript.JSaddle.Object (js, js2, jsg1, jsg3)
36+
37+create :: Int -> JSM MutableBuffer
38+create n | n >= 0 = SomeBuffer <$> jsg1 "h$newByteArray" n
39+ | otherwise = error "create: negative size"
40+{-# INLINE create #-}
41+
42+createFromArrayBuffer :: SomeArrayBuffer any -> GHCJSPure (SomeBuffer any)
43+createFromArrayBuffer (SomeArrayBuffer buf) = GHCJSPure $ SomeBuffer <$> jsg1 "h$wrapBuffer" buf
44+{-# INLINE createFromArrayBuffer #-}
45+
46+getArrayBuffer :: SomeBuffer any -> GHCJSPure (SomeArrayBuffer any)
47+getArrayBuffer (SomeBuffer buf) = GHCJSPure $ SomeArrayBuffer <$> buf ^. js "buf"
48+{-# INLINE getArrayBuffer #-}
49+
50+getInt32Array :: SomeBuffer any -> GHCJSPure (I.SomeInt32Array any)
51+getInt32Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "i3"
52+{-# INLINE getInt32Array #-}
53+
54+getUint8Array :: SomeBuffer any -> GHCJSPure (I.SomeUint8Array any)
55+getUint8Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "u8"
56+{-# INLINE getUint8Array #-}
57+
58+getUint16Array :: SomeBuffer any -> GHCJSPure (I.SomeUint16Array any)
59+getUint16Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "u1"
60+{-# INLINE getUint16Array #-}
61+
62+getFloat32Array :: SomeBuffer any -> GHCJSPure (I.SomeFloat32Array any)
63+getFloat32Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "f3"
64+{-# INLINE getFloat32Array #-}
65+
66+getFloat64Array :: SomeBuffer any -> GHCJSPure (I.SomeFloat64Array any)
67+getFloat64Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "f6"
68+{-# INLINE getFloat64Array #-}
69+
70+getDataView :: SomeBuffer any -> GHCJSPure (SomeDataView any)
71+getDataView (SomeBuffer buf) = GHCJSPure $ SomeDataView <$> buf ^. js "dv"
72+{-# INLINE getDataView #-}
73+
74+freeze :: MutableBuffer -> JSM Buffer
75+freeze = js_clone
76+{-# INLINE freeze #-}
77+
78+thaw :: Buffer -> JSM MutableBuffer
79+thaw = js_clone
80+{-# INLINE thaw #-}
81+
82+clone :: MutableBuffer -> JSM (SomeBuffer any2)
83+clone = js_clone
84+{-# INLINE clone #-}
85+
86+fromByteString :: ByteString -> GHCJSPure (Buffer, Int, Int)
87+fromByteString bs = GHCJSPure $ do
88+ buffer <- SomeBuffer <$> jsg1 "h$newByteArrayFromBase64String" (decodeUtf8 $ B64.encode bs)
89+ return (buffer, 0, BS.length bs)
90+{-# INLINE fromByteString #-}
91+
92+-- | Wrap a 'Buffer' into a 'ByteString' using the given offset
93+-- and length.
94+toByteString :: Int -> Maybe Int -> Buffer -> GHCJSPure ByteString
95+toByteString off mbLen buf = GHCJSPure $ do
96+ bufLen <- ghcjsPure $ byteLength buf
97+ case mbLen of
98+ _ | off < 0 -> error "toByteString: negative offset"
99+ | off > bufLen -> error "toByteString: offset past end of buffer"
100+ Just len | len < 0 -> error "toByteString: negative length"
101+ | len > bufLen - off -> error "toByteString: length past end of buffer"
102+ | otherwise -> ghcjsPure $ unsafeToByteString off len buf
103+ Nothing -> ghcjsPure $ unsafeToByteString off (bufLen - off) buf
104+
105+unsafeToByteString :: Int -> Int -> Buffer -> GHCJSPure ByteString
106+unsafeToByteString off len (SomeBuffer buf) = GHCJSPure $ do
107+ b64 <- jsg3 "h$byteArrayToBase64String" off len buf >>= fromJSValUnchecked
108+ return $ case B64.decode (encodeUtf8 b64) of
109+ Left err -> error $ "unsafeToByteString base 64 decode error :" ++ err
110+ Right bs -> bs
111+
112+byteLength :: SomeBuffer any -> GHCJSPure Int
113+byteLength (SomeBuffer buf) = GHCJSPure $ buf ^. js "len" >>= fromJSValUnchecked
114+{-# INLINE byteLength #-}
115+
116+js_clone :: SomeBuffer any1 -> JSM (SomeBuffer any2)
117+js_clone (SomeBuffer buf) = SomeBuffer <$> jsg1 "h$wrapBuffer" (buf ^. js "buf" ^. js2 "slice" (buf ^. js "u8" ^. js "byteOffset") (buf ^. js "len"))
jsaddle/src-ghc/GHCJS/Buffer/Types.hsnew file+11
@@ -0,0 +1,11 @@
1+{-# LANGUAGE DataKinds, KindSignatures, PolyKinds #-}
2+
3+module GHCJS.Buffer.Types where
4+
5+import GHCJS.Types
6+import GHCJS.Internal.Types
7+
8+newtype SomeBuffer (a :: MutabilityType s) = SomeBuffer JSVal
9+
10+type Buffer = SomeBuffer Immutable
11+type MutableBuffer = SomeBuffer Mutable
jsaddle/src-ghc/GHCJS/Concurrent.hsnew file+22
@@ -0,0 +1,22 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+
3+module GHCJS.Concurrent ( OnBlocked(..)
4+ , WouldBlockException(..)
5+ ) where
6+
7+import GHCJS.Prim
8+
9+import Data.Data
10+
11+{- |
12+ The runtime tries to run synchronous threads to completion. Sometimes it's
13+ not possible to continue running a thread, for example when the thread
14+ tries to take an empty 'MVar'. The runtime can then either throw a
15+ 'WouldBlockException', aborting the blocking action, or continue the
16+ thread asynchronously.
17+ -}
18+
19+data OnBlocked = ContinueAsync -- ^ continue the thread asynchronously if blocked
20+ | ThrowWouldBlock -- ^ throw 'WouldBlockException' if blocked
21+ deriving (Data, Typeable, Enum, Show, Eq, Ord)
22+
jsaddle/src-ghc/GHCJS/Foreign.hsnew file+64
@@ -0,0 +1,64 @@
1+{-# LANGUAGE CPP #-}
2+-----------------------------------------------------------------------------
3+--
4+-- Module : Language.Javascript.JSaddle.Value
5+-- Copyright : (c) Hamish Mackenzie
6+-- License : MIT
7+--
8+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
9+--
10+-- |
11+--
12+-----------------------------------------------------------------------------
13+module GHCJS.Foreign (
14+ jsTrue
15+ , jsFalse
16+ , jsNull
17+ , toJSBool
18+-- , fromJSBool
19+ , jsUndefined
20+ , isTruthy
21+ , isNull
22+ , isUndefined
23+ , isObject
24+ , isFunction
25+ , isString
26+ , isBoolean
27+ , isSymbol
28+ , isNumber
29+ , JSType(..)
30+ , jsTypeOf
31+) where
32+
33+import GHCJS.Foreign.Internal
34+import Language.Javascript.JSaddle.Types (JSVal(..), GHCJSPure(..))
35+import Language.Javascript.JSaddle.Object (jsg1)
36+import GHCJS.Marshal (FromJSVal(..))
37+
38+isObject :: JSVal -> GHCJSPure Bool
39+isObject v = GHCJSPure $ jsg1 "h$isObject" v >>= fromJSValUnchecked
40+{-# INLINE isObject #-}
41+
42+isFunction :: JSVal -> GHCJSPure Bool
43+isFunction v = GHCJSPure $ jsg1 "h$isFunction" v >>= fromJSValUnchecked
44+{-# INLINE isFunction #-}
45+
46+isString :: JSVal -> GHCJSPure Bool
47+isString v = GHCJSPure $ jsg1 "h$isString" v >>= fromJSValUnchecked
48+{-# INLINE isString #-}
49+
50+isBoolean :: JSVal -> GHCJSPure Bool
51+isBoolean v = GHCJSPure $ jsg1 "h$isBoolean" v >>= fromJSValUnchecked
52+{-# INLINE isBoolean #-}
53+
54+isSymbol :: JSVal -> GHCJSPure Bool
55+isSymbol v = GHCJSPure $ jsg1 "h$isSymbol" v >>= fromJSValUnchecked
56+{-# INLINE isSymbol #-}
57+
58+isNumber :: JSVal -> GHCJSPure Bool
59+isNumber v = GHCJSPure $ jsg1 "h$isNumber" v >>= fromJSValUnchecked
60+{-# INLINE isNumber #-}
61+
62+jsTypeOf :: JSVal -> GHCJSPure JSType
63+jsTypeOf v = GHCJSPure $ toEnum <$> (jsg1 "h$jsonTypeOf" v >>= fromJSValUnchecked)
64+{-# INLINE jsTypeOf #-}
jsaddle/src-ghc/GHCJS/Foreign/Internal.hsnew file+67
@@ -0,0 +1,67 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.Javascript.JSaddle.Value
4+-- Copyright : (c) Hamish Mackenzie
5+-- License : MIT
6+--
7+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
8+--
9+-- |
10+--
11+-----------------------------------------------------------------------------
12+module GHCJS.Foreign.Internal (
13+ jsTrue
14+ , jsFalse
15+ , jsNull
16+ , toJSBool
17+-- , fromJSBool
18+ , jsUndefined
19+ , isTruthy
20+ , isNull
21+ , isUndefined
22+ , JSType(..)
23+) where
24+
25+import Language.Javascript.JSaddle.Types (JSVal(..), GHCJSPure(..))
26+import Language.Javascript.JSaddle.Native.Internal
27+ (valueToBool)
28+import Data.Typeable (Typeable)
29+import GHCJS.Prim (isNull, isUndefined)
30+import System.IO.Unsafe (unsafePerformIO)
31+import Data.IORef (newIORef)
32+
33+jsTrue :: JSVal
34+jsTrue = JSVal . unsafePerformIO $ newIORef 3
35+{-# NOINLINE jsTrue #-}
36+
37+jsFalse :: JSVal
38+jsFalse = JSVal . unsafePerformIO $ newIORef 2
39+{-# NOINLINE jsFalse #-}
40+
41+jsNull :: JSVal
42+jsNull = JSVal . unsafePerformIO $ newIORef 0
43+{-# NOINLINE jsNull #-}
44+
45+toJSBool :: Bool -> JSVal
46+toJSBool b = JSVal . unsafePerformIO . newIORef $ if b then 3 else 2
47+{-# NOINLINE toJSBool #-}
48+
49+jsUndefined :: JSVal
50+jsUndefined = JSVal . unsafePerformIO $ newIORef 1
51+{-# NOINLINE jsUndefined #-}
52+
53+isTruthy :: JSVal -> GHCJSPure Bool
54+isTruthy = GHCJSPure . valueToBool
55+{-# INLINE isTruthy #-}
56+
57+-- types returned by JS typeof operator
58+data JSType = Undefined
59+ | Object
60+ | Boolean
61+ | Number
62+ | String
63+ | Symbol
64+ | Function
65+ | Other -- ^ implementation dependent
66+ deriving (Show, Eq, Ord, Enum, Typeable)
67+
jsaddle/src-ghc/GHCJS/Internal/Types.hsnew file+16
@@ -0,0 +1,16 @@
1+module GHCJS.Internal.Types ( IsJSVal(..)
2+ , jsval
3+ , MutabilityType(..)
4+ , Mutable
5+ , Immutable
6+ , IsItMutable(..)
7+ , Mutability
8+ ) where
9+
10+import Language.Javascript.JSaddle.Types
11+import Language.Javascript.JSaddle.Native.Internal (stringToValue)
12+
13+instance IsJSVal JSString where
14+ jsval_ a = GHCJSPure $ stringToValue a
15+ {-# INLINE jsval_ #-}
16+
jsaddle/src-ghc/GHCJS/Marshal.hs+37−36
@@ -17,19 +17,23 @@ import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
17
17
18import qualified Data.Aeson as AE
18import qualified Data.Aeson as AE
19import Data.Int (Int8, Int16, Int32)
19import Data.Int (Int8, Int16, Int32)
20+import Data.Text (Text)
20import Data.Word (Word8, Word16, Word32, Word)
21import Data.Word (Word8, Word16, Word32, Word)
21
22
22import GHC.Prim
23import GHC.Prim
23
24
24−import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), Command(ValueToJSONValue), Result(ValueToJSONValueResult))
25+import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), ghcjsPure)
25−import Language.Javascript.JSaddle.Native (withToJSVal)
26+import Language.Javascript.JSaddle.Native.Internal
26−import Language.Javascript.JSaddle.Run(sendCommand)
27+ (valueToJSONValue, jsonValueToValue, valueToNumber)
28+
29+import GHCJS.Types (JSString, isUndefined, isNull)
27−import GHCJS.Marshal.Internal
30+import GHCJS.Foreign.Internal (isTruthy)
28import GHCJS.Marshal.Pure ()
31import GHCJS.Marshal.Pure ()
29−import Language.Javascript.JSaddle.Value (isUndefinedIO, valToNumber,
32+
30− valToBool, valMakeJSON)
31−import Language.Javascript.JSaddle.Array (fromListIO)
33+import JavaScript.Array (fromListIO)
32−import qualified Language.Javascript.JSaddle.Array as A (read)
34+import qualified JavaScript.Array as A (read)
35+
36+import GHCJS.Marshal.Internal
33
37
34instance FromJSVal JSVal where
38instance FromJSVal JSVal where
35 fromJSValUnchecked x = return x
39 fromJSValUnchecked x = return x
@@ -42,65 +46,62 @@ instance FromJSVal () where
42 fromJSVal = fromJSVal_pure
46 fromJSVal = fromJSVal_pure
43-- {-# INLINE fromJSVal #-}
47-- {-# INLINE fromJSVal #-}
44instance FromJSVal Bool where
48instance FromJSVal Bool where
45− fromJSValUnchecked = valToBool
49+ fromJSValUnchecked = ghcjsPure . isTruthy
46 {-# INLINE fromJSValUnchecked #-}
50 {-# INLINE fromJSValUnchecked #-}
47− fromJSVal = fmap Just . valToBool
51+ fromJSVal = fmap Just . ghcjsPure . isTruthy
48 {-# INLINE fromJSVal #-}
52 {-# INLINE fromJSVal #-}
49instance FromJSVal Int where
53instance FromJSVal Int where
50− fromJSValUnchecked = fmap round . valToNumber
54+ fromJSValUnchecked = fmap round . valueToNumber
51 {-# INLINE fromJSValUnchecked #-}
55 {-# INLINE fromJSValUnchecked #-}
52− fromJSVal = fmap (Just . round) . valToNumber
56+ fromJSVal = fmap (Just . round) . valueToNumber
53 {-# INLINE fromJSVal #-}
57 {-# INLINE fromJSVal #-}
54instance FromJSVal Int8 where
58instance FromJSVal Int8 where
55− fromJSValUnchecked = fmap round . valToNumber
59+ fromJSValUnchecked = fmap round . valueToNumber
56 {-# INLINE fromJSValUnchecked #-}
60 {-# INLINE fromJSValUnchecked #-}
57− fromJSVal = fmap (Just . round) . valToNumber
61+ fromJSVal = fmap (Just . round) . valueToNumber
58 {-# INLINE fromJSVal #-}
62 {-# INLINE fromJSVal #-}
59instance FromJSVal Int16 where
63instance FromJSVal Int16 where
60− fromJSValUnchecked = fmap round . valToNumber
64+ fromJSValUnchecked = fmap round . valueToNumber
61 {-# INLINE fromJSValUnchecked #-}
65 {-# INLINE fromJSValUnchecked #-}
62− fromJSVal = fmap (Just . round) . valToNumber
66+ fromJSVal = fmap (Just . round) . valueToNumber
63 {-# INLINE fromJSVal #-}
67 {-# INLINE fromJSVal #-}
64instance FromJSVal Int32 where
68instance FromJSVal Int32 where
65− fromJSValUnchecked = fmap round . valToNumber
69+ fromJSValUnchecked = fmap round . valueToNumber
66 {-# INLINE fromJSValUnchecked #-}
70 {-# INLINE fromJSValUnchecked #-}
67− fromJSVal = fmap (Just . round) . valToNumber
71+ fromJSVal = fmap (Just . round) . valueToNumber
68 {-# INLINE fromJSVal #-}
72 {-# INLINE fromJSVal #-}
69instance FromJSVal Word where
73instance FromJSVal Word where
70− fromJSValUnchecked = fmap round . valToNumber
74+ fromJSValUnchecked = fmap round . valueToNumber
71 {-# INLINE fromJSValUnchecked #-}
75 {-# INLINE fromJSValUnchecked #-}
72− fromJSVal = fmap (Just . round) . valToNumber
76+ fromJSVal = fmap (Just . round) . valueToNumber
73 {-# INLINE fromJSVal #-}
77 {-# INLINE fromJSVal #-}
74instance FromJSVal Word8 where
78instance FromJSVal Word8 where
75− fromJSValUnchecked = fmap round . valToNumber
79+ fromJSValUnchecked = fmap round . valueToNumber
76 {-# INLINE fromJSValUnchecked #-}
80 {-# INLINE fromJSValUnchecked #-}
77− fromJSVal = fmap (Just . round) . valToNumber
81+ fromJSVal = fmap (Just . round) . valueToNumber
78 {-# INLINE fromJSVal #-}
82 {-# INLINE fromJSVal #-}
79instance FromJSVal Word16 where
83instance FromJSVal Word16 where
80− fromJSValUnchecked = fmap round . valToNumber
84+ fromJSValUnchecked = fmap round . valueToNumber
81 {-# INLINE fromJSValUnchecked #-}
85 {-# INLINE fromJSValUnchecked #-}
82− fromJSVal = fmap (Just . round) . valToNumber
86+ fromJSVal = fmap (Just . round) . valueToNumber
83 {-# INLINE fromJSVal #-}
87 {-# INLINE fromJSVal #-}
84instance FromJSVal Word32 where
88instance FromJSVal Word32 where
85− fromJSValUnchecked = fmap round . valToNumber
89+ fromJSValUnchecked = fmap round . valueToNumber
86 {-# INLINE fromJSValUnchecked #-}
90 {-# INLINE fromJSValUnchecked #-}
87− fromJSVal = fmap (Just . round) . valToNumber
91+ fromJSVal = fmap (Just . round) . valueToNumber
88 {-# INLINE fromJSVal #-}
92 {-# INLINE fromJSVal #-}
89instance FromJSVal Float where
93instance FromJSVal Float where
90− fromJSValUnchecked = fmap realToFrac . valToNumber
94+ fromJSValUnchecked = fmap realToFrac . valueToNumber
91 {-# INLINE fromJSValUnchecked #-}
95 {-# INLINE fromJSValUnchecked #-}
92− fromJSVal = fmap (Just . realToFrac) . valToNumber
96+ fromJSVal = fmap (Just . realToFrac) . valueToNumber
93 {-# INLINE fromJSVal #-}
97 {-# INLINE fromJSVal #-}
94instance FromJSVal Double where
98instance FromJSVal Double where
95− fromJSValUnchecked = valToNumber
99+ fromJSValUnchecked = valueToNumber
96 {-# INLINE fromJSValUnchecked #-}
100 {-# INLINE fromJSValUnchecked #-}
97− fromJSVal = fmap Just . valToNumber
101+ fromJSVal = fmap Just . valueToNumber
98 {-# INLINE fromJSVal #-}
102 {-# INLINE fromJSVal #-}
99instance FromJSVal AE.Value where
103instance FromJSVal AE.Value where
100− fromJSVal r =
104+ fromJSVal r = Just <$> valueToJSONValue r
101− withToJSVal r $ \rval -> do
102− ValueToJSONValueResult result <- sendCommand (ValueToJSONValue rval)
103− return $ Just result
104 {-# INLINE fromJSVal #-}
105 {-# INLINE fromJSVal #-}
105instance (FromJSVal a, FromJSVal b) => FromJSVal (a,b) where
106instance (FromJSVal a, FromJSVal b) => FromJSVal (a,b) where
106 fromJSVal r = runMaybeT $ (,) <$> jf r 0 <*> jf r 1
107 fromJSVal r = runMaybeT $ (,) <$> jf r 0 <*> jf r 1
@@ -127,7 +128,7 @@ instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJ
127jf :: FromJSVal a => JSVal -> Int -> MaybeT JSM a
128jf :: FromJSVal a => JSVal -> Int -> MaybeT JSM a
128jf r n = MaybeT $ do
129jf r n = MaybeT $ do
129 r' <- A.read n (SomeJSArray r)
130 r' <- A.read n (SomeJSArray r)
130− isUndefinedIO r >>= \case
131+ ghcjsPure (isUndefined r) >>= \case
131 True -> return Nothing
132 True -> return Nothing
132 False -> fromJSVal r'
133 False -> fromJSVal r'
133
134
@@ -164,5 +165,5 @@ arr7 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSM JSVal
164arr7 a b c d e f g = coerce <$> fromListIO [a,b,c,d,e,f,g]
165arr7 a b c d e f g = coerce <$> fromListIO [a,b,c,d,e,f,g]
165
166
166toJSVal_aeson :: AE.ToJSON a => a -> JSM JSVal
167toJSVal_aeson :: AE.ToJSON a => a -> JSM JSVal
167−toJSVal_aeson = valMakeJSON . AE.toJSON
168+toJSVal_aeson = jsonValueToValue . AE.toJSON
168
169
jsaddle/src-ghc/GHCJS/Marshal/Internal.hs+66−32
@@ -1,21 +1,21 @@
1−{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, DefaultSignatures,
1+{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, DefaultSignatures,
2 TypeOperators, TupleSections, FlexibleContexts, FlexibleInstances,
2 TypeOperators, TupleSections, FlexibleContexts, FlexibleInstances,
3 LambdaCase
3 LambdaCase
4 #-}
4 #-}
5
5
6−module GHCJS.Marshal.Internal (
6+module GHCJS.Marshal.Internal ( FromJSVal(..)
7− FromJSVal(..)
8− , ToJSVal(..)
7+ , ToJSVal(..)
9− , PToJSVal(..)
8+ , PToJSVal(..)
10− , PFromJSVal(..)
9+ , PFromJSVal(..)
11− , Purity(..)
10+ , Purity(..)
12− , toJSVal_generic
11+ , toJSVal_generic
13− , fromJSVal_generic
12+ , fromJSVal_generic
14− , toJSVal_pure
13+ , toJSVal_pure
15− , fromJSVal_pure
14+ , fromJSVal_pure
16− , fromJSValUnchecked_pure
15+ , fromJSValUnchecked_pure
17− ) where
16+ ) where
18−
17+
18+import Control.Applicative
19import Control.Monad
19import Control.Monad
20
20
21import Data.Data
21import Data.Data
@@ -25,11 +25,17 @@ import qualified Data.Text as T (pack)
25
25
26import GHC.Generics
26import GHC.Generics
27
27
28−import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), MutableJSArray, JSString)
28+import qualified GHCJS.Prim.Internal as Prim
29−import Language.Javascript.JSaddle.Foreign (jsNull, jsTrue, isUndefinedIO)
29+import qualified GHCJS.Foreign.Internal as F
30−import Language.Javascript.JSaddle.String (textToStr)
30+import GHCJS.Types
31+
32+import qualified Data.JSString.Internal.Type as JSS
33+
31import qualified JavaScript.Object.Internal as OI (Object(..), create, setProp, getProp)
34import qualified JavaScript.Object.Internal as OI (Object(..), create, setProp, getProp)
32−import qualified JavaScript.Array.Internal as AI (create, push, read, fromListIO, toListIO)
35+import qualified JavaScript.Array.Internal as AI (SomeJSArray(..), create, push, read, fromListIO, toListIO)
36+
37+import Language.Javascript.JSaddle.Types (JSM, MutableJSArray, GHCJSPure(..), ghcjsPure, ghcjsPureMap, JSadddleHasCallStack)
38+import Language.Javascript.JSaddle.String (textToStr)
33
39
34data Purity = PureShared -- ^ conversion is pure even if the original value is shared
40data Purity = PureShared -- ^ conversion is pure even if the original value is shared
35 | PureExclusive -- ^ conversion is pure if the we only convert once
41 | PureExclusive -- ^ conversion is pure if the we only convert once
@@ -49,25 +55,53 @@ class ToJSVal a where
49 toJSValListOf :: [a] -> JSM JSVal
55 toJSValListOf :: [a] -> JSM JSVal
50 toJSValListOf = fmap coerce . AI.fromListIO <=< mapM toJSVal
56 toJSValListOf = fmap coerce . AI.fromListIO <=< mapM toJSVal
51
57
58+ -- default toJSVal :: PToJSVal a => a -> JSM (JSVal a)
59+ -- toJSVal x = return (pToJSVal x)
60+
52 default toJSVal :: (Generic a, GToJSVal (Rep a ())) => a -> JSM JSVal
61 default toJSVal :: (Generic a, GToJSVal (Rep a ())) => a -> JSM JSVal
53 toJSVal = toJSVal_generic id
62 toJSVal = toJSVal_generic id
54
63
64+fromJustWithStack :: JSadddleHasCallStack => Maybe a -> a
65+fromJustWithStack Nothing = error "fromJSValUnchecked: fromJSVal result was Nothing"
66+fromJustWithStack (Just x) = x
67+
55class FromJSVal a where
68class FromJSVal a where
56 fromJSVal :: JSVal -> JSM (Maybe a)
69 fromJSVal :: JSVal -> JSM (Maybe a)
57
70
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
58 fromJSValUnchecked :: JSVal -> JSM a
81 fromJSValUnchecked :: JSVal -> JSM a
59 fromJSValUnchecked = fmap fromJust . fromJSVal
82 fromJSValUnchecked = fmap fromJust . fromJSVal
83+#endif
60 {-# INLINE fromJSValUnchecked #-}
84 {-# INLINE fromJSValUnchecked #-}
61
85
62 fromJSValListOf :: JSVal -> JSM (Maybe [a])
86 fromJSValListOf :: JSVal -> JSM (Maybe [a])
63 fromJSValListOf = fmap sequence . (mapM fromJSVal <=< AI.toListIO . coerce) -- fixme should check that it's an array
87 fromJSValListOf = fmap sequence . (mapM fromJSVal <=< AI.toListIO . coerce) -- fixme should check that it's an array
64
88
89+#if MIN_VERSION_base(4,9,0) && defined(JSADDLE_HAS_CALL_STACK)
90+ fromJSValUncheckedListOf :: JSadddleHasCallStack => JSVal -> JSM [a]
91+#else
65 fromJSValUncheckedListOf :: JSVal -> JSM [a]
92 fromJSValUncheckedListOf :: JSVal -> JSM [a]
93+#endif
66 fromJSValUncheckedListOf = mapM fromJSValUnchecked <=< AI.toListIO . coerce
94 fromJSValUncheckedListOf = mapM fromJSValUnchecked <=< AI.toListIO . coerce
67
95
96+ -- default fromJSVal :: PFromJSVal a => JSVal a -> JSM (Maybe a)
97+ -- fromJSVal x = return (Just (pFromJSVal x))
98+
68 default fromJSVal :: (Generic a, GFromJSVal (Rep a ())) => JSVal -> JSM (Maybe a)
99 default fromJSVal :: (Generic a, GFromJSVal (Rep a ())) => JSVal -> JSM (Maybe a)
69 fromJSVal = fromJSVal_generic id
100 fromJSVal = fromJSVal_generic id
70
101
102+ -- default fromJSValUnchecked :: PFromJSVal a => a -> IO a
103+ -- fromJSValUnchecked x = return (pFromJSVal x)
104+
71-- -----------------------------------------------------------------------------
105-- -----------------------------------------------------------------------------
72
106
73class GToJSVal a where
107class GToJSVal a where
@@ -92,8 +126,8 @@ instance (GToJSVal (a p), GToJSVal (b p)) => GToJSVal ((a :+: b) p) where
92 gToJSVal f _ (L1 x) = gToJSVal f True x
126 gToJSVal f _ (L1 x) = gToJSVal f True x
93 gToJSVal f _ (R1 x) = gToJSVal f True x
127 gToJSVal f _ (R1 x) = gToJSVal f True x
94
128
95−instance (GToJSVal (a p)) => GToJSVal (M1 D c a p) where
129+instance (Datatype c, GToJSVal (a p)) => GToJSVal (M1 D c a p) where
96− gToJSVal f b (M1 x) = gToJSVal f b x
130+ gToJSVal f b m@(M1 x) = gToJSVal f b x
97
131
98instance (Constructor c, GToJSVal (a p)) => GToJSVal (M1 C c a p) where
132instance (Constructor c, GToJSVal (a p)) => GToJSVal (M1 C c a p) where
99 gToJSVal f True m@(M1 x) = do
133 gToJSVal f True m@(M1 x) = do
@@ -109,7 +143,7 @@ instance (GToJSArr (a p), GToJSArr (b p), GToJSProp (a p), GToJSProp (b p)) => G
109 gToJSProp f obj' xy
143 gToJSProp f obj' xy
110 return obj'
144 return obj'
111 gToJSVal f False xy = do
145 gToJSVal f False xy = do
112− arr@(SomeJSArray arr') <- AI.create
146+ arr@(AI.SomeJSArray arr') <- AI.create
113 gToJSArr f arr xy
147 gToJSArr f arr xy
114 return arr'
148 return arr'
115
149
@@ -133,10 +167,10 @@ instance GToJSVal (a p) => GToJSArr (M1 S c a p) where
133 AI.push r a
167 AI.push r a
134
168
135instance GToJSVal (V1 p) where
169instance GToJSVal (V1 p) where
136− gToJSVal _ _ _ = return jsNull
170+ gToJSVal _ _ _ = return Prim.jsNull
137
171
138instance GToJSVal (U1 p) where
172instance GToJSVal (U1 p) where
139− gToJSVal _ _ _ = return jsTrue
173+ gToJSVal _ _ _ = return F.jsTrue
140
174
141toJSVal_generic :: forall a . (Generic a, GToJSVal (Rep a ()))
175toJSVal_generic :: forall a . (Generic a, GToJSVal (Rep a ()))
142 => (String -> String) -> a -> JSM JSVal
176 => (String -> String) -> a -> JSM JSVal
@@ -163,26 +197,26 @@ instance GFromJSVal (f p) => GFromJSVal (Rec1 f p) where
163 gFromJSVal f b r = gFromJSVal f b r
197 gFromJSVal f b r = gFromJSVal f b r
164
198
165instance (GFromJSVal (a p), GFromJSVal (b p)) => GFromJSVal ((a :+: b) p) where
199instance (GFromJSVal (a p), GFromJSVal (b p)) => GFromJSVal ((a :+: b) p) where
166− gFromJSVal f _b r = do
200+ gFromJSVal f b r = do
167 l <- gFromJSVal f True r
201 l <- gFromJSVal f True r
168 case l of
202 case l of
169 Just x -> return (L1 <$> Just x)
203 Just x -> return (L1 <$> Just x)
170 Nothing -> fmap R1 <$> gFromJSVal f True r
204 Nothing -> fmap R1 <$> gFromJSVal f True r
171
205
172−instance GFromJSVal (a p) => GFromJSVal (M1 D c a p) where
206+instance (Datatype c, GFromJSVal (a p)) => GFromJSVal (M1 D c a p) where
173 gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r
207 gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r
174
208
175instance forall c a p . (Constructor c, GFromJSVal (a p)) => GFromJSVal (M1 C c a p) where
209instance forall c a p . (Constructor c, GFromJSVal (a p)) => GFromJSVal (M1 C c a p) where
176 gFromJSVal f True r = do
210 gFromJSVal f True r = do
177 r' <- OI.getProp (packJSS . f $ conName (undefined :: M1 C c a p)) (OI.Object r)
211 r' <- OI.getProp (packJSS . f $ conName (undefined :: M1 C c a p)) (OI.Object r)
178− isUndefinedIO r' >>= \case
212+ ghcjsPure (isUndefined r') >>= \case
179 True -> return Nothing
213 True -> return Nothing
180 False -> fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r'
214 False -> fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r'
181 gFromJSVal f _ r = fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r
215 gFromJSVal f _ r = fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r
182
216
183instance (GFromJSArr (a p), GFromJSArr (b p), GFromJSProp (a p), GFromJSProp (b p)) => GFromJSVal ((a :*: b) p) where
217instance (GFromJSArr (a p), GFromJSArr (b p), GFromJSProp (a p), GFromJSProp (b p)) => GFromJSVal ((a :*: b) p) where
184 gFromJSVal f True r = gFromJSProp f r
218 gFromJSVal f True r = gFromJSProp f r
185− gFromJSVal f False r = fmap fst <$> gFromJSArr f (SomeJSArray r) 0
219+ gFromJSVal f False r = fmap fst <$> gFromJSArr f (AI.SomeJSArray r) 0
186
220
187instance GFromJSVal (a p) => GFromJSVal (M1 S c a p) where
221instance GFromJSVal (a p) => GFromJSVal (M1 S c a p) where
188 gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r
222 gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r
@@ -197,7 +231,7 @@ instance (GFromJSProp (a p), GFromJSProp (b p)) => GFromJSProp ((a :*: b) p) whe
197instance forall c a p . (Selector c, GFromJSVal (a p)) => GFromJSProp (M1 S c a p) where
231instance forall c a p . (Selector c, GFromJSVal (a p)) => GFromJSProp (M1 S c a p) where
198 gFromJSProp f o = do
232 gFromJSProp f o = do
199 p <- OI.getProp (packJSS . f $ selName (undefined :: M1 S c a p)) (OI.Object o)
233 p <- OI.getProp (packJSS . f $ selName (undefined :: M1 S c a p)) (OI.Object o)
200− isUndefinedIO p >>= \case
234+ ghcjsPure (isUndefined p) >>= \case
201 True -> return Nothing
235 True -> return Nothing
202 False -> fmap M1 <$> gFromJSVal f False p
236 False -> fmap M1 <$> gFromJSVal f False p
203
237
@@ -214,7 +248,7 @@ instance (GFromJSArr (a p), GFromJSArr (b p)) => GFromJSArr ((a :*: b) p) where
214instance (GFromJSVal (a p)) => GFromJSArr (M1 S c a p) where
248instance (GFromJSVal (a p)) => GFromJSArr (M1 S c a p) where
215 gFromJSArr f o n = do
249 gFromJSArr f o n = do
216 r <- AI.read n o
250 r <- AI.read n o
217− isUndefinedIO r >>= \case
251+ ghcjsPure (isUndefined r) >>= \case
218 True -> return Nothing
252 True -> return Nothing
219 False -> fmap ((,n+1) . M1) <$> gFromJSVal f False r
253 False -> fmap ((,n+1) . M1) <$> gFromJSVal f False r
220
254
@@ -231,15 +265,15 @@ fromJSVal_generic f x = fmap to <$> (gFromJSVal f False x :: JSM (Maybe (Rep a (
231-- -----------------------------------------------------------------------------
265-- -----------------------------------------------------------------------------
232
266
233fromJSVal_pure :: PFromJSVal a => JSVal -> JSM (Maybe a)
267fromJSVal_pure :: PFromJSVal a => JSVal -> JSM (Maybe a)
234−fromJSVal_pure x = return (Just (pFromJSVal x))
268+fromJSVal_pure = return . Just . pFromJSVal
235{-# INLINE fromJSVal_pure #-}
269{-# INLINE fromJSVal_pure #-}
236
270
237fromJSValUnchecked_pure :: PFromJSVal a => JSVal -> JSM a
271fromJSValUnchecked_pure :: PFromJSVal a => JSVal -> JSM a
238−fromJSValUnchecked_pure x = return (pFromJSVal x)
272+fromJSValUnchecked_pure = return . pFromJSVal
239{-# INLINE fromJSValUnchecked_pure #-}
273{-# INLINE fromJSValUnchecked_pure #-}
240
274
241toJSVal_pure :: PToJSVal a => a -> JSM JSVal
275toJSVal_pure :: PToJSVal a => a -> JSM JSVal
242−toJSVal_pure x = return (pToJSVal x)
276+toJSVal_pure = return . pToJSVal
243{-# INLINE toJSVal_pure #-}
277{-# INLINE toJSVal_pure #-}
244
278
245-- -----------------------------------------------------------------------------
279-- -----------------------------------------------------------------------------
jsaddle/src-ghc/GHCJS/Marshal/Pure.hs+5−6
@@ -1,12 +1,11 @@
1{-# OPTIONS_GHC -fno-warn-orphans #-}
1{-# OPTIONS_GHC -fno-warn-orphans #-}
2−module GHCJS.Marshal.Pure
2+module GHCJS.Marshal.Pure ( PFromJSVal(..)
3− ( PFromJSVal(..)
4− , PToJSVal(..)
3+ , PToJSVal(..)
5− ) where
4+ ) where
6
5
6+import GHCJS.Types
7+import GHCJS.Foreign.Internal (jsFalse, jsTrue)
7import GHCJS.Marshal.Internal
8import GHCJS.Marshal.Internal
8−import Language.Javascript.JSaddle.Types (JSVal(..))
9−import Language.Javascript.JSaddle.Foreign (jsFalse, jsTrue)
10
9
11instance PFromJSVal JSVal where pFromJSVal = id
10instance PFromJSVal JSVal where pFromJSVal = id
12 {-# INLINE pFromJSVal #-}
11 {-# INLINE pFromJSVal #-}
jsaddle/src-ghc/GHCJS/Prim.hsnew file+84
@@ -0,0 +1,84 @@
1+{-# LANGUAGE MagicHash #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+
5+module GHCJS.Prim ( module GHCJS.Prim.Internal
6+ , fromJSString
7+ , toJSString
8+ , isNull
9+ , isUndefined
10+ ) where
11+
12+import GHCJS.Prim.Internal
13+--import Data.Int (Int64)
14+--import Data.Typeable (Typeable)
15+--import Unsafe.Coerce (unsafeCoerce)
16+
17+--import Data.Aeson (ToJSON(..), FromJSON(..))
18+import qualified Data.Text as T (unpack, pack)
19+import Data.JSString.Text (textFromJSVal)
20+
21+--import GHC.Prim
22+--import qualified GHC.Exception as Ex
23+--import qualified GHC.Exts as Exts
24+
25+import Language.Javascript.JSaddle.Types (JSVal(..), JSString(..), GHCJSPure(..), ghcjsPureMap)
26+import qualified Language.Javascript.JSaddle.Native.Internal as N
27+ (stringToValue, isNull, isUndefined)
28+{- | Low-level conversion utilities for packages that cannot
29+ depend on ghcjs-base
30+ -}
31+
32+fromJSString :: JSVal -> GHCJSPure String
33+fromJSString = ghcjsPureMap T.unpack . textFromJSVal
34+{-# INLINE fromJSString #-}
35+
36+toJSString :: String -> GHCJSPure JSVal
37+toJSString s = GHCJSPure $ N.stringToValue (JSString $ T.pack s)
38+{-# INLINE toJSString #-}
39+
40+--fromJSArray :: JSVal -> IO [JSVal]
41+--fromJSArray = unsafeCoerce . js_fromJSArray
42+--{-# INLINE fromJSArray #-}
43+--
44+--toJSArray :: [JSVal] -> IO JSVal
45+--toJSArray = js_toJSArray . unsafeCoerce . seqList
46+--{-# INLINE toJSArray #-}
47+--
48+--{- | returns zero if the JSVal does not contain a number
49+-- -}
50+--fromJSInt :: JSVal -> Int
51+--fromJSInt = js_fromJSInt
52+--{-# INLINE fromJSInt #-}
53+--
54+--toJSInt :: Int -> JSVal
55+--toJSInt = js_toJSInt
56+--{-# INLINE toJSInt #-}
57+--
58+
59+isNull :: JSVal -> GHCJSPure Bool
60+isNull = GHCJSPure . N.isNull
61+{-# INLINE isNull #-}
62+
63+isUndefined :: JSVal -> GHCJSPure Bool
64+isUndefined = GHCJSPure . N.isUndefined
65+{-# INLINE isUndefined #-}
66+
67+--getProp :: JSVal -> String -> IO JSVal
68+--getProp o p = js_getProp o (unsafeCoerce $ seqList p)
69+--{-# INLINE getProp #-}
70+--
71+--getProp' :: JSVal -> JSVal -> IO JSVal
72+--getProp' o p = js_getProp' o p
73+--{-# INLINE getProp' #-}
74+--
75+---- reduce the spine and all list elements to whnf
76+--seqList :: [a] -> [a]
77+--seqList xs = go xs `seq` xs
78+-- where go (x:xs) = x `seq` go xs
79+-- go [] = ()
80+--
81+--seqListSpine :: [a] -> [a]
82+--seqListSpine xs = go xs `seq` xs
83+-- where go (x:xs) = go xs
84+-- go [] = ()
jsaddle/src-ghc/GHCJS/Prim/Internal.hsnew file+68
@@ -0,0 +1,68 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+
4+module GHCJS.Prim.Internal ( JSVal(..)
5+ , JSValueRef
6+ , JSException(..)
7+ , WouldBlockException(..)
8+ , mkJSException
9+ , jsNull
10+ ) where
11+
12+import Control.DeepSeq (NFData(..))
13+import Data.Int (Int64)
14+import Data.Typeable (Typeable)
15+import Unsafe.Coerce (unsafeCoerce)
16+
17+import Data.Aeson (ToJSON(..), FromJSON(..))
18+
19+import qualified GHC.Exception as Ex
20+import Data.IORef (newIORef, IORef)
21+import System.IO.Unsafe (unsafePerformIO)
22+
23+-- A reference to a particular JavaScript value inside the JavaScript context
24+type JSValueRef = Int64
25+
26+{-
27+ JSVal is a boxed type that can be used as FFI
28+ argument or result.
29+-}
30+newtype JSVal = JSVal (IORef JSValueRef)
31+
32+instance NFData JSVal where
33+ rnf x = x `seq` ()
34+
35+
36+{-
37+ When a JavaScript exception is raised inside
38+ a safe or interruptible foreign call, it is converted
39+ to a JSException
40+ -}
41+data JSException = JSException JSVal String
42+ deriving (Typeable)
43+
44+instance Ex.Exception JSException
45+
46+instance Show JSException where
47+ show (JSException _ xs) = "JavaScript exception: " ++ xs
48+
49+mkJSException :: JSVal -> IO JSException
50+mkJSException ref =
51+ return (JSException (unsafeCoerce ref) "")
52+
53+jsNull :: JSVal
54+jsNull = JSVal . unsafePerformIO $ newIORef 0
55+{-# NOINLINE jsNull #-}
56+
57+{- | If a synchronous thread tries to do something that can only
58+ be done asynchronously, and the thread is set up to not
59+ continue asynchronously, it receives this exception.
60+ -}
61+data WouldBlockException = WouldBlockException
62+ deriving (Typeable)
63+
64+instance Show WouldBlockException where
65+ show _ = "thread would block"
66+
67+instance Ex.Exception WouldBlockException
68+
jsaddle/src-ghc/GHCJS/Types.hsnew file+60
@@ -0,0 +1,60 @@
1+{-# LANGUAGE EmptyDataDecls #-}
2+{-# LANGUAGE MagicHash #-}
3+{-# LANGUAGE BangPatterns #-}
4+
5+module GHCJS.Types ( JSVal
6+ , WouldBlockException(..)
7+ , JSException(..)
8+ , IsJSVal
9+ , jsval
10+ , isNull
11+ , isUndefined
12+ , nullRef
13+ , JSString
14+ , mkRef
15+ , Ref#
16+-- , toPtr
17+-- , fromPtr
18+ , JSRef
19+ ) where
20+
21+import Data.JSString.Internal.Type (JSString)
22+import GHCJS.Internal.Types
23+
24+import GHCJS.Prim
25+
26+import GHC.Int
27+import GHC.Types
28+import GHC.Prim
29+import GHC.Ptr
30+import GHC.IORef
31+import GHC.IO.Unsafe (unsafePerformIO)
32+
33+import Control.DeepSeq
34+import Unsafe.Coerce
35+
36+type Ref# = IORef Int64
37+
38+mkRef :: Ref# -> JSVal
39+mkRef = JSVal
40+{-# INLINE mkRef #-}
41+
42+nullRef :: JSVal
43+nullRef = JSVal . unsafePerformIO $ newIORef 0
44+{-# NOINLINE nullRef #-}
45+
46+--toPtr :: JSVal -> Ptr a
47+--toPtr (JSVal x) = unsafeCoerce (Ptr' x 0#)
48+--{-# INLINE toPtr #-}
49+--
50+--fromPtr :: Ptr a -> JSVal
51+--fromPtr p = js_ptrVal p
52+--{-# INLINE fromPtr #-}
53+--
54+--data Ptr' a = Ptr' ByteArray# Int#
55+
56+-- | This is a deprecated copmatibility wrapper for the old JSRef type.
57+--
58+-- See https://github.com/ghcjs/ghcjs/issues/421
59+type JSRef a = JSVal
60+{-# DEPRECATED JSRef "Use JSVal instead, or a more specific newtype wrapper of JSVal " #-}
jsaddle/src/Language/Javascript/JSaddle/Array.hs → jsaddle/src-ghc/JavaScript/Array.hsrenamed+36−23
@@ -1,17 +1,6 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE TypeSynonymInstances #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−{-# LANGUAGE Rank2Types #-}
6−#ifdef ghcjs_HOST_OS
7−{-# LANGUAGE ForeignFunctionInterface #-}
8−{-# LANGUAGE JavaScriptFFI #-}
9−{-# OPTIONS_GHC -Wno-dodgy-exports -Wno-dodgy-imports #-}
10−#endif
11−{-# OPTIONS_GHC -fno-warn-orphans #-}
12-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
13--
2--
14−-- Module : Language.Javascript.JSaddle.Object
3+-- Module : JavaScript.Array
15-- Copyright : (c) Hamish Mackenzie
4-- Copyright : (c) Hamish Mackenzie
16-- License : MIT
5-- License : MIT
17--
6--
@@ -20,17 +9,19 @@
20-- | Interface to JavaScript array
9-- | Interface to JavaScript array
21--
10--
22-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
23−
12+module JavaScript.Array
24−module Language.Javascript.JSaddle.Array
25 ( SomeJSArray(..)
13 ( SomeJSArray(..)
26 , JSArray
14 , JSArray
27 , MutableJSArray
15 , MutableJSArray
28 , create
16 , create
29 , length
17 , length
30 , lengthIO
18 , lengthIO
31− , nullIO
19+ , null
20+ , fromList
32 , fromListIO
21 , fromListIO
22+ , toList
33 , toListIO
23 , toListIO
24+ , index, (!)
34 , read
25 , read
35 , write
26 , write
36 , append
27 , append
@@ -39,8 +30,11 @@ module Language.Javascript.JSaddle.Array
39 , unshift
30 , unshift
40 , shift
31 , shift
41 , reverse
32 , reverse
33+ , take
42 , takeIO
34 , takeIO
35+ , drop
43 , dropIO
36 , dropIO
37+ , slice
44 , sliceIO
38 , sliceIO
45 , freeze
39 , freeze
46 , unsafeFreeze
40 , unsafeFreeze
@@ -48,30 +42,34 @@ module Language.Javascript.JSaddle.Array
48 , unsafeThaw
42 , unsafeThaw
49 ) where
43 ) where
50
44
51−import Prelude hiding (read, reverse, null)
45+import Prelude hiding (length, drop, read, take, reverse, null)
52import Control.Monad (void)
46import Control.Monad (void)
53import Language.Javascript.JSaddle.Types
47import Language.Javascript.JSaddle.Types
54 (JSM, JSVal, SomeJSArray(..), JSArray,
48 (JSM, JSVal, SomeJSArray(..), JSArray,
55− MutableJSArray)
49+ MutableJSArray, GHCJSPure(..))
56import Control.Lens.Operators ((^.))
50import Control.Lens.Operators ((^.))
57−import Language.Javascript.JSaddle.Object (js2, js0, (##), js1, js)
51+import Language.Javascript.JSaddle.Object (js2, js0, (<##), js1, js)
58import Language.Javascript.JSaddle.Value (valToNumber)
52import Language.Javascript.JSaddle.Value (valToNumber)
59−import JavaScript.Array.Internal (create, fromListIO, toListIO, read, push)
53+import JavaScript.Array.Internal (create, fromList, fromListIO, toList, toListIO, index, read, push)
54+
55+length :: SomeJSArray m -> GHCJSPure Int
56+length = GHCJSPure . lengthIO
57+{-# INLINE length #-}
60
58
61lengthIO :: SomeJSArray m -> JSM Int
59lengthIO :: SomeJSArray m -> JSM Int
62lengthIO (SomeJSArray x) = round <$> (x ^. js "length" >>= valToNumber)
60lengthIO (SomeJSArray x) = round <$> (x ^. js "length" >>= valToNumber)
63{-# INLINE lengthIO #-}
61{-# INLINE lengthIO #-}
64
62
65−nullIO :: SomeJSArray m -> JSM Bool
63+null :: SomeJSArray m -> GHCJSPure Bool
66−nullIO = fmap (== 0) . lengthIO
64+null = GHCJSPure . fmap (== 0) . lengthIO
67−{-# INLINE nullIO #-}
65+{-# INLINE null #-}
68
66
69append :: SomeJSArray m -> SomeJSArray m -> JSM (SomeJSArray m1)
67append :: SomeJSArray m -> SomeJSArray m -> JSM (SomeJSArray m1)
70append (SomeJSArray x) (SomeJSArray y) = SomeJSArray <$> x ^. js1 "concat" y
68append (SomeJSArray x) (SomeJSArray y) = SomeJSArray <$> x ^. js1 "concat" y
71{-# INLINE append #-}
69{-# INLINE append #-}
72
70
73write :: Int -> JSVal -> MutableJSArray -> JSM ()
71write :: Int -> JSVal -> MutableJSArray -> JSM ()
74−write n e (SomeJSArray x) = void $ (x ## n) e
72+write n e (SomeJSArray x) = void $ (x <## n) e
75{-# INLINE write #-}
73{-# INLINE write #-}
76
74
77pop :: MutableJSArray -> JSM JSVal
75pop :: MutableJSArray -> JSM JSVal
@@ -90,14 +88,26 @@ reverse :: MutableJSArray -> JSM ()
90reverse (SomeJSArray x) = void $ x ^. js0 "reverse"
88reverse (SomeJSArray x) = void $ x ^. js0 "reverse"
91{-# INLINE reverse #-}
89{-# INLINE reverse #-}
92
90
91+take :: Int -> SomeJSArray m -> GHCJSPure (SomeJSArray m1)
92+take n = GHCJSPure . takeIO n
93+{-# INLINE take #-}
94+
93takeIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1)
95takeIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1)
94takeIO n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" (0::Int) n
96takeIO n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" (0::Int) n
95{-# INLINE takeIO #-}
97{-# INLINE takeIO #-}
96
98
99+drop :: Int -> SomeJSArray m -> GHCJSPure (SomeJSArray m1)
100+drop n = GHCJSPure . dropIO n
101+{-# INLINE drop #-}
102+
97dropIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1)
103dropIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1)
98dropIO n (SomeJSArray x) = SomeJSArray <$> x ^. js1 "slice1" n
104dropIO n (SomeJSArray x) = SomeJSArray <$> x ^. js1 "slice1" n
99{-# INLINE dropIO #-}
105{-# INLINE dropIO #-}
100
106
107+slice :: Int -> Int -> JSArray -> GHCJSPure (SomeJSArray m1)
108+slice s n = GHCJSPure . sliceIO s n
109+{-# INLINE slice #-}
110+
101sliceIO :: Int -> Int -> JSArray -> JSM (SomeJSArray m1)
111sliceIO :: Int -> Int -> JSArray -> JSM (SomeJSArray m1)
102sliceIO s n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" s n
112sliceIO s n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" s n
103{-# INLINE sliceIO #-}
113{-# INLINE sliceIO #-}
@@ -118,4 +128,7 @@ unsafeThaw :: JSArray -> JSM MutableJSArray
118unsafeThaw (SomeJSArray x) = pure (SomeJSArray x)
128unsafeThaw (SomeJSArray x) = pure (SomeJSArray x)
119{-# INLINE unsafeThaw #-}
129{-# INLINE unsafeThaw #-}
120
130
131+(!) :: JSArray -> Int -> GHCJSPure JSVal
132+x ! n = GHCJSPure $ read n x
133+{-# INLINE (!) #-}
121
134
jsaddle/src-ghc/JavaScript/Array/Internal.hs+33−20
@@ -1,46 +1,59 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module JavaScript.Array.Internal
2module JavaScript.Array.Internal
3+ ( SomeJSArray(..)
4+ , JSArray
5+ , MutableJSArray
6+ , STJSArray
3− ( create
7+ , create
8+ , fromList
4 , fromListIO
9 , fromListIO
10+ , toList
5 , toListIO
11 , toListIO
12+ , index
6 , read
13 , read
7 , push
14 , push
8 ) where
15 ) where
9
16
10import Prelude hiding(read)
17import Prelude hiding(read)
11import Control.Monad (void)
18import Control.Monad (void)
19+import GHCJS.Types (JSVal)
20+import Data.JSString.Internal.Type (JSString(..))
12−import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), MutableJSArray, Object(..), JSString(..))
21+import Language.Javascript.JSaddle.Types (JSM, SomeJSArray(..), JSArray, MutableJSArray, STJSArray, Object(..), GHCJSPure(..))
13import Language.Javascript.JSaddle.Native.Internal
22import Language.Javascript.JSaddle.Native.Internal
14− (withObject, withJSVal, withJSString, withJSVals)
23+ (newArray, getPropertyByName, getPropertyAtIndex, callAsFunction, valueToNumber)
15−import Language.Javascript.JSaddle.Run
16− (Command(..), Result(..), AsyncCommand(..), sendCommand, sendLazyCommand)
17
24
18create :: JSM MutableJSArray
25create :: JSM MutableJSArray
19−create = SomeJSArray <$> sendLazyCommand (NewArray [])
26+create = SomeJSArray <$> newArray []
20{-# INLINE create #-}
27{-# INLINE create #-}
21
28
29+fromList :: [JSVal] -> GHCJSPure (SomeJSArray m)
30+fromList = GHCJSPure . fromListIO
31+{-# INLINE fromList #-}
32+
22fromListIO :: [JSVal] -> JSM (SomeJSArray m)
33fromListIO :: [JSVal] -> JSM (SomeJSArray m)
23−fromListIO xs = withJSVals xs $ \xs' -> SomeJSArray <$> sendLazyCommand (NewArray xs')
34+fromListIO xs = SomeJSArray <$> newArray xs
24{-# INLINE fromListIO #-}
35{-# INLINE fromListIO #-}
25
36
37+toList :: SomeJSArray m -> GHCJSPure [JSVal]
38+toList = GHCJSPure . toListIO
39+{-# INLINE toList #-}
40+
26toListIO :: SomeJSArray m -> JSM [JSVal]
41toListIO :: SomeJSArray m -> JSM [JSVal]
27−toListIO (SomeJSArray x) =
42+toListIO (SomeJSArray x) = do
28− withObject (Object x) $ \this -> do
43+ len <- getPropertyByName (JSString "length") (Object x) >>= valueToNumber
29− l <- withJSString (JSString "length") $ sendLazyCommand . GetPropertyByName this
44+ mapM (`getPropertyAtIndex` Object x) [0..round len - 1]
30− withJSVal l $ \l' -> do
31− ValueToNumberResult len <- sendCommand (ValueToNumber l')
32− mapM (sendLazyCommand . GetPropertyAtIndex this) [0..round len - 1]
33{-# INLINE toListIO #-}
45{-# INLINE toListIO #-}
34
46
47+index :: Int -> SomeJSArray m -> GHCJSPure JSVal
48+index n = GHCJSPure . read n
49+{-# INLINE index #-}
50+
35read :: Int -> SomeJSArray m -> JSM JSVal
51read :: Int -> SomeJSArray m -> JSM JSVal
36−read n (SomeJSArray x) =
52+read n (SomeJSArray x) = getPropertyAtIndex n $ Object x
37− withObject (Object x) $ \this -> sendLazyCommand $ GetPropertyAtIndex this n
38{-# INLINE read #-}
53{-# INLINE read #-}
39
54
40push :: JSVal -> MutableJSArray -> JSM ()
55push :: JSVal -> MutableJSArray -> JSM ()
41−push e (SomeJSArray x) =
56+push e (SomeJSArray x) = void $ do
42− void $ withJSVal e $ \e' ->
57+ f <- getPropertyByName (JSString "push") (Object x)
43− withObject (Object x) $ \this -> do
58+ void $ callAsFunction (Object f) (Object x) [e]
44− f <- withJSString (JSString "push") $ sendLazyCommand . GetPropertyByName this
45− withObject (Object f) $ \f' -> sendLazyCommand $ CallAsFunction f' this [e']
46{-# INLINE push #-}
59{-# INLINE push #-}
jsaddle/src-ghc/JavaScript/Object.hsnew file+10
@@ -0,0 +1,10 @@
1+module JavaScript.Object ( Object
2+ , create
3+ , getProp, unsafeGetProp
4+ , setProp, unsafeSetProp
5+ -- , allProps
6+ , listProps
7+ -- , isInstanceOf
8+ ) where
9+
10+import JavaScript.Object.Internal
jsaddle/src-ghc/JavaScript/Object/Internal.hs+26−22
@@ -7,43 +7,47 @@ module JavaScript.Object.Internal
7 , unsafeGetProp
7 , unsafeGetProp
8 , setProp
8 , setProp
9 , unsafeSetProp
9 , unsafeSetProp
10−-- , isInstanceOfIO
10+-- , isInstanceOf
11 ) where
11 ) where
12
12
13import Language.Javascript.JSaddle.Types (JSM, JSVal, Object(..), JSString)
13import Language.Javascript.JSaddle.Types (JSM, JSVal, Object(..), JSString)
14import Language.Javascript.JSaddle.Native.Internal
14import Language.Javascript.JSaddle.Native.Internal
15− (withObject, withJSString, withJSVal, wrapJSString)
15+ (newEmptyObject, propertyNames, getPropertyByName, setPropertyByName)
16−import Language.Javascript.JSaddle.Run
17− (Command(..), AsyncCommand(..), Result(..), sendCommand, sendLazyCommand, sendAsyncCommand)
18
16
17+-- | create an empty object
19create :: JSM Object
18create :: JSM Object
20−create = Object <$> sendLazyCommand NewEmptyObject
19+create = newEmptyObject
20+{-# INLINE create #-}
21+
22+--allProps :: Object -> JSM JSArray
23+--allProps o = js_allProps o
24+--{-# INLINE allProps #-}
21
25
22listProps :: Object -> JSM [JSString]
26listProps :: Object -> JSM [JSString]
23−listProps this =
27+listProps = propertyNames
24− withObject this $ \rthis -> do
25− PropertyNamesResult result <- sendCommand $ PropertyNames rthis
26− mapM wrapJSString result
27{-# INLINE listProps #-}
28{-# INLINE listProps #-}
28
29
29−unsafeGetProp :: JSString -> Object -> JSM JSVal
30+{- | get a property from an object. If accessing the property results in
30−unsafeGetProp name this =
31+ an exception, the exception is converted to a JSException. Since exception
31− withObject this $ \rthis ->
32+ handling code prevents some optimizations in some JS engines, you may want
32− withJSString name $ sendLazyCommand . GetPropertyByName rthis
33−{-# INLINE unsafeGetProp #-}
33+ to use unsafeGetProp instead
34−
34+ -}
35getProp :: JSString -> Object -> JSM JSVal
35getProp :: JSString -> Object -> JSM JSVal
36getProp = unsafeGetProp
36getProp = unsafeGetProp
37{-# INLINE getProp #-}
37{-# INLINE getProp #-}
38
38
39−unsafeSetProp :: JSString -> JSVal -> Object -> JSM ()
39+unsafeGetProp :: JSString -> Object -> JSM JSVal
40−unsafeSetProp name val this =
40+unsafeGetProp = getPropertyByName
41− withObject this $ \rthis ->
41+{-# INLINE unsafeGetProp #-}
42− withJSString name $ \rname ->
43− withJSVal val $ \rval ->
44− sendAsyncCommand $ SetPropertyByName rthis rname rval
45−{-# INLINE unsafeSetProp #-}
46
42
47setProp :: JSString -> JSVal -> Object -> JSM ()
43setProp :: JSString -> JSVal -> Object -> JSM ()
48setProp = unsafeSetProp
44setProp = unsafeSetProp
49{-# INLINE setProp #-}
45{-# INLINE setProp #-}
46+
47+unsafeSetProp :: JSString -> JSVal -> Object -> JSM ()
48+unsafeSetProp = setPropertyByName
49+{-# INLINE unsafeSetProp #-}
50+
51+--isInstanceOf :: Object -> JSVal -> GHCJSPure Bool
52+--isInstanceOf o s = js_isInstanceOf o s
53+--{-# INLINE isInstanceOf #-}
jsaddle/src-ghc/JavaScript/TypedArray.hsnew file+19
@@ -0,0 +1,19 @@
1+module JavaScript.TypedArray
2+ ( TypedArray(..)
3+ , Int8Array, Int16Array, Int32Array
4+ , Uint8Array, Uint16Array, Uint32Array
5+ , Uint8ClampedArray, Float32Array, Float64Array
6+ , length
7+ , byteLength
8+ , byteOffset
9+ , buffer
10+ , subarray
11+ , set
12+ , unsafeSet
13+ ) where
14+
15+import Prelude ()
16+
17+import JavaScript.TypedArray.Internal
18+import JavaScript.TypedArray.Internal.Types
19+
jsaddle/src-ghc/JavaScript/TypedArray/ArrayBuffer.hsnew file+51
@@ -0,0 +1,51 @@
1+module JavaScript.TypedArray.ArrayBuffer
2+ ( ArrayBuffer
3+ , MutableArrayBuffer
4+ , freeze, unsafeFreeze
5+ , thaw, unsafeThaw
6+ , byteLengthIO
7+ ) where
8+
9+import Control.Lens.Operators ((^.))
10+
11+import GHCJS.Marshal (fromJSValUnchecked)
12+
13+import Language.Javascript.JSaddle.Types (JSM)
14+import Language.Javascript.JSaddle.Object (jsg, new, js, js1, js2)
15+import JavaScript.TypedArray.ArrayBuffer.Internal
16+
17+create :: Int -> JSM MutableArrayBuffer
18+create n = SomeArrayBuffer <$> new (jsg "ArrayBuffer") [n]
19+{-# INLINE create #-}
20+
21+{- | Create an immutable 'ArrayBuffer' by copying a 'MutableArrayBuffer' -}
22+freeze :: MutableArrayBuffer -> JSM ArrayBuffer
23+freeze (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js1 "slice" (0 :: Int)
24+{-# INLINE freeze #-}
25+
26+{- | Create an immutable 'ArrayBuffer' from a 'MutableArrayBuffer' without
27+ copying. The result shares the buffer with the argument, not modify
28+ the data in the 'MutableArrayBuffer' after freezing
29+ -}
30+unsafeFreeze :: MutableArrayBuffer -> JSM ArrayBuffer
31+unsafeFreeze (SomeArrayBuffer b) = pure (SomeArrayBuffer b)
32+{-# INLINE unsafeFreeze #-}
33+
34+{- | Create a 'MutableArrayBuffer' by copying an immutable 'ArrayBuffer' -}
35+thaw :: ArrayBuffer -> JSM MutableArrayBuffer
36+thaw (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js1 "slice" (0 :: Int)
37+{-# INLINE thaw #-}
38+
39+unsafeThaw :: ArrayBuffer -> JSM MutableArrayBuffer
40+unsafeThaw (SomeArrayBuffer b) = pure (SomeArrayBuffer b)
41+{-# INLINE unsafeThaw #-}
42+
43+sliceIO :: Int -> Maybe Int -> SomeArrayBuffer any -> JSM (SomeArrayBuffer any)
44+sliceIO begin (Just end) (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js2 "slice" begin end
45+sliceIO begin _ (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js1 "slice" begin
46+{-# INLINE sliceIO #-}
47+
48+byteLengthIO :: SomeArrayBuffer any -> JSM Int
49+byteLengthIO (SomeArrayBuffer b) = b ^. js "byteLength" >>= fromJSValUnchecked
50+{-# INLINE byteLengthIO #-}
51+
jsaddle/src-ghc/JavaScript/TypedArray/ArrayBuffer/Internal.hsnew file+33
@@ -0,0 +1,33 @@
1+{-# LANGUAGE GHCForeignImportPrim #-}
2+{-# LANGUAGE MagicHash #-}
3+{-# LANGUAGE UnboxedTuples #-}
4+{-# LANGUAGE MagicHash #-}
5+{-# LANGUAGE TypeSynonymInstances #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE DataKinds #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE DeriveDataTypeable #-}
10+
11+module JavaScript.TypedArray.ArrayBuffer.Internal where
12+
13+import GHCJS.Types
14+
15+import GHCJS.Internal.Types
16+import GHCJS.Marshal.Pure
17+
18+import GHC.Exts (State#)
19+
20+import Data.Typeable
21+
22+newtype SomeArrayBuffer (a :: MutabilityType s) =
23+ SomeArrayBuffer JSVal deriving Typeable
24+instance IsJSVal (SomeArrayBuffer m)
25+
26+type ArrayBuffer = SomeArrayBuffer Immutable
27+type MutableArrayBuffer = SomeArrayBuffer Mutable
28+type STArrayBuffer s = SomeArrayBuffer (STMutable s)
29+
30+instance PToJSVal MutableArrayBuffer where
31+ pToJSVal (SomeArrayBuffer b) = b
32+instance PFromJSVal MutableArrayBuffer where
33+ pFromJSVal = SomeArrayBuffer
jsaddle/src-ghc/JavaScript/TypedArray/ArrayBuffer/Type.hsnew file+6
@@ -0,0 +1,6 @@
1+module JavaScript.TypedArray.ArrayBuffer.Type where
2+
3+import GHCJS.Prim
4+
5+
6+
jsaddle/src-ghc/JavaScript/TypedArray/DataView/Internal.hsnew file+147
@@ -0,0 +1,147 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE JavaScriptFFI #-}
3+{-# LANGUAGE ForeignFunctionInterface #-}
4+{-# LANGUAGE UnliftedFFITypes #-}
5+{-# LANGUAGE GHCForeignImportPrim #-}
6+{-# LANGUAGE MagicHash #-}
7+{-# LANGUAGE UnboxedTuples #-}
8+{-# LANGUAGE DeriveDataTypeable #-}
9+{-# LANGUAGE DataKinds #-}
10+{-# LANGUAGE KindSignatures #-}
11+{-# LANGUAGE PolyKinds #-}
12+
13+module JavaScript.TypedArray.DataView.Internal where
14+
15+import Data.Int
16+import Data.Typeable
17+import Data.Word
18+
19+import GHC.Exts ( State# )
20+
21+import GHCJS.Prim
22+import GHCJS.Internal.Types
23+
24+import JavaScript.TypedArray.ArrayBuffer.Internal
25+
26+newtype SomeDataView (a :: MutabilityType s) = SomeDataView JSVal
27+ deriving Typeable
28+
29+type DataView = SomeDataView Immutable
30+type MutableDataView = SomeDataView Mutable
31+type STDataView s = SomeDataView (STMutable s)
32+
33+-- #define JSU foreign import javascript unsafe
34+-- #define JSS foreign import javascript safe
35+--
36+--JSU "new DataView($1)"
37+-- js_dataView1 :: JSVal -> JSVal
38+--JSS "new DataView($2,$1)"
39+-- js_dataView2 :: Int -> JSVal -> SomeDataView m
40+--JSU "new DataView($2,$1)"
41+-- js_unsafeDataView2 :: Int -> JSVal-> SomeDataView m
42+--JSS "new DataView($3,$1,$2)"
43+-- js_dataView :: Int -> Int -> JSVal -> SomeDataView m
44+--JSU "new DataView($3,$1,$2)"
45+-- js_unsafeDataView :: Int -> Int -> JSVal -> JSVal
46+--JSU "new DataView($1.buffer.slice($1.byteOffset, $1.byteLength))"
47+-- js_cloneDataView :: SomeDataView m -> IO (SomeDataView m1)
48+--
49+---- ----------------------------------------------------------------------------
50+---- immutable getters
51+--
52+--JSU "$2.getInt8($1)" js_i_unsafeGetInt8 :: Int -> DataView -> Int8
53+--JSU "$2.getUint8($1)" js_i_unsafeGetUint8 :: Int -> DataView -> Word8
54+--JSU "$2.getInt16($1)" js_i_unsafeGetInt16BE :: Int -> DataView -> Int16
55+--JSU "$2.getInt32($1)" js_i_unsafeGetInt32BE :: Int -> DataView -> Int
56+--JSU "$2.getUint16($1)" js_i_unsafeGetUint16BE :: Int -> DataView -> Word16
57+--JSU "$2.getUint32($1)|0" js_i_unsafeGetUint32BE :: Int -> DataView -> Word
58+--JSU "$2.getFloat32($1)" js_i_unsafeGetFloat32BE :: Int -> DataView -> Double
59+--JSU "$2.getFloat64($1)" js_i_unsafeGetFloat64BE :: Int -> DataView -> Double
60+--JSU "$2.getInt16($1,true)" js_i_unsafeGetInt16LE :: Int -> DataView -> Int16
61+--JSU "$2.getInt32($1,true)" js_i_unsafeGetInt32LE :: Int -> DataView -> Int
62+--JSU "$2.getUint16($1,true)" js_i_unsafeGetUint16LE :: Int -> DataView -> Word16
63+--JSU "$2.getUint32($1,true)|0" js_i_unsafeGetUint32LE :: Int -> DataView -> Word
64+--JSU "$2.getFloat32($1,true)" js_i_unsafeGetFloat32LE :: Int -> DataView -> Double
65+--JSU "$2.getFloat64($1,true)" js_i_unsafeGetFloat64LE :: Int -> DataView -> Double
66+--
67+--JSS "$2.getInt8($1)" js_i_getInt8 :: Int -> DataView -> Int8
68+--JSS "$2.getUint8($1)" js_i_getUint8 :: Int -> DataView -> Word8
69+--JSS "$2.getInt16($1)" js_i_getInt16BE :: Int -> DataView -> Int16
70+--JSS "$2.getInt32($1)" js_i_getInt32BE :: Int -> DataView -> Int
71+--JSS "$2.getUint16($1)" js_i_getUint16BE :: Int -> DataView -> Word16
72+--JSS "$2.getUint32($1)|0" js_i_getUint32BE :: Int -> DataView -> Word
73+--JSS "$2.getFloat32($1)" js_i_getFloat32BE :: Int -> DataView -> Double
74+--JSS "$2.getFloat64($1)" js_i_getFloat64BE :: Int -> DataView -> Double
75+--JSS "$2.getInt16($1,true)" js_i_getInt16LE :: Int -> DataView -> Int16
76+--JSS "$2.getInt32($1,true)" js_i_getInt32LE :: Int -> DataView -> Int
77+--JSS "$2.getUint16($1,true)" js_i_getUint16LE :: Int -> DataView -> Word16
78+--JSS "$2.getUint32($1,true)|0" js_i_getUint32LE :: Int -> DataView -> Word
79+--JSS "$2.getFloat32($1,true)" js_i_getFloat32LE :: Int -> DataView -> Double
80+--JSS "$2.getFloat64($1,true)" js_i_getFloat64LE :: Int -> DataView -> Double
81+--
82+---- ----------------------------------------------------------------------------
83+---- mutable getters
84+--
85+--JSU "$2.getInt8($1)" js_m_unsafeGetInt8 :: Int -> SomeDataView m -> State# s -> (# State# s, Int8 #)
86+--JSU "$2.getUint8($1)" js_m_unsafeGetUint8 :: Int -> SomeDataView m -> State# s -> (# State# s, Word8 #)
87+--JSU "$2.getInt16($1)" js_m_unsafeGetInt16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)
88+--JSU "$2.getInt32($1)" js_m_unsafeGetInt32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)
89+--JSU "$2.getUint16($1)" js_m_unsafeGetUint16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)
90+--JSU "$2.getUint32($1)|0" js_m_unsafeGetUint32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)
91+--JSU "$2.getFloat32($1)" js_m_unsafeGetFloat32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
92+--JSU "$2.getFloat64($1)" js_m_unsafeGetFloat64BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
93+--JSU "$2.getInt16($1,true)" js_m_unsafeGetInt16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)
94+--JSU "$2.getInt32($1,true)" js_m_unsafeGetInt32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)
95+--JSU "$2.getUint16($1,true)" js_m_unsafeGetUint16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)
96+--JSU "$2.getUint32($1,true)|0" js_m_unsafeGetUint32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)
97+--JSU "$2.getFloat32($1,true)" js_m_unsafeGetFloat32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
98+--JSU "$2.getFloat64($1,true)" js_m_unsafeGetFloat64LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
99+--
100+--JSS "$2.getInt8($1)" js_m_getInt8 :: Int -> SomeDataView m -> State# s -> (# State# s, Int8 #)
101+--JSS "$2.getUint8($1)" js_m_getUint8 :: Int -> SomeDataView m -> State# s -> (# State# s, Word8 #)
102+--JSS "$2.getInt16($1)" js_m_getInt16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)
103+--JSS "$2.getInt32($1)" js_m_getInt32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)
104+--JSS "$2.getUint16($1)" js_m_getUint16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)
105+--JSS "$2.getUint32($1)|0" js_m_getUint32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)
106+--JSS "$2.getFloat32($1)" js_m_getFloat32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
107+--JSS "$2.getFloat64($1)" js_m_getFloat64BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
108+--JSS "$2.getInt16($1,true)" js_m_getInt16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)
109+--JSS "$2.getInt32($1,true)" js_m_getInt32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)
110+--JSS "$2.getUint16($1,true)" js_m_getUint16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)
111+--JSS "$2.getUint32($1,true)|0" js_m_getUint32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)
112+--JSS "$2.getFloat32($1,true)" js_m_getFloat32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
113+--JSS "$2.getFloat64($1,true)" js_m_getFloat64LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
114+--
115+---- ----------------------------------------------------------------------------
116+---- mutable setters
117+--
118+--JSU "$3.setInt8($1,$2)" js_unsafeSetInt8 :: Int -> Int8 -> SomeDataView m -> State# s -> (# State# s, () #)
119+--JSU "$3.setUint8($1,$2)" js_unsafeSetUint8 :: Int -> Word8 -> SomeDataView m -> State# s -> (# State# s, () #)
120+--JSU "$3.setInt16($1,$2)" js_unsafeSetInt16BE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)
121+--JSU "$3.setInt32($1,$2)" js_unsafeSetInt32BE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)
122+--JSU "$3.setUint16($1,$2)" js_unsafeSetUint16BE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)
123+--JSU "$3.setUint32($1,$2)" js_unsafeSetUint32BE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)
124+--JSU "$3.setFloat32($1,$2)" js_unsafeSetFloat32BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
125+--JSU "$3.setFloat64($1,$2)" js_unsafeSetFloat64BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
126+--JSU "$3.setInt16($1,$2,true)" js_unsafeSetInt16LE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)
127+--JSU "$3.setInt32($1,$2,true)" js_unsafeSetInt32LE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)
128+--JSU "$3.setUint16($1,$2,true)" js_unsafeSetUint16LE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)
129+--JSU "$3.setUint32($1,$2,true)" js_unsafeSetUint32LE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)
130+--JSU "$3.setFloat32($1,$2,true)" js_unsafeSetFloat32LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
131+--JSU "$3.setFloat64($1,$2,true)" js_unsafeSetFloat64LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
132+--
133+--JSS "$3.setInt8($1,$2)" js_setInt8 :: Int -> Int8 -> SomeDataView m -> State# s -> (# State# s, () #)
134+--JSS "$3.setUint8($1,$2)" js_setUint8 :: Int -> Word8 -> SomeDataView m -> State# s -> (# State# s, () #)
135+--JSS "$3.setInt16($1,$2)" js_setInt16BE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)
136+--JSS "$3.setInt32($1,$2)" js_setInt32BE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)
137+--JSS "$3.setUint16($1,$2)" js_setUint16BE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)
138+--JSS "$3.setUint32($1,$2)" js_setUint32BE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)
139+--JSS "$3.setFloat32($1,$2)" js_setFloat32BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
140+--JSS "$3.setFloat64($1,$2)" js_setFloat64BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
141+--JSS "$3.setInt16($1,$2,true)" js_setInt16LE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)
142+--JSS "$3.setInt32($1,$2,true)" js_setInt32LE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)
143+--JSS "$3.setUint16($1,$2,true)" js_setUint16LE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)
144+--JSS "$3.setUint32($1,$2,true)" js_setUint32LE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)
145+--JSS "$3.setFloat32($1,$2,true)" js_setFloat32LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
146+--JSS "$3.setFloat64($1,$2,true)" js_setFloat64LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
147+
jsaddle/src-ghc/JavaScript/TypedArray/Immutable.hsnew file+1
@@ -0,0 +1 @@
1+module JavaScript.TypedArray.Immutable where
jsaddle/src-ghc/JavaScript/TypedArray/Internal.hsnew file+344
@@ -0,0 +1,344 @@
1+{-# LANGUAGE TypeFamilies #-}
2+{-# LANGUAGE TypeSynonymInstances #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE DataKinds #-}
5+{-# LANGUAGE PolyKinds #-}
6+
7+module JavaScript.TypedArray.Internal where
8+
9+import Prelude hiding ((!!))
10+
11+import GHC.Int
12+import GHC.Word
13+
14+import GHCJS.Internal.Types
15+
16+import Control.Monad (void)
17+import Control.Lens.Operators ((^.))
18+
19+import GHCJS.Marshal (fromJSValUnchecked)
20+
21+import JavaScript.Array.Internal (SomeJSArray(..))
22+import JavaScript.TypedArray.ArrayBuffer
23+import JavaScript.TypedArray.ArrayBuffer.Internal (SomeArrayBuffer(..))
24+import JavaScript.TypedArray.Internal.Types
25+
26+import Language.Javascript.JSaddle.Types (JSM, GHCJSPure(..))
27+import Language.Javascript.JSaddle.Object (js, jsg, js1, js2, new, (!!), (<##))
28+
29+elemSize :: SomeTypedArray e m -> GHCJSPure Int
30+elemSize (SomeTypedArray a) = GHCJSPure $ a ^. js "BYTES_PER_ELEMENT" >>= fromJSValUnchecked
31+{-# INLINE [1] elemSize #-}
32+{-# RULES "elemSizeUint8Clamped" forall (x :: SomeUint8ClampedArray m). elemSize x = GHCJSPure $ return 1 #-}
33+{-# RULES "elemSizeUint8" forall (x :: SomeUint8Array m). elemSize x = GHCJSPure $ return 1 #-}
34+{-# RULES "elemSizeUint16" forall (x :: SomeUint16Array m). elemSize x = GHCJSPure $ return 2 #-}
35+{-# RULES "elemSizeUint32" forall (x :: SomeUint32Array m). elemSize x = GHCJSPure $ return 4 #-}
36+{-# RULES "elemSizeInt8" forall (x :: SomeInt8Array m). elemSize x = GHCJSPure $ return 1 #-}
37+{-# RULES "elemSizeInt16" forall (x :: SomeInt16Array m). elemSize x = GHCJSPure $ return 2 #-}
38+{-# RULES "elemSizeInt32" forall (x :: SomeInt32Array m). elemSize x = GHCJSPure $ return 4 #-}
39+{-# RULES "elemSizeFloat32" forall (x :: SomeFloat32Array m). elemSize x = GHCJSPure $ return 4 #-}
40+{-# RULES "elemSizeFloat64" forall (x :: SomeFloat64Array m). elemSize x = GHCJSPure $ return 8 #-}
41+
42+instance TypedArray IOInt8Array where
43+ index = indexI8
44+ unsafeIndex = unsafeIndexI8
45+ setIndex i x = setIndexI i (fromIntegral x)
46+ unsafeSetIndex i x = unsafeSetIndexI i (fromIntegral x)
47+ indexOf s x = indexOfI s (fromIntegral x)
48+ lastIndexOf s x = lastIndexOfI s (fromIntegral x)
49+ create l = SomeTypedArray <$> new (jsg "Int8Array") [l]
50+ fromArray = int8ArrayFrom
51+ fromArrayBuffer = undefined
52+
53+instance TypedArray IOInt16Array where
54+ index = indexI16
55+ unsafeIndex = unsafeIndexI16
56+ setIndex i x = setIndexI i (fromIntegral x)
57+ unsafeSetIndex i x = unsafeSetIndexI i (fromIntegral x)
58+ indexOf s x = indexOfI s (fromIntegral x)
59+ lastIndexOf s x = lastIndexOfI s (fromIntegral x)
60+ create l = SomeTypedArray <$> new (jsg "Int16Array") [l]
61+ fromArray = int16ArrayFrom
62+ fromArrayBuffer = undefined
63+
64+instance TypedArray IOInt32Array where
65+ index = indexI
66+ unsafeIndex = unsafeIndexI
67+ setIndex = setIndexI
68+ unsafeSetIndex = unsafeSetIndexI
69+ indexOf = indexOfI
70+ lastIndexOf = lastIndexOfI
71+ create l = SomeTypedArray <$> new (jsg "Int32Array") [l]
72+ fromArray = int32ArrayFrom
73+ fromArrayBuffer = undefined
74+
75+instance TypedArray IOUint8ClampedArray where
76+ index = indexW8
77+ unsafeIndex = unsafeIndexW8
78+ setIndex i x = setIndexW i (fromIntegral x)
79+ unsafeSetIndex i x = unsafeSetIndexW i (fromIntegral x)
80+ indexOf s x = indexOfW s (fromIntegral x)
81+ lastIndexOf s x = lastIndexOfW s (fromIntegral x)
82+ create l = SomeTypedArray <$> new (jsg "Uint8ClampedArray") [l]
83+ fromArray = uint8ClampedArrayFrom
84+ fromArrayBuffer = undefined
85+
86+instance TypedArray IOUint8Array where
87+ index = indexW8
88+ unsafeIndex = unsafeIndexW8
89+ setIndex i x = setIndexW i (fromIntegral x)
90+ unsafeSetIndex i x = unsafeSetIndexW i (fromIntegral x)
91+ indexOf s x = indexOfW s (fromIntegral x)
92+ lastIndexOf s x = lastIndexOfW s (fromIntegral x)
93+ create l = SomeTypedArray <$> new (jsg "Uint8Array") [l]
94+ fromArray = uint8ArrayFrom
95+ fromArrayBuffer = undefined
96+
97+instance TypedArray IOUint16Array where
98+ index = indexW16
99+ unsafeIndex = unsafeIndexW16
100+ setIndex i x = setIndexW i (fromIntegral x)
101+ unsafeSetIndex i x = unsafeSetIndexW i (fromIntegral x)
102+ indexOf s x = indexOfW s (fromIntegral x)
103+ lastIndexOf s x = lastIndexOfW s (fromIntegral x)
104+ create l = SomeTypedArray <$> new (jsg "Uint16Array") [l]
105+ fromArray = uint16ArrayFrom
106+ fromArrayBuffer = undefined
107+
108+instance TypedArray IOUint32Array where
109+ index = indexW
110+ unsafeIndex = unsafeIndexW
111+ setIndex = setIndexW
112+ unsafeSetIndex = unsafeSetIndexW
113+ indexOf = indexOfW
114+ lastIndexOf = lastIndexOfW
115+ create l = SomeTypedArray <$> new (jsg "Uint32Array") [l]
116+ fromArray = uint32ArrayFrom
117+ fromArrayBuffer = undefined
118+
119+instance TypedArray IOFloat32Array where
120+ index = indexD
121+ unsafeIndex = unsafeIndexD
122+ setIndex = setIndexD
123+ unsafeSetIndex = unsafeSetIndexD
124+ indexOf = indexOfD
125+ lastIndexOf = lastIndexOfD
126+ create l = SomeTypedArray <$> new (jsg "Float32Array") [l]
127+ fromArray = float32ArrayFrom
128+ fromArrayBuffer = undefined
129+
130+instance TypedArray IOFloat64Array where
131+ index = indexD
132+ unsafeIndex = unsafeIndexD
133+ setIndex = setIndexD
134+ unsafeSetIndex = unsafeSetIndexD
135+ indexOf = indexOfD
136+ lastIndexOf = lastIndexOfD
137+ create l = SomeTypedArray <$> new (jsg "Float64Array") [l]
138+ fromArray = float64ArrayFrom
139+ fromArrayBuffer = undefined
140+
141+
142+class TypedArray a where
143+ unsafeIndex :: Int -> a -> JSM (Elem a)
144+ index :: Int -> a -> JSM (Elem a)
145+ unsafeSetIndex :: Int -> Elem a -> a -> JSM ()
146+ setIndex :: Int -> Elem a -> a -> JSM ()
147+ create :: Int -> JSM a
148+ fromArray :: SomeJSArray m -> JSM a
149+ fromArrayBuffer :: MutableArrayBuffer -> Int -> Maybe Int -> JSM a
150+ indexOf :: Int -> Elem a -> a -> JSM Int
151+ lastIndexOf :: Int -> Elem a -> a -> JSM Int
152+
153+-- -----------------------------------------------------------------------------
154+
155+indexI :: Int -> SomeTypedArray e m -> JSM Int
156+indexI i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
157+{-# INLINE indexI #-}
158+
159+indexI16 :: Int -> SomeTypedArray e m -> JSM Int16
160+indexI16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
161+{-# INLINE indexI16 #-}
162+
163+indexI8 :: Int -> SomeTypedArray e m -> JSM Int8
164+indexI8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
165+{-# INLINE indexI8 #-}
166+
167+indexW :: Int -> SomeTypedArray e m -> JSM Word
168+indexW i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
169+{-# INLINE indexW #-}
170+
171+indexW16 :: Int -> SomeTypedArray e m -> JSM Word16
172+indexW16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
173+{-# INLINE indexW16 #-}
174+
175+indexW8 :: Int -> SomeTypedArray e m -> JSM Word8
176+indexW8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
177+{-# INLINE indexW8 #-}
178+
179+indexD :: Int -> SomeTypedArray e m -> JSM Double
180+indexD i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
181+{-# INLINE indexD #-}
182+
183+-- -----------------------------------------------------------------------------
184+
185+unsafeIndexI :: Int -> SomeTypedArray e m -> JSM Int
186+unsafeIndexI i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
187+{-# INLINE unsafeIndexI #-}
188+
189+unsafeIndexI16 :: Int -> SomeTypedArray e m -> JSM Int16
190+unsafeIndexI16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
191+{-# INLINE unsafeIndexI16 #-}
192+
193+unsafeIndexI8 :: Int -> SomeTypedArray e m -> JSM Int8
194+unsafeIndexI8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
195+{-# INLINE unsafeIndexI8 #-}
196+
197+unsafeIndexW :: Int -> SomeTypedArray e m -> JSM Word
198+unsafeIndexW i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
199+{-# INLINE unsafeIndexW #-}
200+
201+unsafeIndexW16 :: Int -> SomeTypedArray e m -> JSM Word16
202+unsafeIndexW16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
203+{-# INLINE unsafeIndexW16 #-}
204+
205+unsafeIndexW8 :: Int -> SomeTypedArray e m -> JSM Word8
206+unsafeIndexW8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
207+{-# INLINE unsafeIndexW8 #-}
208+
209+unsafeIndexD :: Int -> SomeTypedArray e m -> JSM Double
210+unsafeIndexD i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
211+{-# INLINE unsafeIndexD #-}
212+
213+-- -----------------------------------------------------------------------------
214+
215+int8ArrayFrom :: SomeJSArray m0 -> JSM (SomeInt8Array m1)
216+int8ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Int8Array" ^. js1 "from" a
217+{-# INLINE int8ArrayFrom #-}
218+
219+int16ArrayFrom :: SomeJSArray m0 -> JSM (SomeInt16Array m1)
220+int16ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Int16Array" ^. js1 "from" a
221+{-# INLINE int16ArrayFrom #-}
222+
223+int32ArrayFrom :: SomeJSArray m0 -> JSM (SomeInt32Array m1)
224+int32ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Int32Array" ^. js1 "from" a
225+{-# INLINE int32ArrayFrom #-}
226+
227+uint8ArrayFrom :: SomeJSArray m0 -> JSM (SomeUint8Array m1)
228+uint8ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint8Array" ^. js1 "from" a
229+{-# INLINE uint8ArrayFrom #-}
230+
231+uint8ClampedArrayFrom :: SomeJSArray m0 -> JSM (SomeUint8ClampedArray m1)
232+uint8ClampedArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint8ClampedArray" ^. js1 "from" a
233+{-# INLINE uint8ClampedArrayFrom #-}
234+
235+uint16ArrayFrom :: SomeJSArray m0 -> JSM (SomeUint16Array m1)
236+uint16ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint16Array" ^. js1 "from" a
237+{-# INLINE uint16ArrayFrom #-}
238+
239+uint32ArrayFrom :: SomeJSArray m0 -> JSM (SomeUint32Array m1)
240+uint32ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint32Array" ^. js1 "from" a
241+{-# INLINE uint32ArrayFrom #-}
242+
243+float32ArrayFrom :: SomeJSArray m0 -> JSM (SomeFloat32Array m1)
244+float32ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Float32Array" ^. js1 "from" a
245+{-# INLINE float32ArrayFrom #-}
246+
247+float64ArrayFrom :: SomeJSArray m0 -> JSM (SomeFloat64Array m1)
248+float64ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Float64Array" ^. js1 "from" a
249+{-# INLINE float64ArrayFrom #-}
250+
251+-- -----------------------------------------------------------------------------
252+
253+setIndexI :: Mutability m ~ IsMutable
254+ => Int -> Int -> SomeTypedArray e m -> JSM ()
255+setIndexI i x (SomeTypedArray a) = (a <## i) x
256+{-# INLINE setIndexI #-}
257+
258+unsafeSetIndexI :: Mutability m ~ IsMutable
259+ => Int -> Int -> SomeTypedArray e m -> JSM ()
260+unsafeSetIndexI i x (SomeTypedArray a) = (a <## i) x
261+{-# INLINE unsafeSetIndexI #-}
262+
263+setIndexW :: Mutability m ~ IsMutable
264+ => Int -> Word -> SomeTypedArray e m -> JSM ()
265+setIndexW i x (SomeTypedArray a) = (a <## i) x
266+{-# INLINE setIndexW #-}
267+
268+unsafeSetIndexW :: Mutability m ~ IsMutable
269+ => Int -> Word -> SomeTypedArray e m -> JSM ()
270+unsafeSetIndexW i x (SomeTypedArray a) = (a <## i) x
271+{-# INLINE unsafeSetIndexW #-}
272+
273+setIndexD :: Mutability m ~ IsMutable
274+ => Int -> Double -> SomeTypedArray e m -> JSM ()
275+setIndexD i x (SomeTypedArray a) = (a <## i) x
276+{-# INLINE setIndexD #-}
277+
278+unsafeSetIndexD :: Mutability m ~ IsMutable
279+ => Int -> Double -> SomeTypedArray e m -> JSM ()
280+unsafeSetIndexD i x (SomeTypedArray a) = (a <## i) x
281+{-# INLINE unsafeSetIndexD #-}
282+
283+indexOfI :: Mutability m ~ IsMutable
284+ => Int -> Int -> SomeTypedArray e m -> JSM Int
285+indexOfI s x (SomeTypedArray a) = a ^. js2 "indexOf" x s >>= fromJSValUnchecked
286+{-# INLINE indexOfI #-}
287+
288+indexOfW :: Int -> Word -> SomeTypedArray e m -> JSM Int
289+indexOfW s x (SomeTypedArray a) = a ^. js2 "indexOf" x s >>= fromJSValUnchecked
290+{-# INLINE indexOfW #-}
291+
292+indexOfD :: Int -> Double -> SomeTypedArray e m -> JSM Int
293+indexOfD s x (SomeTypedArray a) = a ^. js2 "indexOf" x s >>= fromJSValUnchecked
294+{-# INLINE indexOfD #-}
295+
296+lastIndexOfI :: Int -> Int -> SomeTypedArray e m -> JSM Int
297+lastIndexOfI s x (SomeTypedArray a) = a ^. js2 "lastIndexOf" x s >>= fromJSValUnchecked
298+{-# INLINE lastIndexOfI #-}
299+
300+lastIndexOfW :: Int -> Word -> SomeTypedArray e m -> JSM Int
301+lastIndexOfW s x (SomeTypedArray a) = a ^. js2 "lastIndexOf" x s >>= fromJSValUnchecked
302+{-# INLINE lastIndexOfW #-}
303+
304+lastIndexOfD :: Int -> Double -> SomeTypedArray e m -> JSM Int
305+lastIndexOfD s x (SomeTypedArray a) = a ^. js2 "lastIndexOf" x s >>= fromJSValUnchecked
306+{-# INLINE lastIndexOfD #-}
307+
308+-- -----------------------------------------------------------------------------
309+-- non-class operations usable for all typed array
310+{-| length of the typed array in elements -}
311+length :: SomeTypedArray e m -> GHCJSPure Int
312+length (SomeTypedArray a) = GHCJSPure $ a ^. js "length" >>= fromJSValUnchecked
313+{-# INLINE length #-}
314+
315+{-| length of the array in bytes -}
316+byteLength :: SomeTypedArray e m -> GHCJSPure Int
317+byteLength (SomeTypedArray a) = GHCJSPure $ a ^. js "byteLength" >>= fromJSValUnchecked
318+{-# INLINE byteLength #-}
319+
320+{-| offset of the array in the buffer -}
321+byteOffset :: SomeTypedArray e m -> GHCJSPure Int
322+byteOffset (SomeTypedArray a) = GHCJSPure $ a ^. js "byteOffset" >>= fromJSValUnchecked
323+{-# INLINE byteOffset #-}
324+
325+{-| the underlying buffer of the array -}
326+buffer :: SomeTypedArray e m -> GHCJSPure (SomeArrayBuffer m)
327+buffer (SomeTypedArray a) = GHCJSPure $ SomeArrayBuffer <$> a ^. js "buffer"
328+{-# INLINE buffer #-}
329+
330+{-| create a view of the existing array -}
331+subarray :: Int -> Int -> SomeTypedArray e m -> GHCJSPure (SomeTypedArray e m)
332+subarray begin end (SomeTypedArray a) = GHCJSPure$ SomeTypedArray <$> a ^. js2 "subarray" begin end
333+{-# INLINE subarray #-}
334+
335+-- fixme convert JSException to Haskell exception
336+{-| copy the elements of one typed array to another -}
337+set :: Int -> SomeTypedArray e m -> SomeTypedArray e1 Mutable -> GHCJSPure ()
338+set offset (SomeTypedArray src) (SomeTypedArray dest) = GHCJSPure $ void $ dest ^. js2 "set" offset src
339+{-# INLINE set #-}
340+
341+unsafeSet :: Int -> SomeTypedArray e m -> SomeTypedArray e1 Mutable -> GHCJSPure ()
342+unsafeSet offset (SomeTypedArray src) (SomeTypedArray dest) = GHCJSPure $ void $ dest ^. js2 "set" offset src
343+{-# INLINE unsafeSet #-}
344+
jsaddle/src-ghc/JavaScript/TypedArray/Internal/Types.hsnew file+121
@@ -0,0 +1,121 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE PolyKinds #-}
5+
6+module JavaScript.TypedArray.Internal.Types where
7+
8+import GHCJS.Types
9+import GHCJS.Internal.Types
10+import Language.Javascript.JSaddle (IsJSVal)
11+
12+import Data.Int
13+import Data.Typeable
14+import Data.Word
15+
16+newtype SomeTypedArray (e :: TypedArrayElem) (m :: MutabilityType s) =
17+ SomeTypedArray JSVal deriving Typeable
18+instance IsJSVal (SomeTypedArray e m)
19+
20+{-
21+newtype SomeSTTypedArray s e = SomeSTTypedArray JSVal
22+ deriving (Typeable)
23+-}
24+
25+type SomeSTTypedArray s (e :: TypedArrayElem) = SomeTypedArray e (STMutable s)
26+
27+-- -----------------------------------------------------------------------------
28+
29+data TypedArrayElem = Int8Elem
30+ | Int16Elem
31+ | Int32Elem
32+ | Uint8Elem
33+ | Uint16Elem
34+ | Uint32Elem
35+ | Uint8ClampedElem
36+ | Float32Elem
37+ | Float64Elem
38+
39+-- -----------------------------------------------------------------------------
40+
41+type SomeInt8Array = SomeTypedArray Int8Elem
42+type SomeInt16Array = SomeTypedArray Int16Elem
43+type SomeInt32Array = SomeTypedArray Int32Elem
44+
45+type SomeUint8Array = SomeTypedArray Uint8Elem
46+type SomeUint16Array = SomeTypedArray Uint16Elem
47+type SomeUint32Array = SomeTypedArray Uint32Elem
48+
49+type SomeFloat32Array = SomeTypedArray Float32Elem
50+type SomeFloat64Array = SomeTypedArray Float64Elem
51+
52+type SomeUint8ClampedArray = SomeTypedArray Uint8ClampedElem
53+
54+-- -----------------------------------------------------------------------------
55+
56+type Int8Array = SomeInt8Array Immutable
57+type Int16Array = SomeInt16Array Immutable
58+type Int32Array = SomeInt32Array Immutable
59+
60+type Uint8Array = SomeUint8Array Immutable
61+type Uint16Array = SomeUint16Array Immutable
62+type Uint32Array = SomeUint32Array Immutable
63+
64+type Uint8ClampedArray = SomeUint8ClampedArray Immutable
65+
66+type Float32Array = SomeFloat32Array Immutable
67+type Float64Array = SomeFloat64Array Immutable
68+
69+-- -----------------------------------------------------------------------------
70+
71+type IOInt8Array = SomeInt8Array Mutable
72+type IOInt16Array = SomeInt16Array Mutable
73+type IOInt32Array = SomeInt32Array Mutable
74+
75+type IOUint8Array = SomeUint8Array Mutable
76+type IOUint16Array = SomeUint16Array Mutable
77+type IOUint32Array = SomeUint32Array Mutable
78+
79+type IOUint8ClampedArray = SomeUint8ClampedArray Mutable
80+
81+type IOFloat32Array = SomeFloat32Array Mutable
82+type IOFloat64Array = SomeFloat64Array Mutable
83+
84+-- -----------------------------------------------------------------------------
85+
86+type STInt8Array s = SomeSTTypedArray s Int8Elem
87+type STInt16Array s = SomeSTTypedArray s Int16Elem
88+type STInt32Array s = SomeSTTypedArray s Int32Elem
89+
90+type STUint8Array s = SomeSTTypedArray s Uint8Elem
91+type STUint16Array s = SomeSTTypedArray s Uint16Elem
92+type STUint32Array s = SomeSTTypedArray s Uint32Elem
93+
94+type STFloat32Array s = SomeSTTypedArray s Float32Elem
95+type STFloat64Array s = SomeSTTypedArray s Float64Elem
96+
97+type STUint8ClampedArray s = SomeSTTypedArray s Uint8ClampedElem
98+
99+-- -----------------------------------------------------------------------------
100+
101+type family Elem x where
102+ Elem (SomeUint8Array m) = Word8
103+ Elem (SomeUint8ClampedArray m) = Word8
104+ Elem (SomeUint16Array m) = Word16
105+ Elem (SomeUint32Array m) = Word
106+ Elem (SomeInt8Array m) = Int8
107+ Elem (SomeInt16Array m) = Int16
108+ Elem (SomeInt32Array m) = Int
109+ Elem (SomeFloat32Array m) = Double
110+ Elem (SomeFloat64Array m) = Double
111+
112+ Elem (STUint8Array s) = Word8
113+ Elem (STUint8ClampedArray s) = Word8
114+ Elem (STUint16Array s) = Word16
115+ Elem (STUint32Array s) = Word
116+ Elem (STInt8Array s) = Int8
117+ Elem (STInt16Array s) = Int16
118+ Elem (STInt32Array s) = Int
119+ Elem (STFloat32Array s) = Double
120+ Elem (STFloat64Array s) = Double
121+
jsaddle/src/Language/Javascript/JSaddle.hs+5−6
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
3--
2--
4-- Module : Language.Javascript.JSaddle
3-- Module : Language.Javascript.JSaddle
@@ -10,7 +9,7 @@
10-- | This package provides an EDSL for calling JavaScript that
9-- | This package provides an EDSL for calling JavaScript that
11-- can be used both from GHCJS and GHC. When using GHC
10-- can be used both from GHCJS and GHC. When using GHC
12-- the application is run using Warp and WebSockets to
11-- the application is run using Warp and WebSockets to
13−-- drive a small JavaScipt helper.
12+-- drive a small JavaScript helper.
14-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
15
14
16module Language.Javascript.JSaddle (
15module Language.Javascript.JSaddle (
@@ -36,10 +35,10 @@ module Language.Javascript.JSaddle (
36 --
35 --
37 -- Where it makes sense code examples are given in two forms. One
36 -- Where it makes sense code examples are given in two forms. One
38 -- that uses 'eval' to run a purely JavaScript version and one that
37 -- that uses 'eval' to run a purely JavaScript version and one that
39− -- uses more of the JSaddle EDSL feature being demonstated.
38+ -- uses more of the JSaddle EDSL feature being demonstrated.
40
39
41 -- * Calling Haskell from JavaScript
40 -- * Calling Haskell from JavaScript
42− -- | You can call back into haskell from JavaScript using 'fun' to
41+ -- | You can call back into Haskell from JavaScript using 'fun' to
43 -- convert a Haskell function in the JSM monad into a javascript
42 -- convert a Haskell function in the JSM monad into a javascript
44 -- value.
43 -- value.
45
44
@@ -53,8 +52,8 @@ module Language.Javascript.JSaddle (
53 -- and the server will run the Haskell code. The JSaddle parts will
52 -- and the server will run the Haskell code. The JSaddle parts will
54 -- be executed by sending commands back to the browser.
53 -- be executed by sending commands back to the browser.
55
54
56− -- Although the code JavaScript code is executed in the the strict order
55+ -- Although the JavaScript code is executed in the strict order
57− -- set out by the EDSL it done asynchonously to the Haskell code.
56+ -- set out by the EDSL it is done asynchronously to the Haskell code.
58 -- This improves the performance by reducing the number of round trips
57 -- This improves the performance by reducing the number of round trips
59 -- needed between the Haskell and JavaScript code.
58 -- needed between the Haskell and JavaScript code.
60
59
jsaddle/src/Language/Javascript/JSaddle/Debug.hsnew file+48
@@ -0,0 +1,48 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+-----------------------------------------------------------------------------
4+--
5+-- Module : Language.Javascript.JSaddle.WebSockets
6+-- Copyright : (c) Hamish Mackenzie
7+-- License : MIT
8+--
9+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.Javascript.JSaddle.Debug (
16+ contexts
17+ , addContext
18+ , removeContext
19+ , runOnAll
20+ , runOnAll_
21+) where
22+
23+import Language.Javascript.JSaddle
24+ (runJSM, askJSM, JSM, JSContextRef(..))
25+import Data.IORef (readIORef, atomicModifyIORef', newIORef, IORef)
26+import System.IO.Unsafe (unsafePerformIO)
27+import Data.Monoid ((<>))
28+import Control.Monad.IO.Class (MonadIO(..))
29+import Data.Int (Int64)
30+
31+contexts :: IORef [JSContextRef]
32+contexts = unsafePerformIO $ newIORef []
33+{-# NOINLINE contexts #-}
34+
35+addContext :: JSM ()
36+addContext = do
37+ ctx <- askJSM
38+ liftIO $ atomicModifyIORef' contexts $ \c -> (c <> [ctx], ())
39+
40+removeContext :: MonadIO m => Int64 -> m ()
41+removeContext cid =
42+ liftIO $ atomicModifyIORef' contexts $ \c -> (filter ((/= cid) . contextId) c, ())
43+
44+runOnAll :: MonadIO m => JSM a -> m [a]
45+runOnAll f = liftIO (readIORef contexts) >>= mapM (runJSM f)
46+
47+runOnAll_ :: MonadIO m => JSM a -> m ()
48+runOnAll_ f = liftIO (readIORef contexts) >>= mapM_ (runJSM f)
jsaddle/src/Language/Javascript/JSaddle/Evaluate.hs+3−7
@@ -27,9 +27,7 @@ import Control.Monad.IO.Class (MonadIO(..))
27import Language.Javascript.JSaddle.Types (JSString)
27import Language.Javascript.JSaddle.Types (JSString)
28#else
28#else
29import Language.Javascript.JSaddle.Native.Internal
29import Language.Javascript.JSaddle.Native.Internal
30− (withJSString)
30+ (evaluateScript)
31−import Language.Javascript.JSaddle.Run
32− (AsyncCommand(..), sendLazyCommand)
33#endif
31#endif
34import Language.Javascript.JSaddle.Marshal.String (ToJSString(..))
32import Language.Javascript.JSaddle.Marshal.String (ToJSString(..))
35import Language.Javascript.JSaddle.Monad (JSM)
33import Language.Javascript.JSaddle.Monad (JSM)
@@ -52,10 +50,8 @@ eval :: (ToJSString script)
52 -> JSM JSVal
50 -> JSM JSVal
53#ifdef ghcjs_HOST_OS
51#ifdef ghcjs_HOST_OS
54eval script = liftIO $ js_eval (toJSString script)
52eval script = liftIO $ js_eval (toJSString script)
55−foreign import javascript unsafe "$r = eval($1);"
53+foreign import javascript safe "$r = eval($1);"
56 js_eval :: JSString -> IO JSVal
54 js_eval :: JSString -> IO JSVal
57#else
55#else
58−eval script = do
56+eval = evaluateScript . toJSString
59− let rscript = toJSString script
60− withJSString rscript $ sendLazyCommand . EvaluateScript
61#endif
57#endif
jsaddle/src/Language/Javascript/JSaddle/Exception.hs+6−1
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2-----------------------------------------------------------------------------
3-----------------------------------------------------------------------------
3--
4--
@@ -17,7 +18,11 @@ module Language.Javascript.JSaddle.Exception (
17) where
18) where
18
19
19import qualified Control.Exception as E (Exception)
20import qualified Control.Exception as E (Exception)
20−import Language.Javascript.JSaddle.Types (JSVal)
21+#ifdef ghcjs_HOST_OS
22+import GHCJS.Prim (JSVal)
23+#else
24+import GHCJS.Prim.Internal (JSVal)
25+#endif
21import Data.Typeable (Typeable)
26import Data.Typeable (Typeable)
22
27
23newtype JSException = JSException JSVal deriving (Typeable)
28newtype JSException = JSException JSVal deriving (Typeable)
jsaddle/src/Language/Javascript/JSaddle/Foreign.hsdeleted−99
@@ -1,99 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−-----------------------------------------------------------------------------
3−--
4−-- Module : Language.Javascript.JSaddle.Value
5−-- Copyright : (c) Hamish Mackenzie
6−-- License : MIT
7−--
8−-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
9−--
10−-- | This module is like `GHCJS.Foreign` but some functions are in
11−--
12−-----------------------------------------------------------------------------
13−module Language.Javascript.JSaddle.Foreign (
14− jsTrue
15− , jsFalse
16− , jsNull
17− , toJSBool
18−-- , fromJSBoolIO
19− , jsUndefined
20− , isTruthyIO
21− , isNullIO
22− , isUndefinedIO
23−-- , isObjectIO
24−-- , isFunctionIO
25−-- , isStringIO
26−-- , isBooleanIO
27−-- , isSymbolIO
28−-- , isNumberIO
29−) where
30−
31−#ifdef ghcjs_HOST_OS
32−import Language.Javascript.JSaddle.Types (JSM, JSVal)
33−import GHCJS.Foreign (toJSBool, isTruthy, jsNull, jsUndefined, jsTrue, jsFalse, isNull, isUndefined)
34−#else
35−import Language.Javascript.JSaddle.Types (JSM, JSVal(..))
36−import Language.Javascript.JSaddle.Native.Internal
37− (withJSVal)
38−import Language.Javascript.JSaddle.Run
39− (Command(..), Result(..), sendCommand)
40−#endif
41−
42−#ifndef ghcjs_HOST_OS
43−jsTrue :: JSVal
44−jsTrue = JSVal 3
45−{-# INLINE jsTrue #-}
46−
47−jsFalse :: JSVal
48−jsFalse = JSVal 2
49−{-# INLINE jsFalse #-}
50−
51−jsNull :: JSVal
52−jsNull = JSVal 0
53−{-# INLINE jsNull #-}
54−
55−toJSBool :: Bool -> JSVal
56−toJSBool b = JSVal $ if b then 3 else 2
57−{-# INLINE toJSBool #-}
58−
59−jsUndefined :: JSVal
60−jsUndefined = JSVal 1
61−{-# INLINE jsUndefined #-}
62−#endif
63−
64−isTruthyIO :: JSVal -> JSM Bool
65−#ifdef ghcjs_HOST_OS
66−isTruthyIO = return . isTruthy
67−#else
68−isTruthyIO (JSVal 0) = return False -- null
69−isTruthyIO (JSVal 1) = return False -- undefined
70−isTruthyIO (JSVal 2) = return False -- false
71−isTruthyIO (JSVal 3) = return True -- true
72−isTruthyIO v = withJSVal v $ \rval -> do
73− ValueToBoolResult result <- sendCommand (ValueToBool rval)
74− return result
75−#endif
76−{-# INLINE isTruthyIO #-}
77−
78−isNullIO :: JSVal -> JSM Bool
79−#ifdef ghcjs_HOST_OS
80−isNullIO = return . isNull
81−#else
82−isNullIO (JSVal 0) = return True
83−isNullIO v = withJSVal v $ \rval -> do
84− IsNullResult result <- sendCommand $ IsNull rval
85− return result
86−#endif
87−{-# INLINE isNullIO #-}
88−
89−isUndefinedIO :: JSVal -> JSM Bool
90−#ifdef ghcjs_HOST_OS
91−isUndefinedIO = return . isUndefined
92−#else
93−isUndefinedIO (JSVal 1) = return True
94−isUndefinedIO v = withJSVal v $ \rval -> do
95− IsUndefinedResult result <- sendCommand $ IsUndefined rval
96− return result
97−#endif
98−{-# INLINE isUndefinedIO #-}
99−
jsaddle/src/Language/Javascript/JSaddle/Helper.hsnew file+30
@@ -0,0 +1,30 @@
1+{-# LANGUAGE CPP #-}
2+module Language.Javascript.JSaddle.Helper where
3+
4+import GHCJS.Types (JSVal)
5+import Language.Javascript.JSaddle.Types (JSM)
6+
7+#ifdef ghcjs_HOST_OS
8+import GHCJS.Marshal.Pure (pFromJSVal, pToJSVal)
9+import JavaScript.TypedArray.ArrayBuffer (MutableArrayBuffer)
10+#else
11+import JavaScript.TypedArray.ArrayBuffer.Internal (MutableArrayBuffer, SomeArrayBuffer(..))
12+#endif
13+
14+-- | Helper function needed because there is no FromJSVal instance for MutableArrayBuffer
15+mutableArrayBufferFromJSVal :: JSVal -> JSM MutableArrayBuffer
16+#ifdef ghcjs_HOST_OS
17+mutableArrayBufferFromJSVal = return . pFromJSVal
18+#else
19+mutableArrayBufferFromJSVal = return . SomeArrayBuffer
20+#endif
21+{-# INLINE mutableArrayBufferFromJSVal #-}
22+
23+-- | Helper function needed because there is no ToJSVal instance for MutableArrayBuffer
24+mutableArrayBufferToJSVal :: MutableArrayBuffer -> JSM JSVal
25+#ifdef ghcjs_HOST_OS
26+mutableArrayBufferToJSVal = return . pToJSVal
27+#else
28+mutableArrayBufferToJSVal (SomeArrayBuffer v) = return v
29+#endif
30+{-# INLINE mutableArrayBufferToJSVal #-}
jsaddle/src/Language/Javascript/JSaddle/Monad.hs+3−26
@@ -38,13 +38,12 @@ module Language.Javascript.JSaddle.Monad (
38 , bracket
38 , bracket
39) where
39) where
40
40
41−import Prelude hiding (read)
42#ifndef ghcjs_HOST_OS
41#ifndef ghcjs_HOST_OS
43−import Control.Monad.Trans.Reader (runReaderT, ask, ReaderT(..))
42+import Control.Monad.Trans.Reader (runReaderT, ask)
44#endif
43#endif
45import Control.Monad.IO.Class (MonadIO(..))
44import Control.Monad.IO.Class (MonadIO(..))
46−import qualified Control.Exception as E (Exception, catch, bracket)
45+import Control.Monad.Catch (catch, bracket)
47−import Language.Javascript.JSaddle.Types (JSM(..), MonadJSM, liftJSM, JSContextRef(..))
46+import Language.Javascript.JSaddle.Types (JSM(..), MonadJSM, liftJSM, JSContextRef)
48import Language.Javascript.JSaddle.Run (syncPoint, syncAfter, waitForAnimationFrame, nextAnimationFrame)
47import Language.Javascript.JSaddle.Run (syncPoint, syncAfter, waitForAnimationFrame, nextAnimationFrame)
49
48
50-- | Gets the JavaScript context from the monad
49-- | Gets the JavaScript context from the monad
@@ -66,25 +65,3 @@ runJSM f = liftIO . runReaderT (unJSM f)
66-- | Alternative version of 'runJSM'
65-- | Alternative version of 'runJSM'
67runJSaddle :: MonadIO m => JSContextRef -> JSM a -> m a
66runJSaddle :: MonadIO m => JSContextRef -> JSM a -> m a
68runJSaddle = flip runJSM
67runJSaddle = flip runJSM
69−
70−
71−-- | Wrapped version of 'E.catch' that runs in a MonadIO that works
72−-- a bit better with 'JSM'
73−catch :: E.Exception e
74− => JSM b
75− -> (e -> JSM b)
76− -> JSM b
77−t `catch` c = do
78− r <- askJSM
79− liftIO (runJSM (syncAfter t) r `E.catch` \e -> runJSM (c e) r)
80−
81−-- | Wrapped version of 'E.bracket' that runs in a MonadIO that works
82−-- a bit better with 'JSM'
83−bracket :: JSM a -> (a -> JSM b) -> (a -> JSM c) -> JSM c
84−bracket aquire release f = do
85− r <- askJSM
86− liftIO $ E.bracket
87− (runJSM (syncAfter aquire) r)
88− (\x -> runJSM (syncAfter $ release x) r)
89− (\x -> runJSM (syncAfter $ f x) r)
90−
jsaddle/src/Language/Javascript/JSaddle/Native.hs+1−6
@@ -11,12 +11,7 @@
11-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
12
12
13module Language.Javascript.JSaddle.Native (
13module Language.Javascript.JSaddle.Native (
14− wrapJSVal
14+ module Language.Javascript.JSaddle.Native.Internal
15− , wrapJSString
16− , withJSVal
17− , withJSVals
18− , withObject
19− , withJSString
20 , withToJSVal
15 , withToJSVal
21) where
16) where
22
17
jsaddle/src/Language/Javascript/JSaddle/Native/Internal.hs+212−23
@@ -1,3 +1,6 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE MagicHash #-}
3+{-# LANGUAGE UnboxedTuples #-}
1-----------------------------------------------------------------------------
4-----------------------------------------------------------------------------
2--
5--
3-- Module : Language.Javascript.JSaddle.Native
6-- Module : Language.Javascript.JSaddle.Native
@@ -17,48 +20,234 @@ module Language.Javascript.JSaddle.Native.Internal (
17 , withJSVals
20 , withJSVals
18 , withObject
21 , withObject
19 , withJSString
22 , 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
20) where
48) where
21
49
22−import Control.Monad.Trans.Reader (ask)
23import Control.Monad.IO.Class (MonadIO(..))
50import Control.Monad.IO.Class (MonadIO(..))
51+
52+import Data.Aeson (Value)
53+
24import Language.Javascript.JSaddle.Types
54import Language.Javascript.JSaddle.Types
25− (JSContextRef(..), AsyncCommand(..), JSM(..), JSString(..),
55+ (AsyncCommand(..), JSM(..), JSString(..), addCallback,
26− Object(..), JSVal(..), JSValueReceived(..), JSValueForSend(..),
56+ Object(..), JSVal(..), JSValueForSend(..), JSCallAsFunction,
27 JSStringReceived(..), JSStringForSend(..), JSObjectForSend(..))
57 JSStringReceived(..), JSStringForSend(..), JSObjectForSend(..))
28−import System.Mem.Weak (addFinalizer)
58+import Language.Javascript.JSaddle.Monad (askJSM)
29−import Control.Monad.Primitive (touch)
59+import Language.Javascript.JSaddle.Run
30−import Control.Monad (when)
60+ (Command(..), Result(..), sendCommand,
31−
61+ sendAsyncCommand, sendLazyCommand, wrapJSVal)
32−wrapJSVal :: JSValueReceived -> JSM JSVal
62+import GHC.IORef (IORef(..), readIORef)
33−wrapJSVal (JSValueReceived ref) = do
63+import GHC.STRef (STRef(..))
34− -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
64+import GHC.IO (IO(..))
35− let result = JSVal ref
65+import GHC.Base (touch#)
36− when (ref >= 5) $ do
37− ctx <- JSM ask
38− liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref
39− return result
40
66
41wrapJSString :: MonadIO m => JSStringReceived -> m JSString
67wrapJSString :: MonadIO m => JSStringReceived -> m JSString
42wrapJSString (JSStringReceived ref) = return $ JSString ref
68wrapJSString (JSStringReceived ref) = return $ JSString ref
43
69
70+touchIORef :: IORef a -> IO ()
71+touchIORef (IORef (STRef r#)) = IO $ \s -> case touch# r# s of s' -> (# s', () #)
72+
44withJSVal :: MonadIO m => JSVal -> (JSValueForSend -> m a) -> m a
73withJSVal :: MonadIO m => JSVal -> (JSValueForSend -> m a) -> m a
45−withJSVal v@(JSVal ref) f =
74+withJSVal (JSVal ref) f = do
46− do result <- f (JSValueForSend ref)
75+ result <- (f . JSValueForSend) =<< liftIO (readIORef ref)
47− liftIO $ touch v
76+ liftIO $ touchIORef ref
48 return result
77 return result
49
78
50withJSVals :: MonadIO m => [JSVal] -> ([JSValueForSend] -> m a) -> m a
79withJSVals :: MonadIO m => [JSVal] -> ([JSValueForSend] -> m a) -> m a
51withJSVals v f =
80withJSVals v f =
52− do result <- f (map (\(JSVal ref) -> JSValueForSend ref) v)
81+ do result <- f =<< mapM (\(JSVal ref) -> liftIO $ JSValueForSend <$> readIORef ref) v
53− liftIO $ mapM_ touch v
82+ liftIO $ mapM_ (\(JSVal ref) -> touchIORef ref) v
54 return result
83 return result
55
84
56withObject :: MonadIO m => Object -> (JSObjectForSend -> m a) -> m a
85withObject :: MonadIO m => Object -> (JSObjectForSend -> m a) -> m a
57withObject (Object o) f = withJSVal o (f . JSObjectForSend)
86withObject (Object o) f = withJSVal o (f . JSObjectForSend)
58
87
59withJSString :: MonadIO m => JSString -> (JSStringForSend -> m a) -> m a
88withJSString :: MonadIO m => JSString -> (JSStringForSend -> m a) -> m a
60−withJSString v@(JSString ref) f =
89+withJSString (JSString ref) f = f (JSStringForSend ref)
61− do result <- f (JSStringForSend ref)
90+
62− liftIO $ touch v
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)
63 return result
207 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 #-}
64
247
248+propertyNames :: Object -> JSM [JSString]
249+propertyNames this =
250+ withObject this $ \rthis -> do
251+ ~(PropertyNamesResult result) <- sendCommand $ PropertyNames rthis
252+ mapM wrapJSString result
253+{-# INLINE propertyNames #-}
jsaddle/src/Language/Javascript/JSaddle/Null.hsnew file+56
@@ -0,0 +1,56 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+-----------------------------------------------------------------------------
4+--
5+-- Module : Language.Javascript.JSaddle.WebSockets
6+-- Copyright : (c) Hamish Mackenzie
7+-- License : MIT
8+--
9+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.Javascript.JSaddle.Null (
16+ run
17+) where
18+
19+import Language.Javascript.JSaddle.Types
20+ (BatchResults(..), JSM, JSStringReceived(..), Batch(..),
21+ Results(..), Result(..), Command(..))
22+import Control.Concurrent.Chan (readChan, writeChan, newChan)
23+import Language.Javascript.JSaddle.Run (runJavaScript)
24+import Control.Concurrent (forkIO)
25+import Control.Monad (forever)
26+import Data.Aeson (Value(..))
27+import Data.Maybe (mapMaybe)
28+
29+-- | This is for performance testing JSaddle code that does not need to
30+-- to read anything back from the JavaScript context.
31+-- Anthing that does try to read will get JS null, 0 or "" back (depending
32+-- on how the value is read).
33+run :: JSM () -> IO ()
34+run f = do
35+ batches <- newChan
36+ (processResult, _processSyncResult, start) <- runJavaScript (writeChan batches) f
37+ _ <- forkIO $ forever $
38+ readChan batches >>= \case
39+ Batch commands _ batchNumber ->
40+ processResult $ BatchResults batchNumber . Success [] $ mapMaybe (\case
41+ Left _ -> Nothing
42+ Right command -> Just $
43+ case command of
44+ DeRefVal _ -> DeRefValResult 0 ""
45+ ValueToBool _ -> ValueToBoolResult False
46+ ValueToNumber _ -> ValueToNumberResult 0
47+ ValueToString _ -> ValueToStringResult (JSStringReceived "")
48+ ValueToJSON _ -> ValueToJSONResult (JSStringReceived "null")
49+ ValueToJSONValue _ -> ValueToJSONValueResult Null
50+ IsNull _ -> IsNullResult True
51+ IsUndefined _ -> IsUndefinedResult False
52+ StrictEqual _ _ -> StrictEqualResult False
53+ InstanceOf _ _ -> InstanceOfResult False
54+ PropertyNames _ -> PropertyNamesResult []
55+ Sync -> SyncResult) commands
56+ start
jsaddle/src/Language/Javascript/JSaddle/Object.hs+54−29
@@ -66,6 +66,7 @@ module Language.Javascript.JSaddle.Object (
66 -- * Calling Haskell From JavaScript
66 -- * Calling Haskell From JavaScript
67 , Function(..)
67 , Function(..)
68 , function
68 , function
69+ , asyncFunction
69 , freeFunction
70 , freeFunction
70 , fun
71 , fun
71 , JSCallAsFunction
72 , JSCallAsFunction
@@ -102,7 +103,7 @@ import Data.Coerce (coerce)
102#ifdef ghcjs_HOST_OS
103#ifdef ghcjs_HOST_OS
103import GHCJS.Types (nullRef)
104import GHCJS.Types (nullRef)
104import GHCJS.Foreign.Callback
105import GHCJS.Foreign.Callback
105− (releaseCallback, syncCallback2, OnBlocked(..), Callback)
106+ (releaseCallback, syncCallback2, asyncCallback2, OnBlocked(..), Callback)
106import GHCJS.Marshal (ToJSVal(..))
107import GHCJS.Marshal (ToJSVal(..))
107import JavaScript.Array (MutableJSArray)
108import JavaScript.Array (MutableJSArray)
108import qualified JavaScript.Array as Array (toListIO, fromListIO)
109import qualified JavaScript.Array as Array (toListIO, fromListIO)
@@ -113,17 +114,15 @@ import Language.Javascript.JSaddle.Types
113 (JSString, Object(..),
114 (JSString, Object(..),
114 JSVal(..), JSCallAsFunction)
115 JSVal(..), JSCallAsFunction)
115#else
116#else
116−import Data.Text (Text)
117import GHCJS.Marshal.Internal (ToJSVal(..))
117import GHCJS.Marshal.Internal (ToJSVal(..))
118import Language.Javascript.JSaddle.Native
118import Language.Javascript.JSaddle.Native
119− (withJSVals, withObject)
119+ (newAsyncCallback, newSyncCallback, callAsFunction, callAsConstructor)
120−import Language.Javascript.JSaddle.Run
121− (AsyncCommand(..), sendLazyCommand)
122import Language.Javascript.JSaddle.Monad (askJSM, JSM)
120import Language.Javascript.JSaddle.Monad (askJSM, JSM)
123import Language.Javascript.JSaddle.Types
121import Language.Javascript.JSaddle.Types
124− (JSString, Object(..), SomeJSArray(..),
122+ (JSValueForSend(..), AsyncCommand(..), JSString, Object(..),
125− JSVal(..), JSCallAsFunction, JSContextRef(..))
123+ SomeJSArray(..), JSVal(..), JSCallAsFunction, JSContextRef(..))
126import JavaScript.Object.Internal (create, listProps)
124import JavaScript.Object.Internal (create, listProps)
125+import Language.Javascript.JSaddle.Run (sendAsyncCommand)
127#endif
126#endif
128import JavaScript.Array.Internal (fromListIO)
127import JavaScript.Array.Internal (fromListIO)
129import Language.Javascript.JSaddle.Value (valToObject)
128import Language.Javascript.JSaddle.Value (valToObject)
@@ -133,6 +132,8 @@ import Language.Javascript.JSaddle.Arguments (MakeArgs(..))
133import Control.Monad.IO.Class (MonadIO(..))
132import Control.Monad.IO.Class (MonadIO(..))
134import Language.Javascript.JSaddle.Properties
133import Language.Javascript.JSaddle.Properties
135import Control.Lens (IndexPreservingGetter, to)
134import Control.Lens (IndexPreservingGetter, to)
135+import Data.IORef (newIORef, readIORef)
136+import System.IO.Unsafe (unsafePerformIO)
136
137
137-- $setup
138-- $setup
138-- >>> import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
139-- >>> import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
@@ -280,6 +281,7 @@ jsgf name = global # name
280-- > jsg0 name = jsgf name ()
281-- > jsg0 name = jsgf name ()
281--
282--
282-- >>> testJSaddle $ jsg0 "globalFunc" >>= valToText
283-- >>> testJSaddle $ jsg0 "globalFunc" >>= valToText
284+-- A JavaScript exception was thrown! (may not reach Haskell code)
283-- TypeError:...undefine...
285-- TypeError:...undefine...
284jsg0 :: (ToJSString name) => name -> JSM JSVal
286jsg0 :: (ToJSString name) => name -> JSM JSVal
285jsg0 name = jsgf name ()
287jsg0 name = jsgf name ()
@@ -437,9 +439,16 @@ newtype Function = Function {functionObject :: Object}
437#endif
439#endif
438
440
439
441
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+
440-- ^ Make a JavaScript function object that wraps a Haskell function.
447-- ^ 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`).
441function :: JSCallAsFunction -- ^ Haskell function to call
450function :: JSCallAsFunction -- ^ Haskell function to call
442− -> JSM Function -- ^ Returns a JavaScript function object that will
451+ -> JSM Function -- ^ Returns a JavaScript function object that will
443 -- call the Haskell one when it is called
452 -- call the Haskell one when it is called
444#ifdef ghcjs_HOST_OS
453#ifdef ghcjs_HOST_OS
445function f = do
454function f = do
@@ -447,13 +456,26 @@ function f = do
447 rargs <- Array.toListIO (coerce args)
456 rargs <- Array.toListIO (coerce args)
448 f this this rargs -- TODO pass function object through
457 f this this rargs -- TODO pass function object through
449 Function callback <$> makeFunctionWithCallback callback
458 Function callback <$> makeFunctionWithCallback callback
450−foreign import javascript unsafe "$r = function () { $1(this, arguments); }"
451− makeFunctionWithCallback :: Callback (JSVal -> JSVal -> IO ()) -> IO Object
452#else
459#else
453function f = do
460function f = do
454− object <- Object <$> sendLazyCommand NewCallback
461+ object <- newSyncCallback f
455− add <- addCallback <$> askJSM
462+ return $ Function object
456− liftIO $ add object f
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
457 return $ Function object
479 return $ Function object
458#endif
480#endif
459
481
@@ -462,9 +484,16 @@ freeFunction :: Function -> JSM ()
462freeFunction (Function callback _) = liftIO $
484freeFunction (Function callback _) = liftIO $
463 releaseCallback callback
485 releaseCallback callback
464#else
486#else
465−freeFunction (Function object) = do
487+freeFunction (Function (Object (JSVal objectRef))) = do
466− free <- freeCallback <$> askJSM
488+ -- By now the callback should ideally have been removed from whatever
467− liftIO $ free object
489+ -- events it was added to.
490+ -- In case a call to the callback is still pending (perhaps just being sent
491+ -- on the JS side) we use FreeCallback to queue the callback to be freed when
492+ -- the next batch of results comes back fro JS.
493+ -- We are not using withJSVal to keep JS value "alive" because FreeCallback
494+ -- does not use the it.
495+ n <- liftIO $ readIORef objectRef
496+ sendAsyncCommand (FreeCallback (JSValueForSend n))
468#endif
497#endif
469
498
470instance ToJSVal Function where
499instance ToJSVal Function where
@@ -497,13 +526,12 @@ array args = do
497 Object . coerce <$> fromListIO rargs
526 Object . coerce <$> fromListIO rargs
498
527
499-- | JavaScript's global object
528-- | JavaScript's global object
500−global :: Object
501#ifdef ghcjs_HOST_OS
529#ifdef ghcjs_HOST_OS
502−global = js_window
503−foreign import javascript unsafe "$r = window"
530+foreign import javascript unsafe "$r = globalThis"
504− js_window :: Object
531+ global :: Object
505#else
532#else
506−global = Object (JSVal 4)
533+global :: Object
534+global = Object . JSVal . unsafePerformIO $ newIORef 4
507#endif
535#endif
508
536
509-- | Get a list containing the property names present on a given object
537-- | Get a list containing the property names present on a given object
@@ -528,14 +556,12 @@ objCallAsFunction :: MakeArgs args
528objCallAsFunction f this args = do
556objCallAsFunction f this args = do
529 rargs <- makeArgs args >>= liftIO . Array.fromListIO
557 rargs <- makeArgs args >>= liftIO . Array.fromListIO
530 liftIO $ js_apply f this rargs
558 liftIO $ js_apply f this rargs
531−foreign import javascript unsafe "$r = $1.apply($2, $3)"
559+foreign import javascript safe "$r = $1.apply($2, $3)"
532 js_apply :: Object -> Object -> MutableJSArray -> IO JSVal
560 js_apply :: Object -> Object -> MutableJSArray -> IO JSVal
533#else
561#else
534objCallAsFunction f this args = do
562objCallAsFunction f this args = do
535 rargs <- makeArgs args
563 rargs <- makeArgs args
536− withObject f $ \rfunction ->
564+ callAsFunction f this rargs
537− withObject this $ \rthis ->
538− withJSVals rargs $ sendLazyCommand . CallAsFunction rfunction rthis
539#endif
565#endif
540
566
541-- | Call a JavaScript object as a constructor. Consider using 'new'.
567-- | Call a JavaScript object as a constructor. Consider using 'new'.
@@ -550,7 +576,7 @@ objCallAsConstructor :: MakeArgs args
550objCallAsConstructor f args = do
576objCallAsConstructor f args = do
551 rargs <- makeArgs args >>= liftIO . Array.fromListIO
577 rargs <- makeArgs args >>= liftIO . Array.fromListIO
552 liftIO $ js_new f rargs
578 liftIO $ js_new f rargs
553−foreign import javascript unsafe "\
579+foreign import javascript safe "\
554 switch($2.length) {\
580 switch($2.length) {\
555 case 0 : $r = new $1(); break;\
581 case 0 : $r = new $1(); break;\
556 case 1 : $r = new $1($2[0]); break;\
582 case 1 : $r = new $1($2[0]); break;\
@@ -577,8 +603,7 @@ foreign import javascript unsafe "\
577#else
603#else
578objCallAsConstructor f args = do
604objCallAsConstructor f args = do
579 rargs <- makeArgs args
605 rargs <- makeArgs args
580− withObject f $ \rfunction ->
606+ callAsConstructor f rargs
581− withJSVals rargs $ sendLazyCommand . CallAsConstructor rfunction
582#endif
607#endif
583
608
584-- >>> testJSaddle $ strictEqual nullObject (eval "null")
609-- >>> testJSaddle $ strictEqual nullObject (eval "null")
@@ -587,5 +612,5 @@ nullObject :: Object
587#ifdef ghcjs_HOST_OS
612#ifdef ghcjs_HOST_OS
588nullObject = Object nullRef
613nullObject = Object nullRef
589#else
614#else
590−nullObject = Object (JSVal 0)
615+nullObject = Object . JSVal . unsafePerformIO $ newIORef 0
591#endif
616#endif
jsaddle/src/Language/Javascript/JSaddle/Run.hs+195−80
@@ -1,6 +1,9 @@
1+{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE MagicHash #-}
6+{-# LANGUAGE UnboxedTuples #-}
4-----------------------------------------------------------------------------
7-----------------------------------------------------------------------------
5--
8--
6-- Module : Language.Javascript.JSaddle.Run
9-- Module : Language.Javascript.JSaddle.Run
@@ -19,6 +22,7 @@ module Language.Javascript.JSaddle.Run (
19 , syncAfter
22 , syncAfter
20 , waitForAnimationFrame
23 , waitForAnimationFrame
21 , nextAnimationFrame
24 , nextAnimationFrame
25+ , enableLogging
22#ifndef ghcjs_HOST_OS
26#ifndef ghcjs_HOST_OS
23 -- * Functions used to implement JSaddle using JSON messaging
27 -- * Functions used to implement JSaddle using JSON messaging
24 , runJavaScript
28 , runJavaScript
@@ -28,56 +32,72 @@ module Language.Javascript.JSaddle.Run (
28 , sendCommand
32 , sendCommand
29 , sendLazyCommand
33 , sendLazyCommand
30 , sendAsyncCommand
34 , sendAsyncCommand
35+ , wrapJSVal
31#endif
36#endif
32) where
37) where
33
38
34#ifdef ghcjs_HOST_OS
39#ifdef ghcjs_HOST_OS
35−import Language.Javascript.JSaddle.Types (JSM)
40+import Language.Javascript.JSaddle.Types (JSM, syncPoint, syncAfter)
36import qualified JavaScript.Web.AnimationFrame as GHCJS
41import qualified JavaScript.Web.AnimationFrame as GHCJS
37 (waitForAnimationFrame)
42 (waitForAnimationFrame)
38#else
43#else
39−import Control.Exception (throwIO)
44+import Control.Exception (throwIO, evaluate)
40−import Control.Monad (void, forever)
45+import Control.Monad (void, when, zipWithM_)
41import Control.Monad.IO.Class (MonadIO(..))
46import Control.Monad.IO.Class (MonadIO(..))
42import Control.Monad.Trans.Reader (ask, runReaderT)
47import Control.Monad.Trans.Reader (ask, runReaderT)
43−import Control.Monad.STM (STM, atomically)
48+import Control.Monad.STM (atomically)
44−import Control.Concurrent (forkIO)
49+import Control.Concurrent (forkIO, myThreadId)
45import Control.Concurrent.STM.TChan
50import Control.Concurrent.STM.TChan
46 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
51 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
47import Control.Concurrent.STM.TVar
52import Control.Concurrent.STM.TVar
48− (writeTVar, readTVar, readTVarIO, modifyTVar, newTVarIO)
53+ (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
49import Control.Concurrent.MVar
54import Control.Concurrent.MVar
50− (MVar, MVar, putMVar, takeMVar, newEmptyMVar)
55+ (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)
51
56
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(..))
52import Data.Monoid ((<>))
63import Data.Monoid ((<>))
53−import qualified Data.Text as T (unpack)
64+import qualified Data.Text as T (unpack, pack)
54−import qualified Data.Map as M (lookup, delete, insert, empty)
65+import qualified Data.Map as M (lookup, delete, insert, empty, size)
66+import qualified Data.Set as S (empty, member, insert, delete)
55import Data.Time.Clock (getCurrentTime,diffUTCTime)
67import Data.Time.Clock (getCurrentTime,diffUTCTime)
68+import Data.IORef
69+ (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)
56
70
57import Language.Javascript.JSaddle.Types
71import Language.Javascript.JSaddle.Types
58− (Command(..), AsyncCommand(..), Result(..), JSContextRef(..), JSVal(..),
72+ (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
59− Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
73+ Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand)
60import Language.Javascript.JSaddle.Exception (JSException(..))
74import Language.Javascript.JSaddle.Exception (JSException(..))
61−import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
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_)
62#endif
82#endif
63
83
64−-- | Forces execution of pending asyncronous code
65−syncPoint :: JSM ()
66−#ifdef ghcjs_HOST_OS
84+#ifndef ghcjs_HOST_OS
67−syncPoint = return ()
85+#if MIN_VERSION_base(4,11,0)
86+currentBytesUsed = gcdetails_live_bytes . gc
68#else
87#else
69−syncPoint = void $ sendCommand Sync
88+getRTSStatsEnabled = getGCStatsEnabled
89+getRTSStats = getGCStats
90+#endif
70#endif
91#endif
71
92
72−-- | Forces execution of pending asyncronous code after performing `f`
93+-- | Enable (or disable) JSaddle logging
73−syncAfter :: JSM a -> JSM a
94+enableLogging :: Bool -> JSM ()
74#ifdef ghcjs_HOST_OS
95#ifdef ghcjs_HOST_OS
75−syncAfter = id
96+enableLogging _ = return ()
76#else
97#else
77−syncAfter f = do
98+enableLogging v = do
78− result <- f
99+ f <- doEnableLogging <$> JSM ask
79− syncPoint
100+ liftIO $ f v
80− return result
81#endif
101#endif
82
102
83-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
103-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
@@ -105,17 +125,12 @@ nextAnimationFrame f = do
105 syncAfter (f t)
125 syncAfter (f t)
106
126
107#ifndef ghcjs_HOST_OS
127#ifndef ghcjs_HOST_OS
108−sendCommand :: Command -> JSM Result
109−sendCommand cmd = do
110− s <- doSendCommand <$> JSM ask
111− liftIO $ s cmd
112−
113sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
128sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
114sendLazyCommand cmd = do
129sendLazyCommand cmd = do
115 nextRefTVar <- nextRef <$> JSM ask
130 nextRefTVar <- nextRef <$> JSM ask
116 n <- liftIO . atomically $ do
131 n <- liftIO . atomically $ do
117 n <- subtract 1 <$> readTVar nextRefTVar
132 n <- subtract 1 <$> readTVar nextRefTVar
118− writeTVar nextRefTVar n
133+ writeTVar nextRefTVar $! n
119 return n
134 return n
120 s <- doSendAsyncCommand <$> JSM ask
135 s <- doSendAsyncCommand <$> JSM ask
121 liftIO $ s (cmd $ JSValueForSend n)
136 liftIO $ s (cmd $ JSValueForSend n)
@@ -126,71 +141,171 @@ sendAsyncCommand cmd = do
126 s <- doSendAsyncCommand <$> JSM ask
141 s <- doSendAsyncCommand <$> JSM ask
127 liftIO $ s cmd
142 liftIO $ s cmd
128
143
129−runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Result -> IO (), IO ())
144+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
130runJavaScript sendBatch entryPoint = do
145runJavaScript sendBatch entryPoint = do
146+ contextId' <- randomIO
131 startTime' <- getCurrentTime
147 startTime' <- getCurrentTime
132− recvChan <- newTChanIO
148+ recvMVar <- newEmptyMVar
149+ lastAsyncBatch <- newEmptyMVar
133 commandChan <- newTChanIO
150 commandChan <- newTChanIO
134 callbacks <- newTVarIO M.empty
151 callbacks <- newTVarIO M.empty
135 nextRef' <- newTVarIO 0
152 nextRef' <- newTVarIO 0
153+ finalizerThreads' <- newMVar S.empty
154+ animationFrameHandlers' <- newMVar []
155+ loggingEnabled <- newIORef False
156+ liveRefs' <- newMVar S.empty
136 let ctx = JSContextRef {
157 let ctx = JSContextRef {
158+ contextId = contextId'
137− startTime = startTime'
159+ , startTime = startTime'
138− , doSendCommand = \cmd -> do
160+ , doSendCommand = \cmd -> cmd `deepseq` do
139− result <- newEmptyMVar
161+ result <- newEmptyMVar
140− atomically $ writeTChan commandChan (Right (cmd, result))
162+ atomically $ writeTChan commandChan (Right (cmd, result))
163+ unsafeInterleaveIO $
141− takeMVar result >>= \case
164+ takeMVar result >>= \case
165+ (ThrowJSValue v) -> do
166+ jsval <- wrapJSVal' ctx v
142− (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
167+ throwIO $ JSException jsval
143− r -> return r
168+ r -> return r
144− , doSendAsyncCommand = atomically . writeTChan commandChan . Left
169+ , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
170+ , addCallback = \(Object (JSVal ioref)) cb -> do
171+ val <- readIORef ioref
145− , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar callbacks (M.insert val cb)
172+ atomically $ modifyTVar' callbacks (M.insert val cb)
146− , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar callbacks (M.delete val)
173+ , nextRef = nextRef'
147− , nextRef = nextRef'
174+ , doEnableLogging = atomicWriteIORef loggingEnabled
175+ , finalizerThreads = finalizerThreads'
176+ , animationFrameHandlers = animationFrameHandlers'
177+ , liveRefs = liveRefs'
148− }
178+ }
149− let processResult = \case
179+ processResults :: Bool -> Results -> IO ()
180+ processResults syncCallbacks = \case
150 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
181 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
151− (Callback f this a) -> do
182+ (Callback n br (JSValueReceived fNumber) f this a) -> do
183+ putMVar recvMVar (n, br)
152− f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
184+ f' <- runReaderT (unJSM $ wrapJSVal f) ctx
153 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
185 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
154 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
186 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
187+ logInfo (("Call " <> show fNumber <> " ") <>)
155 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
188 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
156 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
189 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
190+ Just cb -> void . forkIO $ do
157− Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
191+ runReaderT (unJSM $ cb f' this' args) ctx
158− m -> atomically $ writeTChan recvChan m
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 ->
159− _ <- forkIO . forever $ readBatch commandChan >>= \case
216+ readBatch nBatch commandChan >>= \case
160− (batch, Just resultMVar) -> do
217+ (batch@(Batch cmds _ _), resultMVars) -> do
161− sendBatch batch
218+ logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
162− atomically (readTChan recvChan) >>= putMVar resultMVar
219+ _ <- tryTakeMVar lastAsyncBatch
163− (batch, Nothing) -> do
220+ putMVar lastAsyncBatch batch
164 sendBatch batch
221 sendBatch batch
165− atomically (readTChan recvChan) >>= \case
222+ takeResult recvMVar nBatch >>= \case
166− SyncResult -> return ()
223+ (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"
167− ThrowJSValue e -> atomically (discardToSyncPoint commandChan) >>= (`putMVar` ThrowJSValue e)
224+ (_, Success callbacksToFree results)
168− _ -> error "Unexpected result processing batch"
225+ | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
169− return ()
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))
170− return (processResult, runReaderT (unJSM entryPoint) ctx)
238+ return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)
171 where
239 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
172− readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, Maybe (MVar Result))
248+ readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
173− readBatch chan = do
249+ readBatch nBatch chan = do
174 first <- atomically $ readTChan chan -- We want at least one command to send
250 first <- atomically $ readTChan chan -- We want at least one command to send
175− loop first []
251+ loop first ([], [])
176 where
252 where
253+ loop :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
177− loop (Left asyncCmd@(SyncWithAnimationFrame _)) asyncCmds =
254+ loop (Left asyncCmd@(SyncWithAnimationFrame _)) (cmds, resultMVars) =
178− atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (asyncCmd:asyncCmds)
255+ atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
179− loop (Right (cmd, resultMVar)) asyncCmds =
256+ loop (Right (syncCmd, resultMVar)) (cmds', resultMVars') = do
180− return (Batch (reverse asyncCmds) cmd False, Just resultMVar)
257+ let cmds = Right syncCmd:cmds'
181− loop (Left asyncCmd) asyncCmds' = do
258+ resultMVars = resultMVar:resultMVars'
182− let asyncCmds = asyncCmd:asyncCmds'
183 atomically (tryReadTChan chan) >>= \case
259 atomically (tryReadTChan chan) >>= \case
184− Nothing -> return (Batch (reverse asyncCmds) Sync False, Nothing)
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)
185− Just cmd -> loop cmd asyncCmds
266+ Just cmd -> loop cmd (cmds, resultMVars)
186 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
267 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
187− loopAnimation (Right (cmd, resultMVar)) asyncCmds =
268+ loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
269+ loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =
188− return (Batch (reverse asyncCmds) cmd True, Just resultMVar)
270+ return (Batch (reverse (Right Sync:cmds)) True nBatch, reverse (resultMVar:resultMVars))
189− loopAnimation (Left asyncCmd) asyncCmds =
271+ loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
190− atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (asyncCmd:asyncCmds)
272+ atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
191− discardToSyncPoint :: TChan (Either AsyncCommand (Command, MVar Result)) -> STM (MVar Result)
273+ loopAnimation (Left asyncCmd) (cmds, resultMVars) =
192− discardToSyncPoint chan =
274+ atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
193− readTChan chan >>= \case
275+
194− Right (_, resultMVar) -> return resultMVar
276+addThreadFinalizer :: ThreadId -> IO () -> IO ()
195− _ -> discardToSyncPoint chan
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)
196#endif
311#endif
jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+253−117
@@ -13,7 +13,6 @@
13
13
14module Language.Javascript.JSaddle.Run.Files (
14module Language.Javascript.JSaddle.Run.Files (
15 indexHtml
15 indexHtml
16− , jsaddleJs
17 , initState
16 , initState
18 , runBatch
17 , runBatch
19 , ghcjsHelpers
18 , ghcjsHelpers
@@ -31,30 +30,54 @@ indexHtml =
31 \</head>\n\
30 \</head>\n\
32 \<body>\n\
31 \<body>\n\
33 \</body>\n\
32 \</body>\n\
34− \<script src=\"jsaddle.js\"></script>\n\
33+ \<script src=\"/jsaddle.js\"></script>\n\
35 \</html>"
34 \</html>"
36
35
37initState :: ByteString
36initState :: ByteString
38initState = "\
37initState = "\
39 \ var jsaddle_values = new Map();\n\
38 \ var jsaddle_values = new Map();\n\
39+ \ var jsaddle_free = new Map();\n\
40 \ jsaddle_values.set(0, null);\n\
40 \ jsaddle_values.set(0, null);\n\
41 \ jsaddle_values.set(1, undefined);\n\
41 \ jsaddle_values.set(1, undefined);\n\
42 \ jsaddle_values.set(2, false);\n\
42 \ jsaddle_values.set(2, false);\n\
43 \ jsaddle_values.set(3, true);\n\
43 \ jsaddle_values.set(3, true);\n\
44− \ jsaddle_values.set(4, window);\n\
44+ \ jsaddle_values.set(4, globalThis);\n\
45 \ var jsaddle_index = 100;\n\
45 \ 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\
46 \"
50 \"
47
51
48−runBatch :: (ByteString -> ByteString) -> ByteString
52+runBatch :: (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString
49−runBatch send = "\
53+runBatch send sendSync = "\
54+ \ var runBatch = function(firstBatch, initialSyncDepth) {\n\
50− \ var processBatch = function(timestamp) {\n\
55+ \ var processBatch = function(timestamp) {\n\
56+ \ var batch = firstBatch;\n\
57+ \ var callbacksToFree = [];\n\
58+ \ var results = [];\n\
59+ \ inCallback++;\n\
51− \ try {\n\
60+ \ try {\n\
61+ \ syncDepth = initialSyncDepth || 0;\n\
62+ \ for(;;){\n\
63+ \ if(batch[2] === expectedBatch) {\n\
64+ \ expectedBatch++;\n\
52− \ var nAsyncLength = batch[0].length;\n\
65+ \ var nCommandsLength = batch[0].length;\n\
53− \ for (var nAsync = 0; nAsync != nAsyncLength; nAsync++) {\n\
66+ \ for (var nCommand = 0; nCommand != nCommandsLength; nCommand++) {\n\
54− \ var d = batch[0][nAsync];\n\
67+ \ var cmd = batch[0][nCommand];\n\
68+ \ if (cmd.Left) {\n\
69+ \ var d = cmd.Left;\n\
55− \ switch (d.tag) {\n\
70+ \ switch (d.tag) {\n\
56 \ case \"FreeRef\":\n\
71 \ 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\
57− \ jsaddle_values.delete(d.contents);\n\
79+ \ jsaddle_values.delete(refsToFree[nRef]);\n\
80+ \ jsaddle_free.delete(d.contents);\n\
58 \ break;\n\
81 \ break;\n\
59 \ case \"SetPropertyByName\":\n\
82 \ case \"SetPropertyByName\":\n\
60 \ jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]);\n\
83 \ jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]);\n\
@@ -70,6 +93,10 @@ runBatch send = "\
70 \ var n = d.contents[1];\n\
93 \ var n = d.contents[1];\n\
71 \ jsaddle_values.set(n, d.contents[0]);\n\
94 \ jsaddle_values.set(n, d.contents[0]);\n\
72 \ break;\n\
95 \ break;\n\
96+ \ case \"JSONValueToValue\":\n\
97+ \ var n = d.contents[1];\n\
98+ \ jsaddle_values.set(n, d.contents[0]);\n\
99+ \ break;\n\
73 \ case \"GetPropertyByName\":\n\
100 \ case \"GetPropertyByName\":\n\
74 \ var n = d.contents[2];\n\
101 \ var n = d.contents[2];\n\
75 \ jsaddle_values.set(n, jsaddle_values.get(d.contents[0])[d.contents[1]]);\n\
102 \ jsaddle_values.set(n, jsaddle_values.get(d.contents[0])[d.contents[1]]);\n\
@@ -86,10 +113,12 @@ runBatch send = "\
86 \ var n = d.contents;\n\
113 \ var n = d.contents;\n\
87 \ jsaddle_values.set(n, {});\n\
114 \ jsaddle_values.set(n, {});\n\
88 \ break;\n\
115 \ break;\n\
89− \ case \"NewCallback\":\n\
116+ \ case \"NewAsyncCallback\":\n\
90 \ (function() {\n\
117 \ (function() {\n\
91 \ var nFunction = d.contents;\n\
118 \ var nFunction = d.contents;\n\
119+ \ var func = function() {\n\
120+ \ var nFunctionInFunc = ++jsaddle_index;\n\
92− \ jsaddle_values.set(nFunction, function() {\n\
121+ \ jsaddle_values.set(nFunctionInFunc, func);\n\
93 \ var nThis = ++jsaddle_index;\n\
122 \ var nThis = ++jsaddle_index;\n\
94 \ jsaddle_values.set(nThis, this);\n\
123 \ jsaddle_values.set(nThis, this);\n\
95 \ var args = [];\n\
124 \ var args = [];\n\
@@ -98,8 +127,41 @@ runBatch send = "\
98 \ jsaddle_values.set(nArg, arguments[i]);\n\
127 \ jsaddle_values.set(nArg, arguments[i]);\n\
99 \ args[i] = nArg;\n\
128 \ args[i] = nArg;\n\
100 \ }\n\
129 \ }\n\
101− \ " <> send "{\"tag\": \"Callback\", \"contents\": [nFunction, nThis, args]}" <> "\n\
130+ \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n\
131+ \ };\n\
132+ \ jsaddle_values.set(nFunction, func);\n\
102− \ })})();\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\
103 \ break;\n\
165 \ break;\n\
104 \ case \"CallAsFunction\":\n\
166 \ case \"CallAsFunction\":\n\
105 \ var n = d.contents[3];\n\
167 \ var n = d.contents[3];\n\
@@ -142,117 +204,137 @@ runBatch send = "\
142 \ jsaddle_values.set(n, d.contents[0].map(function(v){return jsaddle_values.get(v);}));\n\
204 \ jsaddle_values.set(n, d.contents[0].map(function(v){return jsaddle_values.get(v);}));\n\
143 \ break;\n\
205 \ break;\n\
144 \ case \"SyncWithAnimationFrame\":\n\
206 \ case \"SyncWithAnimationFrame\":\n\
145− \ var n = d.contents[0];\n\
207+ \ var n = d.contents;\n\
146 \ jsaddle_values.set(n, timestamp);\n\
208 \ jsaddle_values.set(n, timestamp);\n\
147 \ break;\n\
209 \ break;\n\
210+ \ case \"StartSyncBlock\":\n\
211+ \ syncDepth++;\n\
212+ \ break;\n\
213+ \ case \"EndSyncBlock\":\n\
214+ \ syncDepth--;\n\
215+ \ break;\n\
148 \ default:\n\
216 \ default:\n\
149 \ " <> send "{\"tag\": \"ProtocolError\", \"contents\": e.data}" <> "\n\
217 \ " <> send "{\"tag\": \"ProtocolError\", \"contents\": e.data}" <> "\n\
150 \ return;\n\
218 \ return;\n\
151− \ }\n\
152 \ }\n\
219 \ }\n\
220+ \ } else {\n\
153− \ var d = batch[1];\n\
221+ \ var d = cmd.Right;\n\
154 \ switch (d.tag) {\n\
222 \ switch (d.tag) {\n\
155− \ case \"ValueToString\":\n\
223+ \ case \"ValueToString\":\n\
156− \ var val = jsaddle_values.get(d.contents);\n\
224+ \ var val = jsaddle_values.get(d.contents);\n\
157− \ var s = val === null ? \"null\" : val === undefined ? \"undefined\" : val.toString();\n\
225+ \ var s = val === null ? \"null\" : val === undefined ? \"undefined\" : val.toString();\n\
158− \ " <> send "{\"tag\": \"ValueToStringResult\", \"contents\": s}" <> "\n\
226+ \ results.push({\"tag\": \"ValueToStringResult\", \"contents\": s});\n\
159− \ break;\n\
227+ \ break;\n\
160− \ case \"ValueToBool\":\n\
228+ \ case \"ValueToBool\":\n\
161− \ " <> send "{\"tag\": \"ValueToBoolResult\", \"contents\": jsaddle_values.get(d.contents) ? true : false}" <> "\n\
229+ \ results.push({\"tag\": \"ValueToBoolResult\", \"contents\": jsaddle_values.get(d.contents) ? true : false});\n\
162− \ break;\n\
230+ \ break;\n\
163− \ case \"ValueToNumber\":\n\
231+ \ case \"ValueToNumber\":\n\
164− \ " <> send "{\"tag\": \"ValueToNumberResult\", \"contents\": Number(jsaddle_values.get(d.contents))}" <> "\n\
232+ \ results.push({\"tag\": \"ValueToNumberResult\", \"contents\": Number(jsaddle_values.get(d.contents))});\n\
165− \ break;\n\
233+ \ break;\n\
166− \ case \"ValueToJSON\":\n\
234+ \ case \"ValueToJSON\":\n\
167− \ var s = jsaddle_values.get(d.contents) === undefined ? \"\" : JSON.stringify(jsaddle_values.get(d.contents));\n\
235+ \ var s = jsaddle_values.get(d.contents) === undefined ? \"\" : JSON.stringify(jsaddle_values.get(d.contents));\n\
168− \ " <> send "{\"tag\": \"ValueToJSONResult\", \"contents\": s}" <> "\n\
236+ \ results.push({\"tag\": \"ValueToJSONResult\", \"contents\": s});\n\
169− \ break;\n\
237+ \ break;\n\
170− \ case \"ValueToJSONValue\":\n\
238+ \ case \"ValueToJSONValue\":\n\
171− \ " <> send "{\"tag\": \"ValueToJSONValueResult\", \"contents\": jsaddle_values.get(d.contents)}" <> "\n\
239+ \ results.push({\"tag\": \"ValueToJSONValueResult\", \"contents\": jsaddle_values.get(d.contents)});\n\
172− \ break;\n\
240+ \ break;\n\
173− \ case \"DeRefVal\":\n\
241+ \ case \"DeRefVal\":\n\
174− \ var n = d.contents;\n\
242+ \ var n = d.contents;\n\
175− \ var v = jsaddle_values.get(n);\n\
243+ \ var v = jsaddle_values.get(n);\n\
176− \ var c = (v === null ) ? [0, \"\"] :\n\
244+ \ var c = (v === null ) ? [0, \"\"] :\n\
177− \ (v === undefined ) ? [1, \"\"] :\n\
245+ \ (v === undefined ) ? [1, \"\"] :\n\
178− \ (v === false ) ? [2, \"\"] :\n\
246+ \ (v === false ) ? [2, \"\"] :\n\
179− \ (v === true ) ? [3, \"\"] :\n\
247+ \ (v === true ) ? [3, \"\"] :\n\
180− \ (typeof v === \"number\") ? [-1, v.toString()] :\n\
248+ \ (typeof v === \"number\") ? [-1, v.toString()] :\n\
181− \ (typeof v === \"string\") ? [-2, v]\n\
249+ \ (typeof v === \"string\") ? [-2, v]\n\
182− \ : [n, \"\"];\n\
250+ \ : [-3, \"\"];\n\
183− \ " <> send "{\"tag\": \"DeRefValResult\", \"contents\": c}" <> "\n\
251+ \ results.push({\"tag\": \"DeRefValResult\", \"contents\": c});\n\
184− \ break;\n\
252+ \ break;\n\
185− \ case \"IsNull\":\n\
253+ \ case \"IsNull\":\n\
186− \ " <> send "{\"tag\": \"IsNullResult\", \"contents\": jsaddle_values.get(d.contents) === null}" <> "\n\
254+ \ results.push({\"tag\": \"IsNullResult\", \"contents\": jsaddle_values.get(d.contents) === null});\n\
187− \ break;\n\
255+ \ break;\n\
188− \ case \"IsUndefined\":\n\
256+ \ case \"IsUndefined\":\n\
189− \ " <> send "{\"tag\": \"IsUndefinedResult\", \"contents\": jsaddle_values.get(d.contents) === undefined}" <> "\n\
257+ \ results.push({\"tag\": \"IsUndefinedResult\", \"contents\": jsaddle_values.get(d.contents) === undefined});\n\
190− \ break;\n\
258+ \ break;\n\
191− \ case \"InstanceOf\":\n\
259+ \ case \"InstanceOf\":\n\
192− \ " <> send "{\"tag\": \"InstanceOfResult\", \"contents\": jsaddle_values.get(d.contents[0]) instanceof jsaddle_values.get(d.contents[1])}" <> "\n\
260+ \ results.push({\"tag\": \"InstanceOfResult\", \"contents\": jsaddle_values.get(d.contents[0]) instanceof jsaddle_values.get(d.contents[1])});\n\
193− \ break;\n\
261+ \ break;\n\
194− \ case \"StrictEqual\":\n\
262+ \ case \"StrictEqual\":\n\
195− \ " <> send "{\"tag\": \"StrictEqualResult\", \"contents\": jsaddle_values.get(d.contents[0]) === jsaddle_values.get(d.contents[1])}" <> "\n\
263+ \ results.push({\"tag\": \"StrictEqualResult\", \"contents\": jsaddle_values.get(d.contents[0]) === jsaddle_values.get(d.contents[1])});\n\
196− \ break;\n\
264+ \ break;\n\
197− \ case \"PropertyNames\":\n\
265+ \ case \"PropertyNames\":\n\
198− \ var result = [];\n\
266+ \ var result = [];\n\
199− \ for (name in jsaddle_values.get(d.contents)) { result.push(name); }\n\
267+ \ for (name in jsaddle_values.get(d.contents)) { result.push(name); }\n\
200− \ " <> send "{\"tag\": \"PropertyNamesResult\", \"contents\": result}" <> "\n\
268+ \ results.push({\"tag\": \"PropertyNamesResult\", \"contents\": result});\n\
201− \ break;\n\
269+ \ break;\n\
202− \ case \"Sync\":\n\
270+ \ case \"Sync\":\n\
203− \ " <> send "{\"tag\": \"SyncResult\", \"contents\": []}" <> "\n\
271+ \ results.push({\"tag\": \"SyncResult\", \"contents\": []});\n\
204− \ break;\n\
272+ \ break;\n\
205− \ default:\n\
273+ \ default:\n\
206− \ " <> send "{\"tag\": \"ProtocolError\", \"contents\": e.data}" <> "\n\
274+ \ results.push({\"tag\": \"ProtocolError\", \"contents\": e.data});\n\
207− \ }\n\
275+ \ }\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\
213 \ }\n\
276 \ }\n\
214− \ };\n\
215− \ if(batch[2]) {\n\
216− \ window.requestAnimationFrame(processBatch);\n\
217 \ }\n\
277 \ }\n\
218− \ else {\n\
278+ \ if(syncDepth <= 0) {\n\
219− \ processBatch(window.performance ? window.performance.now() : null);\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\
220− \ }\n\
313+ \ }\n\
221− \"
314+ \ }\n\
222−
315+ \ catch (err) {\n\
223−-- Use this to generate this string for embedding
316+ \ var n = ++jsaddle_index;\n\
224−-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy
317+ \ jsaddle_values.set(n, err);\n\
225−jsaddleJs :: ByteString
318+ \ console.log(err);\n\
226−jsaddleJs = "\
319+ \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Failure\", \"contents\": [callbacksToFree, results, n, String(err)]}]}" <> "\n\
227− \if(typeof global !== \"undefined\") {\n\
320+ \ }\n\
228− \ global.window = global;\n\
321+ \ if(inCallback == 1) {\n\
229− \ global.WebSocket = require('ws');\n\
322+ \ while(asyncBatch !== null) {\n\
230− \}\n\
323+ \ var b = asyncBatch;\n\
231− \\n\
324+ \ asyncBatch = null;\n\
232− \var connect = function() {\n\
325+ \ if(b[2] == expectedBatch) runBatch(b);\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\
248− \ };\n\
326+ \ }\n\
249− \ ws.onerror = function() {\n\
327+ \ }\n\
250− \ setTimeout(connect, 1000);\n\
328+ \ inCallback--;\n\
251 \ };\n\
329 \ };\n\
330+ \ if(batch[1] && (initialSyncDepth || 0) === 0) {\n\
331+ \ window.requestAnimationFrame(processBatch);\n\
252− \}\n\
332+ \ }\n\
253− \\n\
333+ \ else {\n\
254− \ " <> ghcjsHelpers <> "\
334+ \ processBatch(window.performance ? window.performance.now() : null);\n\
255− \connect();\n\
335+ \ }\n\
336+ \ };\n\
337+ \ runBatch(batch);\n\
256 \"
338 \"
257
339
258ghcjsHelpers :: ByteString
340ghcjsHelpers :: ByteString
@@ -323,4 +405,58 @@ ghcjsHelpers = "\
323 \ }\n\
405 \ }\n\
324 \\n\
406 \\n\
325 \}\n\
407 \}\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\
326 \"
462 \"
jsaddle/src/Language/Javascript/JSaddle/Types.hs+262−47
@@ -1,18 +1,20 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2#ifdef ghcjs_HOST_OS
2#ifdef ghcjs_HOST_OS
3−{-# LANGUAGE ConstraintKinds #-}
4{-# OPTIONS_GHC -Wno-dodgy-exports #-}
3{-# OPTIONS_GHC -Wno-dodgy-exports #-}
5#else
4#else
6{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE UndecidableInstances #-}
6{-# LANGUAGE UndecidableInstances #-}
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE DeriveGeneric #-}
8{-# LANGUAGE DeriveGeneric #-}
10−{-# LANGUAGE DefaultSignatures #-}
11{-# LANGUAGE DataKinds #-}
9{-# LANGUAGE DataKinds #-}
12−{-# LANGUAGE KindSignatures #-}
13{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE PolyKinds #-}
14{-# LANGUAGE FlexibleContexts #-}
11{-# LANGUAGE FlexibleContexts #-}
12+{-# LANGUAGE DefaultSignatures #-}
13+{-# LANGUAGE ImplicitParams #-}
15#endif
14#endif
15+{-# LANGUAGE ConstraintKinds #-}
16+{-# LANGUAGE KindSignatures #-}
17+{-# LANGUAGE AllowAmbiguousTypes #-}
16-----------------------------------------------------------------------------
18-----------------------------------------------------------------------------
17--
19--
18-- Module : Language.Javascript.JSaddle.Types
20-- Module : Language.Javascript.JSaddle.Types
@@ -34,18 +36,41 @@ module Language.Javascript.JSaddle.Types (
34 , MonadJSM(..)
36 , MonadJSM(..)
35 , liftJSM
37 , liftJSM
36
38
39+ -- * Pure GHCJS functions
40+ , GHCJSPure(..)
41+ , ghcjsPure
42+ , ghcjsPureMap
43+ , ghcjsPureId
44+
37 -- * JavaScript Value Types
45 -- * JavaScript Value Types
38 , JSVal(..)
46 , JSVal(..)
47+ , IsJSVal(..)
48+ , jsval
39 , SomeJSArray(..)
49 , SomeJSArray(..)
40 , JSArray
50 , JSArray
41 , MutableJSArray
51 , MutableJSArray
52+ , STJSArray
42 , Object(..)
53 , Object(..)
43 , JSString(..)
54 , JSString(..)
44 , Nullable(..)
55 , Nullable(..)
45 , JSCallAsFunction
56 , JSCallAsFunction
46
57
47− -- * JavaScript Context Commands
58+ -- * Debugging
59+ , JSadddleHasCallStack
60+
61+ -- * Sync JSM
62+ , syncPoint
63+ , syncAfter
64+
48#ifndef ghcjs_HOST_OS
65#ifndef ghcjs_HOST_OS
66+ , sendCommand
67+
68+ -- * JavaScript Context Commands
69+ , MutabilityType(..)
70+ , Mutable
71+ , Immutable
72+ , IsItMutable(..)
73+ , Mutability
49 , JSValueReceived(..)
74 , JSValueReceived(..)
50 , JSValueForSend(..)
75 , JSValueForSend(..)
51 , JSStringReceived(..)
76 , JSStringReceived(..)
@@ -55,6 +80,8 @@ module Language.Javascript.JSaddle.Types (
55 , Command(..)
80 , Command(..)
56 , Batch(..)
81 , Batch(..)
57 , Result(..)
82 , Result(..)
83+ , BatchResults(..)
84+ , Results(..)
58#endif
85#endif
59) where
86) where
60
87
@@ -62,26 +89,48 @@ import Control.Monad.IO.Class (MonadIO(..))
62#ifdef ghcjs_HOST_OS
89#ifdef ghcjs_HOST_OS
63import GHCJS.Types
90import GHCJS.Types
64import JavaScript.Object.Internal (Object(..))
91import JavaScript.Object.Internal (Object(..))
65−import JavaScript.Array.Internal (SomeJSArray(..), JSArray, MutableJSArray)
92+import JavaScript.Array.Internal (SomeJSArray(..), JSArray, MutableJSArray, STJSArray)
66import GHCJS.Nullable (Nullable(..))
93import GHCJS.Nullable (Nullable(..))
67#else
94#else
95+import GHCJS.Prim.Internal (JSVal(..), JSValueRef)
96+import Data.JSString.Internal.Type (JSString(..))
68import Control.DeepSeq (NFData(..))
97import 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(..))
69−import Control.Monad.Trans.Reader (ReaderT(..))
105+import Control.Monad.Trans.Reader (ReaderT(..), ask)
106+import Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))
70−import Control.Monad.Trans.State.Lazy (StateT(..))
107+import Control.Monad.Trans.RWS.Strict as Strict (RWST(..))
108+import Control.Monad.Trans.State.Lazy as Lazy (StateT(..))
71−import qualified Control.Monad.Trans.State.Strict as Strict
109+import Control.Monad.Trans.State.Strict as Strict (StateT(..))
72− (StateT(..))
110+import Control.Monad.Trans.Writer.Lazy as Lazy (WriterT(..))
111+import Control.Monad.Trans.Writer.Strict as Strict (WriterT(..))
73import Control.Monad.Trans.Class (MonadTrans(..))
112import Control.Monad.Trans.Class (MonadTrans(..))
74import Control.Monad.Fix (MonadFix)
113import Control.Monad.Fix (MonadFix)
75import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))
114import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))
76import Control.Concurrent.STM.TVar (TVar)
115import Control.Concurrent.STM.TVar (TVar)
77−import Data.Coerce (Coercible, coerce)
116+import Control.Concurrent.MVar (MVar)
78import Data.Int (Int64)
117import Data.Int (Int64)
118+import Data.Set (Set)
79import Data.Text (Text)
119import Data.Text (Text)
80import Data.Time.Clock (UTCTime(..))
120import Data.Time.Clock (UTCTime(..))
81import Data.Typeable (Typeable)
121import Data.Typeable (Typeable)
122+import Data.Coerce (coerce, Coercible)
82import Data.Aeson
123import Data.Aeson
83 (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..), Value)
124 (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..), Value)
84import GHC.Generics (Generic)
125import 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)
85#endif
134#endif
86
135
87-- | Identifies a JavaScript execution context.
136-- | Identifies a JavaScript execution context.
@@ -92,12 +141,16 @@ import GHC.Generics (Generic)
92type JSContextRef = ()
141type JSContextRef = ()
93#else
142#else
94data JSContextRef = JSContextRef {
143data JSContextRef = JSContextRef {
144+ contextId :: Int64
95− startTime :: UTCTime
145+ , startTime :: UTCTime
96− , doSendCommand :: Command -> IO Result
146+ , doSendCommand :: Command -> IO Result
97− , doSendAsyncCommand :: AsyncCommand -> IO ()
147+ , doSendAsyncCommand :: AsyncCommand -> IO ()
98− , addCallback :: Object -> JSCallAsFunction -> IO ()
148+ , addCallback :: Object -> JSCallAsFunction -> IO ()
99− , freeCallback :: Object -> IO ()
100− , nextRef :: TVar JSValueRef
149+ , nextRef :: TVar JSValueRef
150+ , doEnableLogging :: Bool -> IO ()
151+ , finalizerThreads :: MVar (Set Text)
152+ , animationFrameHandlers :: MVar [Double -> JSM ()]
153+ , liveRefs :: MVar (Set Int64)
101}
154}
102#endif
155#endif
103
156
@@ -113,9 +166,97 @@ data JSContextRef = JSContextRef {
113type JSM = IO
166type JSM = IO
114#else
167#else
115newtype JSM a = JSM { unJSM :: ReaderT JSContextRef IO a }
168newtype JSM a = JSM { unJSM :: ReaderT JSContextRef IO a }
116− deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
169+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadThrow, MonadUnliftIO, Fail.MonadFail)
170+
171+instance MonadCatch JSM where
172+ t `catch` c = JSM (unJSM (syncAfter t) `catch` \e -> unJSM (c e))
173+
174+instance MonadMask JSM where
175+ mask a = JSM $ mask $ \unmask -> unJSM (a $ q unmask)
176+ where q :: (ReaderT JSContextRef IO a -> ReaderT JSContextRef IO a) -> JSM a -> JSM a
177+ q unmask (JSM b) = syncAfter . JSM $ unmask b
178+ uninterruptibleMask a =
179+ JSM $ uninterruptibleMask $ \unmask -> unJSM (a $ q unmask)
180+ where q :: (ReaderT JSContextRef IO a -> ReaderT JSContextRef IO a) -> JSM a -> JSM a
181+ q unmask (JSM b) = syncAfter . JSM $ unmask b
182+#if MIN_VERSION_exceptions(0,9,0)
183+ generalBracket acquire release use =
184+ JSM $ generalBracket
185+ (unJSM acquire)
186+ (\resource exitCase -> unJSM $ release resource exitCase)
187+ (unJSM . syncAfter . use)
188+#endif
189+
190+#endif
191+
192+-- | Forces execution of pending asyncronous code
193+syncPoint :: JSM ()
194+#ifdef ghcjs_HOST_OS
195+syncPoint = return ()
196+#else
197+syncPoint = do
198+ SyncResult <- sendCommand Sync
199+ return ()
200+#endif
201+
202+-- | Forces execution of pending asyncronous code after performing `f`
203+syncAfter :: JSM a -> JSM a
204+#ifdef ghcjs_HOST_OS
205+syncAfter = id
206+#else
207+syncAfter f = do
208+ result <- f
209+ syncPoint
210+ return result
117#endif
211#endif
118
212
213+#ifndef ghcjs_HOST_OS
214+sendCommand :: Command -> JSM Result
215+sendCommand cmd = do
216+ s <- doSendCommand <$> JSM ask
217+ liftIO $ s cmd
218+#endif
219+
220+-- | Type we can give to functions that are pure when using ghcjs, but
221+-- live in JSM when using jsaddle.
222+--
223+-- Some functions that can be pure in GHCJS cannot be implemented in
224+-- a pure way in JSaddle (because we need to know the JSContextRef).
225+-- Instead we implement versions of these functions in that return
226+-- `GHCJSPure a` instead of `a`. To call them in a way that will
227+-- work when compiling with GHCJS use `ghcjsPure`.
228+#ifdef ghcjs_HOST_OS
229+type GHCJSPure a = a
230+#else
231+newtype GHCJSPure a = GHCJSPure (JSM a)
232+#endif
233+
234+-- | Used when you want to call a functions that is pure in GHCJS, but
235+-- lives in the JSM in jsaddle.
236+ghcjsPure :: GHCJSPure a -> JSM a
237+#ifdef ghcjs_HOST_OS
238+ghcjsPure = pure
239+#else
240+ghcjsPure (GHCJSPure x) = x
241+#endif
242+{-# INLINE ghcjsPure #-}
243+
244+ghcjsPureMap :: (a -> b) -> GHCJSPure a -> GHCJSPure b
245+#ifdef ghcjs_HOST_OS
246+ghcjsPureMap = id
247+#else
248+ghcjsPureMap f (GHCJSPure x) = GHCJSPure (f <$> x)
249+#endif
250+{-# INLINE ghcjsPureMap #-}
251+
252+ghcjsPureId :: a -> GHCJSPure a
253+#ifdef ghcjs_HOST_OS
254+ghcjsPureId = id
255+#else
256+ghcjsPureId = GHCJSPure . return
257+#endif
258+{-# INLINE ghcjsPureId #-}
259+
119-- | The 'MonadJSM' is to 'JSM' what 'MonadIO' is to 'IO'.
260-- | The 'MonadJSM' is to 'JSM' what 'MonadIO' is to 'IO'.
120-- When using GHCJS it is 'MonadIO'.
261-- When using GHCJS it is 'MonadIO'.
121#ifdef ghcjs_HOST_OS
262#ifdef ghcjs_HOST_OS
@@ -123,21 +264,64 @@ type MonadJSM = MonadIO
123#else
264#else
124class (Applicative m, MonadIO m) => MonadJSM m where
265class (Applicative m, MonadIO m) => MonadJSM m where
125 liftJSM' :: JSM a -> m a
266 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)
126− {-# MINIMAL liftJSM' #-}
270+ {-# INLINE liftJSM' #-}
127
271
128instance MonadJSM JSM where
272instance MonadJSM JSM where
129 liftJSM' = id
273 liftJSM' = id
130 {-# INLINE liftJSM' #-}
274 {-# INLINE liftJSM' #-}
131
275
132−instance MonadJSM m => MonadJSM (ReaderT e m) where
276+instance (MonadJSM m) => MonadJSM (ContT r m) where
277+ liftJSM' = lift . liftJSM'
278+ {-# INLINE liftJSM' #-}
279+
280+instance (Error e, MonadJSM m) => MonadJSM (ErrorT e m) where
281+ liftJSM' = lift . liftJSM'
282+ {-# INLINE liftJSM' #-}
283+
284+instance (MonadJSM m) => MonadJSM (ExceptT e m) where
285+ liftJSM' = lift . liftJSM'
286+ {-# INLINE liftJSM' #-}
287+
288+instance (MonadJSM m) => MonadJSM (IdentityT m) where
289+ liftJSM' = lift . liftJSM'
290+ {-# INLINE liftJSM' #-}
291+
292+instance (MonadJSM m) => MonadJSM (ListT m) where
293+ liftJSM' = lift . liftJSM'
294+ {-# INLINE liftJSM' #-}
295+
296+instance (MonadJSM m) => MonadJSM (MaybeT m) where
297+ liftJSM' = lift . liftJSM'
298+ {-# INLINE liftJSM' #-}
299+
300+instance (MonadJSM m) => MonadJSM (ReaderT r m) where
301+ liftJSM' = lift . liftJSM'
302+ {-# INLINE liftJSM' #-}
303+
304+instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.RWST r w s m) where
305+ liftJSM' = lift . liftJSM'
306+ {-# INLINE liftJSM' #-}
307+
308+instance (Monoid w, MonadJSM m) => MonadJSM (Strict.RWST r w s m) where
309+ liftJSM' = lift . liftJSM'
310+ {-# INLINE liftJSM' #-}
311+
312+instance (MonadJSM m) => MonadJSM (Lazy.StateT s m) where
133 liftJSM' = lift . liftJSM'
313 liftJSM' = lift . liftJSM'
134 {-# INLINE liftJSM' #-}
314 {-# INLINE liftJSM' #-}
135
315
136−instance MonadJSM m => MonadJSM (StateT r m) where
316+instance (MonadJSM m) => MonadJSM (Strict.StateT s m) where
137 liftJSM' = lift . liftJSM'
317 liftJSM' = lift . liftJSM'
138 {-# INLINE liftJSM' #-}
318 {-# INLINE liftJSM' #-}
139
319
320+instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.WriterT w m) where
321+ liftJSM' = lift . liftJSM'
322+ {-# INLINE liftJSM' #-}
323+
140−instance MonadJSM m => MonadJSM (Strict.StateT r m) where
324+instance (Monoid w, MonadJSM m) => MonadJSM (Strict.WriterT w m) where
141 liftJSM' = lift . liftJSM'
325 liftJSM' = lift . liftJSM'
142 {-# INLINE liftJSM' #-}
326 {-# INLINE liftJSM' #-}
143
327
@@ -172,23 +356,15 @@ type JSCallAsFunction = JSVal -- ^ Function object
172 -- as an argument and invoke it from haskell.
356 -- as an argument and invoke it from haskell.
173
357
174#ifndef ghcjs_HOST_OS
358#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` ()
183
359
184class IsJSVal a where
360class IsJSVal a where
185− jsval_ :: a -> JSVal
361+ jsval_ :: a -> GHCJSPure JSVal
186
362
187− default jsval_ :: Coercible a JSVal => a -> JSVal
363+ default jsval_ :: Coercible a JSVal => a -> GHCJSPure JSVal
188− jsval_ = coerce
364+ jsval_ = GHCJSPure . return . coerce
189 {-# INLINE jsval_ #-}
365 {-# INLINE jsval_ #-}
190
366
191−jsval :: IsJSVal a => a -> JSVal
367+jsval :: IsJSVal a => a -> GHCJSPure JSVal
192jsval = jsval_
368jsval = jsval_
193{-# INLINE jsval #-}
369{-# INLINE jsval #-}
194
370
@@ -209,38 +385,43 @@ type family Mutability (a :: MutabilityType s) :: IsItMutable where
209
385
210newtype SomeJSArray (m :: MutabilityType s) = SomeJSArray JSVal
386newtype SomeJSArray (m :: MutabilityType s) = SomeJSArray JSVal
211 deriving (Typeable)
387 deriving (Typeable)
388+instance IsJSVal (SomeJSArray m)
212
389
213-- | See 'JavaScript.Array.Internal.JSArray'
390-- | See 'JavaScript.Array.Internal.JSArray'
214type JSArray = SomeJSArray Immutable
391type JSArray = SomeJSArray Immutable
215-- | See 'JavaScript.Array.Internal.MutableJSArray'
392-- | See 'JavaScript.Array.Internal.MutableJSArray'
216type MutableJSArray = SomeJSArray Mutable
393type MutableJSArray = SomeJSArray Mutable
217
394
395+-- | See 'JavaScript.Array.Internal.STJSArray'
396+type STJSArray s = SomeJSArray (STMutable s)
397+
218-- | See 'JavaScript.Object.Internal.Object'
398-- | See 'JavaScript.Object.Internal.Object'
219−newtype Object = Object JSVal deriving(Show, ToJSON, FromJSON)
399+newtype Object = Object JSVal
220
400
221-- | See 'GHCJS.Nullable.Nullable'
401-- | See 'GHCJS.Nullable.Nullable'
222newtype Nullable a = Nullable a
402newtype Nullable a = Nullable a
223
403
224−-- | See 'Data.JSString.Internal.Type'
225−newtype JSString = JSString Text deriving(Show, ToJSON, FromJSON)
226−
227-- | Wrapper used when receiving a 'JSVal' from the JavaScript context
404-- | Wrapper used when receiving a 'JSVal' from the JavaScript context
228newtype JSValueReceived = JSValueReceived JSValueRef deriving(Show, ToJSON, FromJSON)
405newtype JSValueReceived = JSValueReceived JSValueRef deriving(Show, ToJSON, FromJSON)
229
406
230-- | Wrapper used when sending a 'JSVal' to the JavaScript context
407-- | Wrapper used when sending a 'JSVal' to the JavaScript context
231−newtype JSValueForSend = JSValueForSend JSValueRef deriving(Show, ToJSON, FromJSON)
408+newtype JSValueForSend = JSValueForSend JSValueRef deriving(Show, ToJSON, FromJSON, Generic)
409+instance NFData JSValueForSend
232
410
233-- | Wrapper used when sending a 'Object' to the JavaScript context
411-- | Wrapper used when sending a 'Object' to the JavaScript context
234−newtype JSObjectForSend = JSObjectForSend JSValueForSend deriving(Show, ToJSON, FromJSON)
412+newtype JSObjectForSend = JSObjectForSend JSValueForSend deriving(Show, ToJSON, FromJSON, Generic)
413+instance NFData JSObjectForSend
235
414
236-- | Wrapper used when receiving a 'JSString' from the JavaScript context
415-- | Wrapper used when receiving a 'JSString' from the JavaScript context
237newtype JSStringReceived = JSStringReceived Text deriving(Show, ToJSON, FromJSON)
416newtype JSStringReceived = JSStringReceived Text deriving(Show, ToJSON, FromJSON)
238
417
239-- | Wrapper used when sending a 'JString' to the JavaScript context
418-- | Wrapper used when sending a 'JString' to the JavaScript context
240−newtype JSStringForSend = JSStringForSend Text deriving(Show, ToJSON, FromJSON)
419+newtype JSStringForSend = JSStringForSend Text deriving(Show, ToJSON, FromJSON, Generic)
420+instance NFData JSStringForSend
241
421
242-- | Command sent to a JavaScript context for execution asynchronously
422-- | Command sent to a JavaScript context for execution asynchronously
243−data AsyncCommand = FreeRef JSValueForSend
423+data AsyncCommand = FreeRef Text JSValueForSend
424+ | FreeRefs Text
244 | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend
425 | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend
245 | SetPropertyAtIndex JSObjectForSend Int JSValueForSend
426 | SetPropertyAtIndex JSObjectForSend Int JSValueForSend
246 | StringToValue JSStringForSend JSValueForSend
427 | StringToValue JSStringForSend JSValueForSend
@@ -251,17 +432,23 @@ data AsyncCommand = FreeRef JSValueForSend
251 | CallAsFunction JSObjectForSend JSObjectForSend [JSValueForSend] JSValueForSend
432 | CallAsFunction JSObjectForSend JSObjectForSend [JSValueForSend] JSValueForSend
252 | CallAsConstructor JSObjectForSend [JSValueForSend] JSValueForSend
433 | CallAsConstructor JSObjectForSend [JSValueForSend] JSValueForSend
253 | NewEmptyObject JSValueForSend
434 | NewEmptyObject JSValueForSend
435+ | NewAsyncCallback JSValueForSend
436+ | NewSyncCallback JSValueForSend
254− | NewCallback JSValueForSend
437+ | FreeCallback JSValueForSend
255 | NewArray [JSValueForSend] JSValueForSend
438 | NewArray [JSValueForSend] JSValueForSend
256 | EvaluateScript JSStringForSend JSValueForSend
439 | EvaluateScript JSStringForSend JSValueForSend
257 | SyncWithAnimationFrame JSValueForSend
440 | SyncWithAnimationFrame JSValueForSend
441+ | StartSyncBlock
442+ | EndSyncBlock
258− deriving (Show, Generic)
443+ deriving (Show, Generic)
259
444
260instance ToJSON AsyncCommand where
445instance ToJSON AsyncCommand where
261 toEncoding = genericToEncoding defaultOptions
446 toEncoding = genericToEncoding defaultOptions
262
447
263instance FromJSON AsyncCommand
448instance FromJSON AsyncCommand
264
449
450+instance NFData AsyncCommand
451+
265-- | Command sent to a JavaScript context for execution synchronously
452-- | Command sent to a JavaScript context for execution synchronously
266data Command = DeRefVal JSValueForSend
453data Command = DeRefVal JSValueForSend
267 | ValueToBool JSValueForSend
454 | ValueToBool JSValueForSend
@@ -282,8 +469,10 @@ instance ToJSON Command where
282
469
283instance FromJSON Command
470instance FromJSON Command
284
471
472+instance NFData Command
473+
285-- | Batch of commands that can be sent together to the JavaScript context
474-- | Batch of commands that can be sent together to the JavaScript context
286−data Batch = Batch [AsyncCommand] Command Bool
475+data Batch = Batch [Either AsyncCommand Command] Bool Int
287 deriving (Show, Generic)
476 deriving (Show, Generic)
288
477
289instance ToJSON Batch where
478instance ToJSON Batch where
@@ -291,6 +480,8 @@ instance ToJSON Batch where
291
480
292instance FromJSON Batch
481instance FromJSON Batch
293
482
483+instance NFData Batch
484+
294-- | Result of a 'Command' returned from the JavaScript context
485-- | Result of a 'Command' returned from the JavaScript context
295data Result = DeRefValResult JSValueRef Text
486data Result = DeRefValResult JSValueRef Text
296 | ValueToBoolResult Bool
487 | ValueToBoolResult Bool
@@ -302,18 +493,42 @@ data Result = DeRefValResult JSValueRef Text
302 | IsUndefinedResult Bool
493 | IsUndefinedResult Bool
303 | StrictEqualResult Bool
494 | StrictEqualResult Bool
304 | InstanceOfResult Bool
495 | InstanceOfResult Bool
305− | Callback JSValueReceived JSValueReceived [JSValueReceived]
306 | PropertyNamesResult [JSStringReceived]
496 | PropertyNamesResult [JSStringReceived]
307 | ThrowJSValue JSValueReceived
497 | ThrowJSValue JSValueReceived
308− | ProtocolError Text
309 | SyncResult
498 | SyncResult
310− deriving (Show, Generic)
499+ deriving (Show, Generic)
311
500
312instance ToJSON Result where
501instance ToJSON Result where
313 toEncoding = genericToEncoding defaultOptions
502 toEncoding = genericToEncoding defaultOptions
314
503
315instance FromJSON Result
504instance 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
316#endif
525#endif
317
526
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
318
533
319
534
jsaddle/src/Language/Javascript/JSaddle/Value.hs+57−87
@@ -45,7 +45,7 @@ module Language.Javascript.JSaddle.Value (
45 , showJSValue
45 , showJSValue
46
46
47 -- * Converting JavaScript values
47 -- * Converting JavaScript values
48− , isTruthyIO
48+ , isTruthy
49 , valToBool
49 , valToBool
50 , valToNumber
50 , valToNumber
51 , valToStr
51 , valToStr
@@ -57,11 +57,11 @@ module Language.Javascript.JSaddle.Value (
57 , val
57 , val
58 , jsNull
58 , jsNull
59 , valNull
59 , valNull
60− , isNullIO
60+ , isNull
61 , valIsNull
61 , valIsNull
62 , jsUndefined
62 , jsUndefined
63 , valUndefined
63 , valUndefined
64− , isUndefinedIO
64+ , isUndefined
65 , valIsUndefined
65 , valIsUndefined
66 , maybeNullOrUndefined
66 , maybeNullOrUndefined
67 , maybeNullOrUndefined'
67 , maybeNullOrUndefined'
@@ -84,32 +84,31 @@ module Language.Javascript.JSaddle.Value (
84import Data.Text (Text)
84import Data.Text (Text)
85import qualified Data.Text as T (pack, unpack)
85import qualified Data.Text as T (pack, unpack)
86import Data.Aeson (Value)
86import Data.Aeson (Value)
87+import Data.JSString.Text (textToJSString)
87
88
88#ifdef ghcjs_HOST_OS
89#ifdef ghcjs_HOST_OS
89import Language.Javascript.JSaddle.Types
90import Language.Javascript.JSaddle.Types
90− (Object(..), JSString(..), JSVal(..))
91+ (Object(..), JSString(..), JSVal(..), ghcjsPure)
91import GHCJS.Marshal (ToJSVal(..))
92import GHCJS.Marshal (ToJSVal(..))
92−import GHCJS.Marshal.Pure (pToJSVal)
93−import Data.JSString.Text (textToJSString)
94#else
93#else
95import Data.Char (chr, ord)
94import Data.Char (chr, ord)
96import Data.Word (Word, Word8, Word16, Word32)
95import Data.Word (Word, Word8, Word16, Word32)
97import Data.Int (Int8, Int16, Int32)
96import Data.Int (Int8, Int16, Int32)
98import GHCJS.Marshal.Internal (ToJSVal(..), FromJSVal(..))
97import GHCJS.Marshal.Internal (ToJSVal(..), FromJSVal(..))
99import Language.Javascript.JSaddle.Types
98import Language.Javascript.JSaddle.Types
100− (Object(..), JSString(..), JSVal(..), JSValueForSend(..))
99+ (Object(..), JSString(..), JSVal(..), ghcjsPure)
101import Language.Javascript.JSaddle.Native
100import Language.Javascript.JSaddle.Native
102− (wrapJSString, withJSVal, withObject, withJSString, withToJSVal)
101+ (valueToNumber, valueToString, valueToJSON, numberToValue, stringToValue, jsonValueToValue)
102+import qualified Language.Javascript.JSaddle.Native as N
103+ (deRefVal, strictEqual, instanceOf)
103−import Language.Javascript.JSaddle.Run
104+import Language.Javascript.JSaddle.Run (Result(..))
104− (Command(..), AsyncCommand(..), Result(..), sendCommand,
105− sendLazyCommand)
106#endif
105#endif
107import Language.Javascript.JSaddle.Monad (JSM)
106import Language.Javascript.JSaddle.Monad (JSM)
108import Language.Javascript.JSaddle.Classes
107import Language.Javascript.JSaddle.Classes
109 (MakeObject(..), MakeArgs(..))
108 (MakeObject(..), MakeArgs(..))
110import Language.Javascript.JSaddle.Marshal.String (ToJSString(..), FromJSString(..))
109import Language.Javascript.JSaddle.Marshal.String (ToJSString(..), FromJSString(..))
111import Language.Javascript.JSaddle.String (strToText, textToStr)
110import Language.Javascript.JSaddle.String (strToText, textToStr)
112−import Language.Javascript.JSaddle.Foreign (jsTrue, jsFalse, jsNull, toJSBool, jsUndefined, isTruthyIO, isNullIO, isUndefinedIO)
111+import GHCJS.Foreign.Internal (jsTrue, jsFalse, jsNull, toJSBool, jsUndefined, isTruthy, isNull, isUndefined)
113
112
114-- $setup
113-- $setup
115-- >>> import Language.Javascript.JSaddle.Test (testJSaddle)
114-- >>> import Language.Javascript.JSaddle.Test (testJSaddle)
@@ -166,7 +165,7 @@ showJSValue (ValObject _) = "object"
166-- >>> testJSaddle $ valToBool "1"
165-- >>> testJSaddle $ valToBool "1"
167-- true
166-- true
168valToBool :: ToJSVal value => value -> JSM Bool
167valToBool :: ToJSVal value => value -> JSM Bool
169−valToBool value = toJSVal value >>= isTruthyIO
168+valToBool value = toJSVal value >>= ghcjsPure . isTruthy
170
169
171-- | Given a JavaScript value get its numeric value.
170-- | Given a JavaScript value get its numeric value.
172-- May throw JSException.
171-- May throw JSException.
@@ -192,10 +191,7 @@ valToNumber :: ToJSVal value => value -> JSM Double
192valToNumber value = jsrefToNumber <$> toJSVal value
191valToNumber value = jsrefToNumber <$> toJSVal value
193foreign import javascript unsafe "$r = Number($1);" jsrefToNumber :: JSVal -> Double
192foreign import javascript unsafe "$r = Number($1);" jsrefToNumber :: JSVal -> Double
194#else
193#else
195−valToNumber value =
194+valToNumber value = toJSVal value >>= valueToNumber
196− withToJSVal value $ \rval -> do
197− ValueToNumberResult result <- sendCommand (ValueToNumber rval)
198− return result
199#endif
195#endif
200
196
201-- | Given a JavaScript value get its string value (as a JavaScript string).
197-- | Given a JavaScript value get its string value (as a JavaScript string).
@@ -222,10 +218,7 @@ valToStr :: ToJSVal value => value -> JSM JSString
222valToStr value = jsrefToString <$> toJSVal value
218valToStr value = jsrefToString <$> toJSVal value
223foreign import javascript unsafe "$r = $1.toString();" jsrefToString :: JSVal -> JSString
219foreign import javascript unsafe "$r = $1.toString();" jsrefToString :: JSVal -> JSString
224#else
220#else
225−valToStr value =
221+valToStr value = toJSVal value >>= valueToString
226− withToJSVal value $ \rval -> do
227− ValueToStringResult result <- sendCommand (ValueToString rval)
228− wrapJSString result
229#endif
222#endif
230
223
231-- | Given a JavaScript value get its string value (as a Haskell 'Text').
224-- | Given a JavaScript value get its string value (as a Haskell 'Text').
@@ -276,10 +269,7 @@ valToJSON :: ToJSVal value => value -> JSM JSString
276valToJSON value = jsrefToJSON <$> toJSVal value
269valToJSON value = jsrefToJSON <$> toJSVal value
277foreign import javascript unsafe "$r = $1 === undefined ? \"\" : JSON.stringify($1);" jsrefToJSON :: JSVal -> JSString
270foreign import javascript unsafe "$r = $1 === undefined ? \"\" : JSON.stringify($1);" jsrefToJSON :: JSVal -> JSString
278#else
271#else
279−valToJSON value =
272+valToJSON value = toJSVal value >>= valueToJSON
280− withToJSVal value $ \rval -> do
281− ValueToJSONResult result <- sendCommand (ValueToJSON rval)
282− wrapJSString result
283#endif
273#endif
284
274
285-- | Given a JavaScript value get its object value.
275-- | Given a JavaScript value get its object value.
@@ -305,7 +295,7 @@ valToObject :: ToJSVal value => value -> JSM Object
305valToObject value = Object <$> toJSVal value
295valToObject value = Object <$> toJSVal value
306
296
307instance MakeObject JSVal where
297instance MakeObject JSVal where
308− makeObject = valToObject
298+ makeObject = return . Object
309
299
310instance ToJSVal Object where
300instance ToJSVal Object where
311 toJSVal (Object r) = return r
301 toJSVal (Object r) = return r
@@ -356,16 +346,16 @@ instance ToJSVal a => ToJSVal (Maybe a) where
356 {-# INLINE toJSVal #-}
346 {-# INLINE toJSVal #-}
357instance FromJSVal a => FromJSVal (Maybe a) where
347instance FromJSVal a => FromJSVal (Maybe a) where
358 fromJSValUnchecked x =
348 fromJSValUnchecked x =
359− isUndefinedIO x >>= \case
349+ ghcjsPure (isUndefined x) >>= \case
360 True -> return Nothing
350 True -> return Nothing
361− False -> isNullIO x >>= \case
351+ False -> ghcjsPure (isNull x) >>= \case
362 True -> return Nothing
352 True -> return Nothing
363 False -> fromJSVal x
353 False -> fromJSVal x
364 {-# INLINE fromJSValUnchecked #-}
354 {-# INLINE fromJSValUnchecked #-}
365 fromJSVal x =
355 fromJSVal x =
366− isUndefinedIO x >>= \case
356+ ghcjsPure (isUndefined x) >>= \case
367 True -> return (Just Nothing)
357 True -> return (Just Nothing)
368− False -> isNullIO x >>= \case
358+ False -> ghcjsPure (isNull x) >>= \case
369 True -> return (Just Nothing)
359 True -> return (Just Nothing)
370 False -> fmap (fmap Just) fromJSVal x
360 False -> fmap (fmap Just) fromJSVal x
371 {-# INLINE fromJSVal #-}
361 {-# INLINE fromJSVal #-}
@@ -382,7 +372,7 @@ instance FromJSVal a => FromJSVal [a] where
382
372
383-- | Test a JavaScript value to see if it is @null@
373-- | Test a JavaScript value to see if it is @null@
384valIsNull :: ToJSVal value => value -> JSM Bool
374valIsNull :: ToJSVal value => value -> JSM Bool
385−valIsNull value = toJSVal value >>= isNullIO
375+valIsNull value = toJSVal value >>= ghcjsPure . isNull
386
376
387----------- undefined ---------------
377----------- undefined ---------------
388-- | An @undefined@ JavaScript value
378-- | An @undefined@ JavaScript value
@@ -405,26 +395,26 @@ instance MakeArgs () where
405
395
406-- | Test a JavaScript value to see if it is @undefined@
396-- | Test a JavaScript value to see if it is @undefined@
407valIsUndefined :: ToJSVal value => value -> JSM Bool
397valIsUndefined :: ToJSVal value => value -> JSM Bool
408−valIsUndefined value = toJSVal value >>= isUndefinedIO
398+valIsUndefined value = toJSVal value >>= ghcjsPure . isUndefined
409
399
410-- | Convert a JSVal to a Maybe JSVal (converting null and undefined to Nothing)
400-- | Convert a JSVal to a Maybe JSVal (converting null and undefined to Nothing)
411maybeNullOrUndefined :: ToJSVal value => value -> JSM (Maybe JSVal)
401maybeNullOrUndefined :: ToJSVal value => value -> JSM (Maybe JSVal)
412maybeNullOrUndefined value = do
402maybeNullOrUndefined value = do
413 rval <- toJSVal value
403 rval <- toJSVal value
414− valIsNull rval >>= \case
404+ ghcjsPure (isNull rval) >>= \case
415 True -> return Nothing
405 True -> return Nothing
416 _ ->
406 _ ->
417− valIsUndefined rval >>= \case
407+ ghcjsPure (isUndefined rval) >>= \case
418 True -> return Nothing
408 True -> return Nothing
419 _ -> return (Just rval)
409 _ -> return (Just rval)
420
410
421maybeNullOrUndefined' :: ToJSVal value => (JSVal -> JSM a) -> value -> JSM (Maybe a)
411maybeNullOrUndefined' :: ToJSVal value => (JSVal -> JSM a) -> value -> JSM (Maybe a)
422maybeNullOrUndefined' f value = do
412maybeNullOrUndefined' f value = do
423 rval <- toJSVal value
413 rval <- toJSVal value
424− valIsNull rval >>= \case
414+ ghcjsPure (isNull rval) >>= \case
425 True -> return Nothing
415 True -> return Nothing
426 _ ->
416 _ ->
427− valIsUndefined rval >>= \case
417+ ghcjsPure (isUndefined rval) >>= \case
428 True -> return Nothing
418 True -> return Nothing
429 _ -> Just <$> f rval
419 _ -> Just <$> f rval
430
420
@@ -448,52 +438,49 @@ instance MakeArgs Bool where
448----------- numbers ---------------
438----------- numbers ---------------
449-- | Make a JavaScript number
439-- | Make a JavaScript number
450valMakeNumber :: Double -> JSM JSVal
440valMakeNumber :: Double -> JSM JSVal
451−#ifdef ghcjs_HOST_OS
452−valMakeNumber n = toJSVal n
441+valMakeNumber = toJSVal
453−#else
442+{-# INLINE valMakeNumber #-}
454−valMakeNumber = sendLazyCommand . NumberToValue
455−#endif
456
443
457#ifndef ghcjs_HOST_OS
444#ifndef ghcjs_HOST_OS
458-- | Makes a JavaScript number
445-- | Makes a JavaScript number
459instance ToJSVal Double where
446instance ToJSVal Double where
460− toJSVal = valMakeNumber
447+ toJSVal = numberToValue
461 {-# INLINE toJSVal #-}
448 {-# INLINE toJSVal #-}
462
449
463instance ToJSVal Float where
450instance ToJSVal Float where
464− toJSVal = valMakeNumber . realToFrac
451+ toJSVal = numberToValue . realToFrac
465 {-# INLINE toJSVal #-}
452 {-# INLINE toJSVal #-}
466
453
467instance ToJSVal Word where
454instance ToJSVal Word where
468− toJSVal = valMakeNumber . fromIntegral
455+ toJSVal = numberToValue . fromIntegral
469 {-# INLINE toJSVal #-}
456 {-# INLINE toJSVal #-}
470
457
471instance ToJSVal Word8 where
458instance ToJSVal Word8 where
472− toJSVal = valMakeNumber . fromIntegral
459+ toJSVal = numberToValue . fromIntegral
473 {-# INLINE toJSVal #-}
460 {-# INLINE toJSVal #-}
474
461
475instance ToJSVal Word16 where
462instance ToJSVal Word16 where
476− toJSVal = valMakeNumber . fromIntegral
463+ toJSVal = numberToValue . fromIntegral
477 {-# INLINE toJSVal #-}
464 {-# INLINE toJSVal #-}
478
465
479instance ToJSVal Word32 where
466instance ToJSVal Word32 where
480− toJSVal = valMakeNumber . fromIntegral
467+ toJSVal = numberToValue . fromIntegral
481 {-# INLINE toJSVal #-}
468 {-# INLINE toJSVal #-}
482
469
483instance ToJSVal Int where
470instance ToJSVal Int where
484− toJSVal = valMakeNumber . fromIntegral
471+ toJSVal = numberToValue . fromIntegral
485 {-# INLINE toJSVal #-}
472 {-# INLINE toJSVal #-}
486
473
487instance ToJSVal Int8 where
474instance ToJSVal Int8 where
488− toJSVal = valMakeNumber . fromIntegral
475+ toJSVal = numberToValue . fromIntegral
489 {-# INLINE toJSVal #-}
476 {-# INLINE toJSVal #-}
490
477
491instance ToJSVal Int16 where
478instance ToJSVal Int16 where
492− toJSVal = valMakeNumber . fromIntegral
479+ toJSVal = numberToValue . fromIntegral
493 {-# INLINE toJSVal #-}
480 {-# INLINE toJSVal #-}
494
481
495instance ToJSVal Int32 where
482instance ToJSVal Int32 where
496− toJSVal = valMakeNumber . fromIntegral
483+ toJSVal = numberToValue . fromIntegral
497 {-# INLINE toJSVal #-}
484 {-# INLINE toJSVal #-}
498#endif
485#endif
499
486
@@ -503,25 +490,18 @@ instance MakeArgs Double where
503
490
504-- | Make a JavaScript string from `Text`
491-- | Make a JavaScript string from `Text`
505valMakeText :: Text -> JSM JSVal
492valMakeText :: Text -> JSM JSVal
506−#ifdef ghcjs_HOST_OS
507−valMakeText = return . pToJSVal . textToJSString
493+valMakeText = toJSVal . textToJSString
508−#else
494+{-# INLINE valMakeText #-}
509−valMakeText text = valMakeString (textToStr text)
510−#endif
511
495
512-- | Make a JavaScript string from `JSString`
496-- | Make a JavaScript string from `JSString`
513valMakeString :: JSString -> JSM JSVal
497valMakeString :: JSString -> JSM JSVal
514−#ifdef ghcjs_HOST_OS
515−valMakeString = return . pToJSVal
498+valMakeString = toJSVal
516−#else
499+{-# INLINE valMakeString #-}
517−valMakeString s =
518− withJSString s $ sendLazyCommand . StringToValue
519−#endif
520
500
521#ifndef ghcjs_HOST_OS
501#ifndef ghcjs_HOST_OS
522-- | Makes a JavaScript string
502-- | Makes a JavaScript string
523instance ToJSVal Text where
503instance ToJSVal Text where
524− toJSVal = valMakeText
504+ toJSVal = stringToValue . JSString
525 {-# INLINE toJSVal #-}
505 {-# INLINE toJSVal #-}
526instance FromJSVal Text where
506instance FromJSVal Text where
527 fromJSValUnchecked = valToText
507 fromJSValUnchecked = valToText
@@ -537,7 +517,7 @@ instance MakeArgs Text where
537#ifndef ghcjs_HOST_OS
517#ifndef ghcjs_HOST_OS
538-- | Makes a JavaScript string
518-- | Makes a JavaScript string
539instance ToJSVal JSString where
519instance ToJSVal JSString where
540− toJSVal = valMakeString
520+ toJSVal = stringToValue
541 {-# INLINE toJSVal #-}
521 {-# INLINE toJSVal #-}
542instance FromJSVal JSString where
522instance FromJSVal JSString where
543 fromJSValUnchecked = valToStr
523 fromJSValUnchecked = valToStr
@@ -584,16 +564,12 @@ instance FromJSVal Char where
584
564
585-- | Make a JavaScript string from AESON `Value`
565-- | Make a JavaScript string from AESON `Value`
586valMakeJSON :: Value -> JSM JSVal
566valMakeJSON :: Value -> JSM JSVal
587−#ifdef ghcjs_HOST_OS
588valMakeJSON = toJSVal
567valMakeJSON = toJSVal
589−#else
590−valMakeJSON = sendLazyCommand . JSONValueToValue
591−#endif
592
568
593#ifndef ghcjs_HOST_OS
569#ifndef ghcjs_HOST_OS
594-- | Makes a JSON value
570-- | Makes a JSON value
595instance ToJSVal Value where
571instance ToJSVal Value where
596− toJSVal = valMakeJSON
572+ toJSVal = jsonValueToValue
597 {-# INLINE toJSVal #-}
573 {-# INLINE toJSVal #-}
598#endif
574#endif
599
575
@@ -644,16 +620,16 @@ foreign import javascript unsafe "$r = ($1 === undefined)?0:\
644#else
620#else
645deRefVal value = do
621deRefVal value = do
646 v <- toJSVal value
622 v <- toJSVal value
647− withJSVal v $ \rval ->
623+ result <- N.deRefVal v
648− sendCommand (DeRefVal rval) >>= \case
624+ return $ case result of
649− DeRefValResult 0 _ -> return ValNull
625+ DeRefValResult 0 _ -> ValNull
650− DeRefValResult 1 _ -> return ValUndefined
626+ DeRefValResult 1 _ -> ValUndefined
651− DeRefValResult 2 _ -> return $ ValBool False
627+ DeRefValResult 2 _ -> ValBool False
652− DeRefValResult 3 _ -> return $ ValBool True
628+ DeRefValResult 3 _ -> ValBool True
653− DeRefValResult (-1) s -> return $ ValNumber (read (T.unpack s))
629+ DeRefValResult (-1) s -> ValNumber (read (T.unpack s))
654− DeRefValResult (-2) s -> return $ ValString s
630+ DeRefValResult (-2) s -> ValString s
655− DeRefValResult ref _ -> return $ ValObject (Object (JSVal ref))
631+ DeRefValResult (-3) _ -> ValObject (Object v)
656− _ -> error "Unexpected result dereferencing JSaddle value"
632+ _ -> error "Unexpected result dereferencing JSaddle value"
657#endif
633#endif
658
634
659-- | Make a JavaScript value out of a 'JSValue' ADT.
635-- | Make a JavaScript value out of a 'JSValue' ADT.
@@ -712,10 +688,7 @@ strictEqual a b = do
712#ifdef ghcjs_HOST_OS
688#ifdef ghcjs_HOST_OS
713 return $ jsvalueisstrictequal aval bval
689 return $ jsvalueisstrictequal aval bval
714#else
690#else
715− withJSVal aval $ \aref ->
691+ N.strictEqual aval bval
716− withJSVal bval $ \bref -> do
717− StrictEqualResult result <- sendCommand $ StrictEqual aref bref
718− return result
719#endif
692#endif
720
693
721#ifdef ghcjs_HOST_OS
694#ifdef ghcjs_HOST_OS
@@ -733,10 +706,7 @@ instanceOf value constructor = do
733#ifdef ghcjs_HOST_OS
706#ifdef ghcjs_HOST_OS
734 return $ js_isInstanceOf v c
707 return $ js_isInstanceOf v c
735#else
708#else
736− withJSVal v $ \rval ->
709+ N.instanceOf v c
737− withObject c $ \c' -> do
738− InstanceOfResult result <- sendCommand $ InstanceOf rval c'
739− return result
740#endif
710#endif
741
711
742
712
nix/hix.nixnew file+8
@@ -0,0 +1,8 @@
1+{pkgs, ...}:
2+{ modules = [({pkgs, ...}: {
3+ packages.webkit2gtk3-javascriptcore.components.library.doHaddock = false;
4+ })];
5+ shell.buildInputs = [ pkgs.nodejs ];
6+ shell.tools.cabal = {};
7+ shell.crossPlatforms = p: [ p.ghcjs ];
8+}
travis/build.sh+2−13
@@ -6,19 +6,8 @@ GHCVER=`ghc --numeric-version`
6
6
7JSADDLE_WARP_VERSION=`head -n2 jsaddle-warp/jsaddle-warp.cabal | tail -n1 | sed 's/[^0-9.]//g'`
7JSADDLE_WARP_VERSION=`head -n2 jsaddle-warp/jsaddle-warp.cabal | tail -n1 | sed 's/[^0-9.]//g'`
8
8
9−if [[ -d .cabal && -d .ghc ]]; then
10− cp -a .cabal .ghc /root
11−fi
12−
13−npm install ws
14−
15cabal update
9cabal update
16cabal new-build 'jsaddle-warp:lib:jsaddle-warp' 'jsaddle-warp:test:test-tool'
10cabal new-build 'jsaddle-warp:lib:jsaddle-warp' 'jsaddle-warp:test:test-tool'
11+cd jsaddle-warp
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 .
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
18−
19−# update the cache
20−rm -rf .cabal
21−cp -a /root/.cabal ./
22−rm -rf .ghc
23−cp -a /root/.ghc ./
24
13
travis/trusty.Dockerfile+1−1
@@ -4,7 +4,7 @@ RUN apt-get update && \
4 apt-get -y install software-properties-common && \
4 apt-get -y install software-properties-common && \
5 add-apt-repository -y ppa:hvr/ghc && \
5 add-apt-repository -y ppa:hvr/ghc && \
6 apt-get update && \
6 apt-get update && \
7− apt-get -y install happy-1.19.5 alex-3.1.7 nodejs npm
7+ apt-get -y install happy-1.19.5 alex-3.1.7 phantomjs
8
8
9RUN mkdir /build
9RUN mkdir /build
10WORKDIR /build
10WORKDIR /build
travis/vivid.Dockerfile+1−1
@@ -4,7 +4,7 @@ RUN apt-get update && \
4 apt-get -y install software-properties-common && \
4 apt-get -y install software-properties-common && \
5 add-apt-repository -y ppa:hvr/ghc && \
5 add-apt-repository -y ppa:hvr/ghc && \
6 apt-get update && \
6 apt-get update && \
7− apt-get -y install happy-1.19.5 alex-3.1.7 nodejs npm
7+ apt-get -y install happy-1.19.5 alex-3.1.7 phantomjs
8
8
9RUN mkdir /build
9RUN mkdir /build
10WORKDIR /build
10WORKDIR /build
travis/wily.Dockerfile+1−1
@@ -4,7 +4,7 @@ RUN apt-get update && \
4 apt-get -y install software-properties-common && \
4 apt-get -y install software-properties-common && \
5 add-apt-repository -y ppa:hvr/ghc && \
5 add-apt-repository -y ppa:hvr/ghc && \
6 apt-get update && \
6 apt-get update && \
7− apt-get -y install happy-1.19.5 alex-3.1.7 nodejs npm
7+ apt-get -y install happy-1.19.5 alex-3.1.7 phantomjs
8
8
9RUN mkdir /build
9RUN mkdir /build
10WORKDIR /build
10WORKDIR /build
travis/xenial.Dockerfile+1−1
@@ -4,7 +4,7 @@ RUN apt-get update && \
4 apt-get -y install software-properties-common && \
4 apt-get -y install software-properties-common && \
5 add-apt-repository -y ppa:hvr/ghc && \
5 add-apt-repository -y ppa:hvr/ghc && \
6 apt-get update && \
6 apt-get update && \
7− apt-get -y install happy-1.19.5 alex-3.1.7 nodejs npm
7+ apt-get -y install happy-1.19.5 alex-3.1.7 phantomjs
8
8
9RUN mkdir /build
9RUN mkdir /build
10WORKDIR /build
10WORKDIR /build