on e10bb6e help sign in
.travis.yml+22−40
since splitsnapshots
unifiedsplit
@@ -1,47 +1,29 @@
1−language: nix
1+sudo: required
2−nix: 2.2.2
2+services:
3+ - docker
3
4
4−jobs:
5+cache:
5− include:
6+ directories:
6− - stage: Build
7+ - .cabal
7− env: OS=linux GHCVER=ghc865
8+ - .ghc
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
24
9
25−install:
10+env:
26−- sudo mkdir -p /etc/nix
11+# - CABALVER=1.24 GHCVER=7.10.3 OSVER=xenial
27−- echo "substituters = https://cache.nixos.org https://hydra.iohk.io" | sudo tee -a /etc/nix/nix.conf > /dev/null
12+ - CABALVER=1.24 GHCVER=8.0.1 OSVER=xenial
28−- echo "trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=" | sudo tee -a /etc/nix/nix.conf > /dev/null
13+ - CABALVER=1.24 GHCVER=7.10.3 OSVER=trusty
14+ - CABALVER=1.24 GHCVER=8.0.1 OSVER=trusty
29
15
30−script:
16+before_install:
31−- nix-build --argstr haskellCompiler $GHCVER -A hsPkgs.jsaddle.components.library
17+ - docker build -t ghc -f travis/$OSVER.Dockerfile travis
32−- nix-build --argstr haskellCompiler $GHCVER -A hsPkgs.jsaddle-warp.components.library
33−- nix-build --argstr haskellCompiler $GHCVER -A hsPkgs.jsaddle-clib.components.library
34−- |
35− if [ "$OS" == "macos" ]; then
36− nix-build --argstr haskellCompiler $GHCVER -A hsPkgs.jsaddle-wkwebview.components.library
37− fi
38−# TODO try to find how to get working webkitgtk with nix on macOS
39−- |
40− if [ "$OS" != "macos" ]; then
41− nix-build --argstr haskellCompiler $GHCVER -A hsPkgs.jsaddle-webkit2gtk.components.library
42− fi
43
18
19+script:
20+ - docker run -v `pwd`:/build ghc
21+ sh -x -c "
22+ apt-get install -y cabal-install-$CABALVER ghc-$GHCVER &&
23+ export PATH=\$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/alex/3.1.7/bin:/opt/happy/1.19.5/bin:\$PATH &&
24+ ./travis/build.sh"
44notifications:
25notifications:
45 irc:
26 irc:
46 channels: "irc.freenode.net#ghcjs"
27 channels: "irc.freenode.net#ghcjs"
28+ skip_join: true
47− email: true
29+ email: true
README.md+14−34
@@ -13,8 +13,7 @@ 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− (jsg, js, js1, jss, fun, valToNumber, syncPoint)
16+ (run, jsg, js, js1, jss, fun, valToNumber, syncPoint)
17−import Language.Javascript.JSaddle.Warp (run)
18
17
19main = run 3709 $ do
18main = run 3709 $ do
20 doc <- jsg "document"
19 doc <- jsg "document"
@@ -80,7 +79,7 @@ main = run 3708 $ do
80 appendChild newParagraph text
79 appendChild newParagraph text
81 appendChild body (Just newParagraph)
80 appendChild body (Just newParagraph)
82 return ()
81 return ()
83−
82+
84 -- Make an exit button
83 -- Make an exit button
85 exitMVar <- liftIO newEmptyMVar
84 exitMVar <- liftIO newEmptyMVar
86 Just exit <- createElement doc (Just "span")
85 Just exit <- createElement doc (Just "span")
@@ -103,31 +102,15 @@ When compiled with GHC this code will run a Warp web server you can connect to a
103
102
104## How does it work on GHC
103## How does it work on GHC
105
104
106−There are a number of different JSaddle runners to choose from
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
107−
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.
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.
119
107
120−Haskell callbacks from JavaScript are supported by sending JSON back from the command interpreter. These can be synchronous (blocking the
108+### Why use WebSockets?
121−JavaScript thread until the Haskell callback completes) or asynchronous.
122
109
123−### Why use a JavaScript command interpreter?
124−
125−Older versions of JSaddle relied on the WebKit1 interface to WebKitGTK and JavaScriptCore that is only supported in older versions of
126−WebKitGTK. With the newer WebKit2 interface this level of access is only available to WebKit Extensions.
110+Older versions relied on WebKitGTK and JavaScriptCore, but in WekKit2 the interface JSaddle used is only available to WebKit Extensions
111+so most of the benefits of this interface are lost (extensions are not in the same process as Gtk and RPC would have been needed).
127−The general advice for people migrating from WebKit1 to WebKit2 seems to be to use JavaScript.
112+The general advice for people migrating from WebKit1 to WebKit2 seems to be to use JavaScript. There is an interface in WebKit2
128−
113+to send JavaScript code from the host application, but it does not seem to provide any advantages over the WebSockets approach.
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.
131
114
132### JSVal
115### JSVal
133
116
@@ -137,8 +120,8 @@ The first five keys `[0..4]` are
137these values. Both the Haskell code and `jsaddle.js` can allocate new `JSVal` keys. The Haskell code allocates negative
120these values. Both the Haskell code and `jsaddle.js` can allocate new `JSVal` keys. The Haskell code allocates negative
138keys and `jsaddle.js` allocates positive keys to avoid clashing.
121keys and `jsaddle.js` allocates positive keys to avoid clashing.
139
122
140−The haskell code will not know the value to go with the key, but it will include it in commands to the server
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
141−that are sort of "hey call this function and put the result in the map with this key"). This allows for the
124+that are sort of "hey call this function and and put the result in the map with this key"). This allows for the
142lazy execution of the JSaddle code.
125lazy execution of the JSaddle code.
143
126
144A finalizer is added on the Haskell code and an asynchronous `FreeJSVal` command is automatically sent to `jsaddle.js`
127A finalizer is added on the Haskell code and an asynchronous `FreeJSVal` command is automatically sent to `jsaddle.js`
@@ -146,7 +129,7 @@ when the JSVal is no longer reachable. The `jsaddle.js` code then deletes the k
146
129
147### JSStrings
130### JSStrings
148
131
149−These are haskell `Text` type and so reside on the native side of the WebSocket. If you want to avoid transferring large string values over the WebSocket use `toJSVal` to convert it to a `JSVal`.
132+These are haskell `Text` type and so reside on the native side of the WebSocket. If you want to make avoid transferring large string values over the WebSocket use `toJSVal` to conevt it to a `JSVal`.
150
133
151### Lazy Execution
134### Lazy Execution
152
135
@@ -178,7 +161,7 @@ force all the pending asynchronous commands to be executed.
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.
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.
179
162
180For the best performance you may want to write both JS FFI and JSaddle wrappers
163For the best performance you may want to write both JS FFI and JSaddle wrappers
181−for your JavaScript code. This is the approach taken by `ghcjs-dom`.
164+For your JavaScript code. This is the approach taken by recent versions of `ghcjs-dom`.
182
165
183For instance here is `getElementById` from the `ghcjs-dom-jsffi` (used by `ghcjs-dom` when compiled with GHCJS)
166For instance here is `getElementById` from the `ghcjs-dom-jsffi` (used by `ghcjs-dom` when compiled with GHCJS)
184
167
@@ -213,10 +196,7 @@ JSaddle does not support exceptions well. When compiled with GHCJS an exception
213at the point the exception is thrown.
196at the point the exception is thrown.
214
197
215When using GHC the Haskell executions will probably continue for a while before the exception is received at all by the Haskell code
198When using GHC the Haskell executions will probably continue for a while before the exception is received at all by the Haskell code
216−(because the lazy execution of the JS code). The exception will be thrown when the next synchronous command is executed.
199+(because the lazy execution of the JS code). The exception will be thrown when the the next synchronous command is executed.
217When it reaches the synchronous command a haskell type JSException will be thrown (this may not be the thread that initiated the
200When it reaches the synchronous command a haskell type JSException will be thrown (this may not be the thread that initiated the
218command that caused the exception). You can use `syncPoint` and `syncAfter` to force the exception to be thrown.
201command that caused the exception). You can use `syncPoint` and `syncAfter` to force the exception to be thrown.
219There are `JSM` versions of `catch` and `bracket` that also include a `syncPoint` call.
202There 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+35−4
@@ -1,10 +1,41 @@
1+flags: -overloaded-methods -overloaded-signals -overloaded-properties
2+
1packages:
3packages:
2 jsaddle/
4 jsaddle/
3 jsaddle-warp/
5 jsaddle-warp/
4 jsaddle-wkwebview/
6 jsaddle-wkwebview/
7+-- jsaddle-webkitgtk/
5 jsaddle-webkit2gtk/
8 jsaddle-webkit2gtk/
6− jsaddle-clib/
7−
8−constraints: haskell-gi-overloading == 0.0
9
9
10−allow-newer: websockets:random, splitmix:time, *:time, *:unix, *:process, stm:base
10+package gi-atk
11+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
12+package gi-cairo
13+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
14+package gi-gdk
15+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
16+package gi-gdkpixbuf
17+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
18+package gi-gio
19+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
20+package gi-glib
21+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
22+package gi-gobject
23+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
24+package gi-gtk
25+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
26+package gi-gtk-hs
27+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
28+package gi-gtkosxapplication
29+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
30+package gi-gtksource
31+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
32+package gi-javascriptcore
33+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
34+package gi-pango
35+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
36+package gi-soup
37+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
38+package gi-webkit
39+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
40+package gi-webkit2
41+ flags: -overloaded-methods -overloaded-signals -overloaded-properties
jsaddle-clib/LICENSEdeleted−21
@@ -1,21 +0,0 @@
1−Copyright (c) 2010-2012 Hamish Mackenzie, Victor Nazarov, Luite Stegeman
2−
3−Permission is hereby granted, free of charge, to any person obtaining
4−a copy of this software and associated documentation files (the
5−"Software"), to deal in the Software without restriction, including
6−without limitation the rights to use, copy, modify, merge, publish,
7−distribute, sublicense, and/or sell copies of the Software, and to
8−permit persons to whom the Software is furnished to do so, subject to
9−the following conditions:
10−
11−The above copyright notice and this permission notice shall be
12−included in all copies or substantial portions of the Software.
13−
14−THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15−EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16−MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
17−NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
18−LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
19−OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
20−WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21−
jsaddle-clib/Setup.lhsdeleted−6
@@ -1,6 +0,0 @@
1−#!/usr/bin/runhaskell
2−> module Main where
3−> import Distribution.Simple
4−> main :: IO ()
5−> main = defaultMain
6−
jsaddle-clib/cbits/include/jsaddle.hdeleted−24
@@ -1,24 +0,0 @@
1−#ifndef JSADDLE_H
2−#define JSADDLE_H
3−
4−typedef struct native_callbacks {
5− void (* jsaddleStart) ();
6− void (* jsaddleResult) (char *);
7− char * (* jsaddleSyncResult) (char *);
8− char * jsaddleJsData;
9− char * jsaddleHtmlData;
10−} native_callbacks;
11−
12−typedef struct app_callbacks {
13− void (* mainActivity_onCreate) ();
14− void (* mainActivity_onStart) ();
15− void (* mainActivity_onResume) ();
16− void (* mainActivity_onPause) ();
17− void (* mainActivity_onStop) ();
18− void (* mainActivity_onDestroy) ();
19− void (* mainActivity_onRestart) ();
20− void (* mainActivity_onNewIntent) (char *, char *);
21− void (* firebaseInstanceIdService_sendRegistrationToServer) (char *);
22−} app_callbacks;
23−
24−#endif
jsaddle-clib/jsaddle-clib.cabaldeleted−40
@@ -1,40 +0,0 @@
1−name: jsaddle-clib
2−version: 0.9.8.0
3−cabal-version: >=1.10
4−build-type: Simple
5−license: MIT
6−license-file: LICENSE
7−maintainer: Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
8−synopsis: Interface for JavaScript that works with GHCJS and GHC
9−description:
10− This package provides an EDSL for calling JavaScript that
11− can be used both from GHCJS and GHC.
12−category: Web, Javascript
13−author: Hamish Mackenzie
14−
15−source-repository head
16− type: git
17− location: https://github.com/ghcjs/jsaddle
18−
19−library
20− exposed-modules:
21− Language.Javascript.JSaddle.CLib
22− Language.Javascript.JSaddle.CLib.Internal
23− build-depends:
24− aeson >=0.8.0.2 && <1.6,
25− base <5,
26− base-compat >=0.9.0 && <0.12,
27− bytestring >=0.10.6.0 && <0.11,
28− jsaddle >= 0.9.0.0 && <0.10,
29− data-default,
30− text
31− default-language: Haskell2010
32− hs-source-dirs: src
33− Include-dirs: cbits/include
34− Includes: jsaddle.h
35− Install-includes: jsaddle.h
36− ghc-options: -ferror-spans -Wall
37− if impl(ghcjs)
38− hs-source-dirs: src-ghcjs
39− else
40− hs-source-dirs: src-ghc
jsaddle-clib/src-ghc/Language/Javascript/JSaddle/CLib.hsdeleted−157
@@ -1,157 +0,0 @@
1−{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}
2−module Language.Javascript.JSaddle.CLib
3− ( jsaddleInit
4− , NativeCallbacks (..)
5− , AppCallbacks (..)
6− , AppConfig (..)
7− , pokeAppConfig
8− , appConfigToAppCallbacks
9− ) where
10−
11−import Prelude ()
12−import Prelude.Compat
13−
14−import Control.Monad (void)
15−import Control.Concurrent (forkIO)
16−
17−import Data.Aeson (encode, decode)
18−import Data.ByteString (useAsCString, packCString)
19−import Data.ByteString.Char8 (unpack)
20−import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)
21−import Data.Default (def, Default)
22−import Data.Text (Text)
23−import qualified Data.Text.Encoding as T
24−
25−import Foreign.C.String (CString, newCString)
26−import Foreign.Ptr (FunPtr, Ptr)
27−import Foreign.Storable (poke)
28−import Foreign.Marshal.Utils (new)
29−
30−import Language.Javascript.JSaddle (JSM)
31−import Language.Javascript.JSaddle.Run (runJavaScript)
32−import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
33−
34−import Language.Javascript.JSaddle.CLib.Internal
35−
36−foreign import ccall safe "dynamic"
37− mkCallback :: FunPtr (CString -> IO ()) -> CString -> IO ()
38−
39−foreign import ccall safe "wrapper"
40− wrapStartCallback :: IO () -> IO (FunPtr (IO ()))
41−
42−foreign import ccall safe "wrapper"
43− wrapMessageCallback :: (CString -> IO ()) -> IO (FunPtr (CString -> IO ()))
44−
45−foreign import ccall safe "wrapper"
46− wrapMessageCallback2 :: (CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> IO ()))
47−
48−foreign import ccall safe "wrapper"
49− wrapSyncCallback :: (CString -> IO CString) -> IO (FunPtr (CString -> IO CString))
50−
51−jsaddleInit :: JSM () -> FunPtr (CString -> IO ()) -> IO (Ptr NativeCallbacks)
52−jsaddleInit jsm evaluateJavascriptAsyncPtr = do
53− let evaluateJavascriptAsync = mkCallback evaluateJavascriptAsyncPtr
54− (processResult, processSyncResult, start) <- runJavaScript (\batch ->
55− useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");")
56− evaluateJavascriptAsync) jsm
57− jsaddleStartPtr <- wrapStartCallback $ void $ forkIO start
58− jsaddleResultPtr <- wrapMessageCallback $ \s -> do
59− result <- decode . fromStrict <$> packCString s
60− case result of
61− Nothing -> error $ "jsaddle message decode failed: " <> show result
62− Just r -> processResult r
63− jsaddleSyncResultPtr <- wrapSyncCallback $ \s -> do
64− result <- decode . fromStrict <$> packCString s
65− case result of
66− Nothing -> error $ "jsaddle message decode failed: " <> show result
67− Just r -> newCString =<< unpack . toStrict . encode <$> processSyncResult r
68− jsaddleJsPtr <- newCString $ unpack $ toStrict jsaddleJs
69− jsaddleHtmlPtr <- newCString $ unpack $ toStrict indexHtml
70− new NativeCallbacks
71− { _nativeCallbacks_jsaddleStart = jsaddleStartPtr
72− , _nativeCallbacks_jsaddleResult = jsaddleResultPtr
73− , _nativeCallbacks_jsaddleSyncResult = jsaddleSyncResultPtr
74− , _nativeCallbacks_jsaddleJsData = jsaddleJsPtr
75− , _nativeCallbacks_jsaddleHtmlData = jsaddleHtmlPtr
76− }
77−
78−data AppConfig = AppConfig
79− { _appConfig_mainActivityOnCreate :: IO ()
80− , _appConfig_mainActivityOnStart :: IO ()
81− , _appConfig_mainActivityOnResume :: IO ()
82− , _appConfig_mainActivityOnPause :: IO ()
83− , _appConfig_mainActivityOnStop :: IO ()
84− , _appConfig_mainActivityOnDestroy :: IO ()
85− , _appConfig_mainActivityOnRestart :: IO ()
86− , _appConfig_mainActivityOnNewIntent :: (Text -> Text -> IO ())
87− , _appConfig_firebaseInstanceIdServiceSendRegistrationToServer :: Text -> IO ()
88− }
89−
90−instance Default AppConfig where
91− def = AppConfig
92− { _appConfig_mainActivityOnCreate = return ()
93− , _appConfig_mainActivityOnStart = return ()
94− , _appConfig_mainActivityOnResume = return ()
95− , _appConfig_mainActivityOnPause = return ()
96− , _appConfig_mainActivityOnStop = return ()
97− , _appConfig_mainActivityOnDestroy = return ()
98− , _appConfig_mainActivityOnRestart = return ()
99− , _appConfig_mainActivityOnNewIntent = \_ _ -> return ()
100− , _appConfig_firebaseInstanceIdServiceSendRegistrationToServer = \_ -> return ()
101− }
102−
103−appConfigToAppCallbacks :: AppConfig -> IO AppCallbacks
104−appConfigToAppCallbacks c = do
105− create <- wrapStartCallback $ _appConfig_mainActivityOnCreate c
106− start <- wrapStartCallback $ _appConfig_mainActivityOnStart c
107− resume <- wrapStartCallback $ _appConfig_mainActivityOnResume c
108− pause <- wrapStartCallback $ _appConfig_mainActivityOnPause c
109− stop <- wrapStartCallback $ _appConfig_mainActivityOnStop c
110− destroy <- wrapStartCallback $ _appConfig_mainActivityOnDestroy c
111− restart <- wrapStartCallback $ _appConfig_mainActivityOnRestart c
112− newIntent <- wrapMessageCallback2 $ \intentAction intentData -> do
113− intentAction' <- fromUtf8CString intentAction
114− intentData' <- fromUtf8CString intentData
115− _appConfig_mainActivityOnNewIntent c intentAction' intentData'
116− firebaseRegPtr <- wrapMessageCallback $ \token -> do
117− token' <- fromUtf8CString token
118− _appConfig_firebaseInstanceIdServiceSendRegistrationToServer c token'
119− return $ AppCallbacks
120− { _appCallbacks_mainActivity_onCreate = create
121− , _appCallbacks_mainActivity_onStart = start
122− , _appCallbacks_mainActivity_onResume = resume
123− , _appCallbacks_mainActivity_onPause = pause
124− , _appCallbacks_mainActivity_onStop = stop
125− , _appCallbacks_mainActivity_onDestroy = destroy
126− , _appCallbacks_mainActivity_onRestart = restart
127− , _appCallbacks_mainActivity_onNewIntent = newIntent
128− , _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer = firebaseRegPtr
129− }
130−
131−fromUtf8CString :: CString -> IO Text
132−fromUtf8CString = fmap T.decodeUtf8 . packCString
133−
134−pokeAppConfig :: Ptr AppCallbacks -> AppConfig -> IO ()
135−pokeAppConfig ptr cfg = poke ptr =<< appConfigToAppCallbacks cfg
136−
137−jsaddleJs :: ByteString
138−jsaddleJs = ghcjsHelpers <> "\
139− \runJSaddleBatch = (function() {\n\
140− \ " <> initState <> "\n\
141− \ return function(batch) {\n\
142− \ " <> runBatch (\a -> "jsaddle.postMessage(JSON.stringify(" <> a <> "));")
143− (Just (\a -> "JSON.parse(jsaddle.syncMessage(JSON.stringify(" <> a <> ")))")) <> "\
144− \ };\n\
145− \})();\n\
146− \jsaddle.postReady();\n"
147−
148−indexHtml :: ByteString
149−indexHtml =
150− "<!DOCTYPE html>\n\
151− \<html>\n\
152− \<head>\n\
153− \<title>JSaddle</title>\n\
154− \</head>\n\
155− \<body>\n\
156− \</body>\n\
157− \</html>"
jsaddle-clib/src-ghcjs/Language/Javascript/JSaddle/CLib.hsdeleted−7
@@ -1,7 +0,0 @@
1−module Language.Javascript.JSaddle.CLib
2− ( run
3− ) where
4−
5−run :: IO () -> IO ()
6−run = id
7−{-# INLINE run #-}
jsaddle-clib/src/Language/Javascript/JSaddle/CLib/Internal.hscdeleted−67
@@ -1,67 +0,0 @@
1−{-# LANGUAGE ForeignFunctionInterface #-}
2−module Language.Javascript.JSaddle.CLib.Internal where
3−
4−import Foreign
5−import Foreign.C
6−
7−#include "jsaddle.h"
8−
9−data NativeCallbacks = NativeCallbacks
10− { _nativeCallbacks_jsaddleStart :: !(FunPtr (IO ())) -- void (jsaddleStart *)()
11− , _nativeCallbacks_jsaddleResult :: !(FunPtr (CString -> IO ())) -- void (jsaddleResult *)(char *)
12− , _nativeCallbacks_jsaddleSyncResult :: !(FunPtr (CString -> IO CString)) -- char * (jsaddleSyncResult *)(char *)
13− , _nativeCallbacks_jsaddleJsData :: !CString -- char * jsaddleJsData
14− , _nativeCallbacks_jsaddleHtmlData :: !CString -- char * jsaddleHtmlData
15− }
16−
17−instance Storable NativeCallbacks where
18− sizeOf _ = #{size native_callbacks}
19− alignment _ = #{alignment native_callbacks}
20− poke p nc = do
21− #{poke native_callbacks, jsaddleStart} p $ _nativeCallbacks_jsaddleStart nc
22− #{poke native_callbacks, jsaddleResult} p $ _nativeCallbacks_jsaddleResult nc
23− #{poke native_callbacks, jsaddleSyncResult} p $ _nativeCallbacks_jsaddleSyncResult nc
24− #{poke native_callbacks, jsaddleJsData} p $ _nativeCallbacks_jsaddleJsData nc
25− #{poke native_callbacks, jsaddleHtmlData} p $ _nativeCallbacks_jsaddleHtmlData nc
26− peek p = NativeCallbacks
27− <$> #{peek native_callbacks, jsaddleStart} p
28− <*> #{peek native_callbacks, jsaddleResult} p
29− <*> #{peek native_callbacks, jsaddleSyncResult} p
30− <*> #{peek native_callbacks, jsaddleJsData} p
31− <*> #{peek native_callbacks, jsaddleHtmlData} p
32−
33−data AppCallbacks = AppCallbacks
34− { _appCallbacks_mainActivity_onCreate :: !(FunPtr (IO ()))
35− , _appCallbacks_mainActivity_onStart :: !(FunPtr (IO ()))
36− , _appCallbacks_mainActivity_onResume :: !(FunPtr (IO ()))
37− , _appCallbacks_mainActivity_onPause :: !(FunPtr (IO ()))
38− , _appCallbacks_mainActivity_onStop :: !(FunPtr (IO ()))
39− , _appCallbacks_mainActivity_onDestroy :: !(FunPtr (IO ()))
40− , _appCallbacks_mainActivity_onRestart :: !(FunPtr (IO ()))
41− , _appCallbacks_mainActivity_onNewIntent :: !(FunPtr (CString -> CString -> IO ()))
42− , _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer :: !(FunPtr (CString -> IO ()))
43− }
44−
45−instance Storable AppCallbacks where
46− sizeOf _ = #{size app_callbacks}
47− alignment _ = #{alignment app_callbacks}
48− poke p nc = do
49− #{poke app_callbacks, mainActivity_onCreate} p $ _appCallbacks_mainActivity_onCreate nc
50− #{poke app_callbacks, mainActivity_onStart} p $ _appCallbacks_mainActivity_onStart nc
51− #{poke app_callbacks, mainActivity_onResume} p $ _appCallbacks_mainActivity_onResume nc
52− #{poke app_callbacks, mainActivity_onPause} p $ _appCallbacks_mainActivity_onPause nc
53− #{poke app_callbacks, mainActivity_onStop} p $ _appCallbacks_mainActivity_onStop nc
54− #{poke app_callbacks, mainActivity_onDestroy} p $ _appCallbacks_mainActivity_onDestroy nc
55− #{poke app_callbacks, mainActivity_onRestart} p $ _appCallbacks_mainActivity_onRestart nc
56− #{poke app_callbacks, mainActivity_onNewIntent} p $ _appCallbacks_mainActivity_onNewIntent nc
57− #{poke app_callbacks, firebaseInstanceIdService_sendRegistrationToServer} p $ _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer nc
58− peek p = AppCallbacks
59− <$> #{peek app_callbacks, mainActivity_onCreate} p
60− <*> #{peek app_callbacks, mainActivity_onStart} p
61− <*> #{peek app_callbacks, mainActivity_onResume} p
62− <*> #{peek app_callbacks, mainActivity_onPause} p
63− <*> #{peek app_callbacks, mainActivity_onStop} p
64− <*> #{peek app_callbacks, mainActivity_onDestroy} p
65− <*> #{peek app_callbacks, mainActivity_onRestart} p
66− <*> #{peek app_callbacks, mainActivity_onNewIntent} p
67− <*> #{peek app_callbacks, firebaseInstanceIdService_sendRegistrationToServer} p
jsaddle-warp/jsaddle-warp.cabal+14−37
@@ -1,5 +1,5 @@
1name: jsaddle-warp
1name: jsaddle-warp
2−version: 0.9.8.0
2+version: 0.7.1.0
3cabal-version: >=1.10
3cabal-version: >=1.10
4build-type: Simple
4build-type: Simple
5license: MIT
5license: MIT
@@ -10,37 +10,32 @@ 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 JavaScript helper.
13+ drive a small JavaScipt 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
21
20
22library
21library
23
22
24 if !impl(ghcjs -any)
23 if !impl(ghcjs -any)
25 exposed-modules:
24 exposed-modules:
26 Language.Javascript.JSaddle.WebSockets
25 Language.Javascript.JSaddle.WebSockets
27− other-modules:
28− Language.Javascript.JSaddle.WebSockets.Compat
29 build-depends:
26 build-depends:
30− aeson >=0.8.0.2 && <1.6,
27+ aeson >=0.8.0.2 && <1.1,
31− bytestring >=0.10.6.0 && <0.11,
32− containers >=0.5.6.2 && <0.7,
28+ containers >=0.5.6.2 && <0.6,
33− foreign-store >=0.2 && <0.3,
34− http-types >=0.8.6 && <0.13,
29+ http-types >=0.8.6 && <0.10,
35− jsaddle >=0.9.4.0 && <0.10,
30+ jsaddle >=0.7.0.0 && <0.8,
36− stm >=2.4.4 && <2.6,
31+ stm >=2.4.4 && <2.5,
37 text >=1.2.1.3 && <1.3,
32 text >=1.2.1.3 && <1.3,
38− time >=1.5.0.1 && <1.11,
33+ time >=1.5.0.1 && <1.7,
39 transformers >=0.4.2.0 && <0.6,
34 transformers >=0.4.2.0 && <0.6,
40 wai >=3.0.3.0 && <3.3,
35 wai >=3.0.3.0 && <3.3,
41 wai-websockets >=3.0.0.6 && <3.1,
36 wai-websockets >=3.0.0.6 && <3.1,
42− warp >=3.1.2 && <3.4,
37+ warp >=3.1.2 && <3.3,
43− websockets >=0.9.5.0 && <0.13
38+ websockets >=0.9.5.0 && <0.10
44 exposed-modules:
39 exposed-modules:
45 Language.Javascript.JSaddle.Warp
40 Language.Javascript.JSaddle.Warp
46 build-depends:
41 build-depends:
@@ -50,39 +45,21 @@ library
50 ghc-options: -ferror-spans -Wall
45 ghc-options: -ferror-spans -Wall
51
46
52test-suite test-tool
47test-suite test-tool
53− if impl(ghcjs -any) || os(ios)
54− buildable: False
55
48
49+ if !impl(ghcjs -any)
56− build-depends:
50+ build-depends:
57 QuickCheck -any,
51 QuickCheck -any,
58− aeson -any,
59 bytestring -any,
52 bytestring -any,
60− containers -any,
61 deepseq -any,
53 deepseq -any,
62− doctest >=0.10.1 && <0.19,
54+ doctest >=0.10.1 && <0.12,
63− exceptions -any,
64 filepath >=1.4.0.0 && <1.5,
55 filepath >=1.4.0.0 && <1.5,
65− foreign-store -any,
66 ghc-prim -any,
56 ghc-prim -any,
67− http-types -any,
68 jsaddle -any,
57 jsaddle -any,
69 jsaddle-warp -any,
58 jsaddle-warp -any,
70 lens -any,
59 lens -any,
71− network -any,
72 ref-tf -any,
60 ref-tf -any,
73 primitive -any,
61 primitive -any,
74− process >=1.2.3.0 && <1.7,
62+ process >=1.2.3.0 && <1.5
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
86 type: exitcode-stdio-1.0
63 type: exitcode-stdio-1.0
87 main-is: DocTest.hs
64 main-is: DocTest.hs
88 build-depends:
65 build-depends:
jsaddle-warp/src/Language/Javascript/JSaddle/Test.hs+12−13
@@ -17,22 +17,21 @@ module Language.Javascript.JSaddle.Test (
17 , listWindowProperties
17 , listWindowProperties
18) where
18) where
19
19
20−import Prelude hiding((!!), catch)
21import Control.Applicative
20import Control.Applicative
22−import Control.Concurrent (threadDelay, forkIO, ThreadId)
21+import Prelude hiding((!!), catch)
23−import Control.Concurrent.MVar
24− (tryTakeMVar, putMVar, takeMVar, newEmptyMVar, MVar)
25−import Control.Lens.Getter ((^.))
26−import Control.Monad (forever, forM)
27−import Control.Monad.IO.Class (MonadIO(..))
28import Control.Monad.Trans.Reader (runReaderT)
22import Control.Monad.Trans.Reader (runReaderT)
23+import Language.Javascript.JSaddle
24+import qualified Data.Text as T
25+import Control.Monad.IO.Class (MonadIO(..))
26+import Control.Monad (forever, forM)
27+import Control.Lens.Getter ((^.))
29import Data.Monoid ((<>))
28import Data.Monoid ((<>))
29+import Control.Concurrent.MVar
30+ (tryTakeMVar, putMVar, takeMVar, newEmptyMVar, MVar)
31+import System.IO.Unsafe (unsafePerformIO)
32+import Control.Concurrent (threadDelay, forkIO, ThreadId)
30import Data.Text (Text)
33import Data.Text (Text)
31−import qualified Data.Text as T
32−import Language.Javascript.JSaddle
33import Language.Javascript.JSaddle.Warp (run)
34import Language.Javascript.JSaddle.Warp (run)
34−import System.IO.Unsafe (unsafePerformIO)
35−import System.Timeout (timeout)
36
35
37context :: MVar JSContextRef
36context :: MVar JSContextRef
38context = unsafePerformIO newEmptyMVar
37context = unsafePerformIO newEmptyMVar
@@ -53,12 +52,12 @@ startServer =
53
52
54-- >>> testJSaddle $ ((global ^. js "console" . js "log") # ["Hello"])
53-- >>> testJSaddle $ ((global ^. js "console" . js "log") # ["Hello"])
55testJSaddle :: ToJSVal val => JSM val -> IO ()
54testJSaddle :: ToJSVal val => JSM val -> IO ()
56−testJSaddle f = timeout 10000000 (do
55+testJSaddle f = do
57 startServer
56 startServer
58 c <- takeMVar context
57 c <- takeMVar context
59 runReaderT (unJSM $ (f >>= valToText >>= liftIO . putStrLn . T.unpack)
58 runReaderT (unJSM $ (f >>= valToText >>= liftIO . putStrLn . T.unpack)
60 `catch` \ (JSException e) -> valToText e >>= liftIO . putStrLn . T.unpack) c
59 `catch` \ (JSException e) -> valToText e >>= liftIO . putStrLn . T.unpack) c
61− putMVar context c) >>= maybe (putStrLn "testJSaddle timed out") return
60+ putMVar context c
62
61
63debugLog :: String -> IO ()
62debugLog :: String -> IO ()
64debugLog _ = return ()
63debugLog _ = return ()
jsaddle-warp/src/Language/Javascript/JSaddle/Warp.hs+4−3
@@ -17,7 +17,8 @@ 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− , module Language.Javascript.JSaddle.WebSockets
20+ , jsaddleOr
21+ , jsaddleApp
21#endif
22#endif
22) where
23) where
23
24
@@ -28,7 +29,7 @@ import Network.WebSockets (defaultConnectionOptions)
28
29
29import Language.Javascript.JSaddle.Types (JSM)
30import Language.Javascript.JSaddle.Types (JSM)
30import Language.Javascript.JSaddle.Run (syncPoint)
31import Language.Javascript.JSaddle.Run (syncPoint)
31−import Language.Javascript.JSaddle.WebSockets
32+import Language.Javascript.JSaddle.WebSockets (jsaddleOr, jsaddleApp)
32#endif
33#endif
33
34
34-- | Run the given 'JSM' action as the main entry point. Either directly
35-- | Run the given 'JSM' action as the main entry point. Either directly
@@ -39,6 +40,6 @@ run _port = id
39#else
40#else
40run :: Int -> JSM () -> IO ()
41run :: Int -> JSM () -> IO ()
41run port f =
42run port f =
42− runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
43+ runSettings (setPort port (setTimeout 3600 defaultSettings)) $
43 jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp
44 jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp
44#endif
45#endif
jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs+40−287
@@ -1,7 +1,5 @@
1{-# LANGUAGE LambdaCase #-}
1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−{-# LANGUAGE RecursiveDo #-}
5-----------------------------------------------------------------------------
3-----------------------------------------------------------------------------
6--
4--
7-- Module : Language.Javascript.JSaddle.WebSockets
5-- Module : Language.Javascript.JSaddle.WebSockets
@@ -18,302 +16,57 @@ module Language.Javascript.JSaddle.WebSockets (
18 -- * Running JSM over WebSockets
16 -- * Running JSM over WebSockets
19 jsaddleOr
17 jsaddleOr
20 , jsaddleApp
18 , jsaddleApp
21− , jsaddleWithAppOr
22− , jsaddleAppWithJs
23− , jsaddleAppWithJsOr
24− , jsaddleAppPartial
25− , jsaddleJs
26− , jsaddleJs'
27− , debug
28− , debugOr
29− , debugWrapper
30) where
19) where
31
20
32−import Control.Monad (when, void, forever)
21+import Control.Monad (forever)
33−import Control.Concurrent (killThread, forkIO, threadDelay)
22+import Control.Concurrent (forkIO)
34−import Control.Exception (handle, AsyncException, throwIO, fromException, finally)
35
23
36import Data.Monoid ((<>))
24import Data.Monoid ((<>))
37import Data.Aeson (encode, decode)
25import Data.Aeson (encode, decode)
38
26
39−import Network.Wai
27+import Network.Wai (Application)
40− (Middleware, lazyRequestBody, Application, Request, Response,
41− ResponseReceived)
42import Network.WebSockets
28import Network.WebSockets
43− (defaultConnectionOptions, ConnectionOptions(..), sendTextData,
29+ (ConnectionOptions(..), sendTextData, receiveDataMessage,
44− receiveDataMessage, acceptRequest, ServerApp, sendPing)
30+ acceptRequest, ServerApp)
31+import qualified Network.WebSockets as WS (DataMessage(..))
45import Network.Wai.Handler.WebSockets (websocketsOr)
32import Network.Wai.Handler.WebSockets (websocketsOr)
46−import Network.HTTP.Types (Status(..))
47
33
48−import Language.Javascript.JSaddle.Types (JSM(..), JSContextRef(..))
34+import Language.Javascript.JSaddle.Types (JSM(..))
49import qualified Network.Wai as W
35import qualified Network.Wai as W
50− (responseLBS, requestMethod, pathInfo, modifyResponse, responseStatus)
36+ (responseLBS, requestMethod, Application, pathInfo)
51−import qualified Data.Text as T (pack)
37+import Data.Text (Text)
52import qualified Network.HTTP.Types as H
38import qualified Network.HTTP.Types as H
53− (status403, status200)
39+ (status403, status200, status405)
54−import Language.Javascript.JSaddle.Run (syncPoint, runJavaScript)
40+import Language.Javascript.JSaddle.Run (runJavaScript)
55−import Language.Javascript.JSaddle.Run.Files (indexHtml, runBatch, ghcjsHelpers, initState)
41+import Language.Javascript.JSaddle.Run.Files (indexHtml, jsaddleJs)
56−import Language.Javascript.JSaddle.Debug
42+
57− (removeContext, addContext)
58−import Data.Maybe (fromMaybe)
59−import qualified Data.Map as M (empty, insert, lookup)
60−import Data.IORef
61− (readIORef, newIORef, atomicModifyIORef')
62−import Data.ByteString.Lazy (ByteString)
63−import qualified Data.ByteString.Lazy as LBS
64− (toStrict, stripPrefix)
65−import Control.Concurrent.MVar
66− (tryTakeMVar, MVar, tryPutMVar, modifyMVar_, putMVar, takeMVar,
67− readMVar, newMVar, newEmptyMVar, modifyMVar)
68−import Network.Wai.Handler.Warp
69− (defaultSettings, setTimeout, setPort, runSettings)
70−import Foreign.Store (readStore, lookupStore, writeStore, Store(..))
71−import Language.Javascript.JSaddle (askJSM)
72−import Control.Monad.IO.Class (MonadIO(..))
73−
74−import Language.Javascript.JSaddle.WebSockets.Compat (getTextMessageByteString)
75−import qualified Data.Text.Encoding as T (decodeUtf8)
76−
77−jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application
43+jsaddleOr :: ConnectionOptions -> JSM () -> Application -> Application
78−jsaddleOr opts entryPoint otherApp = do
44+jsaddleOr opts entryPoint = websocketsOr opts wsApp
79− syncHandlers <- newIORef M.empty
45+ where
80− asyncHandlers <- newIORef M.empty
81− let wsApp :: ServerApp
46+ wsApp :: ServerApp
82− wsApp pending_conn = do
47+ wsApp pending_conn = do
83− conn <- acceptRequest pending_conn
48+ conn <- acceptRequest pending_conn
84− initMsg <- receiveDataMessage conn
85− case getTextMessageByteString initMsg of
86− Just "" -> do
87− rec (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) $ do
49+ (processResult, start) <- runJavaScript (sendTextData conn . encode) entryPoint
88− syncKey <- T.pack . show . contextId <$> askJSM
89− liftIO $ atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))
90− liftIO $ atomicModifyIORef' asyncHandlers (\m -> (M.insert syncKey processResult m, ()))
91− liftIO $ sendTextData conn (encode syncKey)
92− entryPoint
93− start
94− waitTillClosed conn
95− Just syncKey ->
96− M.lookup (T.decodeUtf8 $ LBS.toStrict syncKey) <$> readIORef syncHandlers >>= \case
97− Nothing -> error "jsaddle missing sync message handler"
98− Just processResult ->
99− forever $
50+ _ <- forkIO . forever $
100− receiveDataMessage conn >>= \msg -> case getTextMessageByteString msg of
51+ receiveDataMessage conn >>= \case
101− Just t ->
52+ (WS.Text t) ->
102− case decode t of
53+ case decode t of
103− Nothing -> error $ "jsaddle Results decode failed : " <> show t
54+ Nothing -> error $ "jsaddle WebSocket decode failed : " <> show t
104− Just r -> processResult r
55+ Just r -> processResult r
105− _ -> error "jsaddle WebSocket unexpected binary data"
106 _ -> error "jsaddle WebSocket unexpected binary data"
56 _ -> error "jsaddle WebSocket unexpected binary data"
107−
57+ start
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−
140
58
141jsaddleApp :: Application
59jsaddleApp :: Application
142−jsaddleApp = jsaddleAppWithJs $ jsaddleJs False
60+jsaddleApp req = jsaddleAppPieces (W.pathInfo req) req
143−
61+
144−jsaddleAppWithJs :: ByteString -> Application
62+jsaddleAppPieces :: [Text] -> W.Application
145−jsaddleAppWithJs js req sendResponse =
63+jsaddleAppPieces _ req sendResponse
146− jsaddleAppWithJsOr js
64+ | W.requestMethod req `notElem` ["GET", "HEAD"] = sendResponse $ W.responseLBS
65+ H.status405
147− (\_ _ -> sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")
66+ [("Content-Type", "text/plain")]
148− req sendResponse
67+ "Only GET or HEAD is supported"
149−
150−jsaddleAppWithJsOr :: ByteString -> Application -> Application
151−jsaddleAppWithJsOr js otherApp req sendResponse =
152− fromMaybe (otherApp req sendResponse)
153− (jsaddleAppPartialWithJs js req sendResponse)
154−
155−jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application
156−jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->
157− (fromMaybe (otherApp req sendResponse)
158− (jsaddleAppPartial req sendResponse))
159−
160−jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
161−jsaddleAppPartial = jsaddleAppPartialWithJs $ jsaddleJs False
162−
163−indexResponse :: Response
164−indexResponse = W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
68+jsaddleAppPieces [] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
165−
166−jsaddleAppPartialWithJs :: ByteString -> Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
167−jsaddleAppPartialWithJs js req sendResponse = case (W.requestMethod req, W.pathInfo req) of
168− ("GET", []) -> Just $ sendResponse indexResponse
169− ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] js
69+jsaddleAppPieces ["jsaddle.js"] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs
170− _ -> Nothing
70+jsaddleAppPieces _rawPieces _req sendResponse = sendResponse $ W.responseLBS H.status403
171−
71+ [ ("Content-Type", "text/plain")
172−jsaddleJs :: Bool -> ByteString
72+ ] "Forbidden"
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.hsdeleted−29
@@ -1,29 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−-----------------------------------------------------------------------------
3−--
4−-- Module : Language.Javascript.JSaddle.WebSockets.Compat
5−-- Copyright : (c) Hamish Mackenzie
6−-- License : MIT
7−--
8−-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
9−--
10−-- | This module is necessary to harmonize various versions of the websockets
11−-- package; we can't do this CPP inline in
12−-- Language.Javascript.JSaddle.WebSockets because that module uses multi-line
13−-- strings, which are incompatible with CPP
14−--
15−-----------------------------------------------------------------------------
16−module Language.Javascript.JSaddle.WebSockets.Compat where
17−
18−import Data.ByteString.Lazy (ByteString)
19−import qualified Network.WebSockets as WS (DataMessage(..))
20−
21−getTextMessageByteString :: WS.DataMessage -> Maybe ByteString
22−getTextMessageByteString msg = case msg of
23−#if MIN_VERSION_websockets(0,11,0)
24− (WS.Text t _) ->
25−#else
26− (WS.Text t) ->
27−#endif
28− Just t
29− _ -> Nothing
jsaddle-warp/tests/DocTest.hs+61−84
@@ -11,17 +11,15 @@ 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
14+import Control.Concurrent (forkIO)
15− (takeMVar, newEmptyMVar, forkIO, threadDelay, putMVar)
16import Control.Monad (void)
15import Control.Monad (void)
17−import Control.Monad.IO.Class (MonadIO(..))
18import Data.Monoid ((<>))
16import Data.Monoid ((<>))
19import System.Environment (getArgs)
17import System.Environment (getArgs)
20−import Test.WebDriver (runSession, defaultConfig, openPage, closeSession)
18+import Language.Javascript.JSaddle.Run.Files (jsaddleJs)
19+import qualified Data.ByteString.Lazy.Char8 as BS (unpack)
21
20
22main :: IO ()
21main :: IO ()
23main = do
22main = do
24− putStrLn "Testing JSaddle"
25 jsaddlePath <- getArgs >>= \case
23 jsaddlePath <- getArgs >>= \case
26 [arg] -> return arg
24 [arg] -> return arg
27 _ -> do
25 _ -> do
@@ -29,84 +27,63 @@ main = do
29 exitFailure
27 exitFailure
30 hSetBuffering stdout LineBuffering
28 hSetBuffering stdout LineBuffering
31 hSetBuffering stderr LineBuffering
29 hSetBuffering stderr LineBuffering
32− putStrLn "Checking for phantomjs"
33− node <- system "phantomjs --version" >>= \case
30+ node <- system "nodejs --version" >>= \case
34− ExitSuccess -> return ()
31+ ExitSuccess -> return "nodejs"
32+ _ -> return "node"
33+ system (node <> " --version") >>= \case
34+ ExitSuccess -> putStrLn "Node.js found"
35 e -> do
35 e -> do
36− putStrLn "phantomjs not found"
36+ putStrLn "Node.js not found"
37 exitWith e
37 exitWith e
38− putStrLn "Starting phantomjs"
39− forkIO . void $ readProcess "phantomjs" ["--webdriver=4444"] "" >>= putStr
38+ forkIO . void $ readProcess node ["--harmony"] (BS.unpack jsaddleJs) >>= putStr
40− threadDelay 5000000
41− putStrLn "Running Tests"
42− done <- newEmptyMVar
43− forkIO $ do
44− liftIO $ doctest [
39+ doctest [
45− "-hide-all-packages",
40+ "-hide-all-packages",
46− "-package=base-" ++ VERSION_base,
41+ "-package=base-" ++ VERSION_base,
47− "-package=lens-" ++ VERSION_lens,
42+ "-package=lens-" ++ VERSION_lens,
48− "-package=text-" ++ VERSION_text,
43+ "-package=text-" ++ VERSION_text,
49− "-package=bytestring-" ++ VERSION_bytestring,
44+ "-package=bytestring-" ++ VERSION_bytestring,
50− "-package=transformers-" ++ VERSION_transformers,
45+ "-package=transformers-" ++ VERSION_transformers,
51− "-package=websockets-" ++ VERSION_websockets,
46+ "-package=websockets-" ++ VERSION_websockets,
52− "-package=primitive-" ++ VERSION_primitive,
47+ "-package=primitive-" ++ VERSION_primitive,
53− "-package=aeson-" ++ VERSION_aeson,
48+ "-package=aeson-" ++ VERSION_aeson,
54− "-package=websockets-" ++ VERSION_websockets,
49+ "-package=websockets-" ++ VERSION_websockets,
55− "-package=wai-" ++ VERSION_wai,
50+ "-package=wai-" ++ VERSION_wai,
56− "-package=wai-websockets-" ++ VERSION_wai_websockets,
51+ "-package=wai-websockets-" ++ VERSION_wai_websockets,
57− "-package=warp-" ++ VERSION_warp,
52+ "-package=warp-" ++ VERSION_warp,
58− "-package=http-types-" ++ VERSION_http_types,
53+ "-package=http-types-" ++ VERSION_http_types,
59− "-package=stm-" ++ VERSION_stm,
54+ "-package=stm-" ++ VERSION_stm,
60− "-package=time-" ++ VERSION_time,
55+ "-package=time-" ++ VERSION_time,
61− "-package=containers-" ++ VERSION_containers,
56+ "-package=containers-" ++ VERSION_containers,
62− "-package=process-" ++ VERSION_process,
57+ "-package=process-" ++ VERSION_process,
63− "-package=filepath-" ++ VERSION_filepath,
58+ "-package=filepath-" ++ VERSION_filepath,
64− "-package=ref-tf-" ++ VERSION_ref_tf,
59+ "-package=ref-tf-" ++ VERSION_ref_tf,
65− "-package=deepseq-" ++ VERSION_deepseq,
60+ "-package=deepseq-" ++ VERSION_deepseq,
66− "-package=ghc-prim-" ++ VERSION_ghc_prim,
61+ "-package=ghc-prim-" ++ VERSION_ghc_prim,
67− "-package=exceptions-" ++ VERSION_exceptions,
62+ "-i" <> jsaddlePath </> "jsaddle-warp/src",
68− "-package=unliftio-core-" ++ VERSION_unliftio_core,
63+ "-i" <> jsaddlePath </> "jsaddle-warp/src-ghc",
69− "-package=random-" ++ VERSION_random,
70− "-package=foreign-store-" ++ VERSION_foreign_store,
71− "-i" <> "src",
72− "-i" <> "src-ghc",
73− "src/Language/Javascript/JSaddle/Test.hs",
64+ jsaddlePath </> "jsaddle-warp/src/Language/Javascript/JSaddle/Test.hs",
74− "-i" <> jsaddlePath,
65+ "-i" <> jsaddlePath </> "jsaddle",
75− jsaddlePath </> "src-ghc/Data/JSString/Text.hs",
66+ jsaddlePath </> "jsaddle/src-ghc/GHCJS/Marshal.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",
67+ jsaddlePath </> "jsaddle/src-ghc/GHCJS/Marshal/Pure.hs",
82− jsaddlePath </> "src-ghc/GHCJS/Marshal/Internal.hs",
68+ jsaddlePath </> "jsaddle/src-ghc/GHCJS/Marshal/Internal.hs",
83− jsaddlePath </> "src-ghc/GHCJS/Prim.hs",
69+ jsaddlePath </> "jsaddle/src-ghc/JavaScript/Array/Internal.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",
70+ jsaddlePath </> "jsaddle/src-ghc/JavaScript/Object/Internal.hs",
88− jsaddlePath </> "src-ghc/JavaScript/Object/Internal.hs",
71+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle.hs",
89− jsaddlePath </> "src/Language/Javascript/JSaddle.hs",
72+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Array.hs",
90− jsaddlePath </> "src/Language/Javascript/JSaddle/Arguments.hs",
73+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Arguments.hs",
91− jsaddlePath </> "src/Language/Javascript/JSaddle/Classes.hs",
74+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Classes.hs",
92− jsaddlePath </> "src/Language/Javascript/JSaddle/Classes/Internal.hs",
75+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Classes/Internal.hs",
93− jsaddlePath </> "src/Language/Javascript/JSaddle/Debug.hs",
94− jsaddlePath </> "src/Language/Javascript/JSaddle/Evaluate.hs",
76+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Evaluate.hs",
95− jsaddlePath </> "src/Language/Javascript/JSaddle/Exception.hs",
77+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Exception.hs",
78+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Foreign.hs",
96− jsaddlePath </> "src/Language/Javascript/JSaddle/Monad.hs",
79+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Monad.hs",
97− jsaddlePath </> "src/Language/Javascript/JSaddle/Marshal/String.hs",
80+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Marshal/String.hs",
98− jsaddlePath </> "src/Language/Javascript/JSaddle/Native.hs",
81+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Native.hs",
99− jsaddlePath </> "src/Language/Javascript/JSaddle/Native/Internal.hs",
82+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Native/Internal.hs",
100− jsaddlePath </> "src/Language/Javascript/JSaddle/Object.hs",
83+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Object.hs",
101− jsaddlePath </> "src/Language/Javascript/JSaddle/Properties.hs",
84+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Properties.hs",
102− jsaddlePath </> "src/Language/Javascript/JSaddle/Run.hs",
85+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Run.hs",
103− jsaddlePath </> "src/Language/Javascript/JSaddle/Run/Files.hs",
86+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs",
104− jsaddlePath </> "src/Language/Javascript/JSaddle/String.hs",
87+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/String.hs",
105− jsaddlePath </> "src/Language/Javascript/JSaddle/Types.hs",
88+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Types.hs",
106− jsaddlePath </> "src/Language/Javascript/JSaddle/Value.hs" ]
89+ jsaddlePath </> "jsaddle/src/Language/Javascript/JSaddle/Value.hs" ]
107− putMVar done ()
108− threadDelay 5000000
109− runSession defaultConfig $ do
110− openPage "http://127.0.0.1:3709"
111− liftIO $ takeMVar done
112− closeSession
jsaddle-webkit2gtk/jsaddle-webkit2gtk.cabal+12−19
@@ -1,5 +1,5 @@
1name: jsaddle-webkit2gtk
1name: jsaddle-webkit2gtk
2−version: 0.9.8.0
2+version: 0.7.1.0
3cabal-version: >=1.10
3cabal-version: >=1.10
4build-type: Simple
4build-type: Simple
5license: MIT
5license: MIT
@@ -17,32 +17,25 @@ author: Hamish Mackenzie
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-webkit2gtk
21
20
22library
21library
23 exposed-modules:
22 exposed-modules:
24− Language.Javascript.JSaddle.WebKitGTK
23+ Language.Javascript.JSaddle.WebKit2GTK
25 build-depends:
24 build-depends:
26− base <5
27− if !impl(ghcjs -any)
28− build-depends:
29− aeson >=0.8.0.2 && <1.6,
25+ aeson >=0.8.0.2 && <1.1,
30 base <5,
26 base <5,
31 bytestring >=0.10.6.0 && <0.11,
27 bytestring >=0.10.6.0 && <0.11,
32− directory >=1.0.0.2 && <1.4,
28+ directory >=1.0.0.2 && <1.3,
33− gi-glib >=2.0.14 && <2.1,
29+ gi-glib >=2.0.6 && <2.1,
34− gi-gio >=2.0.14 && <2.1,
30+ gi-gio >=2.0.6 && <2.1,
35− gi-gtk >=3.0.17 && <3.1,
31+ gi-gtk >=3.0.6 && <3.1,
36− gi-webkit2 >=4.0.14 && <4.1,
32+ gi-webkit2 >=4.0.6 && <4.1,
37− gi-javascriptcore >=4.0.14 && <4.1,
33+ gi-javascriptcore >=4.0.6 && <4.1,
38− haskell-gi-base >=0.20 && <0.26,
34+ haskell-gi-base >=0.20 && <0.21,
39− haskell-gi-overloading >=0.0 && < 2.0,
40− jsaddle >=0.9.4.0 && <0.10,
35+ jsaddle >=0.7.0.0 && <0.8,
41 text >=1.2.1.3 && <1.3,
36 text >=1.2.1.3 && <1.3,
37+ unix >=2.3.1.0 && <2.8,
42 webkit2gtk3-javascriptcore >=0.14.0.0 && <0.15
38 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
39 default-language: Haskell2010
47 hs-source-dirs: src
40 hs-source-dirs: src
48 ghc-options: -ferror-spans -Wall
41 ghc-options: -ferror-spans -Wall
jsaddle-webkit2gtk/src/Language/Javascript/JSaddle/WebKitGTK.hs → jsaddle-webkit2gtk/src/Language/Javascript/JSaddle/WebKit2GTK.hsrenamed+55−72
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE ScopedTypeVariables #-}
1{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE PatternSynonyms #-}
3{-# LANGUAGE PatternSynonyms #-}
@@ -14,95 +13,97 @@
14-- |
13-- |
15--
14--
16-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
17−module Language.Javascript.JSaddle.WebKitGTK (
16+module Language.Javascript.JSaddle.WebKit2GTK (
18 -- * Running JSM in a WebView
17 -- * Running JSM in a WebView
19 run
18 run
20−#ifndef ghcjs_HOST_OS
21 , runInWebView
19 , runInWebView
22−#endif
23 ) where
20 ) where
24
21
25−#ifdef ghcjs_HOST_OS
26−
27−run :: IO () -> IO ()
28−run = id
29−{-# INLINE run #-}
30−
31−#else
32−
33import Control.Monad (void)
22import Control.Monad (void)
34import Control.Monad.IO.Class (MonadIO(..), MonadIO)
23import Control.Monad.IO.Class (MonadIO(..), MonadIO)
35import Control.Concurrent (forkIO, yield)
24import Control.Concurrent (forkIO, yield)
36
25
37−#ifndef mingw32_HOST_OS
38import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch))
26import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch))
39−#endif
40import System.Directory (getCurrentDirectory)
27import System.Directory (getCurrentDirectory)
41
28
42import Data.Monoid ((<>))
29import Data.Monoid ((<>))
43import Data.ByteString.Lazy (toStrict, fromStrict)
30import Data.ByteString.Lazy (toStrict, fromStrict)
44import qualified Data.ByteString.Lazy as LB (ByteString)
31import qualified Data.ByteString.Lazy as LB (ByteString)
45import Data.Aeson (encode, decode)
32import Data.Aeson (encode, decode)
33+import Data.Text (Text)
46import qualified Data.Text as T (pack)
34import qualified Data.Text as T (pack)
35+import Data.Text.Foreign (fromPtr)
47import Data.Text.Encoding (decodeUtf8, encodeUtf8)
36import Data.Text.Encoding (decodeUtf8, encodeUtf8)
48
37
38+import Foreign.Ptr (castPtr, nullPtr)
39+
49import Data.GI.Base.BasicTypes (GObject)
40import Data.GI.Base.BasicTypes (GObject)
50import Data.GI.Base.Signals
41import Data.GI.Base.Signals
51 (connectSignalFunPtr, SignalConnectMode(..), SignalConnectMode,
42 (connectSignalFunPtr, SignalConnectMode(..), SignalConnectMode,
52 SignalHandlerId)
43 SignalHandlerId)
44+import Data.GI.Base.ManagedPtr (withManagedPtr)
53
45
54import GI.GLib (timeoutAdd, idleAdd, pattern PRIORITY_HIGH, pattern PRIORITY_DEFAULT)
46import GI.GLib (timeoutAdd, idleAdd, pattern PRIORITY_HIGH, pattern PRIORITY_DEFAULT)
55import qualified GI.Gtk as Gtk (main, init)
47import qualified GI.Gtk as Gtk (main, init)
56import GI.Gtk
48import GI.Gtk
57 (windowSetPosition, windowSetDefaultSize, windowNew,
49 (windowSetPosition, windowSetDefaultSize, windowNew,
58− scrolledWindowNew, Adjustment, containerAdd,
50+ scrolledWindowNew, noAdjustment, containerAdd,
59 WindowType(..), WindowPosition(..), widgetDestroy,
51 WindowType(..), WindowPosition(..), widgetDestroy,
60 widgetGetToplevel, widgetShowAll, onWidgetDestroy,
52 widgetGetToplevel, widgetShowAll, onWidgetDestroy,
61 mainQuit)
53 mainQuit)
62−import GI.Gio (Cancellable)
54+import GI.Gio (noCancellable)
63−import GI.JavaScriptCore (valueToString)
55+import GI.JavaScriptCore (Value(..), GlobalContext(..))
64import GI.WebKit2
56import GI.WebKit2
65− (scriptDialogPromptSetText, scriptDialogPromptGetDefaultText,
66− scriptDialogGetMessage, scriptDialogGetDialogType,
67− onWebViewScriptDialog, WebView,
68− setSettingsEnableWriteConsoleMessagesToStdout,
57+ (WebView, setSettingsEnableWriteConsoleMessagesToStdout,
69− setSettingsEnableJavascript, webViewNewWithUserContentManager,
58+ setSettingsEnableJavascript,
70− userContentManagerNew,
59+ webViewNewWithUserContentManager, userContentManagerNew,
71 userContentManagerRegisterScriptMessageHandler,
60 userContentManagerRegisterScriptMessageHandler,
72− javascriptResultGetJsValue,
61+ javascriptResultGetValue, javascriptResultGetGlobalContext,
73 webViewGetUserContentManager,
62 webViewGetUserContentManager,
74 mk_UserContentManagerScriptMessageReceivedCallback,
63 mk_UserContentManagerScriptMessageReceivedCallback,
75 wrap_UserContentManagerScriptMessageReceivedCallback,
64 wrap_UserContentManagerScriptMessageReceivedCallback,
76 webViewRunJavascript, LoadEvent(..),
65 webViewRunJavascript, LoadEvent(..),
77 UserContentManagerScriptMessageReceivedCallback, webViewLoadHtml,
66 UserContentManagerScriptMessageReceivedCallback, webViewLoadHtml,
78 onWebViewLoadChanged, setSettingsEnableDeveloperExtras,
67 onWebViewLoadChanged, setSettingsEnableDeveloperExtras,
79− webViewSetSettings, webViewGetSettings, ScriptDialogType(..))
68+ webViewSetSettings, webViewGetSettings)
69+
70+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
71+ (JSValueRef, JSContextRef)
72+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
73+ (jsstringgetcharactersptr, jsstringgetlength, jsstringrelease)
74+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
75+ (jsvaluetostringcopy)
80
76
81−import Language.Javascript.JSaddle (JSM, Results, Batch)
77+import Language.Javascript.JSaddle (JSM, Results)
82import Language.Javascript.JSaddle.Run (runJavaScript)
78import Language.Javascript.JSaddle.Run (runJavaScript)
83import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
79import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
84
80
85−noAdjustment :: Maybe Adjustment
86−noAdjustment = Nothing
87−
88−noCancellable :: Maybe Cancellable
89−noCancellable = Nothing
90−
91quitWebView :: WebView -> IO ()
81quitWebView :: WebView -> IO ()
92quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv --TODO: Shouldn't this be postGUISync?
82quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv --TODO: Shouldn't this be postGUISync?
93 widgetDestroy w
83 widgetDestroy w
94
84
95installQuitHandler :: WebView -> IO ()
85installQuitHandler :: WebView -> IO ()
96−#ifdef mingw32_HOST_OS
97−installQuitHandler wv = return () -- TODO: Maybe figure something out here for Windows users.
98−#else
99installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) Nothing
86installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) Nothing
100−#endif
101
87
102postGUIAsync :: IO () -> IO ()
88postGUIAsync :: IO () -> IO ()
103postGUIAsync action =
89postGUIAsync action =
104 void . idleAdd PRIORITY_DEFAULT $ action >> return False
90 void . idleAdd PRIORITY_DEFAULT $ action >> return False
105
91
92+withJSContextRef :: GlobalContext -> (JSContextRef -> IO a) -> IO a
93+withJSContextRef (GlobalContext ctx) f = withManagedPtr ctx (f . castPtr)
94+
95+withJSValueRef :: Value -> (JSValueRef -> IO a) -> IO a
96+withJSValueRef (Value ptr) f = withManagedPtr ptr (f . castPtr)
97+
98+valueToText :: JSContextRef -> JSValueRef -> IO Text
99+valueToText ctxRef s = do
100+ jsstring <- jsvaluetostringcopy ctxRef s nullPtr
101+ l <- jsstringgetlength jsstring
102+ p <- jsstringgetcharactersptr jsstring
103+ result <- fromPtr (castPtr p) (fromIntegral l)
104+ jsstringrelease jsstring
105+ return result
106+
106run :: JSM () -> IO ()
107run :: JSM () -> IO ()
107run main = do
108run main = do
108 _ <- Gtk.init Nothing
109 _ <- Gtk.init Nothing
@@ -127,17 +128,17 @@ run main = do
127 void . onWebViewLoadChanged webView $ \case
128 void . onWebViewLoadChanged webView $ \case
128 LoadEventFinished -> runInWebView main webView
129 LoadEventFinished -> runInWebView main webView
129 _ -> return ()
130 _ -> return ()
130− webViewLoadHtml webView "" . Just $ "file://" <> T.pack pwd <> "/index.html"
131+ webViewLoadHtml webView "" . Just $ "file://" <> T.pack pwd <> "/"
131 installQuitHandler webView
132 installQuitHandler webView
132 Gtk.main
133 Gtk.main
133
134
134runInWebView :: JSM () -> WebView -> IO ()
135runInWebView :: JSM () -> WebView -> IO ()
135runInWebView f webView = do
136runInWebView f webView = do
136− (processResults, syncResults, start) <- runJavaScript (\batch -> postGUIAsync $
137+ (processResults, start) <- runJavaScript (\batch -> postGUIAsync $
137 webViewRunJavascript webView (decodeUtf8 . toStrict $ "runJSaddleBatch(" <> encode batch <> ");") noCancellable Nothing)
138 webViewRunJavascript webView (decodeUtf8 . toStrict $ "runJSaddleBatch(" <> encode batch <> ");") noCancellable Nothing)
138 f
139 f
139
140
140− addJSaddleHandler webView processResults syncResults
141+ addJSaddleHandler webView processResults
141 webViewRunJavascript webView (decodeUtf8 $ toStrict jsaddleJs) noCancellable . Just $
142 webViewRunJavascript webView (decodeUtf8 $ toStrict jsaddleJs) noCancellable . Just $
142 \_obj _asyncResult ->
143 \_obj _asyncResult ->
143 void $ forkIO start
144 void $ forkIO start
@@ -151,43 +152,25 @@ connectUserContentManagerScriptMessageReceived obj cb after = liftIO $ do
151 let cb' = wrap_UserContentManagerScriptMessageReceivedCallback cb
152 let cb' = wrap_UserContentManagerScriptMessageReceivedCallback cb
152 cb'' <- mk_UserContentManagerScriptMessageReceivedCallback cb'
153 cb'' <- mk_UserContentManagerScriptMessageReceivedCallback cb'
153 connectSignalFunPtr obj "script-message-received::jsaddle" cb'' after
154 connectSignalFunPtr obj "script-message-received::jsaddle" cb'' after
154−#if MIN_VERSION_haskell_gi_base(0,23,0)
155− Nothing
156−#endif
157
155
158−addJSaddleHandler :: WebView -> (Results -> IO ()) -> (Results -> IO Batch) -> IO ()
156+addJSaddleHandler :: WebView -> (Results -> IO ()) -> IO ()
159−addJSaddleHandler webView processResult syncResults = do
157+addJSaddleHandler webView processResult = do
160 manager <- webViewGetUserContentManager webView
158 manager <- webViewGetUserContentManager webView
161 _ <- onUserContentManagerScriptMessageReceived manager $ \result -> do
159 _ <- onUserContentManagerScriptMessageReceived manager $ \result -> do
162− arg <- javascriptResultGetJsValue result
160+ ctx <- javascriptResultGetGlobalContext result
163− bs <- encodeUtf8 <$> valueToString arg
161+ arg <- javascriptResultGetValue result
162+ bs <- withJSContextRef ctx $ \ctxRef ->
163+ withJSValueRef arg $ \argRef ->
164+ encodeUtf8 <$> valueToText ctxRef argRef
164 mapM_ processResult (decode (fromStrict bs))
165 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"
166 void $ userContentManagerRegisterScriptMessageHandler manager "jsaddle"
181
167
182jsaddleJs :: LB.ByteString
168jsaddleJs :: LB.ByteString
183−jsaddleJs = ghcjsHelpers <> mconcat
169+jsaddleJs = ghcjsHelpers <> "\
184− [ "runJSaddleBatch = (function() {\n"
170+ \runJSaddleBatch = (function() {\n\
185− , initState
171+ \ " <> initState <> "\n\
186− , "\nreturn function(batch) {\n"
172+ \ return function(batch) {\n\
187− , runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));\n")
173+ \ " <> runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));") <> "\
188− (Just (\a -> "JSON.parse(window.prompt(\"JSaddleSync\", JSON.stringify(" <> a <> ")))"))
189− , "};\n"
174+ \ };\n\
190− , "})()"
175+ \})()\n\
191− ]
176+ \"
192−
193−#endif
jsaddle-webkitgtk/jsaddle-webkitgtk.cabal+5−8
@@ -1,5 +1,5 @@
1name: jsaddle-webkitgtk
1name: jsaddle-webkitgtk
2−version: 0.9.0.0
2+version: 0.7.1.0
3cabal-version: >=1.10
3cabal-version: >=1.10
4build-type: Simple
4build-type: Simple
5license: MIT
5license: MIT
@@ -17,27 +17,24 @@ author: Hamish Mackenzie
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-webkitgtk
21
20
22library
21library
23 exposed-modules:
22 exposed-modules:
24 Language.Javascript.JSaddle.WebKitGTK
23 Language.Javascript.JSaddle.WebKitGTK
25 build-depends:
24 build-depends:
26− aeson >=0.8.0.2 && <1.3,
25+ aeson >=0.8.0.2 && <1.1,
27 base <5,
26 base <5,
28 bytestring >=0.10.6.0 && <0.11,
27 bytestring >=0.10.6.0 && <0.11,
29− directory >=1.0.0.2 && <1.4,
28+ directory >=1.0.0.2 && <1.3,
30 gi-glib >=2.0.6 && <2.1,
29 gi-glib >=2.0.6 && <2.1,
31 gi-gtk >=3.0.6 && <3.1,
30 gi-gtk >=3.0.6 && <3.1,
32 gi-webkit >=3.0.6 && <3.1,
31 gi-webkit >=3.0.6 && <3.1,
33 gi-javascriptcore >=3.0.6 && <3.1,
32 gi-javascriptcore >=3.0.6 && <3.1,
34 haskell-gi-base >=0.20 && <0.21,
33 haskell-gi-base >=0.20 && <0.21,
35− jsaddle >=0.9.0.0 && <0.10,
34+ jsaddle >=0.7.0.0 && <0.8,
36 text >=1.2.1.3 && <1.3,
35 text >=1.2.1.3 && <1.3,
36+ unix >=2.3.1.0 && <2.8,
37 webkitgtk3-javascriptcore >=0.14.0.0 && <0.15
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
38 default-language: Haskell2010
42 hs-source-dirs: src
39 hs-source-dirs: src
43 ghc-options: -ferror-spans -Wall
40 ghc-options: -ferror-spans -Wall
jsaddle-webkitgtk/src/Language/Javascript/JSaddle/WebKitGTK.hs+11−30
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE ScopedTypeVariables #-}
1{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE PatternSynonyms #-}
3{-# LANGUAGE PatternSynonyms #-}
@@ -17,27 +16,15 @@
17module Language.Javascript.JSaddle.WebKitGTK (
16module Language.Javascript.JSaddle.WebKitGTK (
18 -- * Running JSM in a WebView
17 -- * Running JSM in a WebView
19 run
18 run
20−#ifndef ghcjs_HOST_OS
21 , runInWebView
19 , runInWebView
22−#endif
23 ) where
20 ) where
24
21
25−#ifdef ghcjs_HOST_OS
26−
27−run :: IO () -> IO ()
28−run = id
29−{-# INLINE run #-}
30−
31−#else
32−
33import Control.Monad (when, void)
22import Control.Monad (when, void)
34import qualified Control.Exception as E (catch)
23import qualified Control.Exception as E (catch)
35import Control.Exception (SomeException(..))
24import Control.Exception (SomeException(..))
36import Control.Concurrent (forkIO, yield)
25import Control.Concurrent (forkIO, yield)
37
26
38−#ifndef mingw32_HOST_OS
39−import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch))
27+import System.Posix.Signals (installHandler)
40−#endif
41import System.Directory (getCurrentDirectory)
28import System.Directory (getCurrentDirectory)
42
29
43import Data.Monoid ((<>))
30import Data.Monoid ((<>))
@@ -96,11 +83,7 @@ quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv --TODO: Shouldn't t
96 widgetDestroy w
83 widgetDestroy w
97
84
98installQuitHandler :: WebView -> IO ()
85installQuitHandler :: WebView -> IO ()
99−#ifdef mingw32_HOST_OS
100−installQuitHandler wv = return () -- TODO: Maybe figure something out here for Windows users.
101−#else
102installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) Nothing
86installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) Nothing
103−#endif
104
87
105postGUIAsync :: IO () -> IO ()
88postGUIAsync :: IO () -> IO ()
106postGUIAsync action =
89postGUIAsync action =
@@ -185,7 +168,7 @@ runInWebView f webView = do
185 jsvalueprotect ctxRef result
168 jsvalueprotect ctxRef result
186 return result
169 return result
187
170
188− (processResults, _, start) <- runJavaScript (\batch -> postGUIAsync $
171+ (processResults, start) <- runJavaScript (\batch -> postGUIAsync $
189 withJSContextRef ctx $ \ctxRef ->
172 withJSContextRef ctx $ \ctxRef ->
190 withJSString (decodeUtf8 . toStrict $ encode batch) $ \script -> do
173 withJSString (decodeUtf8 . toStrict $ encode batch) $ \script -> do
191 val <- jsvaluemakestring ctxRef script
174 val <- jsvaluemakestring ctxRef script
@@ -217,14 +200,12 @@ addJSaddleHandler ctxRef processResult = do
217 jsvaluemakeundefined ctxRef
200 jsvaluemakeundefined ctxRef
218
201
219jsaddleJs :: LB.ByteString
202jsaddleJs :: LB.ByteString
220−jsaddleJs = ghcjsHelpers <> mconcat
203+jsaddleJs = ghcjsHelpers <> "\
221− [ "(function() {\n"
204+ \(function() {\n\
222− , initState
205+ \ " <> initState <> "\n\
223− , "\nreturn function(batchJSON) {\n"
206+ \ return function(batchJSON) {\n\
224− , " var batch = JSON.parse(batchJSON);\n"
207+ \ var batch = JSON.parse(batchJSON);\n\
225− , runBatch (\a -> "window.jsaddleCallback(JSON.stringify(" <> a <> "));\n") Nothing
208+ \ " <> runBatch (\a -> "window.jsaddleCallback(JSON.stringify(" <> a <> "));") <> "\
226− , "};\n"
209+ \ };\n\
227− , "})()\n"
210+ \})()\n\
228− ]
211+ \"
229−
230−#endif
jsaddle-wkwebview/cbits-cocoa/AppDelegate.mdeleted−126
@@ -1,126 +0,0 @@
1−#include "HsFFI.h"
2−#import <Cocoa/Cocoa.h>
3−#import <WebKit/WebKit.h>
4−
5−extern void callIO(HsStablePtr);
6−extern bool callWithCStringReturningBool(const char * _Nonnull, HsStablePtr);
7−extern void callWithCString(const char * _Nonnull, HsStablePtr);
8−extern void callWithWebView(WKWebView *, HsStablePtr);
9−
10−@interface AppDelegate : NSObject <NSApplicationDelegate>
11−@property (nonatomic, assign) IBOutlet NSWindow *window;
12−@property (nonatomic, assign) HsStablePtr handler;
13−
14−- (instancetype)initApp:(HsStablePtr)handler progName:(NSString *)progName;
15−@end
16−
17−HsStablePtr global_willFinishLaunchingWithOptions = 0;
18−HsStablePtr global_didFinishLaunchingWithOptions = 0;
19−HsStablePtr global_applicationUniversalLink = 0;
20−HsStablePtr global_applicationOpenFile = 0;
21−uint64_t global_developerExtrasEnabled = 1;
22−
23−@implementation AppDelegate
24−
25−- (void)applicationWillTerminate:(NSNotification *)aNotification {
26− // Insert code here to tear down your application
27−}
28−
29−-(id)initApp:(HsStablePtr)handler progName:(NSString *)progName {
30− self = [super init];
31− if (self) {
32− _handler = handler;
33− NSRect contentSize = NSMakeRect(0.0, 500.0, 1000.0, 700.0);
34− // TODO replace with once nix has newer Cocoa NSUInteger windowStyleMask = NSWindowStyleMaskTitled | NSWindowStyleMaskResizable | NSWindowStyleMaskClosable | NSWindowStyleMaskMiniaturizable;
35− NSUInteger windowStyleMask = NSTitledWindowMask | NSResizableWindowMask | NSClosableWindowMask | NSMiniaturizableWindowMask;
36− _window = [[NSWindow alloc] initWithContentRect:contentSize styleMask:windowStyleMask backing:NSBackingStoreBuffered defer:YES];
37− _window.backgroundColor = [NSColor whiteColor];
38− _window.title = progName;
39− }
40− return self;
41−}
42−
43−-(BOOL)application:(NSApplication *)sender openFile:(NSString *)filename {
44− bool b = callWithCStringReturningBool([filename UTF8String], global_applicationOpenFile);
45− return b ? YES : NO;
46−}
47−
48−-(void)applicationWillFinishLaunching:(NSNotification *)notification {
49− WKWebViewConfiguration *theConfiguration = [[WKWebViewConfiguration alloc] init];
50− if (global_developerExtrasEnabled) {
51− [theConfiguration.preferences setValue:@YES forKey:@"developerExtrasEnabled"];
52− }
53− WKWebView *webView = [[WKWebView alloc] initWithFrame: [_window.contentView frame] configuration:theConfiguration];
54− [_window setContentView:webView];
55− callWithWebView(webView, _handler);
56− callIO(global_willFinishLaunchingWithOptions);
57− // Listen to URL events
58− NSAppleEventManager *manager = [NSAppleEventManager sharedAppleEventManager];
59− [manager
60− setEventHandler:self
61− andSelector:@selector(applicationUniversalLink:)
62− forEventClass:kInternetEventClass
63− andEventID:kAEGetURL];
64−}
65−
66−- (void)applicationUniversalLink:(NSAppleEventDescriptor *)event {
67− NSString *url = [[event paramDescriptorForKeyword:keyDirectObject] stringValue];
68− callWithCString([url UTF8String], global_applicationUniversalLink);
69−}
70−
71−-(void)applicationDidFinishLaunching:(NSNotification *)notification {
72− [_window orderFrontRegardless];
73− [_window center];
74− [NSApp activateIgnoringOtherApps:YES];
75− callIO(global_didFinishLaunchingWithOptions);
76−}
77−
78−-(BOOL) applicationShouldTerminateAfterLastWindowClosed:(NSApplication *)app {
79− return YES;
80−}
81−
82−@end
83−
84−void runInWKWebView(HsStablePtr handler,
85− const char * _Nonnull progName,
86− HsStablePtr hs_willFinishLaunchingWithOptions,
87− HsStablePtr hs_didFinishLaunchingWithOptions,
88− HsStablePtr hs_applicationDidBecomeActive,
89− HsStablePtr hs_applicationWillResignActive,
90− HsStablePtr hs_applicationDidEnterBackground,
91− HsStablePtr hs_applicationWillEnterForeground,
92− HsStablePtr hs_applicationWillTerminate,
93− HsStablePtr hs_applicationSignificantTimeChange,
94− HsStablePtr hs_applicationUniversalLink,
95− const uint64_t hs_requestAuthorizationWithOptions,
96− const uint64_t hs_requestAuthorizationOptionBadge,
97− const uint64_t hs_requestAuthorizationOptionSound,
98− const uint64_t hs_requestAuthorizationOptionAlert,
99− const uint64_t hs_requestAuthorizationOptionCarPlay,
100− const uint64_t hs_registerForRemoteNotifications,
101− HsStablePtr hs_didRegisterForRemoteNotificationsWithDeviceToken,
102− HsStablePtr hs_didFailToRegisterForRemoteNotificationsWithError,
103− const uint64_t hs_developerExtrasEnabled,
104− HsStablePtr hs_applicationOpenFile) {
105− @autoreleasepool {
106− global_willFinishLaunchingWithOptions = hs_willFinishLaunchingWithOptions;
107− global_didFinishLaunchingWithOptions = hs_didFinishLaunchingWithOptions;
108− global_applicationUniversalLink = hs_applicationUniversalLink;
109− global_applicationOpenFile = hs_applicationOpenFile;
110− global_developerExtrasEnabled = hs_developerExtrasEnabled;
111− NSApplication *application = [NSApplication sharedApplication];
112− AppDelegate *appDelegate = [[AppDelegate alloc] initApp:handler progName:[NSString stringWithCString:progName encoding:NSUTF8StringEncoding]];
113− [application setDelegate:appDelegate];
114− const char * _Nonnull argv [] = {"", 0};
115− [application setActivationPolicy:NSApplicationActivationPolicyRegular];
116− [application
117− performSelectorOnMainThread:@selector(run)
118− withObject:nil
119− waitUntilDone:YES];
120− }
121−}
122−
123−BOOL openApp(NSURL * url) {
124− NSWorkspace *workspace = [NSWorkspace sharedWorkspace];
125− return [workspace openURL:url];
126−}
jsaddle-wkwebview/cbits-uikit/AppDelegate.hdeleted−8
@@ -1,8 +0,0 @@
1−#include "HsFFI.h"
2−#import <UIKit/UIKit.h>
3−
4−@interface AppDelegate : UIResponder <UIApplicationDelegate>
5−
6−@property (nonatomic, assign) UIWindow *window;
7−
8−@end
jsaddle-wkwebview/cbits-uikit/AppDelegate.mdeleted−207
@@ -1,207 +0,0 @@
1−#import "AppDelegate.h"
2−#import "ViewController.h"
3−#import <UserNotifications/UserNotifications.h>
4−#import <stdint.h>
5−
6−extern void callIO(HsStablePtr);
7−extern void callWithCString(const char * _Nonnull, HsStablePtr);
8−extern void callWithCIntCString(int n, const char * _Nonnull, HsStablePtr);
9−
10−@interface AppDelegate ()
11−
12−@end
13−
14−HsStablePtr globalHandler = 0;
15−HsStablePtr global_willFinishLaunchingWithOptions = 0;
16−HsStablePtr global_didFinishLaunchingWithOptions = 0;
17−HsStablePtr global_applicationDidBecomeActive = 0;
18−HsStablePtr global_applicationWillResignActive = 0;
19−HsStablePtr global_applicationDidEnterBackground = 0;
20−HsStablePtr global_applicationWillEnterForeground = 0;
21−HsStablePtr global_applicationWillTerminate = 0;
22−HsStablePtr global_applicationSignificantTimeChange = 0;
23−HsStablePtr global_applicationUniversalLink = 0;
24−HsStablePtr global_applicationDidReceiveRemoteNotification = 0;
25−uint64_t global_requestAuthorizationWithOptions = 0;
26−uint64_t global_requestAuthorizationOptionBadge = 0;
27−uint64_t global_requestAuthorizationOptionSound = 0;
28−uint64_t global_requestAuthorizationOptionAlert = 0;
29−uint64_t global_requestAuthorizationOptionCarPlay = 0;
30−uint64_t global_registerForRemoteNotifications = 0;
31−HsStablePtr global_didRegisterForRemoteNotificationsWithDeviceToken = 0;
32−HsStablePtr global_didFailToRegisterForRemoteNotificationsWithError = 0;
33−
34−@implementation AppDelegate
35−
36−- (BOOL)application:(UIApplication *)application willFinishLaunchingWithOptions:(NSDictionary *)launchOptions {
37− // Tells the delegate that the launch process has begun but that state restoration has not yet occurred.
38− callIO(global_willFinishLaunchingWithOptions);
39− return YES;
40−}
41−
42−- (BOOL)application:(UIApplication *)application didFinishLaunchingWithOptions:(NSDictionary *)launchOptions {
43− // Tells the delegate that the launch process is almost done and the app is almost ready to run.
44− self.window = [[UIWindow alloc] initWithFrame:[[UIScreen mainScreen] bounds]];
45− // Override point for customization after application launch.
46− self.window.rootViewController = [[ViewController alloc] initWithHandler:globalHandler];
47− self.window.backgroundColor = [UIColor whiteColor];
48− [self.window makeKeyAndVisible];
49− UNUserNotificationCenter* center = [UNUserNotificationCenter currentNotificationCenter];
50− center.delegate = self;
51− if (global_requestAuthorizationWithOptions) {
52− UNAuthorizationOptions options = (UNAuthorizationOptions)0;
53− if (global_requestAuthorizationOptionBadge) {
54− options = options | UNAuthorizationOptionBadge;
55− }
56− if (global_requestAuthorizationOptionSound) {
57− options = options | UNAuthorizationOptionSound;
58− }
59− if (global_requestAuthorizationOptionAlert) {
60− options = options | UNAuthorizationOptionAlert;
61− }
62− if (global_requestAuthorizationOptionCarPlay) {
63− options = options | UNAuthorizationOptionCarPlay;
64− }
65− [center requestAuthorizationWithOptions:(options)
66− completionHandler:^(BOOL granted, NSError * _Nullable error) {
67− // Handler used to alter application behavior based on types of notifications authorized
68− }];
69− if (global_registerForRemoteNotifications) {
70− [application registerForRemoteNotifications];
71− }
72− }
73− callIO(global_didFinishLaunchingWithOptions);
74− return YES;
75−}
76−
77−- (void)applicationWillResignActive:(UIApplication *)application {
78− // Sent when the application is about to move from active to inactive state. This can occur for certain types of temporary interruptions (such as an incoming phone call or SMS message) or when the user quits the application and it begins the transition to the background state.
79− // Use this method to pause ongoing tasks, disable timers, and invalidate graphics rendering callbacks. Games should use this method to pause the game.
80− callIO(global_applicationWillResignActive);
81−}
82−
83−
84−- (void)applicationDidEnterBackground:(UIApplication *)application {
85− // Use this method to release shared resources, save user data, invalidate timers, and store enough application state information to restore your application to its current state in case it is terminated later.
86− // If your application supports background execution, this method is called instead of applicationWillTerminate: when the user quits.
87− callIO(global_applicationDidEnterBackground);
88−}
89−
90−
91−- (void)applicationWillEnterForeground:(UIApplication *)application {
92− // Called as part of the transition from the background to the active state; here you can undo many of the changes made on entering the background.
93− callIO(global_applicationWillEnterForeground);
94−}
95−
96−
97−- (void)applicationDidBecomeActive:(UIApplication *)application {
98− // Restart any tasks that were paused (or not yet started) while the application was inactive. If the application was previously in the background, optionally refresh the user interface.
99− callIO(global_applicationDidBecomeActive);
100−}
101−
102−
103−- (void)applicationWillTerminate:(UIApplication *)application {
104− // Called when the application is about to terminate. Save data if appropriate. See also applicationDidEnterBackground:.
105− callIO(global_applicationWillTerminate);
106−}
107−
108−- (void)application:(UIApplication *)application didRegisterForRemoteNotificationsWithDeviceToken:(NSData *)deviceToken {
109− // Tells the delegate that the app successfully registered with Apple Push Notification service (APNs).
110− NSString *deviceTokenString = [deviceToken base64EncodedStringWithOptions: 0];
111− callWithCString([deviceTokenString UTF8String], global_didRegisterForRemoteNotificationsWithDeviceToken);
112−}
113−
114−- (void)application:(UIApplication *)application didReceiveRemoteNotification:(NSDictionary *)userInfo fetchCompletionHandler:(void (^)(UIBackgroundFetchResult result))completionHandler {
115− // Sent when the application receives remote notifications in the foreground or background
116− // TODO Allow a configurable CString -> IO () to be passed into AppDelegateConfig
117− if ([userInfo valueForKeyPath:@"aps.badge"] != nil) {
118− [UIApplication sharedApplication].applicationIconBadgeNumber=[[[userInfo objectForKey:@"aps"] objectForKey:@"badge"] intValue];
119− }
120− NSError *error;
121− NSData *jsonData = [NSJSONSerialization dataWithJSONObject:userInfo options:0 error:&error];
122− if (jsonData) {
123− NSString *jsonString = [[NSString alloc] initWithData:jsonData encoding:NSUTF8StringEncoding];
124− callWithCIntCString((int) application.applicationState, [jsonString UTF8String], global_applicationDidReceiveRemoteNotification);
125− } else {
126− NSLog(@"jsaddle-wkwebview didReceiveRemoteNotification handler: error while serialising push notification as JSON");
127− }
128− completionHandler(UIBackgroundFetchResultNewData);
129−}
130−
131−- (void)application:(UIApplication *)application didFailToRegisterForRemoteNotificationsWithError:(NSError *)error {
132− // Sent to the delegate when Apple Push Notification service cannot successfully complete the registration process.
133− NSString *errorString = [error localizedDescription];
134− callWithCString([errorString UTF8String], global_didFailToRegisterForRemoteNotificationsWithError);
135−}
136−
137−- (void)applicationSignificantTimeChange:(UIApplication *)application {
138− // Tells the delegate when there is a significant change in the time.
139− callIO(global_applicationSignificantTimeChange);
140−}
141−
142−- (BOOL)application:(UIApplication *)application continueUserActivity:(NSUserActivity *)userActivity restorationHandler:(void (^)(NSArray *restorableObjects))restorationHandler {
143− // TODO: Reroute universal links when they're clicked in-app.
144− // https://developer.apple.com/reference/webkit/wknavigationdelegate/1455643-webview?language=objc
145− if ([userActivity.activityType isEqualToString:NSUserActivityTypeBrowsingWeb] && userActivity.webpageURL) {
146− callWithCString([userActivity.webpageURL.absoluteString UTF8String], global_applicationUniversalLink);
147− return YES;
148− }
149− return NO;
150−}
151−
152−@end
153−
154−void runInWKWebView(HsStablePtr handler,
155− const char * _Nonnull progName,
156− HsStablePtr hs_willFinishLaunchingWithOptions,
157− HsStablePtr hs_didFinishLaunchingWithOptions,
158− HsStablePtr hs_applicationDidBecomeActive,
159− HsStablePtr hs_applicationWillResignActive,
160− HsStablePtr hs_applicationDidEnterBackground,
161− HsStablePtr hs_applicationWillEnterForeground,
162− HsStablePtr hs_applicationWillTerminate,
163− HsStablePtr hs_applicationSignificantTimeChange,
164− HsStablePtr hs_applicationUniversalLink,
165− HsStablePtr hs_applicationDidReceiveRemoteNotification,
166− const uint64_t hs_requestAuthorizationWithOptions,
167− const uint64_t hs_requestAuthorizationOptionBadge,
168− const uint64_t hs_requestAuthorizationOptionSound,
169− const uint64_t hs_requestAuthorizationOptionAlert,
170− const uint64_t hs_requestAuthorizationOptionCarPlay,
171− const uint64_t hs_registerForRemoteNotifications,
172− HsStablePtr hs_didRegisterForRemoteNotificationsWithDeviceToken,
173− HsStablePtr hs_didFailToRegisterForRemoteNotificationsWithError,
174− const uint64_t hs_developerExtrasEnabled) {
175− @autoreleasepool {
176− globalHandler = handler;
177− global_willFinishLaunchingWithOptions = hs_willFinishLaunchingWithOptions;
178− global_didFinishLaunchingWithOptions = hs_didFinishLaunchingWithOptions;
179− global_applicationDidBecomeActive = hs_applicationDidBecomeActive;
180− global_applicationWillResignActive = hs_applicationWillResignActive;
181− global_applicationDidEnterBackground = hs_applicationDidEnterBackground;
182− global_applicationWillEnterForeground = hs_applicationWillEnterForeground;
183− global_applicationWillTerminate = hs_applicationWillTerminate;
184− global_applicationSignificantTimeChange = hs_applicationSignificantTimeChange;
185− global_applicationUniversalLink = hs_applicationUniversalLink;
186− global_applicationDidReceiveRemoteNotification = hs_applicationDidReceiveRemoteNotification;
187− global_requestAuthorizationWithOptions = hs_requestAuthorizationWithOptions;
188− global_requestAuthorizationOptionBadge = hs_requestAuthorizationOptionBadge;
189− global_requestAuthorizationOptionSound = hs_requestAuthorizationOptionSound;
190− global_requestAuthorizationOptionAlert = hs_requestAuthorizationOptionAlert;
191− global_requestAuthorizationOptionCarPlay = hs_requestAuthorizationOptionCarPlay;
192− global_registerForRemoteNotifications = hs_registerForRemoteNotifications;
193− global_didRegisterForRemoteNotificationsWithDeviceToken = hs_didRegisterForRemoteNotificationsWithDeviceToken;
194− global_didFailToRegisterForRemoteNotificationsWithError = hs_didFailToRegisterForRemoteNotificationsWithError;
195− const char * _Nonnull argv [] = {"", 0};
196− UIApplicationMain(0, argv, nil, NSStringFromClass([AppDelegate class]));
197− }
198−}
199−
200−BOOL openApp(NSURL * url) {
201− UIApplication *app = [UIApplication sharedApplication];
202− if ([app canOpenURL:url]) {
203− [app openURL:url];
204− return true;
205− }
206− return false;
207−}
jsaddle-wkwebview/cbits-uikit/ViewController.hdeleted−10
@@ -1,10 +0,0 @@
1−#include "HsFFI.h"
2−#import <UIKit/UIKit.h>
3−#import <WebKit/WebKit.h>
4−
5−@interface ViewController : UIViewController
6−@property (nonatomic, assign) HsStablePtr handler;
7−@property (nonatomic, assign) WKWebView *webView;
8−
9−- (instancetype)initWithHandler:(HsStablePtr)handler;
10−@end
jsaddle-wkwebview/cbits-uikit/ViewController.mdeleted−40
@@ -1,40 +0,0 @@
1−#import "ViewController.h"
2−
3−extern void callWithWebView(WKWebView *, HsStablePtr);
4−
5−@interface ViewController ()
6−
7−@end
8−
9−@implementation ViewController
10−
11−-(id)initWithHandler:(HsStablePtr)handler {
12− self = [super init];
13− if (self) {
14− _handler = handler;
15− }
16− return self;
17−}
18−
19−- (void)loadView {
20− [super loadView];
21− // WKWebViewConfiguration *theConfiguration = [[WKWebViewConfiguration alloc] init];
22− // [theConfiguration.preferences setValue:@YES forKey:@"developerExtrasEnabled"];
23− _webView = [[WKWebView alloc] init];
24− _webView.autoresizingMask = UIViewAutoresizingFlexibleWidth | UIViewAutoresizingFlexibleHeight;
25− self.view = _webView;
26−}
27−
28−- (void)viewDidLoad {
29− [super viewDidLoad];
30− callWithWebView(_webView, _handler);
31−}
32−
33−
34−- (void)didReceiveMemoryWarning {
35− [super didReceiveMemoryWarning];
36− // Dispose of any resources that can be recreated.
37−}
38−
39−
40−@end
jsaddle-wkwebview/cbits/WKWebView.m+10−79
@@ -2,32 +2,26 @@
2#import <Foundation/Foundation.h>
2#import <Foundation/Foundation.h>
3#import <WebKit/WebKit.h>
3#import <WebKit/WebKit.h>
4
4
5−BOOL openApp(NSURL * url);
5+extern void jsaddleStart(HsStablePtr);
6+extern void jsaddleResult(HsStablePtr, const char * _Nonnull result);
6
7
7−@interface JSaddleHandler : NSObject<WKNavigationDelegate, WKScriptMessageHandler, WKUIDelegate>
8+@interface JSaddleHandler : NSObject<WKNavigationDelegate, WKScriptMessageHandler>
8
9
9@property (nonatomic, assign) HsStablePtr startHandler;
10@property (nonatomic, assign) HsStablePtr startHandler;
10@property (nonatomic, assign) HsStablePtr resultHandler;
11@property (nonatomic, assign) HsStablePtr resultHandler;
11−@property (nonatomic, assign) HsStablePtr syncHandler;
12−@property (nonatomic, assign) void (^completionHandler)(NSString *result);
13
12
14−- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler syncHandler:(HsStablePtr)syncHandler;
13+- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler;
15
14
16@end
15@end
17
16
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−
22@implementation JSaddleHandler
17@implementation JSaddleHandler
23
18
24−- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler syncHandler:(HsStablePtr)syncHandler
19+- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler
25{
20{
26 self = [super init];
21 self = [super init];
27 if (self) {
22 if (self) {
28 _startHandler = startHandler;
23 _startHandler = startHandler;
29 _resultHandler = resultHandler;
24 _resultHandler = resultHandler;
30− _syncHandler = syncHandler;
31 }
25 }
32 return self;
26 return self;
33}
27}
@@ -43,82 +37,19 @@ extern void jsaddleSyncResult(HsStablePtr, JSaddleHandler *, const char * _Nonnu
43 jsaddleResult(self.resultHandler, [s UTF8String]);
37 jsaddleResult(self.resultHandler, [s UTF8String]);
44}
38}
45
39
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−
72@end
40@end
73
41
74−void addJSaddleHandler(WKWebView *webView, HsStablePtr startHandler, HsStablePtr resultHandler, HsStablePtr syncHandler) {
42+void addJSaddleHandler(WKWebView *webView, HsStablePtr startHandler, HsStablePtr resultHandler) {
75− JSaddleHandler * handler = [[JSaddleHandler alloc] initHandler:startHandler resultHandler:resultHandler syncHandler:syncHandler];
43+ JSaddleHandler * handler = [[JSaddleHandler alloc] initHandler:startHandler resultHandler:resultHandler];
76 [[[webView configuration] userContentController] addScriptMessageHandler:handler name:@"jsaddle"];
44 [[[webView configuration] userContentController] addScriptMessageHandler:handler name:@"jsaddle"];
77−#ifdef USE_UIKIT
78− webView.scrollView.bounces = NO;
79−#endif
80 webView.navigationDelegate = handler;
45 webView.navigationDelegate = handler;
81− webView.UIDelegate = handler;
82}
46}
83
47
84void evaluateJavaScript(WKWebView *webView, const char * _Nonnull js) {
48void evaluateJavaScript(WKWebView *webView, const char * _Nonnull js) {
85− NSString *jsString = [[NSString alloc] initWithCString:js encoding:NSUTF8StringEncoding];
86− dispatch_async(dispatch_get_main_queue(), ^{
87− [webView evaluateJavaScript:jsString completionHandler:NULL];
88− [jsString release];
89− });
90−}
91−
92−void completeSync(JSaddleHandler *handler, const char * _Nonnull s) {
93− NSString *string = [[NSString alloc] initWithCString:s encoding:NSUTF8StringEncoding];
94− handler.completionHandler(string);
95− handler.completionHandler = NULL;
96−}
97−
98−void loadHTMLStringWithBaseURL(WKWebView *webView, const char * _Nonnull html, const char * _Nonnull url) {
99− NSString *htmlString = [NSString stringWithCString:html encoding:NSUTF8StringEncoding];
49+ [webView evaluateJavaScript:[NSString stringWithCString:js encoding:NSUTF8StringEncoding] completionHandler:NULL];
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− });
104}
50}
105
51
106−const char * mainBundleResourcePathC() {
52+void loadHTMLString(WKWebView *webView, const char * _Nonnull html) {
107− NSBundle *main = [NSBundle mainBundle];
53+ [webView loadHTMLString:[NSString stringWithCString:html encoding:NSUTF8StringEncoding] baseURL:NULL];
108− if(!main) return NULL;
109− NSString *path = main.resourcePath;
110− if(!path) return NULL;
111− return [path UTF8String];
112}
54}
113
55
114−void loadBundleFile(WKWebView *webView, const char * _Nonnull file, const char * _Nonnull allowing) {
115− NSBundle *main = [NSBundle mainBundle];
116− if(main) {
117− NSString *path = main.resourcePath;
118− if(path) {
119− NSURL *fileUrl = [NSURL fileURLWithPath:[NSString stringWithFormat: @"%@/%@", path, [NSString stringWithCString:file encoding:NSUTF8StringEncoding]]];
120− NSURL *allowingUrl = [NSURL fileURLWithPath:[NSString stringWithFormat: @"%@/%@", path, [NSString stringWithCString:allowing encoding:NSUTF8StringEncoding]]];
121− [webView loadFileURL:fileUrl allowingReadAccessToURL:allowingUrl];
122− }
123− }
124−}
jsaddle-wkwebview/default.nixdeleted−14
@@ -1,14 +0,0 @@
1−{ filterSource ? (x: x) }:
2−self: super:
3−let
4− pkgs = self.callPackage ({pkgs}: pkgs) {};
5− inherit (pkgs) lib;
6−in
7−with pkgs.haskell.lib;
8−overrideCabal (self.callCabal2nix "jsaddle-wkwebview" (filterSource ./.) {}) (drv: {
9− libraryFrameworkDepends = (drv.libraryFrameworkDepends or []) ++
10− (if pkgs.stdenv.hostPlatform.useiOSPrebuilt then [
11− "${pkgs.buildPackages.darwin.xcode}/Contents/Developer/Platforms/${pkgs.stdenv.hostPlatform.xcodePlatform}.platform/Developer/SDKs/${pkgs.stdenv.hostPlatform.xcodePlatform}.sdk/System"
12− ] else (with pkgs.buildPackages.darwin.apple_sdk.frameworks; [ Cocoa WebKit ]));
13− buildDepends = lib.optional (!pkgs.stdenv.hostPlatform.useiOSPrebuilt) [ pkgs.buildPackages.darwin.cf-private ];
14−})
jsaddle-wkwebview/jsaddle-wkwebview.cabal+7−39
@@ -1,5 +1,5 @@
1name: jsaddle-wkwebview
1name: jsaddle-wkwebview
2−version: 0.9.8.0
2+version: 0.7.0.0
3cabal-version: >=1.10
3cabal-version: >=1.10
4build-type: Simple
4build-type: Simple
5license: MIT
5license: MIT
@@ -14,10 +14,6 @@ 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−
21source-repository head
17source-repository head
22 type: git
18 type: git
23 location: https://github.com/ghcjs/jsaddle
19 location: https://github.com/ghcjs/jsaddle
@@ -26,40 +22,12 @@ library
26 exposed-modules:
22 exposed-modules:
27 Language.Javascript.JSaddle.WKWebView
23 Language.Javascript.JSaddle.WKWebView
28 build-depends:
24 build-depends:
25+ aeson >=0.8.0.2 && <1.1,
29− base <5
26+ base <5,
27+ bytestring >=0.10.6.0 && <0.11,
28+ jsaddle >= 0.7.0.0 && <0.8
30 default-language: Haskell2010
29 default-language: Haskell2010
31 hs-source-dirs: src
30 hs-source-dirs: src
32 ghc-options: -ferror-spans -Wall
31 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.hsdeleted−219
@@ -1,219 +0,0 @@
1−module Language.Javascript.JSaddle.WKWebView
2− ( jsaddleMain
3− , jsaddleMainHTMLWithBaseURL
4− , jsaddleMainFile
5− , WKWebView(..)
6− , run
7− , run'
8− , runWithAppConfig
9− , runHTMLWithBaseURL
10− , runFile
11− , mainBundleResourcePath
12− , ApplicationState (..)
13− , AppDelegateConfig (..)
14− , AppDelegateNotificationConfig (..)
15− , AuthorizationOption (..)
16− ) where
17−
18−import Data.ByteString (ByteString)
19−import Data.Default (Default, def)
20−import Data.Set (Set)
21−import qualified Data.Set as Set
22−import Data.Word
23−import Foreign.Marshal.Utils (fromBool)
24−import Language.Javascript.JSaddle.WKWebView.Internal
25− (jsaddleMain, jsaddleMainHTMLWithBaseURL, jsaddleMainFile, WKWebView(..), mainBundleResourcePath)
26−import System.Environment (getProgName)
27−import Foreign.C.String (CString, withCString)
28−import Foreign.C.Types (CBool, CInt)
29−import Foreign.StablePtr (StablePtr, newStablePtr)
30−import Language.Javascript.JSaddle (JSM)
31−
32−foreign import ccall runInWKWebView
33− :: StablePtr (WKWebView -> IO ())
34− -> CString
35− -> StablePtr (IO ()) -- willFinishLaunchingWithOptions
36− -> StablePtr (IO ()) -- didFinishLaunchingWithOptions
37− -> StablePtr (IO ()) -- applicationDidBecomeActive
38− -> StablePtr (IO ()) -- applicationWillResignActive
39− -> StablePtr (IO ()) -- applicationDidEnterBackground
40− -> StablePtr (IO ()) -- applicationWillEnterForeground
41− -> StablePtr (IO ()) -- applicationWillTerminate
42− -> StablePtr (IO ()) -- applicationSignificantTimeChange
43− -> StablePtr (CString -> IO ()) -- applicationUniversalLink
44− -> StablePtr (CInt -> CString -> IO ()) -- applicationDidReceiveRemoteNotification
45− -> Word64 -- whether to run requestAuthorizationWithOptions
46− -> Word64 -- Ask for Badge authorization
47− -> Word64 -- Ask for Sound authorization
48− -> Word64 -- Ask for Alert authorization
49− -> Word64 -- Ask for CarPlay authorization
50− -> Word64 -- registerForRemoteNotifications
51− -> StablePtr (CString -> IO ()) -- didRegisterForRemoteNotificationsWithDeviceToken
52− -> StablePtr (CString -> IO ()) -- didFailToRegisterForRemoteNotificationsWithError
53− -> Word64 -- developerExtrasEnabled
54− -> StablePtr (CString -> IO CBool) -- applicationOpenFile
55− -> IO ()
56−
57−data AppDelegateConfig = AppDelegateConfig
58− { _appDelegateConfig_willFinishLaunchingWithOptions :: IO ()
59− , _appDelegateConfig_didFinishLaunchingWithOptions :: IO ()
60− , _appDelegateConfig_applicationDidBecomeActive :: IO ()
61− , _appDelegateConfig_applicationWillResignActive :: IO ()
62− , _appDelegateConfig_applicationDidEnterBackground :: IO ()
63− , _appDelegateConfig_applicationWillEnterForeground :: IO ()
64− , _appDelegateConfig_applicationWillTerminate :: IO ()
65− , _appDelegateConfig_applicationSignificantTimeChange :: IO ()
66− , _appDelegateConfig_applicationUniversalLink :: CString -> IO ()
67− -- ^ Called when the app is launched from a URL. 'CString' contains the URL.
68− --
69− -- The Core Foundation plist key CFBundleURLTypes controls which URL schemes
70− -- the app should respond to.
71− , _appDelegateConfig_applicationDidReceiveRemoteNotification :: ApplicationState -> CString -> IO ()
72− -- ^ Called when the application receives a remote notification.
73− -- 'ApplicationState' is the current state of the app.
74− -- The 'CString' JSON-encoded user info contained in the notification.
75− -- For more information see https://developer.apple.com/documentation/uikit/uiapplicationdelegate/1623117-application?language=objc
76− , _appDelegateConfig_appDelegateNotificationConfig :: AppDelegateNotificationConfig
77− , _appDelegateConfig_developerExtrasEnabled :: Bool
78− -- ^ Allow devtools in the app. Defaults to 'True'
79− , _appDelegateConfig_applicationOpenFile :: CString -> IO Bool
80− -- ^ Called when the app is launched by opening a file. 'CString' contains
81− -- the file path. Return value is 'True' if the file was successfully
82− -- opened. Defaults to ignoring the file and returning 'False'.
83− --
84− -- The Core Foundation plist key CFBundleDocumentTypes controls which file
85− -- types should be associated with the app.
86− }
87−
88−instance Default AppDelegateConfig where
89− def = AppDelegateConfig
90− { _appDelegateConfig_willFinishLaunchingWithOptions = return ()
91− , _appDelegateConfig_didFinishLaunchingWithOptions = return ()
92− , _appDelegateConfig_applicationDidBecomeActive = return ()
93− , _appDelegateConfig_applicationWillResignActive = return ()
94− , _appDelegateConfig_applicationDidEnterBackground = return ()
95− , _appDelegateConfig_applicationWillEnterForeground = return ()
96− , _appDelegateConfig_applicationWillTerminate = return ()
97− , _appDelegateConfig_applicationSignificantTimeChange = return ()
98− , _appDelegateConfig_applicationUniversalLink = \_ -> return ()
99− , _appDelegateConfig_applicationDidReceiveRemoteNotification = \_ _ -> return ()
100− , _appDelegateConfig_appDelegateNotificationConfig = def
101− , _appDelegateConfig_developerExtrasEnabled = True
102− , _appDelegateConfig_applicationOpenFile = \_ -> return False
103− }
104−
105−data AuthorizationOption = AuthorizationOption_Badge
106− | AuthorizationOption_Sound
107− | AuthorizationOption_Alert
108− | AuthorizationOption_CarPlay
109− deriving (Show, Read, Eq, Ord)
110−
111−data ApplicationState = ApplicationState_Active
112− | ApplicationState_Inactive
113− | ApplicationState_Background
114− | ApplicationState_Unknown CInt
115− deriving (Show, Read, Eq, Ord)
116−
117−data AppDelegateNotificationConfig = AppDelegateNotificationConfig
118− { _appDelegateNotificationConfig_requestAuthorizationWithOptions :: Maybe (Set AuthorizationOption)
119− , _appDelegateNotificationConfig_registerForRemoteNotifications :: Bool
120− , _appDelegateNotificationConfig_didRegisterForRemoteNotificationsWithDeviceToken :: CString -> IO ()
121− , _appDelegateNotificationConfig_didFailToRegisterForRemoteNotificationsWithError :: CString -> IO ()
122− }
123−
124−instance Default AppDelegateNotificationConfig where
125− def = AppDelegateNotificationConfig
126− { _appDelegateNotificationConfig_requestAuthorizationWithOptions = Nothing
127− , _appDelegateNotificationConfig_registerForRemoteNotifications = False
128− , _appDelegateNotificationConfig_didRegisterForRemoteNotificationsWithDeviceToken = \_ -> return ()
129− , _appDelegateNotificationConfig_didFailToRegisterForRemoteNotificationsWithError = \_ -> return ()
130− }
131−
132−
133−-- | Run JSaddle in a WKWebView
134−run :: JSM () -> IO ()
135−run f = run' def (jsaddleMain f)
136−
137−-- | Run JSaddle in a WKWebView
138−runWithAppConfig :: AppDelegateConfig -> JSM () -> IO ()
139−runWithAppConfig cfg = run' cfg . jsaddleMain
140−
141−-- | Run JSaddle in a WKWebView first loading the specified file
142−-- from the mainBundle (relative to the resourcePath).
143−runFile
144− :: ByteString -- ^ The file to navigate to.
145− -> ByteString -- ^ The path to allow read access to.
146− -> AppDelegateConfig
147− -> JSM ()
148− -> IO ()
149−runFile url allowing cfg = run' cfg . jsaddleMainFile url allowing
150−
151−-- | Run JSaddle in a WKWebView first loading the specified html
152−-- as though it came from the specified URL
153−-- (calls WKWebKit function loadHTMLString).
154−runHTMLWithBaseURL
155− :: ByteString -- ^ HTML to load.
156− -> ByteString -- ^ pretend it came from this URL.
157− -> AppDelegateConfig
158− -> JSM ()
159− -> IO ()
160−runHTMLWithBaseURL url allowing cfg = run' cfg . jsaddleMainHTMLWithBaseURL url allowing
161−
162−run' :: AppDelegateConfig
163− -> (WKWebView -> IO ())
164− -> IO ()
165−run' cfg main = do
166− handler <- newStablePtr main
167− progName <- getProgName
168−
169− -- AppDelegate callbacks
170− willFinishLaunchingWithOptions <- newStablePtr $ _appDelegateConfig_willFinishLaunchingWithOptions cfg
171− didFinishLaunchingWithOptions <- newStablePtr $ _appDelegateConfig_didFinishLaunchingWithOptions cfg
172− applicationDidBecomeActive <- newStablePtr $ _appDelegateConfig_applicationDidBecomeActive cfg
173− applicationWillResignActive <- newStablePtr $ _appDelegateConfig_applicationWillResignActive cfg
174− applicationDidEnterBackground <- newStablePtr $ _appDelegateConfig_applicationDidEnterBackground cfg
175− applicationWillEnterForeground <- newStablePtr $ _appDelegateConfig_applicationWillEnterForeground cfg
176− applicationWillTerminate <- newStablePtr $ _appDelegateConfig_applicationWillTerminate cfg
177− applicationSignificantTimeChange <- newStablePtr $ _appDelegateConfig_applicationSignificantTimeChange cfg
178− applicationUniversalLink <- newStablePtr $ _appDelegateConfig_applicationUniversalLink cfg
179− applicationDidReceiveRemoteNotification <- newStablePtr $ \n s -> do
180− let appState = case n of
181− 0 -> ApplicationState_Active
182− 1 -> ApplicationState_Inactive
183− 2 -> ApplicationState_Background
184− _ -> ApplicationState_Unknown n
185− _appDelegateConfig_applicationDidReceiveRemoteNotification cfg appState s
186− applicationOpenFile <- newStablePtr $ fmap fromBool . _appDelegateConfig_applicationOpenFile cfg
187−
188− -- AppDelegate notification configuration
189− let ncfg = _appDelegateConfig_appDelegateNotificationConfig cfg
190− (requestAuthorizationWithOptions, authorizationOptions) =
191− case _appDelegateNotificationConfig_requestAuthorizationWithOptions ncfg of
192− Nothing -> (False, Set.empty)
193− Just opts -> (True, opts)
194− registerForRemoteNotifications = _appDelegateNotificationConfig_registerForRemoteNotifications ncfg
195− didRegisterForRemoteNotificationsWithDeviceToken <- newStablePtr $ _appDelegateNotificationConfig_didRegisterForRemoteNotificationsWithDeviceToken ncfg
196− didFailToRegisterForRemoteNotificationsWithError <- newStablePtr $ _appDelegateNotificationConfig_didFailToRegisterForRemoteNotificationsWithError ncfg
197− withCString progName $ \pn -> runInWKWebView
198− handler
199− pn
200− willFinishLaunchingWithOptions
201− didFinishLaunchingWithOptions
202− applicationDidBecomeActive
203− applicationWillResignActive
204− applicationDidEnterBackground
205− applicationWillEnterForeground
206− applicationWillTerminate
207− applicationSignificantTimeChange
208− applicationUniversalLink
209− applicationDidReceiveRemoteNotification
210− (fromBool requestAuthorizationWithOptions)
211− (fromBool $ Set.member AuthorizationOption_Badge authorizationOptions)
212− (fromBool $ Set.member AuthorizationOption_Sound authorizationOptions)
213− (fromBool $ Set.member AuthorizationOption_Alert authorizationOptions)
214− (fromBool $ Set.member AuthorizationOption_CarPlay authorizationOptions)
215− (fromBool registerForRemoteNotifications)
216− didRegisterForRemoteNotificationsWithDeviceToken
217− didFailToRegisterForRemoteNotificationsWithError
218− (fromBool $ _appDelegateConfig_developerExtrasEnabled cfg)
219− applicationOpenFile
jsaddle-wkwebview/src-ghcjs/Language/Javascript/JSaddle/WKWebView.hsdeleted−7
@@ -1,7 +0,0 @@
1−module Language.Javascript.JSaddle.WKWebView
2− ( run
3− ) where
4−
5−run :: IO () -> IO ()
6−run = id
7−{-# INLINE run #-}
jsaddle-wkwebview/src/Language/Javascript/JSaddle/WKWebView.hsnew file+76
@@ -0,0 +1,76 @@
1+{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}
2+module Language.Javascript.JSaddle.WKWebView
3+ ( jsaddleMain
4+ , WKWebView(..)
5+ ) where
6+
7+import Control.Monad (void, join)
8+import Control.Concurrent (forkIO)
9+
10+import Data.Monoid ((<>))
11+import Data.ByteString (useAsCString, packCString)
12+import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)
13+import Data.Aeson (encode, decode)
14+
15+import Foreign.C.String (CString)
16+import Foreign.Ptr (Ptr)
17+import Foreign.StablePtr (StablePtr, newStablePtr, deRefStablePtr)
18+
19+import Language.Javascript.JSaddle (Result, JSM)
20+import Language.Javascript.JSaddle.Types (Batch(..))
21+import Language.Javascript.JSaddle.Run (runJavaScript)
22+import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
23+
24+newtype WKWebView = WKWebView (Ptr WKWebView)
25+
26+foreign export ccall jsaddleStart :: StablePtr (IO ()) -> IO ()
27+foreign export ccall jsaddleResult :: StablePtr (Result -> IO ()) -> CString -> IO ()
28+foreign import ccall addJSaddleHandler :: WKWebView -> StablePtr (IO ()) -> StablePtr (Result -> IO ()) -> IO ()
29+foreign import ccall loadHTMLString :: WKWebView -> CString -> IO ()
30+foreign import ccall evaluateJavaScript :: WKWebView -> CString -> IO ()
31+
32+jsaddleMain :: JSM () -> WKWebView -> IO ()
33+jsaddleMain f webView = do
34+ (processResult, start) <- runJavaScript (\batch ->
35+ useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");") $
36+ evaluateJavaScript webView)
37+ f
38+
39+ startHandler <- newStablePtr (void $ forkIO start)
40+ resultHandler <- newStablePtr processResult
41+ addJSaddleHandler webView startHandler resultHandler
42+
43+ useAsCString (toStrict indexHtml) $ loadHTMLString webView
44+ useAsCString (toStrict jsaddleJs) $ evaluateJavaScript webView
45+
46+jsaddleStart :: StablePtr (IO ()) -> IO ()
47+jsaddleStart ptrHandler = join (deRefStablePtr ptrHandler)
48+
49+jsaddleResult :: StablePtr (Result -> IO ()) -> CString -> IO ()
50+jsaddleResult ptrHandler s = do
51+ processResult <- deRefStablePtr ptrHandler
52+ result <- packCString s
53+ case decode (fromStrict result) of
54+ Nothing -> error $ "jsaddle WebSocket decode failed : " <> show result
55+ Just r -> processResult r
56+
57+jsaddleJs :: ByteString
58+jsaddleJs = ghcjsHelpers <> "\
59+ \runJSaddleBatch = (function() {\n\
60+ \ " <> initState <> "\n\
61+ \ return function(batch) {\n\
62+ \ " <> runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));") <> "\
63+ \ };\n\
64+ \})();\n\
65+ \"
66+
67+indexHtml :: ByteString
68+indexHtml =
69+ "<!DOCTYPE html>\n\
70+ \<html>\n\
71+ \<head>\n\
72+ \<title>JSaddle</title>\n\
73+ \</head>\n\
74+ \<body>\n\
75+ \</body>\n\
76+ \</html>"
jsaddle-wkwebview/src/Language/Javascript/JSaddle/WKWebView/Internal.hsdeleted−174
@@ -1,174 +0,0 @@
1−{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}
2−module Language.Javascript.JSaddle.WKWebView.Internal
3− ( jsaddleMain
4− , jsaddleMainHTMLWithBaseURL
5− , jsaddleMainFile
6− , WKWebView(..)
7− , mainBundleResourcePath
8− ) where
9−
10−import Control.Monad (void, join)
11−import Control.Concurrent (forkIO, forkOS)
12−import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
13−
14−import Data.Monoid ((<>))
15−import Data.ByteString (useAsCString, packCString)
16−import qualified Data.ByteString as BS (ByteString)
17−import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)
18−import Data.Aeson (encode, decode)
19−import qualified Data.Text as T (pack)
20−import Data.Text.Encoding (encodeUtf8)
21−
22−import Foreign.C.String (CString)
23−import Foreign.C.Types (CBool(..), CInt(..))
24−import Foreign.Ptr (Ptr, nullPtr)
25−import Foreign.StablePtr (StablePtr, newStablePtr, deRefStablePtr)
26−
27−import Language.Javascript.JSaddle (Results, Batch, JSM)
28−import Language.Javascript.JSaddle.Run (runJavaScript)
29−import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
30−
31−import System.Directory (getCurrentDirectory)
32−
33−newtype WKWebView = WKWebView (Ptr WKWebView)
34−newtype JSaddleHandler = JSaddleHandler (Ptr JSaddleHandler)
35−
36−foreign export ccall jsaddleStart :: StablePtr (IO ()) -> IO ()
37−foreign export ccall jsaddleResult :: StablePtr (Results -> IO ()) -> CString -> IO ()
38−foreign export ccall jsaddleSyncResult :: StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()
39−foreign export ccall callWithWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()
40−foreign export ccall callWithCIntCString :: CInt -> CString -> StablePtr (CInt -> CString -> IO ()) -> IO ()
41−foreign export ccall callWithCString :: CString -> StablePtr (CString -> IO ()) -> IO ()
42−foreign export ccall callWithCStringReturningBool :: CString -> StablePtr (CString -> IO CBool) -> IO CBool
43−foreign export ccall callIO :: StablePtr (IO ()) -> IO ()
44−foreign import ccall addJSaddleHandler :: WKWebView -> StablePtr (IO ()) -> StablePtr (Results -> IO ()) -> StablePtr (Results -> IO Batch) -> IO ()
45−foreign import ccall loadHTMLStringWithBaseURL :: WKWebView -> CString -> CString -> IO ()
46−foreign import ccall loadBundleFile :: WKWebView -> CString -> CString -> IO ()
47−foreign import ccall evaluateJavaScript :: WKWebView -> CString -> IO ()
48−foreign import ccall completeSync :: JSaddleHandler -> CString -> IO ()
49−foreign import ccall mainBundleResourcePathC :: IO CString
50−
51−-- | Run JSaddle in WKWebView
52−jsaddleMain :: JSM () -> WKWebView -> IO ()
53−jsaddleMain f webView = do
54− pwd <- getCurrentDirectory
55− let baseURL = encodeUtf8 $ "file://" <> T.pack pwd <> "/index.html"
56− jsaddleMainHTMLWithBaseURL (toStrict indexHtml) baseURL f webView
57−
58−-- | Run JSaddle in WKWebView with initial html and base url
59−jsaddleMainHTMLWithBaseURL
60− :: BS.ByteString -- ^ HTML
61− -> BS.ByteString -- ^ Base URL
62− -> JSM ()
63− -> WKWebView
64− -> IO ()
65−jsaddleMainHTMLWithBaseURL initialHTML baseURL f webView =
66− jsaddleMain' f webView $
67− useAsCString baseURL $ \url ->
68− useAsCString initialHTML $ \html ->
69− loadHTMLStringWithBaseURL webView html url
70−
71−-- | Run JSaddle in a WKWebView first loading the specified file
72−-- from the mainBundle (relative to the resourcePath).
73−jsaddleMainFile :: BS.ByteString -- ^ The file to navigate to.
74− -> BS.ByteString -- ^ The path to allow read access to.
75− -> JSM () -> WKWebView -> IO ()
76−jsaddleMainFile url allowing f webView =
77− jsaddleMain' f webView $
78− useAsCString url $ \u ->
79− useAsCString allowing $ \a ->
80− loadBundleFile webView u a
81−
82−jsaddleMain' :: JSM () -> WKWebView -> IO () -> IO ()
83−jsaddleMain' f webView loadHtml = do
84− ready <- newEmptyMVar
85−
86− (processResult, syncResult, start) <- runJavaScript (\batch ->
87− useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");") $
88− evaluateJavaScript webView)
89− f
90−
91− startHandler <- newStablePtr (putMVar ready ())
92− resultHandler <- newStablePtr processResult
93− syncResultHandler <- newStablePtr syncResult
94− addJSaddleHandler webView startHandler resultHandler syncResultHandler
95− loadHtml
96− void . forkOS $ do
97− takeMVar ready
98− useAsCString (toStrict jsaddleJs) (evaluateJavaScript webView) >> void (forkIO start)
99−
100−jsaddleStart :: StablePtr (IO ()) -> IO ()
101−jsaddleStart ptrHandler = join (deRefStablePtr ptrHandler)
102−
103−jsaddleResult :: StablePtr (Results -> IO ()) -> CString -> IO ()
104−jsaddleResult ptrHandler s = do
105− processResult <- deRefStablePtr ptrHandler
106− result <- packCString s
107− case decode (fromStrict result) of
108− Nothing -> error $ "jsaddle Results decode failed : " <> show result
109− Just r -> processResult r
110−
111−jsaddleSyncResult :: StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()
112−jsaddleSyncResult ptrHandler jsaddleHandler s = do
113− syncProcessResult <- deRefStablePtr ptrHandler
114− result <- packCString s
115− case decode (fromStrict result) of
116− Nothing -> error $ "jsaddle Results decode failed : " <> show result
117− Just r -> do -- void . forkIO $ do
118− batch <- syncProcessResult r
119− useAsCString (toStrict $ encode batch) $
120− completeSync jsaddleHandler
121−
122−callWithWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()
123−callWithWebView webView ptrF = do
124− f <- deRefStablePtr ptrF
125− f webView
126−
127−callWithCString :: CString -> StablePtr (CString -> IO ()) -> IO ()
128−callWithCString c fptr = do
129− f <- deRefStablePtr fptr
130− f c
131−
132−callWithCIntCString :: CInt -> CString -> StablePtr (CInt -> CString -> IO ()) -> IO ()
133−callWithCIntCString n s fptr = do
134− f <- deRefStablePtr fptr
135− f n s
136−
137−callWithCStringReturningBool :: CString -> StablePtr (CString -> IO CBool) -> IO CBool
138−callWithCStringReturningBool c fptr = do
139− f <- deRefStablePtr fptr
140− f c
141−
142−callIO :: StablePtr (IO ()) -> IO ()
143−callIO ptr = do
144− f <- deRefStablePtr ptr
145− f
146−
147−jsaddleJs :: ByteString
148−jsaddleJs = ghcjsHelpers <> "\
149− \runJSaddleBatch = (function() {\n\
150− \ " <> initState <> "\n\
151− \ return function(batch) {\n\
152− \ " <> runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));\n")
153− (Just (\a -> "JSON.parse(window.prompt(\"JSaddleSync\", JSON.stringify(" <> a <> ")))")) <> "\
154− \ };\n\
155− \})();\n\
156− \"
157−
158−indexHtml :: ByteString
159−indexHtml =
160− "<!DOCTYPE html>\n\
161− \<html>\n\
162− \<head>\n\
163− \<title>JSaddle</title>\n\
164− \</head>\n\
165− \<body>\n\
166− \</body>\n\
167− \</html>"
168−
169−mainBundleResourcePath :: IO (Maybe BS.ByteString)
170−mainBundleResourcePath = do
171− bs <- mainBundleResourcePathC
172− if bs == nullPtr
173− then return Nothing
174− else Just <$> packCString bs
jsaddle/jsaddle.cabal+16−61
@@ -1,5 +1,5 @@
1name: jsaddle
1name: jsaddle
2−version: 0.9.8.0
2+version: 0.7.1.0
3cabal-version: >=1.10
3cabal-version: >=1.10
4build-type: Simple
4build-type: Simple
5license: MIT
5license: MIT
@@ -10,22 +10,13 @@ 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 JavaScript helper.
13+ drive a small JavaScipt 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
29
20
30library
21library
31
22
@@ -36,67 +27,36 @@ library
36 else
27 else
37 build-depends:
28 build-depends:
38 attoparsec >=0.11 && <0.14,
29 attoparsec >=0.11 && <0.14,
39− containers >=0.5.6.2 && <0.7,
30+ containers >=0.5.6.2 && <0.6,
40 deepseq >=1.3 && < 1.5,
31 deepseq >=1.3 && < 1.5,
41 filepath >=1.4.0.0 && <1.5,
32 filepath >=1.4.0.0 && <1.5,
42 ghc-prim,
33 ghc-prim,
43− http-types >=0.8.6 && <0.13,
34+ http-types >=0.8.6 && <0.10,
44− process >=1.2.3.0 && <1.7,
35+ process >=1.2.3.0 && <1.5,
45− random >= 1.1 && < 1.3,
46 ref-tf >=0.4.0.1 && <0.5,
36 ref-tf >=0.4.0.1 && <0.5,
47 scientific >=0.3 && <0.4,
37 scientific >=0.3 && <0.4,
48− stm >=2.4.4 && <2.6,
38+ stm >=2.4.4 && <2.5,
49− time >=1.5.0.1 && <1.11,
39+ time >=1.5.0.1 && <1.7,
50 unordered-containers >=0.2 && <0.3,
40 unordered-containers >=0.2 && <0.3,
51− vector >=0.10 && <0.13,
41+ vector >=0.10 && <0.12
52− unliftio-core >=0.1 && < 0.3
53 exposed-modules:
42 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
70 GHCJS.Marshal
43 GHCJS.Marshal
71 GHCJS.Marshal.Internal
44 GHCJS.Marshal.Internal
72 GHCJS.Marshal.Pure
45 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
84 JavaScript.Array.Internal
46 JavaScript.Array.Internal
85− JavaScript.Object
86 JavaScript.Object.Internal
47 JavaScript.Object.Internal
87− Language.Javascript.JSaddle.Debug
88 Language.Javascript.JSaddle.Native
48 Language.Javascript.JSaddle.Native
89 Language.Javascript.JSaddle.Native.Internal
49 Language.Javascript.JSaddle.Native.Internal
90− Language.Javascript.JSaddle.Null
91 hs-source-dirs: src-ghc
50 hs-source-dirs: src-ghc
92 exposed-modules:
51 exposed-modules:
93 Language.Javascript.JSaddle
52 Language.Javascript.JSaddle
53+ Language.Javascript.JSaddle.Array
94 Language.Javascript.JSaddle.Arguments
54 Language.Javascript.JSaddle.Arguments
95 Language.Javascript.JSaddle.Classes
55 Language.Javascript.JSaddle.Classes
96 Language.Javascript.JSaddle.Classes.Internal
56 Language.Javascript.JSaddle.Classes.Internal
97 Language.Javascript.JSaddle.Evaluate
57 Language.Javascript.JSaddle.Evaluate
98 Language.Javascript.JSaddle.Exception
58 Language.Javascript.JSaddle.Exception
99− Language.Javascript.JSaddle.Helper
59+ Language.Javascript.JSaddle.Foreign
100 Language.Javascript.JSaddle.Marshal.String
60 Language.Javascript.JSaddle.Marshal.String
101 Language.Javascript.JSaddle.Monad
61 Language.Javascript.JSaddle.Monad
102 Language.Javascript.JSaddle.Object
62 Language.Javascript.JSaddle.Object
@@ -107,20 +67,15 @@ library
107 Language.Javascript.JSaddle.Value
67 Language.Javascript.JSaddle.Value
108 Language.Javascript.JSaddle.Types
68 Language.Javascript.JSaddle.Types
109 build-depends:
69 build-depends:
110− aeson >=0.11.3.0 && <1.6,
70+ aeson >=0.8.0.2 && <1.1,
111− base >=4.9 && <5,
71+ base <5,
112− base-compat >=0.9.0 && <0.12,
113− base64-bytestring >=1.0.0.1 && <1.2,
114 bytestring >=0.10.6.0 && <0.11,
72 bytestring >=0.10.6.0 && <0.11,
115− exceptions >=0.8 && <0.11,
116− lens >=3.8.5 && <5.1,
73+ lens >=3.8.5 && <4.16,
117− primitive >=0.6.1.0 && <0.8,
74+ primitive >=0.6.1.0 && <0.7,
118 text >=1.2.1.3 && <1.3,
75 text >=1.2.1.3 && <1.3,
119 transformers >=0.4.2.0 && <0.6
76 transformers >=0.4.2.0 && <0.6
120 default-language: Haskell2010
77 default-language: Haskell2010
121 hs-source-dirs: src
78 hs-source-dirs: src
122 ghc-options: -ferror-spans -Wall
79 ghc-options: -ferror-spans -Wall
123− if flag(check-unchecked)
80+
124− cpp-options: -DCHECK_UNCHECKED
81+
125− if flag(call-stacks) || flag(check-unchecked)
126− cpp-options: -DJSADDLE_HAS_CALL_STACK
jsaddle/src-ghc/Data/JSString.hsdeleted−1404
@@ -1,1404 +0,0 @@
1−{-# LANGUAGE MagicHash, BangPatterns, UnboxedTuples, TypeFamilies
2− #-}
3−{-# OPTIONS_GHC -fno-warn-orphans #-}
4−{-| Manipulation of JavaScript strings, API and fusion implementation
5− based on Data.Text by Tom Harper, Duncan Coutts, Bryan O'Sullivan e.a.
6− -}
7−module Data.JSString ( JSString
8−
9− -- * Creation and elimination
10− , pack
11− , unpack, unpack'
12− , singleton
13− , empty
14−
15− -- * Basic interface
16− , cons
17− , snoc
18− , append
19− , uncons
20− , head
21− , last
22− , tail
23− , init
24− , null
25− , length
26− , compareLength
27−
28− -- * Transformations
29− , map
30− , intercalate
31− , intersperse
32− , transpose
33− , reverse
34− , replace
35−
36− -- ** Case conversion
37− , toCaseFold
38− , toLower
39− , toUpper
40− , toTitle
41−
42− -- ** Justification
43− , justifyLeft
44− , justifyRight
45− , center
46−
47− -- * Folds
48− , foldl
49− , foldl'
50− , foldl1
51− , foldl1'
52− , foldr
53− , foldr1
54−
55− -- ** Special folds
56− , concat
57− , concatMap
58− , any
59− , all
60− , maximum
61− , minimum
62−
63− -- * Construction
64−
65− -- ** Scans
66− , scanl
67− , scanl1
68− , scanr
69− , scanr1
70−
71− -- ** Accumulating maps
72− , mapAccumL
73− , mapAccumR
74−
75− -- ** Generation and unfolding
76− , replicate
77− , unfoldr
78− , unfoldrN
79−
80− -- * Substrings
81−
82− -- ** Breaking strings
83− , take
84− , takeEnd
85− , drop
86− , dropEnd
87− , takeWhile
88− , dropWhile
89− , dropWhileEnd
90− , dropAround
91− , strip
92− , stripStart
93− , stripEnd
94− , splitAt
95− , breakOn
96− , breakOnEnd
97− , break
98− , span
99− , group
100− , group'
101− , groupBy
102− , inits
103− , tails
104−
105− -- ** Breaking into many substrings
106− , splitOn, splitOn'
107− , split
108− , chunksOf, chunksOf'
109−
110− -- ** Breaking into lines and words
111− , lines, lines'
112− , words, words'
113− , unlines
114− , unwords
115−
116− -- * Predicates
117− , isPrefixOf
118− , isSuffixOf
119− , isInfixOf
120−
121− -- ** View patterns
122− , stripPrefix
123− , stripSuffix
124− , commonPrefixes
125−
126− -- * Searching
127− , filter
128− , breakOnAll, breakOnAll'
129− , find
130− , partition
131−
132− -- * Indexing
133− , index
134− , findIndex
135− , count
136−
137− -- * Zipping
138− , zip
139− , zipWith
140− ) where
141−
142−import Prelude
143− ( Char, Bool(..), Int, Maybe(..), String, Eq(..), Ord(..), Ordering(..), (++)
144− , Read(..), Show(..), (&&), (||), (+), (-), (.), ($), ($!), (>>)
145− , not, seq, return, otherwise, quot)
146−import qualified Prelude as P
147−
148−import Control.DeepSeq (NFData(..))
149−import Data.Char (isSpace)
150−import Data.Coerce (coerce)
151−import qualified Data.List as L
152−import Data.Data
153−import qualified Data.Text as T
154−import qualified Data.Text.Internal.Fusion as TF
155−import qualified Data.Text.Internal.Fusion.Common as TF
156−
157−import GHC.Exts
158− ( Int#, (+#), (-#), (>=#), (>#), isTrue#, chr#, Char(..)
159− , Int(..), Addr#, tagToEnum#)
160−import qualified GHC.Exts as Exts
161−import qualified GHC.CString as GHC
162−
163−import Unsafe.Coerce
164−
165−import GHCJS.Prim (JSVal)
166−
167−import Data.JSString.Internal.Type
168−import Data.JSString.Internal.Fusion (stream, unstream)
169−import qualified Data.JSString.Internal.Fusion as S
170−import qualified Data.JSString.Internal.Fusion.Common as S
171−
172−instance Exts.IsList JSString where
173− type Item JSString = Char
174− fromList = pack
175− toList = unpack
176−
177−-- -----------------------------------------------------------------------------
178−-- * Conversion to/from 'JSString'
179−
180−-- | /O(n)/ Convert a 'String' into a 'JSString'. Subject to
181−-- fusion.
182−pack :: String -> JSString
183−pack = coerce T.pack
184−{-# INLINE [1] pack #-}
185−
186−{-# RULES
187−"JSSTRING pack -> fused" [~1] forall x.
188− pack x = unstream (S.map safe (S.streamList x))
189−"JSSTRING pack -> unfused" [1] forall x.
190− unstream (S.map safe (S.streamList x)) = pack x
191− #-}
192−
193−-- | /O(n)/ Convert a 'JSString' into a 'String'. Subject to fusion.
194−unpack :: JSString -> String
195−unpack = S.unstreamList . stream
196−{-# INLINE [1] unpack #-}
197−
198−unpack' :: JSString -> String
199−unpack' = coerce T.unpack
200−{-# INLINE unpack' #-}
201−
202−-- | /O(n)/ Convert a literal string into a JSString. Subject to fusion.
203−unpackCString# :: Addr# -> JSString
204−unpackCString# = coerce T.unpackCString#
205−{-# NOINLINE unpackCString# #-}
206−
207−{-# RULES "JSSTRING literal" forall a.
208− unstream (S.map safe (S.streamList (GHC.unpackCString# a)))
209− = unpackCString# a #-}
210−
211−{-# RULES "JSSTRING literal UTF8" forall a.
212− unstream (S.map safe (S.streamList (GHC.unpackCStringUtf8# a)))
213− = unpackCString# a #-}
214−
215−{-# RULES "JSSTRING empty literal"
216− unstream (S.map safe (S.streamList []))
217− = empty_ #-}
218−
219−{-# RULES "JSSTRING singleton literal" forall a.
220− unstream (S.map safe (S.streamList [a]))
221− = singleton a #-}
222−
223−
224−-- | /O(1)/ Convert a character into a 'JSString'. Subject to fusion.
225−-- Performs replacement on invalid scalar values.
226−singleton :: Char -> JSString
227−singleton = coerce T.singleton
228−{-# INLINE [1] singleton #-}
229−
230−{-# RULES
231−"JSSTRING singleton -> fused" [~1] forall a.
232− singleton a = unstream (S.singleton (safe a))
233−"JSSTRING singleton -> unfused" [1] forall a.
234− unstream (S.singleton (safe a)) = singleton a
235− #-}
236−
237−-- This is intended to reduce inlining bloat.
238−-- singleton_ :: Char -> Text
239−-- singleton_ c = js_singleton c
240−
241−-- Text (A.run x) 0 len
242−-- where x :: ST s (A.MArray s)
243−-- x = do arr <- A.new len
244−-- _ <- unsafeWrite arr 0 d
245−-- return arr
246−-- len | d < '\x10000' = 1
247−-- x | otherwise = 2
248−-- d = safe c
249−-- {-# NOINLINE singleton_ #-}
250−
251−-- -----------------------------------------------------------------------------
252−-- * Basic functions
253−
254−-- | /O(n)/ Adds a character to the front of a 'JSString'. This function
255−-- is more costly than its 'List' counterpart because it requires
256−-- copying a new array. Subject to fusion. Performs replacement on
257−-- invalid scalar values.
258−cons :: Char -> JSString -> JSString
259−cons = coerce T.cons
260−{-# INLINE [1] cons #-}
261−
262−{-# RULES
263−"JSSTRING cons -> fused" [~1] forall c x.
264− cons c x = unstream (S.cons (safe c) (stream x))
265−"JSSTRING cons -> unfused" [1] forall c x.
266− unstream (S.cons (safe c) (stream x)) = cons c x
267− #-}
268−
269−infixr 5 `cons`
270−
271−-- | /O(n)/ Adds a character to the end of a 'JSString'. This copies the
272−-- entire array in the process, unless fused. Subject to fusion.
273−-- Performs replacement on invalid scalar values.
274−snoc :: JSString -> Char -> JSString
275−snoc = coerce T.snoc
276− -- unstream (S.snoc (stream t) (safe c))
277−{-# INLINE [1] snoc #-}
278−
279−{-# RULES
280−"JSSTRING snoc -> fused" [~1] forall x c.
281− snoc x c = unstream (S.snoc (stream x) (safe c))
282−"JSSTRING snoc -> unfused" [1] forall x c.
283− unstream (S.snoc (stream x) (safe c)) = snoc x c
284− #-}
285−
286−-- | /O(n)/ Appends one 'JSString' to the other by copying both of them
287−-- into a new 'JSString'. Subject to fusion.
288−append :: JSString -> JSString -> JSString
289−append = coerce T.append
290−{-# INLINE [1] append #-}
291−
292−{-# RULES
293−"JSSTRING append -> fused" [~1] forall x1 x2.
294− append x1 x2 = unstream (S.append (stream x1) (stream x2))
295−"JSSTRING append -> unfused" [1] forall x1 x2.
296− unstream (S.append (stream x1) (stream x2)) = append x1 x2
297− #-}
298−
299−-- | /O(1)/ Returns the first character of a 'JSString', which must be
300−-- non-empty. Subject to fusion.
301−head :: JSString -> Char
302−head = coerce T.head
303−{-# INLINE [1] head #-}
304−
305−{-# RULES
306−"JSSTRING head -> fused" [~1] forall x.
307− head x = S.head (stream x)
308−"JSSTRING head -> unfused" [1] forall x.
309− S.head (stream x) = head x
310− #-}
311−
312−
313−-- | /O(1)/ Returns the first character and rest of a 'JSString', or
314−-- 'Nothing' if empty. Subject to fusion.
315−uncons :: JSString -> Maybe (Char, JSString)
316−uncons = coerce T.uncons
317−{-# INLINE [1] uncons #-}
318−
319−-- | Lifted from Control.Arrow and specialized.
320−second :: (b -> c) -> (a,b) -> (a,c)
321−second f (a, b) = (a, f b)
322−
323−-- | /O(1)/ Returns the last character of a 'JSString', which must be
324−-- non-empty. Subject to fusion.
325−last :: JSString -> Char
326−last = coerce T.last
327−{-# INLINE [1] last #-}
328−
329−{-# RULES
330−"JSSTRING last -> fused" [~1] forall x.
331− last x = S.last (stream x)
332−"JSSTRING last -> unfused" [1] forall x.
333− S.last (stream x) = last x
334− #-}
335−
336−-- | /O(1)/ Returns all characters after the head of a 'JSString', which
337−-- must be non-empty. Subject to fusion.
338−tail :: JSString -> JSString
339−tail = coerce T.tail
340−{-# INLINE [1] tail #-}
341−
342−{-# RULES
343−"JSSTRING tail -> fused" [~1] forall x.
344− tail x = unstream (S.tail (stream x))
345−"JSSTRING tail -> unfused" [1] forall x.
346− unstream (S.tail (stream x)) = tail x
347− #-}
348−
349−-- | /O(1)/ Returns all but the last character of a 'JSString', which must
350−-- be non-empty. Subject to fusion.
351−init :: JSString -> JSString
352−init = coerce T.init
353−{-# INLINE [1] init #-}
354−
355−{-# RULES
356−"JSSTRING init -> fused" [~1] forall t.
357− init t = unstream (S.init (stream t))
358−"JSSTRING init -> unfused" [1] forall t.
359− unstream (S.init (stream t)) = init t
360− #-}
361−
362−-- | /O(1)/ Tests whether a 'JSString' is empty or not. Subject to
363−-- fusion.
364−null :: JSString -> Bool
365−null = coerce T.null
366−{-# INLINE [1] null #-}
367−
368−{-# RULES
369−"JSSTRING null -> fused" [~1] forall t.
370− null t = S.null (stream t)
371−"JSSTRING null -> unfused" [1] forall t.
372− S.null (stream t) = null t
373− #-}
374−
375−-- | /O(n)/ Returns the number of characters in a 'JSString'.
376−-- Subject to fusion.
377−length :: JSString -> Int
378−length = coerce T.length
379−{-# INLINE [1] length #-}
380−
381−{-# RULES
382−"JSSTRING length -> fused" [~1] forall x.
383− length x = S.length (stream x)
384−"JSSTRING length -> unfused" [1] forall x.
385− S.length (stream x) = length x
386− #-}
387−
388−-- | /O(n)/ Compare the count of characters in a 'JSString' to a number.
389−-- Subject to fusion.
390−--
391−-- This function gives the same answer as comparing against the result
392−-- of 'length', but can short circuit if the count of characters is
393−-- greater than the number, and hence be more efficient.
394−compareLength :: JSString -> Int -> Ordering
395−compareLength = coerce T.compareLength
396−{-# INLINE [1] compareLength #-}
397−
398−{-# RULES
399−"JSSTRING compareN/length -> compareLength" [~1] forall t n.
400− compare (length t) n = compareLength t n
401− #-}
402−
403−{-# RULES
404−"JSSTRING ==N/length -> compareLength/==EQ" [~1] forall t n.
405− (==) (length t) n = compareLength t n == EQ
406− #-}
407−
408−{-# RULES
409−"JSSTRING /=N/length -> compareLength//=EQ" [~1] forall t n.
410− (/=) (length t) n = compareLength t n /= EQ
411− #-}
412−
413−{-# RULES
414−"JSSTRING <N/length -> compareLength/==LT" [~1] forall t n.
415− (<) (length t) n = compareLength t n == LT
416− #-}
417−
418−{-# RULES
419−"JSSTRING <=N/length -> compareLength//=GT" [~1] forall t n.
420− (<=) (length t) n = compareLength t n /= GT
421− #-}
422−
423−{-# RULES
424−"JSSTRING >N/length -> compareLength/==GT" [~1] forall t n.
425− (>) (length t) n = compareLength t n == GT
426− #-}
427−
428−{-# RULES
429−"JSSTRING >=N/length -> compareLength//=LT" [~1] forall t n.
430− (>=) (length t) n = compareLength t n /= LT
431− #-}
432−
433−-- -----------------------------------------------------------------------------
434−-- * Transformations
435−-- | /O(n)/ 'map' @f@ @t@ is the 'JSString' obtained by applying @f@ to
436−-- each element of @t@. Subject to fusion. Performs replacement on
437−-- invalid scalar values.
438−map :: (Char -> Char) -> JSString -> JSString
439−map = coerce T.map
440−{-# INLINE [1] map #-}
441−
442−-- | /O(n)/ The 'intercalate' function takes a 'JSString' and a list of
443−-- 'JSString's and concatenates the list after interspersing the first
444−-- argument between each element of the list.
445−intercalate :: JSString -> [JSString] -> JSString
446−intercalate = coerce T.intercalate
447−{-# INLINE [1] intercalate #-}
448−
449−-- | /O(n)/ The 'intersperse' function takes a character and places it
450−-- between the characters of a 'JSString'. Subject to fusion. Performs
451−-- replacement on invalid scalar values.
452−intersperse :: Char -> JSString -> JSString
453−intersperse = coerce T.intersperse
454−{-# INLINE [1] intersperse #-}
455−
456−{-# RULES
457−"JSSTRING intersperse -> fused" [~1] forall c x.
458− intersperse c x = unstream (S.intersperse (safe c) (stream x))
459−"JSSTRING intersperse -> unfused" [1] forall c x.
460− unstream (S.intersperse (safe c) (stream x)) = intersperse c x
461− #-}
462−
463−-- | /O(n)/ Reverse the characters of a string. Subject to fusion.
464−reverse :: JSString -> JSString
465−reverse = coerce T.reverse
466−{-# INLINE [1] reverse #-}
467−
468−{-# RULES
469−"JSSTRING reverse -> fused" [~1] forall x.
470− reverse x = S.reverse (stream x)
471−"JSSTRING reverse -> unfused" [1] forall x.
472− S.reverse (stream x) = reverse x
473− #-}
474−
475−-- | /O(m+n)/ Replace every non-overlapping occurrence of @needle@ in
476−-- @haystack@ with @replacement@.
477−--
478−-- This function behaves as though it was defined as follows:
479−--
480−-- @
481−-- replace needle replacement haystack =
482−-- 'intercalate' replacement ('splitOn' needle haystack)
483−-- @
484−--
485−-- As this suggests, each occurrence is replaced exactly once. So if
486−-- @needle@ occurs in @replacement@, that occurrence will /not/ itself
487−-- be replaced recursively:
488−--
489−-- > replace "oo" "foo" "oo" == "foo"
490−--
491−-- In cases where several instances of @needle@ overlap, only the
492−-- first one will be replaced:
493−--
494−-- > replace "ofo" "bar" "ofofo" == "barfo"
495−--
496−-- In (unlikely) bad cases, this function's time complexity degrades
497−-- towards /O(n*m)/.
498−replace :: JSString
499− -- ^ @needle@ to search for. If this string is empty, an
500− -- error will occur.
501− -> JSString
502− -- ^ @replacement@ to replace @needle@ with.
503− -> JSString
504− -- ^ @haystack@ in which to search.
505− -> JSString
506−replace = coerce T.replace
507−{-# INLINE replace #-}
508−
509−-- ----------------------------------------------------------------------------
510−-- ** Case conversions (folds)
511−
512−-- $case
513−--
514−-- When case converting 'JSString' values, do not use combinators like
515−-- @map toUpper@ to case convert each character of a string
516−-- individually, as this gives incorrect results according to the
517−-- rules of some writing systems. The whole-string case conversion
518−-- functions from this module, such as @toUpper@, obey the correct
519−-- case conversion rules. As a result, these functions may map one
520−-- input character to two or three output characters. For examples,
521−-- see the documentation of each function.
522−--
523−-- /Note/: In some languages, case conversion is a locale- and
524−-- context-dependent operation. The case conversion functions in this
525−-- module are /not/ locale sensitive. Programs that require locale
526−-- sensitivity should use appropriate versions of the
527−-- <http://hackage.haskell.org/package/text-icu-0.6.3.7/docs/Data-Text-ICU.html#g:4 case mapping functions from the text-icu package >.
528−
529−-- | /O(n)/ Convert a string to folded case. Subject to fusion.
530−--
531−-- This function is mainly useful for performing caseless (also known
532−-- as case insensitive) string comparisons.
533−--
534−-- A string @x@ is a caseless match for a string @y@ if and only if:
535−--
536−-- @toCaseFold x == toCaseFold y@
537−--
538−-- The result string may be longer than the input string, and may
539−-- differ from applying 'toLower' to the input string. For instance,
540−-- the Armenian small ligature \"&#xfb13;\" (men now, U+FB13) is case
541−-- folded to the sequence \"&#x574;\" (men, U+0574) followed by
542−-- \"&#x576;\" (now, U+0576), while the Greek \"&#xb5;\" (micro sign,
543−-- U+00B5) is case folded to \"&#x3bc;\" (small letter mu, U+03BC)
544−-- instead of itself.
545−toCaseFold :: JSString -> JSString
546−toCaseFold = coerce T.toCaseFold
547−{-# INLINE [0] toCaseFold #-}
548−
549−-- | /O(n)/ Convert a string to lower case, using simple case
550−-- conversion. Subject to fusion.
551−--
552−-- The result string may be longer than the input string. For
553−-- instance, \"&#x130;\" (Latin capital letter I with dot above,
554−-- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069)
555−-- followed by \" &#x307;\" (combining dot above, U+0307).
556−toLower :: JSString -> JSString
557−toLower = coerce T.toLower
558−{-# INLINE [1] toLower #-}
559−
560−{-# RULES
561−"JSSTRING toLower -> fused" [~1] forall x.
562− toLower x = unstream (S.toLower (stream x))
563−"JSSTRING toLower -> unfused" [1] forall x.
564− unstream (S.toLower (stream x)) = toLower x
565− #-}
566−
567−-- | /O(n)/ Convert a string to upper case, using simple case
568−-- conversion. Subject to fusion.
569−--
570−-- The result string may be longer than the input string. For
571−-- instance, the German \"&#xdf;\" (eszett, U+00DF) maps to the
572−-- two-letter sequence \"SS\".
573−toUpper :: JSString -> JSString
574−toUpper = coerce T.toUpper
575−{-# INLINE [1] toUpper #-}
576−
577−{-# RULES
578−"JSSTRING toUpper -> fused" [~1] forall x.
579− toUpper x = unstream (S.toUpper(stream x))
580−"JSSTRING toUpper -> unfused" [1] forall x.
581− unstream (S.toUpper (stream x)) = toUpper x
582− #-}
583−
584−-- | /O(n)/ Convert a string to title case, using simple case
585−-- conversion. Subject to fusion.
586−--
587−-- The first letter of the input is converted to title case, as is
588−-- every subsequent letter that immediately follows a non-letter.
589−-- Every letter that immediately follows another letter is converted
590−-- to lower case.
591−--
592−-- The result string may be longer than the input string. For example,
593−-- the Latin small ligature &#xfb02; (U+FB02) is converted to the
594−-- sequence Latin capital letter F (U+0046) followed by Latin small
595−-- letter l (U+006C).
596−--
597−-- /Note/: this function does not take language or culture specific
598−-- rules into account. For instance, in English, different style
599−-- guides disagree on whether the book name \"The Hill of the Red
600−-- Fox\" is correctly title cased&#x2014;but this function will
601−-- capitalize /every/ word.
602−toTitle :: JSString -> JSString
603−toTitle = coerce T.toTitle
604−{-# INLINE toTitle #-}
605−
606−-- | /O(n)/ Left-justify a string to the given length, using the
607−-- specified fill character on the right. Subject to fusion.
608−-- Performs replacement on invalid scalar values.
609−--
610−-- Examples:
611−--
612−-- > justifyLeft 7 'x' "foo" == "fooxxxx"
613−-- > justifyLeft 3 'x' "foobar" == "foobar"
614−justifyLeft :: Int -> Char -> JSString -> JSString
615−justifyLeft = coerce T.justifyLeft
616−{-# INLINE [1] justifyLeft #-}
617−
618−{-# RULES
619−"JSSTRING justifyLeft -> fused" [~1] forall k c t.
620− justifyLeft k c t = unstream (S.justifyLeftI k c (stream t))
621−"JSSTRING justifyLeft -> unfused" [1] forall k c t.
622− unstream (S.justifyLeftI k c (stream t)) = justifyLeft k c t
623− #-}
624−
625−-- | /O(n)/ Right-justify a string to the given length, using the
626−-- specified fill character on the left. Performs replacement on
627−-- invalid scalar values.
628−--
629−-- Examples:
630−--
631−-- > justifyRight 7 'x' "bar" == "xxxxbar"
632−-- > justifyRight 3 'x' "foobar" == "foobar"
633−justifyRight :: Int -> Char -> JSString -> JSString
634−justifyRight = coerce T.justifyRight
635−{-# INLINE justifyRight #-}
636−
637−-- | /O(n)/ Center a string to the given length, using the specified
638−-- fill character on either side. Performs replacement on invalid
639−-- scalar values.
640−--
641−-- Examples:
642−--
643−-- > center 8 'x' "HS" = "xxxHSxxx"
644−center :: Int -> Char -> JSString -> JSString
645−center = coerce T.center
646−{-# INLINE center #-}
647−
648−-- | /O(n)/ The 'transpose' function transposes the rows and columns
649−-- of its 'JSString' argument. Note that this function uses 'pack',
650−-- 'unpack', and the list version of transpose, and is thus not very
651−-- efficient.
652−transpose :: [JSString] -> [JSString]
653−transpose = coerce T.transpose
654−
655−-- -----------------------------------------------------------------------------
656−-- * Reducing 'JSString's (folds)
657−
658−-- | /O(n)/ 'foldl', applied to a binary operator, a starting value
659−-- (typically the left-identity of the operator), and a 'JSString',
660−-- reduces the 'JSString' using the binary operator, from left to right.
661−-- Subject to fusion.
662−foldl :: (a -> Char -> a) -> a -> JSString -> a
663−foldl f = coerce (T.foldl f)
664−{-# INLINE foldl #-}
665−
666−-- | /O(n)/ A strict version of 'foldl'. Subject to fusion.
667−foldl' :: (a -> Char -> a) -> a -> JSString -> a
668−foldl' f = coerce (T.foldl' f)
669−{-# INLINE foldl' #-}
670−
671−-- | /O(n)/ A variant of 'foldl' that has no starting value argument,
672−-- and thus must be applied to a non-empty 'JSString'. Subject to fusion.
673−foldl1 :: (Char -> Char -> Char) -> JSString -> Char
674−foldl1 = coerce T.foldl1
675−{-# INLINE foldl1 #-}
676−
677−-- | /O(n)/ A strict version of 'foldl1'. Subject to fusion.
678−foldl1' :: (Char -> Char -> Char) -> JSString -> Char
679−foldl1' = coerce T.foldl1'
680−{-# INLINE foldl1' #-}
681−
682−-- | /O(n)/ 'foldr', applied to a binary operator, a starting value
683−-- (typically the right-identity of the operator), and a 'JSString',
684−-- reduces the 'JSString' using the binary operator, from right to left.
685−-- Subject to fusion.
686−foldr :: (Char -> a -> a) -> a -> JSString -> a
687−foldr f = coerce (T.foldr f)
688−{-# INLINE foldr #-}
689−
690−-- | /O(n)/ A variant of 'foldr' that has no starting value argument,
691−-- and thus must be applied to a non-empty 'JSString'. Subject to
692−-- fusion.
693−foldr1 :: (Char -> Char -> Char) -> JSString -> Char
694−foldr1 = coerce T.foldr1
695−{-# INLINE foldr1 #-}
696−
697−-- -----------------------------------------------------------------------------
698−-- ** Special folds
699−
700−-- | /O(n)/ Concatenate a list of 'JSString's.
701−concat :: [JSString] -> JSString
702−concat = coerce T.concat
703−
704−-- | /O(n)/ Map a function over a 'JSString' that results in a 'JSString', and
705−-- concatenate the results.
706−concatMap :: (Char -> JSString) -> JSString -> JSString
707−concatMap = coerce T.concatMap
708−{-# INLINE concatMap #-}
709−
710−-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the
711−-- 'JSString' @t@ satisifes the predicate @p@. Subject to fusion.
712−any :: (Char -> Bool) -> JSString -> Bool
713−any = coerce T.any
714−{-# INLINE any #-}
715−
716−-- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the
717−-- 'JSString' @t@ satisify the predicate @p@. Subject to fusion.
718−all :: (Char -> Bool) -> JSString -> Bool
719−all = coerce T.all
720−{-# INLINE all #-}
721−
722−-- | /O(n)/ 'maximum' returns the maximum value from a 'JSString', which
723−-- must be non-empty. Subject to fusion.
724−maximum :: JSString -> Char
725−maximum = coerce T.maximum
726−{-# INLINE maximum #-}
727−
728−-- | /O(n)/ 'minimum' returns the minimum value from a 'JSString', which
729−-- must be non-empty. Subject to fusion.
730−minimum :: JSString -> Char
731−minimum = coerce T.minimum
732−{-# INLINE minimum #-}
733−
734−-- -----------------------------------------------------------------------------
735−-- * Building 'JSString's
736−
737−-- | /O(n)/ 'scanl' is similar to 'foldl', but returns a list of
738−-- successive reduced values from the left. Subject to fusion.
739−-- Performs replacement on invalid scalar values.
740−--
741−-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
742−--
743−-- Note that
744−--
745−-- > last (scanl f z xs) == foldl f z xs.
746−scanl :: (Char -> Char -> Char) -> Char -> JSString -> JSString
747−scanl = coerce T.scanl
748−{-# INLINE scanl #-}
749−
750−-- | /O(n)/ 'scanl1' is a variant of 'scanl' that has no starting
751−-- value argument. Subject to fusion. Performs replacement on
752−-- invalid scalar values.
753−--
754−-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
755−scanl1 :: (Char -> Char -> Char) -> JSString -> JSString
756−scanl1 = coerce T.scanl1
757−{-# INLINE scanl1 #-}
758−
759−-- | /O(n)/ 'scanr' is the right-to-left dual of 'scanl'. Performs
760−-- replacement on invalid scalar values.
761−--
762−-- > scanr f v == reverse . scanl (flip f) v . reverse
763−scanr :: (Char -> Char -> Char) -> Char -> JSString -> JSString
764−scanr = coerce T.scanr
765−{-# INLINE scanr #-}
766−
767−-- | /O(n)/ 'scanr1' is a variant of 'scanr' that has no starting
768−-- value argument. Subject to fusion. Performs replacement on
769−-- invalid scalar values.
770−scanr1 :: (Char -> Char -> Char) -> JSString -> JSString
771−scanr1 = coerce T.scanr1
772−{-# INLINE scanr1 #-}
773−
774−-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a
775−-- function to each element of a 'JSString', passing an accumulating
776−-- parameter from left to right, and returns a final 'JSString'. Performs
777−-- replacement on invalid scalar values.
778−mapAccumL :: (a -> Char -> (a,Char)) -> a -> JSString -> (a, JSString)
779−mapAccumL f = coerce (T.mapAccumL f)
780−{-# INLINE mapAccumL #-}
781−
782−-- | The 'mapAccumR' function behaves like a combination of 'map' and
783−-- a strict 'foldr'; it applies a function to each element of a
784−-- 'JSString', passing an accumulating parameter from right to left, and
785−-- returning a final value of this accumulator together with the new
786−-- 'JSString'.
787−-- Performs replacement on invalid scalar values.
788−mapAccumR :: (a -> Char -> (a,Char)) -> a -> JSString -> (a, JSString)
789−mapAccumR f = coerce (T.mapAccumR f)
790−{-# INLINE mapAccumR #-}
791−
792−-- -----------------------------------------------------------------------------
793−-- ** Generating and unfolding 'JSString's
794−
795−-- | /O(n*m)/ 'replicate' @n@ @t@ is a 'JSString' consisting of the input
796−-- @t@ repeated @n@ times.
797−replicate :: Int -> JSString -> JSString
798−replicate = coerce T.replicate
799−{-# INLINE [1] replicate #-}
800−
801−-- | /O(n)/, where @n@ is the length of the result. The 'unfoldr'
802−-- function is analogous to the List 'L.unfoldr'. 'unfoldr' builds a
803−-- 'JSString' from a seed value. The function takes the element and
804−-- returns 'Nothing' if it is done producing the 'JSString', otherwise
805−-- 'Just' @(a,b)@. In this case, @a@ is the next 'Char' in the
806−-- string, and @b@ is the seed value for further production. Subject
807−-- to fusion. Performs replacement on invalid scalar values.
808−unfoldr :: (a -> Maybe (Char,a)) -> a -> JSString
809−unfoldr f = coerce (T.unfoldr f)
810−{-# INLINE unfoldr #-}
811−
812−-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a 'JSString' from a seed
813−-- value. However, the length of the result should be limited by the
814−-- first argument to 'unfoldrN'. This function is more efficient than
815−-- 'unfoldr' when the maximum length of the result is known and
816−-- correct, otherwise its performance is similar to 'unfoldr'. Subject
817−-- to fusion. Performs replacement on invalid scalar values.
818−unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> JSString
819−unfoldrN n f = coerce (T.unfoldrN n f)
820−{-# INLINE unfoldrN #-}
821−
822−-- -----------------------------------------------------------------------------
823−-- * Substrings
824−
825−-- | /O(n)/ 'take' @n@, applied to a 'JSString', returns the prefix of the
826−-- 'JSString' of length @n@, or the 'JSString' itself if @n@ is greater than
827−-- the length of the JSString. Subject to fusion.
828−take :: Int -> JSString -> JSString
829−take = coerce T.take
830−{-# INLINE [1] take #-}
831−{-
832−iterN :: Int -> JSString -> Int
833−iterN n t@(Text _arr _off len) = loop 0 0
834− where loop !i !cnt
835− | i >= len || cnt >= n = i
836− | otherwise = loop (i+d) (cnt+1)
837− where d = iter_ t i
838−-}
839−{-# RULES
840−"JSSTRING take -> fused" [~1] forall n t.
841− take n t = unstream (S.take n (stream t))
842−"JSSTRING take -> unfused" [1] forall n t.
843− unstream (S.take n (stream t)) = take n t
844− #-}
845−
846−-- | /O(n)/ 'takeEnd' @n@ @t@ returns the suffix remaining after
847−-- taking @n@ characters from the end of @t@.
848−--
849−-- Examples:
850−--
851−-- > takeEnd 3 "foobar" == "bar"
852−takeEnd :: Int -> JSString -> JSString
853−takeEnd = coerce T.takeEnd
854−
855−-- | /O(n)/ 'drop' @n@, applied to a 'JSString', returns the suffix of the
856−-- 'JSString' after the first @n@ characters, or the empty 'JSString' if @n@
857−-- is greater than the length of the 'JSString'. Subject to fusion.
858−drop :: Int -> JSString -> JSString
859−drop = coerce T.drop
860−{-# INLINE [1] drop #-}
861−
862−{-# RULES
863−"JSSTRING drop -> fused" [~1] forall n t.
864− drop n t = unstream (S.drop n (stream t))
865−"JSSTRING drop -> unfused" [1] forall n t.
866− unstream (S.drop n (stream t)) = drop n t
867− #-}
868−
869−-- | /O(n)/ 'dropEnd' @n@ @t@ returns the prefix remaining after
870−-- dropping @n@ characters from the end of @t@.
871−--
872−-- Examples:
873−--
874−-- > dropEnd 3 "foobar" == "foo"
875−dropEnd :: Int -> JSString -> JSString
876−dropEnd = coerce T.dropEnd
877−
878−-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'JSString',
879−-- returns the longest prefix (possibly empty) of elements that
880−-- satisfy @p@. Subject to fusion.
881−takeWhile :: (Char -> Bool) -> JSString -> JSString
882−takeWhile = coerce T.takeWhile
883−{-# INLINE [1] takeWhile #-}
884−
885−{-# RULES
886−"TEXT takeWhile -> fused" [~1] forall p t.
887− takeWhile p t = unstream (S.takeWhile p (stream t))
888−"TEXT takeWhile -> unfused" [1] forall p t.
889− unstream (S.takeWhile p (stream t)) = takeWhile p t
890− #-}
891−
892−-- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after
893−-- 'takeWhile' @p@ @t@. Subject to fusion.
894−dropWhile :: (Char -> Bool) -> JSString -> JSString
895−dropWhile = coerce T.dropWhile
896−{-# INLINE [1] dropWhile #-}
897−
898−{-# RULES
899−"TEXT dropWhile -> fused" [~1] forall p t.
900− dropWhile p t = unstream (S.dropWhile p (stream t))
901−"TEXT dropWhile -> unfused" [1] forall p t.
902− unstream (S.dropWhile p (stream t)) = dropWhile p t
903− #-}
904−
905−-- | /O(n)/ 'dropWhileEnd' @p@ @t@ returns the prefix remaining after
906−-- dropping characters that fail the predicate @p@ from the end of
907−-- @t@. Subject to fusion.
908−-- Examples:
909−--
910−-- > dropWhileEnd (=='.') "foo..." == "foo"
911−dropWhileEnd :: (Char -> Bool) -> JSString -> JSString
912−dropWhileEnd = coerce T.dropWhileEnd
913−{-# INLINE [1] dropWhileEnd #-}
914−
915−{-# RULES
916−"TEXT dropWhileEnd -> fused" [~1] forall p t.
917− dropWhileEnd p t = S.reverse (S.dropWhile p (S.reverseStream t))
918−"TEXT dropWhileEnd -> unfused" [1] forall p t.
919− S.reverse (S.dropWhile p (S.reverseStream t)) = dropWhileEnd p t
920− #-}
921−
922−-- | /O(n)/ 'dropAround' @p@ @t@ returns the substring remaining after
923−-- dropping characters that fail the predicate @p@ from both the
924−-- beginning and end of @t@. Subject to fusion.
925−dropAround :: (Char -> Bool) -> JSString -> JSString
926−dropAround = coerce T.dropAround
927−{-# INLINE [1] dropAround #-}
928−
929−-- | /O(n)/ Remove leading white space from a string. Equivalent to:
930−--
931−-- > dropWhile isSpace
932−stripStart :: JSString -> JSString
933−stripStart = coerce T.stripStart
934−{-# INLINE [1] stripStart #-}
935−
936−-- | /O(n)/ Remove trailing white space from a string. Equivalent to:
937−--
938−-- > dropWhileEnd isSpace
939−stripEnd :: JSString -> JSString
940−stripEnd = coerce T.stripEnd
941−{-# INLINE [1] stripEnd #-}
942−
943−-- | /O(n)/ Remove leading and trailing white space from a string.
944−-- Equivalent to:
945−--
946−-- > dropAround isSpace
947−strip :: JSString -> JSString
948−strip = coerce T.strip
949−{-# INLINE [1] strip #-}
950−
951−-- | /O(n)/ 'splitAt' @n t@ returns a pair whose first element is a
952−-- prefix of @t@ of length @n@, and whose second is the remainder of
953−-- the string. It is equivalent to @('take' n t, 'drop' n t)@.
954−splitAt :: Int -> JSString -> (JSString, JSString)
955−splitAt = coerce T.splitAt
956−{-# INLINE splitAt #-}
957−
958−-- | /O(n)/ 'span', applied to a predicate @p@ and text @t@, returns
959−-- a pair whose first element is the longest prefix (possibly empty)
960−-- of @t@ of elements that satisfy @p@, and whose second is the
961−-- remainder of the list.
962−span :: (Char -> Bool) -> JSString -> (JSString, JSString)
963−span = coerce T.span
964−{-# INLINE span #-}
965−
966−-- | /O(n)/ 'break' is like 'span', but the prefix returned is
967−-- over elements that fail the predicate @p@.
968−break :: (Char -> Bool) -> JSString -> (JSString, JSString)
969−break = coerce T.break
970−{-# INLINE break #-}
971−
972−-- | /O(n)/ Group characters in a string according to a predicate.
973−groupBy :: (Char -> Char -> Bool) -> JSString -> [JSString]
974−groupBy = coerce T.groupBy
975−
976−-- | /O(n)/ Group characters in a string by equality.
977−group :: JSString -> [JSString]
978−group = coerce T.group
979−{-# INLINE group #-}
980−
981−group' :: JSString -> [JSString]
982−group' = coerce T.group
983−{-# INLINE group' #-}
984−
985−-- | /O(n^2)/ Return all initial segments of the given 'JSString', shortest
986−-- first.
987−inits :: JSString -> [JSString]
988−inits = coerce T.inits
989−
990−-- | /O(n^2)/ Return all final segments of the given 'JSString', longest
991−-- first.
992−tails :: JSString -> [JSString]
993−tails = coerce T.tails
994−
995−-- $split
996−--
997−-- Splitting functions in this library do not perform character-wise
998−-- copies to create substrings; they just construct new 'JSString's that
999−-- are slices of the original.
1000−
1001−-- | /O(m+n)/ Break a 'JSString' into pieces separated by the first 'JSString'
1002−-- argument (which cannot be empty), consuming the delimiter. An empty
1003−-- delimiter is invalid, and will cause an error to be raised.
1004−--
1005−-- Examples:
1006−--
1007−-- > splitOn "\r\n" "a\r\nb\r\nd\r\ne" == ["a","b","d","e"]
1008−-- > splitOn "aaa" "aaaXaaaXaaaXaaa" == ["","X","X","X",""]
1009−-- > splitOn "x" "x" == ["",""]
1010−--
1011−-- and
1012−--
1013−-- > intercalate s . splitOn s == id
1014−-- > splitOn (singleton c) == split (==c)
1015−--
1016−-- (Note: the string @s@ to split on above cannot be empty.)
1017−--
1018−-- In (unlikely) bad cases, this function's time complexity degrades
1019−-- towards /O(n*m)/.
1020−splitOn :: JSString
1021− -- ^ String to split on. If this string is empty, an error
1022− -- will occur.
1023− -> JSString
1024− -- ^ Input text.
1025− -> [JSString]
1026−splitOn = coerce T.splitOn
1027−{-# INLINE [1] splitOn #-}
1028−
1029−-- RULES
1030−-- "JSSTRING splitOn/singleton -> split/==" [~1] forall c t.
1031−-- splitOn (singleton c) t = split (==c) t
1032−--
1033−
1034−splitOn' :: JSString
1035− -- ^ String to split on. If this string is empty, an error
1036− -- will occur.
1037− -> JSString
1038− -- ^ Input text.
1039− -> [JSString]
1040−splitOn' = coerce T.splitOn
1041−{-# NOINLINE splitOn' #-}
1042−--- {-# INLINE [1] splitOn' #-}
1043−
1044−-- | /O(n)/ Splits a 'JSString' into components delimited by separators,
1045−-- where the predicate returns True for a separator element. The
1046−-- resulting components do not contain the separators. Two adjacent
1047−-- separators result in an empty component in the output. eg.
1048−--
1049−-- > split (=='a') "aabbaca" == ["","","bb","c",""]
1050−-- > split (=='a') "" == [""]
1051−split :: (Char -> Bool) -> JSString -> [JSString]
1052−split = coerce T.split
1053−{-# INLINE split #-}
1054−
1055−-- | /O(n)/ Splits a 'JSString' into components of length @k@. The last
1056−-- element may be shorter than the other chunks, depending on the
1057−-- length of the input. Examples:
1058−--
1059−-- > chunksOf 3 "foobarbaz" == ["foo","bar","baz"]
1060−-- > chunksOf 4 "haskell.org" == ["hask","ell.","org"]
1061−chunksOf :: Int -> JSString -> [JSString]
1062−chunksOf = coerce T.chunksOf
1063−{-# INLINE chunksOf #-}
1064−
1065−-- | /O(n)/ Splits a 'JSString' into components of length @k@. The last
1066−-- element may be shorter than the other chunks, depending on the
1067−-- length of the input. Examples:
1068−--
1069−-- > chunksOf 3 "foobarbaz" == ["foo","bar","baz"]
1070−-- > chunksOf 4 "haskell.org" == ["hask","ell.","org"]
1071−chunksOf' :: Int -> JSString -> [JSString]
1072−chunksOf' = coerce T.chunksOf
1073−{-# INLINE chunksOf' #-}
1074−
1075−-- ----------------------------------------------------------------------------
1076−-- * Searching
1077−
1078−-------------------------------------------------------------------------------
1079−-- ** Searching with a predicate
1080−
1081−-- | /O(n)/ The 'find' function takes a predicate and a 'JSString', and
1082−-- returns the first element matching the predicate, or 'Nothing' if
1083−-- there is no such element.
1084−find :: (Char -> Bool) -> JSString -> Maybe Char
1085−find = coerce T.find
1086−{-# INLINE find #-}
1087−
1088−-- | /O(n)/ The 'partition' function takes a predicate and a 'JSString',
1089−-- and returns the pair of 'JSString's with elements which do and do not
1090−-- satisfy the predicate, respectively; i.e.
1091−--
1092−-- > partition p t == (filter p t, filter (not . p) t)
1093−partition :: (Char -> Bool) -> JSString -> (JSString, JSString)
1094−partition = coerce T.partition
1095−{-# INLINE partition #-}
1096−
1097−-- | /O(n)/ 'filter', applied to a predicate and a 'JSString',
1098−-- returns a 'JSString' containing those characters that satisfy the
1099−-- predicate.
1100−filter :: (Char -> Bool) -> JSString -> JSString
1101−filter = coerce T.filter
1102−{-# INLINE filter #-}
1103−
1104−-- | /O(n+m)/ Find the first instance of @needle@ (which must be
1105−-- non-'null') in @haystack@. The first element of the returned tuple
1106−-- is the prefix of @haystack@ before @needle@ is matched. The second
1107−-- is the remainder of @haystack@, starting with the match.
1108−--
1109−-- Examples:
1110−--
1111−-- > breakOn "::" "a::b::c" ==> ("a", "::b::c")
1112−-- > breakOn "/" "foobar" ==> ("foobar", "")
1113−--
1114−-- Laws:
1115−--
1116−-- > append prefix match == haystack
1117−-- > where (prefix, match) = breakOn needle haystack
1118−--
1119−-- If you need to break a string by a substring repeatedly (e.g. you
1120−-- want to break on every instance of a substring), use 'breakOnAll'
1121−-- instead, as it has lower startup overhead.
1122−--
1123−-- In (unlikely) bad cases, this function's time complexity degrades
1124−-- towards /O(n*m)/.
1125−breakOn :: JSString -> JSString -> (JSString, JSString)
1126−breakOn = coerce T.breakOn
1127−{-# INLINE breakOn #-}
1128−
1129−-- | /O(n+m)/ Similar to 'breakOn', but searches from the end of the
1130−-- string.
1131−--
1132−-- The first element of the returned tuple is the prefix of @haystack@
1133−-- up to and including the last match of @needle@. The second is the
1134−-- remainder of @haystack@, following the match.
1135−--
1136−-- > breakOnEnd "::" "a::b::c" ==> ("a::b::", "c")
1137−breakOnEnd :: JSString -> JSString -> (JSString, JSString)
1138−breakOnEnd = coerce T.breakOnEnd
1139−{-# INLINE breakOnEnd #-}
1140−
1141−-- | /O(n+m)/ Find all non-overlapping instances of @needle@ in
1142−-- @haystack@. Each element of the returned list consists of a pair:
1143−--
1144−-- * The entire string prior to the /k/th match (i.e. the prefix)
1145−--
1146−-- * The /k/th match, followed by the remainder of the string
1147−--
1148−-- Examples:
1149−--
1150−-- > breakOnAll "::" ""
1151−-- > ==> []
1152−-- > breakOnAll "/" "a/b/c/"
1153−-- > ==> [("a", "/b/c/"), ("a/b", "/c/"), ("a/b/c", "/")]
1154−--
1155−-- In (unlikely) bad cases, this function's time complexity degrades
1156−-- towards /O(n*m)/.
1157−--
1158−-- The @needle@ parameter may not be empty.
1159−breakOnAll :: JSString -- ^ @needle@ to search for
1160− -> JSString -- ^ @haystack@ in which to search
1161− -> [(JSString, JSString)]
1162−breakOnAll = coerce T.breakOnAll
1163−{-# INLINE breakOnAll #-}
1164−
1165−breakOnAll' :: JSString -- ^ @needle@ to search for
1166− -> JSString -- ^ @haystack@ in which to search
1167− -> [(JSString, JSString)]
1168−breakOnAll' = coerce T.breakOnAll
1169−{-# INLINE breakOnAll' #-}
1170−
1171−-------------------------------------------------------------------------------
1172−-- ** Indexing 'JSString's
1173−
1174−-- $index
1175−--
1176−-- If you think of a 'JSString' value as an array of 'Char' values (which
1177−-- it is not), you run the risk of writing inefficient code.
1178−--
1179−-- An idiom that is common in some languages is to find the numeric
1180−-- offset of a character or substring, then use that number to split
1181−-- or trim the searched string. With a 'JSString' value, this approach
1182−-- would require two /O(n)/ operations: one to perform the search, and
1183−-- one to operate from wherever the search ended.
1184−--
1185−-- For example, suppose you have a string that you want to split on
1186−-- the substring @\"::\"@, such as @\"foo::bar::quux\"@. Instead of
1187−-- searching for the index of @\"::\"@ and taking the substrings
1188−-- before and after that index, you would instead use @breakOnAll \"::\"@.
1189−
1190−-- | /O(n)/ 'JSString' index (subscript) operator, starting from 0.
1191−index :: JSString -> Int -> Char
1192−index = coerce T.index
1193−{-# INLINE index #-}
1194−
1195−-- | /O(n)/ The 'findIndex' function takes a predicate and a 'JSString'
1196−-- and returns the index of the first element in the 'JSString' satisfying
1197−-- the predicate. Subject to fusion.
1198−findIndex :: (Char -> Bool) -> JSString -> Maybe Int
1199−findIndex = coerce T.findIndex
1200−{-# INLINE findIndex #-}
1201−
1202−-- | /O(n+m)/ The 'count' function returns the number of times the
1203−-- query string appears in the given 'JSString'. An empty query string is
1204−-- invalid, and will cause an error to be raised.
1205−--
1206−-- In (unlikely) bad cases, this function's time complexity degrades
1207−-- towards /O(n*m)/.
1208−count :: JSString -> JSString -> Int
1209−count = coerce T.count
1210−{-# INLINE [1] count #-}
1211−
1212−-- RULES
1213−-- "JSSTRING count/singleton -> countChar" [~1] forall c t.
1214−-- count (singleton c) t = countChar c t
1215−--
1216−
1217−-------------------------------------------------------------------------------
1218−-- * Zipping
1219−
1220−-- | /O(n)/ 'zip' takes two 'JSString's and returns a list of
1221−-- corresponding pairs of bytes. If one input 'JSString' is short,
1222−-- excess elements of the longer 'JSString' are discarded. This is
1223−-- equivalent to a pair of 'unpack' operations.
1224−zip :: JSString -> JSString -> [(Char,Char)]
1225−zip = coerce T.zip
1226−{-# INLINE [0] zip #-}
1227−
1228−-- | /O(n)/ 'zipWith' generalises 'zip' by zipping with the function
1229−-- given as the first argument, instead of a tupling function.
1230−-- Performs replacement on invalid scalar values.
1231−zipWith :: (Char -> Char -> Char) -> JSString -> JSString -> JSString
1232−zipWith = coerce T.zipWith
1233−{-# INLINE [0] zipWith #-}
1234−
1235−-- | /O(n)/ Breaks a 'JSString' up into a list of words, delimited by 'Char's
1236−-- representing white space.
1237−words :: JSString -> [JSString]
1238−words = coerce T.words
1239−{-# INLINE words #-}
1240−
1241−-- fixme: strict words' that allocates the whole list in one go
1242−words' :: JSString -> [JSString]
1243−words' = coerce T.words
1244−{-# INLINE words' #-}
1245−
1246−-- | /O(n)/ Breaks a 'JSString' up into a list of 'JSString's at
1247−-- newline 'Char's. The resulting strings do not contain newlines.
1248−lines :: JSString -> [JSString]
1249−lines = coerce T.lines
1250−{-# INLINE lines #-}
1251−
1252−lines' :: JSString -> [JSString]
1253−lines' = coerce T.lines
1254−{-# INLINE lines' #-}
1255−
1256−{-
1257−-- | /O(n)/ Portably breaks a 'JSString' up into a list of 'JSString's at line
1258−-- boundaries.
1259−--
1260−-- A line boundary is considered to be either a line feed, a carriage
1261−-- return immediately followed by a line feed, or a carriage return.
1262−-- This accounts for both Unix and Windows line ending conventions,
1263−-- and for the old convention used on Mac OS 9 and earlier.
1264−lines' :: Text -> [Text]
1265−lines' ps | null ps = []
1266− | otherwise = h : case uncons t of
1267− Nothing -> []
1268− Just (c,t')
1269− | c == '\n' -> lines t'
1270− | c == '\r' -> case uncons t' of
1271− Just ('\n',t'') -> lines t''
1272− _ -> lines t'
1273− where (h,t) = span notEOL ps
1274− notEOL c = c /= '\n' && c /= '\r'
1275−
1276−-}
1277−
1278−-- | /O(n)/ Joins lines, after appending a terminating newline to
1279−-- each.
1280−unlines :: [JSString] -> JSString
1281−unlines = coerce T.unlines
1282−{-# INLINE unlines #-}
1283−
1284−-- | /O(n)/ Joins words using single space characters.
1285−unwords :: [JSString] -> JSString
1286−unwords = coerce T.unwords
1287−{-# INLINE unwords #-}
1288−
1289−-- | /O(n)/ The 'isPrefixOf' function takes two 'JSString's and returns
1290−-- 'True' iff the first is a prefix of the second. Subject to fusion.
1291−isPrefixOf :: JSString -> JSString -> Bool
1292−isPrefixOf = coerce T.isPrefixOf
1293−{-# INLINE [1] isPrefixOf #-}
1294−
1295−{-# RULES
1296−"JSSTRING isPrefixOf -> fused" [~1] forall x y.
1297− isPrefixOf x y = S.isPrefixOf (stream x) (stream y)
1298−"JSSTRING isPrefixOf -> unfused" [1] forall x y.
1299− S.isPrefixOf (stream x) (stream y) = isPrefixOf x y
1300− #-}
1301−
1302−-- | /O(n)/ The 'isSuffixOf' function takes two 'JSString's and returns
1303−-- 'True' iff the first is a suffix of the second.
1304−isSuffixOf :: JSString -> JSString -> Bool
1305−isSuffixOf = coerce T.isSuffixOf
1306−{-# INLINE isSuffixOf #-}
1307−
1308−-- | The 'isInfixOf' function takes two 'JSString's and returns
1309−-- 'True' iff the first is contained, wholly and intact, anywhere
1310−-- within the second.
1311−--
1312−-- Complexity depends on how the JavaScript engine implements
1313−-- String.prototype.find.
1314−isInfixOf :: JSString -> JSString -> Bool
1315−isInfixOf = coerce T.isInfixOf
1316−{-# INLINE [1] isInfixOf #-}
1317−
1318−{-# RULES
1319−"JSSTRING isInfixOf/singleton -> S.elem/S.stream" [~1] forall n h.
1320− isInfixOf (singleton n) h = S.elem n (S.stream h)
1321− #-}
1322−
1323−-------------------------------------------------------------------------------
1324−-- * View patterns
1325−
1326−-- | /O(n)/ Return the suffix of the second string if its prefix
1327−-- matches the entire first string.
1328−--
1329−-- Examples:
1330−--
1331−-- > stripPrefix "foo" "foobar" == Just "bar"
1332−-- > stripPrefix "" "baz" == Just "baz"
1333−-- > stripPrefix "foo" "quux" == Nothing
1334−--
1335−-- This is particularly useful with the @ViewPatterns@ extension to
1336−-- GHC, as follows:
1337−--
1338−-- > {-# LANGUAGE ViewPatterns #-}
1339−-- > import Data.Text as T
1340−-- >
1341−-- > fnordLength :: JSString -> Int
1342−-- > fnordLength (stripPrefix "fnord" -> Just suf) = T.length suf
1343−-- > fnordLength _ = -1
1344−stripPrefix :: JSString -> JSString -> Maybe JSString
1345−stripPrefix = coerce T.stripPrefix
1346−{-# INLINE stripPrefix #-}
1347−
1348−-- | /O(n)/ Find the longest non-empty common prefix of two strings
1349−-- and return it, along with the suffixes of each string at which they
1350−-- no longer match.
1351−--
1352−-- If the strings do not have a common prefix or either one is empty,
1353−-- this function returns 'Nothing'.
1354−--
1355−-- Examples:
1356−--
1357−-- > commonPrefixes "foobar" "fooquux" == Just ("foo","bar","quux")
1358−-- > commonPrefixes "veeble" "fetzer" == Nothing
1359−-- > commonPrefixes "" "baz" == Nothing
1360−commonPrefixes :: JSString -> JSString -> Maybe (JSString,JSString,JSString)
1361−commonPrefixes = coerce T.commonPrefixes
1362−{-# INLINE commonPrefixes #-}
1363−
1364−-- | /O(n)/ Return the prefix of the second string if its suffix
1365−-- matches the entire first string.
1366−--
1367−-- Examples:
1368−--
1369−-- > stripSuffix "bar" "foobar" == Just "foo"
1370−-- > stripSuffix "" "baz" == Just "baz"
1371−-- > stripSuffix "foo" "quux" == Nothing
1372−--
1373−-- This is particularly useful with the @ViewPatterns@ extension to
1374−-- GHC, as follows:
1375−--
1376−-- > {-# LANGUAGE ViewPatterns #-}
1377−-- > import Data.Text as T
1378−-- >
1379−-- > quuxLength :: Text -> Int
1380−-- > quuxLength (stripSuffix "quux" -> Just pre) = T.length pre
1381−-- > quuxLength _ = -1
1382−stripSuffix :: JSString -> JSString -> Maybe JSString
1383−stripSuffix = coerce T.stripSuffix
1384−{-# INLINE stripSuffix #-}
1385−
1386−---- | Add a list of non-negative numbers. Errors out on overflow.
1387−--sumP :: String -> [Int] -> Int
1388−--sumP fun = go 0
1389−-- where go !a (x:xs)
1390−-- | ax >= 0 = go ax xs
1391−-- | otherwise = overflowError fun
1392−-- where ax = a + x
1393−-- go a _ = a
1394−--
1395−--emptyError :: String -> a
1396−--emptyError fun = P.error $ "Data.JSString." ++ fun ++ ": empty input"
1397−--
1398−--overflowError :: String -> a
1399−--overflowError fun = P.error $ "Data.JSString." ++ fun ++ ": size overflow"
1400−--
1401−--charWidth :: Int# -> Int#
1402−--charWidth cp | isTrue# (cp >=# 0x10000#) = 2#
1403−-- | otherwise = 1#
1404−--{-# INLINE charWidth #-}
jsaddle/src-ghc/Data/JSString/Internal.hsdeleted−1
@@ -1 +0,0 @@
1−module Data.JSString.Internal where
jsaddle/src-ghc/Data/JSString/Internal/Fusion.hsdeleted−127
@@ -1,127 +0,0 @@
1−{-# LANGUAGE BangPatterns, MagicHash
2− #-}
3−module Data.JSString.Internal.Fusion ( -- * Types
4− Stream(..)
5− , Step(..)
6−
7− -- * Creation and elimination
8− , stream
9− , unstream
10− , reverseStream
11−
12− , length
13−
14− -- * Transformations
15− , reverse
16−
17− -- * Construction
18− -- ** Scans
19− , reverseScanr
20−
21− -- ** Accumulating maps
22− , mapAccumL
23−
24− -- ** Generation and unfolding
25− , unfoldrN
26−
27− -- * Indexing
28− , index
29− , findIndex
30− , countChar
31− ) where
32−
33−--import GHC.Exts (Char(..), Int(..), chr#, Int#, isTrue#, (-#), (+#), (>=#))
34−
35−import Prelude hiding (length, reverse)
36−import qualified Data.Text.Internal.Fusion as T
37−--import Data.Char
38−import Data.Coerce (coerce)
39−
40−import Data.JSString.Internal.Type (JSString(..))
41−--import qualified Data.JSString.Internal.Type as I
42−import Data.JSString.Internal.Fusion.Types
43−import qualified Data.JSString.Internal.Fusion.Common as S
44−
45−--import System.IO.Unsafe
46−
47−--import GHCJS.Prim
48−
49−default (Int)
50−
51−-- | /O(n)/ Convert a 'JSString' into a 'Stream Char'.
52−stream :: JSString -> Stream Char
53−stream = coerce T.stream
54−{-# INLINE [0] stream #-}
55−
56−-- | /O(n)/ Convert a 'JSString' into a 'Stream Char', but iterate
57−-- backwards.
58−reverseStream :: JSString -> Stream Char
59−reverseStream = coerce T.reverseStream
60−{-# INLINE [0] reverseStream #-}
61−
62−-- | /O(n)/ Convert a 'Stream Char' into a 'JSString'.
63−unstream :: Stream Char -> JSString
64−unstream = coerce T.unstream
65−{-# INLINE [0] unstream #-}
66−{-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-}
67−
68−
69−-- ----------------------------------------------------------------------------
70−-- * Basic stream functions
71−
72−--runJSString :: ((a -> IO a) -> IO a) -> a
73−--runJSString f = unsafePerformIO (f pure)
74−
75−length :: Stream Char -> Int
76−length = S.lengthI
77−{-# INLINE[0] length #-}
78−
79−-- | /O(n)/ Reverse the characters of a string.
80−reverse :: Stream Char -> JSString
81−reverse = coerce T.reverse
82−{-# INLINE [0] reverse #-}
83−
84−-- | /O(n)/ Perform the equivalent of 'scanr' over a list, only with
85−-- the input and result reversed.
86−reverseScanr :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char
87−reverseScanr = coerce T.reverseScanr
88−{-# INLINE reverseScanr #-}
89−
90−-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a stream from a seed
91−-- value. However, the length of the result is limited by the
92−-- first argument to 'unfoldrN'. This function is more efficient than
93−-- 'unfoldr' when the length of the result is known.
94−unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Stream Char
95−unfoldrN n = S.unfoldrNI n
96−{-# INLINE [0] unfoldrN #-}
97−
98−-------------------------------------------------------------------------------
99−-- ** Indexing streams
100−
101−-- | /O(n)/ stream index (subscript) operator, starting from 0.
102−index :: Stream Char -> Int -> Char
103−index = S.indexI
104−{-# INLINE [0] index #-}
105−
106−-- | The 'findIndex' function takes a predicate and a stream and
107−-- returns the index of the first element in the stream
108−-- satisfying the predicate.
109−findIndex :: (Char -> Bool) -> Stream Char -> Maybe Int
110−findIndex = S.findIndexI
111−{-# INLINE [0] findIndex #-}
112−
113−-- | /O(n)/ The 'count' function returns the number of times the query
114−-- element appears in the given stream.
115−countChar :: Char -> Stream Char -> Int
116−countChar = S.countCharI
117−{-# INLINE [0] countChar #-}
118−
119−-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a
120−-- function to each element of a 'Text', passing an accumulating
121−-- parameter from left to right, and returns a final 'JSString'.
122−mapAccumL :: (a -> Char -> (a, Char)) -> a -> Stream Char -> (a, JSString)
123−mapAccumL a b c = coerce (T.mapAccumL a b c)
124−{-# INLINE [0] mapAccumL #-}
125−
126−-------------------------------------------------------------------------------
127−
jsaddle/src-ghc/Data/JSString/Internal/Fusion/CaseMapping.hsdeleted−570
@@ -1,570 +0,0 @@
1−{-# LANGUAGE Rank2Types #-}
2−-- AUTOMATICALLY GENERATED - DO NOT EDIT
3−-- Generated by scripts/SpecialCasing.hs
4−-- CaseFolding-6.3.0.txt
5−-- Date: 2012-12-20, 22:14:35 GMT [MD]
6−-- SpecialCasing-6.3.0.txt
7−-- Date: 2013-05-08, 13:54:51 GMT [MD]
8−
9−module Data.JSString.Internal.Fusion.CaseMapping where
10−import Data.Char
11−import Data.JSString.Internal.Fusion.Types
12−
13−upperMapping :: forall s. Char -> s -> Step (CC s) Char
14−{-# INLINE upperMapping #-}
15−-- LATIN SMALL LETTER SHARP S
16−upperMapping '\x00df' s = Yield '\x0053' (CC s '\x0053' '\x0000')
17−-- LATIN SMALL LIGATURE FF
18−upperMapping '\xfb00' s = Yield '\x0046' (CC s '\x0046' '\x0000')
19−-- LATIN SMALL LIGATURE FI
20−upperMapping '\xfb01' s = Yield '\x0046' (CC s '\x0049' '\x0000')
21−-- LATIN SMALL LIGATURE FL
22−upperMapping '\xfb02' s = Yield '\x0046' (CC s '\x004c' '\x0000')
23−-- LATIN SMALL LIGATURE FFI
24−upperMapping '\xfb03' s = Yield '\x0046' (CC s '\x0046' '\x0049')
25−-- LATIN SMALL LIGATURE FFL
26−upperMapping '\xfb04' s = Yield '\x0046' (CC s '\x0046' '\x004c')
27−-- LATIN SMALL LIGATURE LONG S T
28−upperMapping '\xfb05' s = Yield '\x0053' (CC s '\x0054' '\x0000')
29−-- LATIN SMALL LIGATURE ST
30−upperMapping '\xfb06' s = Yield '\x0053' (CC s '\x0054' '\x0000')
31−-- ARMENIAN SMALL LIGATURE ECH YIWN
32−upperMapping '\x0587' s = Yield '\x0535' (CC s '\x0552' '\x0000')
33−-- ARMENIAN SMALL LIGATURE MEN NOW
34−upperMapping '\xfb13' s = Yield '\x0544' (CC s '\x0546' '\x0000')
35−-- ARMENIAN SMALL LIGATURE MEN ECH
36−upperMapping '\xfb14' s = Yield '\x0544' (CC s '\x0535' '\x0000')
37−-- ARMENIAN SMALL LIGATURE MEN INI
38−upperMapping '\xfb15' s = Yield '\x0544' (CC s '\x053b' '\x0000')
39−-- ARMENIAN SMALL LIGATURE VEW NOW
40−upperMapping '\xfb16' s = Yield '\x054e' (CC s '\x0546' '\x0000')
41−-- ARMENIAN SMALL LIGATURE MEN XEH
42−upperMapping '\xfb17' s = Yield '\x0544' (CC s '\x053d' '\x0000')
43−-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE
44−upperMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000')
45−-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
46−upperMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301')
47−-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
48−upperMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301')
49−-- LATIN SMALL LETTER J WITH CARON
50−upperMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000')
51−-- LATIN SMALL LETTER H WITH LINE BELOW
52−upperMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000')
53−-- LATIN SMALL LETTER T WITH DIAERESIS
54−upperMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000')
55−-- LATIN SMALL LETTER W WITH RING ABOVE
56−upperMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000')
57−-- LATIN SMALL LETTER Y WITH RING ABOVE
58−upperMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000')
59−-- LATIN SMALL LETTER A WITH RIGHT HALF RING
60−upperMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000')
61−-- GREEK SMALL LETTER UPSILON WITH PSILI
62−upperMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000')
63−-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA
64−upperMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300')
65−-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA
66−upperMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301')
67−-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI
68−upperMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342')
69−-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI
70−upperMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000')
71−-- GREEK SMALL LETTER ETA WITH PERISPOMENI
72−upperMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000')
73−-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA
74−upperMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300')
75−-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA
76−upperMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301')
77−-- GREEK SMALL LETTER IOTA WITH PERISPOMENI
78−upperMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000')
79−-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI
80−upperMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342')
81−-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA
82−upperMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300')
83−-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA
84−upperMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301')
85−-- GREEK SMALL LETTER RHO WITH PSILI
86−upperMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000')
87−-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI
88−upperMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000')
89−-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI
90−upperMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342')
91−-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI
92−upperMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000')
93−-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI
94−upperMapping '\x1f80' s = Yield '\x1f08' (CC s '\x0399' '\x0000')
95−-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI
96−upperMapping '\x1f81' s = Yield '\x1f09' (CC s '\x0399' '\x0000')
97−-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI
98−upperMapping '\x1f82' s = Yield '\x1f0a' (CC s '\x0399' '\x0000')
99−-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI
100−upperMapping '\x1f83' s = Yield '\x1f0b' (CC s '\x0399' '\x0000')
101−-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI
102−upperMapping '\x1f84' s = Yield '\x1f0c' (CC s '\x0399' '\x0000')
103−-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI
104−upperMapping '\x1f85' s = Yield '\x1f0d' (CC s '\x0399' '\x0000')
105−-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
106−upperMapping '\x1f86' s = Yield '\x1f0e' (CC s '\x0399' '\x0000')
107−-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
108−upperMapping '\x1f87' s = Yield '\x1f0f' (CC s '\x0399' '\x0000')
109−-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI
110−upperMapping '\x1f88' s = Yield '\x1f08' (CC s '\x0399' '\x0000')
111−-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI
112−upperMapping '\x1f89' s = Yield '\x1f09' (CC s '\x0399' '\x0000')
113−-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI
114−upperMapping '\x1f8a' s = Yield '\x1f0a' (CC s '\x0399' '\x0000')
115−-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI
116−upperMapping '\x1f8b' s = Yield '\x1f0b' (CC s '\x0399' '\x0000')
117−-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI
118−upperMapping '\x1f8c' s = Yield '\x1f0c' (CC s '\x0399' '\x0000')
119−-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI
120−upperMapping '\x1f8d' s = Yield '\x1f0d' (CC s '\x0399' '\x0000')
121−-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
122−upperMapping '\x1f8e' s = Yield '\x1f0e' (CC s '\x0399' '\x0000')
123−-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
124−upperMapping '\x1f8f' s = Yield '\x1f0f' (CC s '\x0399' '\x0000')
125−-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI
126−upperMapping '\x1f90' s = Yield '\x1f28' (CC s '\x0399' '\x0000')
127−-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI
128−upperMapping '\x1f91' s = Yield '\x1f29' (CC s '\x0399' '\x0000')
129−-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI
130−upperMapping '\x1f92' s = Yield '\x1f2a' (CC s '\x0399' '\x0000')
131−-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI
132−upperMapping '\x1f93' s = Yield '\x1f2b' (CC s '\x0399' '\x0000')
133−-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI
134−upperMapping '\x1f94' s = Yield '\x1f2c' (CC s '\x0399' '\x0000')
135−-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI
136−upperMapping '\x1f95' s = Yield '\x1f2d' (CC s '\x0399' '\x0000')
137−-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
138−upperMapping '\x1f96' s = Yield '\x1f2e' (CC s '\x0399' '\x0000')
139−-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
140−upperMapping '\x1f97' s = Yield '\x1f2f' (CC s '\x0399' '\x0000')
141−-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI
142−upperMapping '\x1f98' s = Yield '\x1f28' (CC s '\x0399' '\x0000')
143−-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI
144−upperMapping '\x1f99' s = Yield '\x1f29' (CC s '\x0399' '\x0000')
145−-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI
146−upperMapping '\x1f9a' s = Yield '\x1f2a' (CC s '\x0399' '\x0000')
147−-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI
148−upperMapping '\x1f9b' s = Yield '\x1f2b' (CC s '\x0399' '\x0000')
149−-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI
150−upperMapping '\x1f9c' s = Yield '\x1f2c' (CC s '\x0399' '\x0000')
151−-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI
152−upperMapping '\x1f9d' s = Yield '\x1f2d' (CC s '\x0399' '\x0000')
153−-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
154−upperMapping '\x1f9e' s = Yield '\x1f2e' (CC s '\x0399' '\x0000')
155−-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
156−upperMapping '\x1f9f' s = Yield '\x1f2f' (CC s '\x0399' '\x0000')
157−-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI
158−upperMapping '\x1fa0' s = Yield '\x1f68' (CC s '\x0399' '\x0000')
159−-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI
160−upperMapping '\x1fa1' s = Yield '\x1f69' (CC s '\x0399' '\x0000')
161−-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI
162−upperMapping '\x1fa2' s = Yield '\x1f6a' (CC s '\x0399' '\x0000')
163−-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI
164−upperMapping '\x1fa3' s = Yield '\x1f6b' (CC s '\x0399' '\x0000')
165−-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI
166−upperMapping '\x1fa4' s = Yield '\x1f6c' (CC s '\x0399' '\x0000')
167−-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI
168−upperMapping '\x1fa5' s = Yield '\x1f6d' (CC s '\x0399' '\x0000')
169−-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
170−upperMapping '\x1fa6' s = Yield '\x1f6e' (CC s '\x0399' '\x0000')
171−-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
172−upperMapping '\x1fa7' s = Yield '\x1f6f' (CC s '\x0399' '\x0000')
173−-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI
174−upperMapping '\x1fa8' s = Yield '\x1f68' (CC s '\x0399' '\x0000')
175−-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI
176−upperMapping '\x1fa9' s = Yield '\x1f69' (CC s '\x0399' '\x0000')
177−-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI
178−upperMapping '\x1faa' s = Yield '\x1f6a' (CC s '\x0399' '\x0000')
179−-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI
180−upperMapping '\x1fab' s = Yield '\x1f6b' (CC s '\x0399' '\x0000')
181−-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI
182−upperMapping '\x1fac' s = Yield '\x1f6c' (CC s '\x0399' '\x0000')
183−-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI
184−upperMapping '\x1fad' s = Yield '\x1f6d' (CC s '\x0399' '\x0000')
185−-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
186−upperMapping '\x1fae' s = Yield '\x1f6e' (CC s '\x0399' '\x0000')
187−-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
188−upperMapping '\x1faf' s = Yield '\x1f6f' (CC s '\x0399' '\x0000')
189−-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI
190−upperMapping '\x1fb3' s = Yield '\x0391' (CC s '\x0399' '\x0000')
191−-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI
192−upperMapping '\x1fbc' s = Yield '\x0391' (CC s '\x0399' '\x0000')
193−-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI
194−upperMapping '\x1fc3' s = Yield '\x0397' (CC s '\x0399' '\x0000')
195−-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI
196−upperMapping '\x1fcc' s = Yield '\x0397' (CC s '\x0399' '\x0000')
197−-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI
198−upperMapping '\x1ff3' s = Yield '\x03a9' (CC s '\x0399' '\x0000')
199−-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI
200−upperMapping '\x1ffc' s = Yield '\x03a9' (CC s '\x0399' '\x0000')
201−-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI
202−upperMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0399' '\x0000')
203−-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI
204−upperMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0399' '\x0000')
205−-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI
206−upperMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0399' '\x0000')
207−-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI
208−upperMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0399' '\x0000')
209−-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI
210−upperMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0399' '\x0000')
211−-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI
212−upperMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0399' '\x0000')
213−-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI
214−upperMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0399')
215−-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI
216−upperMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0399')
217−-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI
218−upperMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0399')
219−upperMapping c s = Yield (toUpper c) (CC s '\0' '\0')
220−lowerMapping :: forall s. Char -> s -> Step (CC s) Char
221−{-# INLINE lowerMapping #-}
222−-- LATIN CAPITAL LETTER I WITH DOT ABOVE
223−lowerMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000')
224−lowerMapping c s = Yield (toLower c) (CC s '\0' '\0')
225−titleMapping :: forall s. Char -> s -> Step (CC s) Char
226−{-# INLINE titleMapping #-}
227−-- LATIN SMALL LETTER SHARP S
228−titleMapping '\x00df' s = Yield '\x0053' (CC s '\x0073' '\x0000')
229−-- LATIN SMALL LIGATURE FF
230−titleMapping '\xfb00' s = Yield '\x0046' (CC s '\x0066' '\x0000')
231−-- LATIN SMALL LIGATURE FI
232−titleMapping '\xfb01' s = Yield '\x0046' (CC s '\x0069' '\x0000')
233−-- LATIN SMALL LIGATURE FL
234−titleMapping '\xfb02' s = Yield '\x0046' (CC s '\x006c' '\x0000')
235−-- LATIN SMALL LIGATURE FFI
236−titleMapping '\xfb03' s = Yield '\x0046' (CC s '\x0066' '\x0069')
237−-- LATIN SMALL LIGATURE FFL
238−titleMapping '\xfb04' s = Yield '\x0046' (CC s '\x0066' '\x006c')
239−-- LATIN SMALL LIGATURE LONG S T
240−titleMapping '\xfb05' s = Yield '\x0053' (CC s '\x0074' '\x0000')
241−-- LATIN SMALL LIGATURE ST
242−titleMapping '\xfb06' s = Yield '\x0053' (CC s '\x0074' '\x0000')
243−-- ARMENIAN SMALL LIGATURE ECH YIWN
244−titleMapping '\x0587' s = Yield '\x0535' (CC s '\x0582' '\x0000')
245−-- ARMENIAN SMALL LIGATURE MEN NOW
246−titleMapping '\xfb13' s = Yield '\x0544' (CC s '\x0576' '\x0000')
247−-- ARMENIAN SMALL LIGATURE MEN ECH
248−titleMapping '\xfb14' s = Yield '\x0544' (CC s '\x0565' '\x0000')
249−-- ARMENIAN SMALL LIGATURE MEN INI
250−titleMapping '\xfb15' s = Yield '\x0544' (CC s '\x056b' '\x0000')
251−-- ARMENIAN SMALL LIGATURE VEW NOW
252−titleMapping '\xfb16' s = Yield '\x054e' (CC s '\x0576' '\x0000')
253−-- ARMENIAN SMALL LIGATURE MEN XEH
254−titleMapping '\xfb17' s = Yield '\x0544' (CC s '\x056d' '\x0000')
255−-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE
256−titleMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000')
257−-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
258−titleMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301')
259−-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
260−titleMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301')
261−-- LATIN SMALL LETTER J WITH CARON
262−titleMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000')
263−-- LATIN SMALL LETTER H WITH LINE BELOW
264−titleMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000')
265−-- LATIN SMALL LETTER T WITH DIAERESIS
266−titleMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000')
267−-- LATIN SMALL LETTER W WITH RING ABOVE
268−titleMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000')
269−-- LATIN SMALL LETTER Y WITH RING ABOVE
270−titleMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000')
271−-- LATIN SMALL LETTER A WITH RIGHT HALF RING
272−titleMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000')
273−-- GREEK SMALL LETTER UPSILON WITH PSILI
274−titleMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000')
275−-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA
276−titleMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300')
277−-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA
278−titleMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301')
279−-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI
280−titleMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342')
281−-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI
282−titleMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000')
283−-- GREEK SMALL LETTER ETA WITH PERISPOMENI
284−titleMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000')
285−-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA
286−titleMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300')
287−-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA
288−titleMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301')
289−-- GREEK SMALL LETTER IOTA WITH PERISPOMENI
290−titleMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000')
291−-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI
292−titleMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342')
293−-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA
294−titleMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300')
295−-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA
296−titleMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301')
297−-- GREEK SMALL LETTER RHO WITH PSILI
298−titleMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000')
299−-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI
300−titleMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000')
301−-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI
302−titleMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342')
303−-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI
304−titleMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000')
305−-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI
306−titleMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0345' '\x0000')
307−-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI
308−titleMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0345' '\x0000')
309−-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI
310−titleMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0345' '\x0000')
311−-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI
312−titleMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0345' '\x0000')
313−-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI
314−titleMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0345' '\x0000')
315−-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI
316−titleMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0345' '\x0000')
317−-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI
318−titleMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0345')
319−-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI
320−titleMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0345')
321−-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI
322−titleMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0345')
323−titleMapping c s = Yield (toTitle c) (CC s '\0' '\0')
324−foldMapping :: forall s. Char -> s -> Step (CC s) Char
325−{-# INLINE foldMapping #-}
326−-- MICRO SIGN
327−foldMapping '\x00b5' s = Yield '\x03bc' (CC s '\x0000' '\x0000')
328−-- LATIN SMALL LETTER SHARP S
329−foldMapping '\x00df' s = Yield '\x0073' (CC s '\x0073' '\x0000')
330−-- LATIN CAPITAL LETTER I WITH DOT ABOVE
331−foldMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000')
332−-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE
333−foldMapping '\x0149' s = Yield '\x02bc' (CC s '\x006e' '\x0000')
334−-- LATIN SMALL LETTER LONG S
335−foldMapping '\x017f' s = Yield '\x0073' (CC s '\x0000' '\x0000')
336−-- LATIN SMALL LETTER J WITH CARON
337−foldMapping '\x01f0' s = Yield '\x006a' (CC s '\x030c' '\x0000')
338−-- COMBINING GREEK YPOGEGRAMMENI
339−foldMapping '\x0345' s = Yield '\x03b9' (CC s '\x0000' '\x0000')
340−-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
341−foldMapping '\x0390' s = Yield '\x03b9' (CC s '\x0308' '\x0301')
342−-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
343−foldMapping '\x03b0' s = Yield '\x03c5' (CC s '\x0308' '\x0301')
344−-- GREEK SMALL LETTER FINAL SIGMA
345−foldMapping '\x03c2' s = Yield '\x03c3' (CC s '\x0000' '\x0000')
346−-- GREEK BETA SYMBOL
347−foldMapping '\x03d0' s = Yield '\x03b2' (CC s '\x0000' '\x0000')
348−-- GREEK THETA SYMBOL
349−foldMapping '\x03d1' s = Yield '\x03b8' (CC s '\x0000' '\x0000')
350−-- GREEK PHI SYMBOL
351−foldMapping '\x03d5' s = Yield '\x03c6' (CC s '\x0000' '\x0000')
352−-- GREEK PI SYMBOL
353−foldMapping '\x03d6' s = Yield '\x03c0' (CC s '\x0000' '\x0000')
354−-- GREEK KAPPA SYMBOL
355−foldMapping '\x03f0' s = Yield '\x03ba' (CC s '\x0000' '\x0000')
356−-- GREEK RHO SYMBOL
357−foldMapping '\x03f1' s = Yield '\x03c1' (CC s '\x0000' '\x0000')
358−-- GREEK LUNATE EPSILON SYMBOL
359−foldMapping '\x03f5' s = Yield '\x03b5' (CC s '\x0000' '\x0000')
360−-- ARMENIAN SMALL LIGATURE ECH YIWN
361−foldMapping '\x0587' s = Yield '\x0565' (CC s '\x0582' '\x0000')
362−-- GEORGIAN CAPITAL LETTER YN
363−foldMapping '\x10c7' s = Yield '\x2d27' (CC s '\x0000' '\x0000')
364−-- GEORGIAN CAPITAL LETTER AEN
365−foldMapping '\x10cd' s = Yield '\x2d2d' (CC s '\x0000' '\x0000')
366−-- LATIN SMALL LETTER H WITH LINE BELOW
367−foldMapping '\x1e96' s = Yield '\x0068' (CC s '\x0331' '\x0000')
368−-- LATIN SMALL LETTER T WITH DIAERESIS
369−foldMapping '\x1e97' s = Yield '\x0074' (CC s '\x0308' '\x0000')
370−-- LATIN SMALL LETTER W WITH RING ABOVE
371−foldMapping '\x1e98' s = Yield '\x0077' (CC s '\x030a' '\x0000')
372−-- LATIN SMALL LETTER Y WITH RING ABOVE
373−foldMapping '\x1e99' s = Yield '\x0079' (CC s '\x030a' '\x0000')
374−-- LATIN SMALL LETTER A WITH RIGHT HALF RING
375−foldMapping '\x1e9a' s = Yield '\x0061' (CC s '\x02be' '\x0000')
376−-- LATIN SMALL LETTER LONG S WITH DOT ABOVE
377−foldMapping '\x1e9b' s = Yield '\x1e61' (CC s '\x0000' '\x0000')
378−-- LATIN CAPITAL LETTER SHARP S
379−foldMapping '\x1e9e' s = Yield '\x0073' (CC s '\x0073' '\x0000')
380−-- GREEK SMALL LETTER UPSILON WITH PSILI
381−foldMapping '\x1f50' s = Yield '\x03c5' (CC s '\x0313' '\x0000')
382−-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA
383−foldMapping '\x1f52' s = Yield '\x03c5' (CC s '\x0313' '\x0300')
384−-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA
385−foldMapping '\x1f54' s = Yield '\x03c5' (CC s '\x0313' '\x0301')
386−-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI
387−foldMapping '\x1f56' s = Yield '\x03c5' (CC s '\x0313' '\x0342')
388−-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI
389−foldMapping '\x1f80' s = Yield '\x1f00' (CC s '\x03b9' '\x0000')
390−-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI
391−foldMapping '\x1f81' s = Yield '\x1f01' (CC s '\x03b9' '\x0000')
392−-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI
393−foldMapping '\x1f82' s = Yield '\x1f02' (CC s '\x03b9' '\x0000')
394−-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI
395−foldMapping '\x1f83' s = Yield '\x1f03' (CC s '\x03b9' '\x0000')
396−-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI
397−foldMapping '\x1f84' s = Yield '\x1f04' (CC s '\x03b9' '\x0000')
398−-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI
399−foldMapping '\x1f85' s = Yield '\x1f05' (CC s '\x03b9' '\x0000')
400−-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
401−foldMapping '\x1f86' s = Yield '\x1f06' (CC s '\x03b9' '\x0000')
402−-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
403−foldMapping '\x1f87' s = Yield '\x1f07' (CC s '\x03b9' '\x0000')
404−-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI
405−foldMapping '\x1f88' s = Yield '\x1f00' (CC s '\x03b9' '\x0000')
406−-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI
407−foldMapping '\x1f89' s = Yield '\x1f01' (CC s '\x03b9' '\x0000')
408−-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI
409−foldMapping '\x1f8a' s = Yield '\x1f02' (CC s '\x03b9' '\x0000')
410−-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI
411−foldMapping '\x1f8b' s = Yield '\x1f03' (CC s '\x03b9' '\x0000')
412−-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI
413−foldMapping '\x1f8c' s = Yield '\x1f04' (CC s '\x03b9' '\x0000')
414−-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI
415−foldMapping '\x1f8d' s = Yield '\x1f05' (CC s '\x03b9' '\x0000')
416−-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
417−foldMapping '\x1f8e' s = Yield '\x1f06' (CC s '\x03b9' '\x0000')
418−-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
419−foldMapping '\x1f8f' s = Yield '\x1f07' (CC s '\x03b9' '\x0000')
420−-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI
421−foldMapping '\x1f90' s = Yield '\x1f20' (CC s '\x03b9' '\x0000')
422−-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI
423−foldMapping '\x1f91' s = Yield '\x1f21' (CC s '\x03b9' '\x0000')
424−-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI
425−foldMapping '\x1f92' s = Yield '\x1f22' (CC s '\x03b9' '\x0000')
426−-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI
427−foldMapping '\x1f93' s = Yield '\x1f23' (CC s '\x03b9' '\x0000')
428−-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI
429−foldMapping '\x1f94' s = Yield '\x1f24' (CC s '\x03b9' '\x0000')
430−-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI
431−foldMapping '\x1f95' s = Yield '\x1f25' (CC s '\x03b9' '\x0000')
432−-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
433−foldMapping '\x1f96' s = Yield '\x1f26' (CC s '\x03b9' '\x0000')
434−-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
435−foldMapping '\x1f97' s = Yield '\x1f27' (CC s '\x03b9' '\x0000')
436−-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI
437−foldMapping '\x1f98' s = Yield '\x1f20' (CC s '\x03b9' '\x0000')
438−-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI
439−foldMapping '\x1f99' s = Yield '\x1f21' (CC s '\x03b9' '\x0000')
440−-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI
441−foldMapping '\x1f9a' s = Yield '\x1f22' (CC s '\x03b9' '\x0000')
442−-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI
443−foldMapping '\x1f9b' s = Yield '\x1f23' (CC s '\x03b9' '\x0000')
444−-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI
445−foldMapping '\x1f9c' s = Yield '\x1f24' (CC s '\x03b9' '\x0000')
446−-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI
447−foldMapping '\x1f9d' s = Yield '\x1f25' (CC s '\x03b9' '\x0000')
448−-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
449−foldMapping '\x1f9e' s = Yield '\x1f26' (CC s '\x03b9' '\x0000')
450−-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
451−foldMapping '\x1f9f' s = Yield '\x1f27' (CC s '\x03b9' '\x0000')
452−-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI
453−foldMapping '\x1fa0' s = Yield '\x1f60' (CC s '\x03b9' '\x0000')
454−-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI
455−foldMapping '\x1fa1' s = Yield '\x1f61' (CC s '\x03b9' '\x0000')
456−-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI
457−foldMapping '\x1fa2' s = Yield '\x1f62' (CC s '\x03b9' '\x0000')
458−-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI
459−foldMapping '\x1fa3' s = Yield '\x1f63' (CC s '\x03b9' '\x0000')
460−-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI
461−foldMapping '\x1fa4' s = Yield '\x1f64' (CC s '\x03b9' '\x0000')
462−-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI
463−foldMapping '\x1fa5' s = Yield '\x1f65' (CC s '\x03b9' '\x0000')
464−-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
465−foldMapping '\x1fa6' s = Yield '\x1f66' (CC s '\x03b9' '\x0000')
466−-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
467−foldMapping '\x1fa7' s = Yield '\x1f67' (CC s '\x03b9' '\x0000')
468−-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI
469−foldMapping '\x1fa8' s = Yield '\x1f60' (CC s '\x03b9' '\x0000')
470−-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI
471−foldMapping '\x1fa9' s = Yield '\x1f61' (CC s '\x03b9' '\x0000')
472−-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI
473−foldMapping '\x1faa' s = Yield '\x1f62' (CC s '\x03b9' '\x0000')
474−-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI
475−foldMapping '\x1fab' s = Yield '\x1f63' (CC s '\x03b9' '\x0000')
476−-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI
477−foldMapping '\x1fac' s = Yield '\x1f64' (CC s '\x03b9' '\x0000')
478−-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI
479−foldMapping '\x1fad' s = Yield '\x1f65' (CC s '\x03b9' '\x0000')
480−-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
481−foldMapping '\x1fae' s = Yield '\x1f66' (CC s '\x03b9' '\x0000')
482−-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
483−foldMapping '\x1faf' s = Yield '\x1f67' (CC s '\x03b9' '\x0000')
484−-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI
485−foldMapping '\x1fb2' s = Yield '\x1f70' (CC s '\x03b9' '\x0000')
486−-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI
487−foldMapping '\x1fb3' s = Yield '\x03b1' (CC s '\x03b9' '\x0000')
488−-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI
489−foldMapping '\x1fb4' s = Yield '\x03ac' (CC s '\x03b9' '\x0000')
490−-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI
491−foldMapping '\x1fb6' s = Yield '\x03b1' (CC s '\x0342' '\x0000')
492−-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI
493−foldMapping '\x1fb7' s = Yield '\x03b1' (CC s '\x0342' '\x03b9')
494−-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI
495−foldMapping '\x1fbc' s = Yield '\x03b1' (CC s '\x03b9' '\x0000')
496−-- GREEK PROSGEGRAMMENI
497−foldMapping '\x1fbe' s = Yield '\x03b9' (CC s '\x0000' '\x0000')
498−-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI
499−foldMapping '\x1fc2' s = Yield '\x1f74' (CC s '\x03b9' '\x0000')
500−-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI
501−foldMapping '\x1fc3' s = Yield '\x03b7' (CC s '\x03b9' '\x0000')
502−-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI
503−foldMapping '\x1fc4' s = Yield '\x03ae' (CC s '\x03b9' '\x0000')
504−-- GREEK SMALL LETTER ETA WITH PERISPOMENI
505−foldMapping '\x1fc6' s = Yield '\x03b7' (CC s '\x0342' '\x0000')
506−-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI
507−foldMapping '\x1fc7' s = Yield '\x03b7' (CC s '\x0342' '\x03b9')
508−-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI
509−foldMapping '\x1fcc' s = Yield '\x03b7' (CC s '\x03b9' '\x0000')
510−-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA
511−foldMapping '\x1fd2' s = Yield '\x03b9' (CC s '\x0308' '\x0300')
512−-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA
513−foldMapping '\x1fd3' s = Yield '\x03b9' (CC s '\x0308' '\x0301')
514−-- GREEK SMALL LETTER IOTA WITH PERISPOMENI
515−foldMapping '\x1fd6' s = Yield '\x03b9' (CC s '\x0342' '\x0000')
516−-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI
517−foldMapping '\x1fd7' s = Yield '\x03b9' (CC s '\x0308' '\x0342')
518−-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA
519−foldMapping '\x1fe2' s = Yield '\x03c5' (CC s '\x0308' '\x0300')
520−-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA
521−foldMapping '\x1fe3' s = Yield '\x03c5' (CC s '\x0308' '\x0301')
522−-- GREEK SMALL LETTER RHO WITH PSILI
523−foldMapping '\x1fe4' s = Yield '\x03c1' (CC s '\x0313' '\x0000')
524−-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI
525−foldMapping '\x1fe6' s = Yield '\x03c5' (CC s '\x0342' '\x0000')
526−-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI
527−foldMapping '\x1fe7' s = Yield '\x03c5' (CC s '\x0308' '\x0342')
528−-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI
529−foldMapping '\x1ff2' s = Yield '\x1f7c' (CC s '\x03b9' '\x0000')
530−-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI
531−foldMapping '\x1ff3' s = Yield '\x03c9' (CC s '\x03b9' '\x0000')
532−-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI
533−foldMapping '\x1ff4' s = Yield '\x03ce' (CC s '\x03b9' '\x0000')
534−-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI
535−foldMapping '\x1ff6' s = Yield '\x03c9' (CC s '\x0342' '\x0000')
536−-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI
537−foldMapping '\x1ff7' s = Yield '\x03c9' (CC s '\x0342' '\x03b9')
538−-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI
539−foldMapping '\x1ffc' s = Yield '\x03c9' (CC s '\x03b9' '\x0000')
540−-- COPTIC CAPITAL LETTER BOHAIRIC KHEI
541−foldMapping '\x2cf2' s = Yield '\x2cf3' (CC s '\x0000' '\x0000')
542−-- LATIN CAPITAL LETTER C WITH BAR
543−foldMapping '\xa792' s = Yield '\xa793' (CC s '\x0000' '\x0000')
544−-- LATIN CAPITAL LETTER H WITH HOOK
545−foldMapping '\xa7aa' s = Yield '\x0266' (CC s '\x0000' '\x0000')
546−-- LATIN SMALL LIGATURE FF
547−foldMapping '\xfb00' s = Yield '\x0066' (CC s '\x0066' '\x0000')
548−-- LATIN SMALL LIGATURE FI
549−foldMapping '\xfb01' s = Yield '\x0066' (CC s '\x0069' '\x0000')
550−-- LATIN SMALL LIGATURE FL
551−foldMapping '\xfb02' s = Yield '\x0066' (CC s '\x006c' '\x0000')
552−-- LATIN SMALL LIGATURE FFI
553−foldMapping '\xfb03' s = Yield '\x0066' (CC s '\x0066' '\x0069')
554−-- LATIN SMALL LIGATURE FFL
555−foldMapping '\xfb04' s = Yield '\x0066' (CC s '\x0066' '\x006c')
556−-- LATIN SMALL LIGATURE LONG S T
557−foldMapping '\xfb05' s = Yield '\x0073' (CC s '\x0074' '\x0000')
558−-- LATIN SMALL LIGATURE ST
559−foldMapping '\xfb06' s = Yield '\x0073' (CC s '\x0074' '\x0000')
560−-- ARMENIAN SMALL LIGATURE MEN NOW
561−foldMapping '\xfb13' s = Yield '\x0574' (CC s '\x0576' '\x0000')
562−-- ARMENIAN SMALL LIGATURE MEN ECH
563−foldMapping '\xfb14' s = Yield '\x0574' (CC s '\x0565' '\x0000')
564−-- ARMENIAN SMALL LIGATURE MEN INI
565−foldMapping '\xfb15' s = Yield '\x0574' (CC s '\x056b' '\x0000')
566−-- ARMENIAN SMALL LIGATURE VEW NOW
567−foldMapping '\xfb16' s = Yield '\x057e' (CC s '\x0576' '\x0000')
568−-- ARMENIAN SMALL LIGATURE MEN XEH
569−foldMapping '\xfb17' s = Yield '\x0574' (CC s '\x056d' '\x0000')
570−foldMapping c s = Yield (toLower c) (CC s '\0' '\0')
jsaddle/src-ghc/Data/JSString/Internal/Fusion/Common.hsdeleted−92
@@ -1,92 +0,0 @@
1−{-# LANGUAGE BangPatterns, MagicHash, RankNTypes #-}
2−
3−module Data.JSString.Internal.Fusion.Common ( -- * Creation and elimination
4− singleton
5− , streamList
6− , unstreamList
7− , streamCString#
8−
9− -- * Basic interface
10− , cons
11− , snoc
12− , append
13− , head
14− , uncons
15− , last
16− , tail
17− , init
18− , null
19− , lengthI
20− , compareLengthI
21− , isSingleton
22−
23− -- * Transformations
24− , map
25− , intercalate
26− , intersperse
27−
28− -- ** Case conversion
29− -- $case
30− , toCaseFold
31− , toLower
32− , toTitle
33− , toUpper
34−
35− -- ** Justification
36− , justifyLeftI
37−
38− -- * Folds
39− , foldl
40− , foldl'
41− , foldl1
42− , foldl1'
43− , foldr
44− , foldr1
45−
46− -- ** Special folds
47− , concat
48− , concatMap
49− , any
50− , all
51− , maximum
52− , minimum
53−
54− -- * Construction
55− -- ** Scans
56− , scanl
57−
58− -- ** Accumulating maps
59− -- , mapAccumL
60−
61− -- ** Generation and unfolding
62− , replicateCharI
63− , replicateI
64− , unfoldr
65− , unfoldrNI
66−
67− -- * Substrings
68− -- ** Breaking strings
69− , take
70− , drop
71− , takeWhile
72− , dropWhile
73−
74− -- * Predicates
75− , isPrefixOf
76−
77− -- * Searching
78− , elem
79− , filter
80−
81− -- * Indexing
82− , findBy
83− , indexI
84− , findIndexI
85− , countCharI
86−
87− -- * Zipping and unzipping
88− , zipWith
89− ) where
90−
91−import Data.Text.Internal.Fusion.Common
92−import Prelude ()
jsaddle/src-ghc/Data/JSString/Internal/Fusion/Types.hsdeleted−122
@@ -1,122 +0,0 @@
1−{-# LANGUAGE BangPatterns, ExistentialQuantification #-}
2−-- |
3−-- Module : Data.Text.Internal.Fusion.Types
4−-- Copyright : (c) Tom Harper 2008-2009,
5−-- (c) Bryan O'Sullivan 2009,
6−-- (c) Duncan Coutts 2009,
7−-- (c) Jasper Van der Jeugt 2011
8−--
9−-- License : BSD-style
10−-- Maintainer : bos@serpentine.com
11−-- Stability : experimental
12−-- Portability : GHC
13−--
14−-- /Warning/: this is an internal module, and does not have a stable
15−-- API or name. Functions in this module may not check or enforce
16−-- preconditions expected by public modules. Use at your own risk!
17−--
18−-- Core stream fusion functionality for text.
19−
20−module Data.JSString.Internal.Fusion.Types
21− (
22− CC(..)
23−-- , M(..)
24−-- , M8
25− , PairS(..)
26− , RS(..)
27− , Step(..)
28− , Stream(..)
29−-- , Switch(..)
30− , empty
31− ) where
32−
33−import Data.Text.Internal.Fusion.Types
34−-- import Data.Text.Internal.Fusion.Size
35−-- import Data.Word (Word8)
36−
37−---- | Specialised tuple for case conversion.
38−--data CC s = CC !s {-# UNPACK #-} !Char {-# UNPACK #-} !Char
39−--
40−---- | Specialised, strict Maybe-like type.
41−--data M a = N
42−-- | J !a
43−--
44−--type M8 = M Word8
45−--
46−---- Restreaming state.
47−--data RS s
48−-- = RS0 !s
49−-- | RS1 !s {-# UNPACK #-} !Word8
50−-- | RS2 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
51−-- | RS3 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
52−--
53−--infixl 2 :*:
54−--data PairS a b = !a :*: !b
55−-- -- deriving (Eq, Ord, Show)
56−--
57−---- | Allow a function over a stream to switch between two states.
58−--data Switch = S1 | S2
59−--
60−--data Step s a = Done
61−-- | Skip !s
62−-- | Yield !a !s
63−--
64−--{-
65−--instance (Show a) => Show (Step s a)
66−-- where show Done = "Done"
67−-- show (Skip _) = "Skip"
68−-- show (Yield x _) = "Yield " ++ show x
69−---}
70−--
71−--instance (Eq a) => Eq (Stream a) where
72−-- (==) = eq
73−--
74−--instance (Ord a) => Ord (Stream a) where
75−-- compare = cmp
76−--
77−---- The length hint in a Stream has two roles. If its value is zero,
78−---- we trust it, and treat the stream as empty. Otherwise, we treat it
79−---- as a hint: it should usually be accurate, so we use it when
80−---- unstreaming to decide what size array to allocate. However, the
81−---- unstreaming functions must be able to cope with the hint being too
82−---- small or too large.
83−--
84−--data Stream a =
85−-- forall s. Stream
86−-- (s -> Step s a) -- stepper function
87−-- !s -- current state
88−--
89−---- | /O(n)/ Determines if two streams are equal.
90−--eq :: (Eq a) => Stream a -> Stream a -> Bool
91−--eq (Stream next1 s1) (Stream next2 s2) = loop (next1 s1) (next2 s2)
92−-- where
93−-- loop Done Done = True
94−-- loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
95−-- loop (Skip s1') x2 = loop (next1 s1') x2
96−-- loop x1 (Skip s2') = loop x1 (next2 s2')
97−-- loop Done _ = False
98−-- loop _ Done = False
99−-- loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
100−-- loop (next1 s1') (next2 s2')
101−--{-# INLINE [0] eq #-}
102−--
103−--cmp :: (Ord a) => Stream a -> Stream a -> Ordering
104−--cmp (Stream next1 s1) (Stream next2 s2) = loop (next1 s1) (next2 s2)
105−-- where
106−-- loop Done Done = EQ
107−-- loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
108−-- loop (Skip s1') x2 = loop (next1 s1') x2
109−-- loop x1 (Skip s2') = loop x1 (next2 s2')
110−-- loop Done _ = LT
111−-- loop _ Done = GT
112−-- loop (Yield x1 s1') (Yield x2 s2') =
113−-- case compare x1 x2 of
114−-- EQ -> loop (next1 s1') (next2 s2')
115−-- other -> other
116−--{-# INLINE [0] cmp #-}
117−--
118−---- | The empty stream.
119−--empty :: Stream a
120−--empty = Stream next ()
121−-- where next _ = Done
122−--{-# INLINE [0] empty #-}
jsaddle/src-ghc/Data/JSString/Internal/Search.hsdeleted−11
@@ -1,11 +0,0 @@
1−module Data.JSString.Internal.Search ( indices
2− ) where
3−
4−import Data.Coerce (coerce)
5−
6−import Data.JSString.Internal.Type (JSString(..))
7−
8−import qualified Data.Text.Internal.Search as T
9−
10−indices :: JSString -> JSString -> [Int]
11−indices = coerce T.indices
jsaddle/src-ghc/Data/JSString/Internal/Type.hsdeleted−116
@@ -1,116 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable, UnboxedTuples, MagicHash,
2− BangPatterns, GeneralizedNewtypeDeriving #-}
3−{-# OPTIONS_HADDOCK not-home #-}
4−module Data.JSString.Internal.Type ( JSString(..)
5− , empty
6− , empty_
7− , safe
8− , firstf
9− ) where
10−
11− {-
12− -- * Construction
13− , text
14− , textP
15− -- * Safety
16− , safe
17− -- * Code that must be here for accessibility
18− , empty
19− , empty_
20− -- * Utilities
21− , firstf
22− -- * Checked multiplication
23− , mul
24− , mul32
25− , mul64
26− -- * Debugging
27− , showText
28−
29− ) where
30−-}
31−import Control.DeepSeq
32−
33−import Data.Coerce (coerce)
34−import Data.Text (Text)
35−import qualified Data.Text as T (empty)
36−import Data.String (IsString)
37−import Data.Aeson (ToJSON(..), FromJSON(..))
38−import Data.Data (Data)
39−-- import Data.Text.Internal.Unsafe.Char (ord)
40−import Data.Typeable (Typeable)
41−import Data.Semigroup (Semigroup)
42−import GHC.Exts (Char(..), ord#, andI#, (/=#), isTrue#)
43−
44−-- | A wrapper around a JavaScript string
45−newtype JSString = JSString Text deriving(Show, Read, IsString, Semigroup, Monoid, Ord, Eq, Data, ToJSON, FromJSON, Typeable)
46−
47−instance NFData JSString where rnf !_ = ()
48−
49−-- | /O(1)/ The empty 'JSString'.
50−empty :: JSString
51−empty = coerce T.empty
52−{-# INLINE [1] empty #-}
53−
54−-- | A non-inlined version of 'empty'.
55−empty_ :: JSString
56−empty_ = coerce T.empty
57−{-# NOINLINE empty_ #-}
58−
59−safe :: Char -> Char
60−safe c@(C# cc)
61− | isTrue# (andI# (ord# cc) 0x1ff800# /=# 0xd800#) = c
62− | otherwise = '\xfffd'
63−{-# INLINE [0] safe #-}
64−
65−
66−-- | Apply a function to the first element of an optional pair.
67−firstf :: (a -> c) -> Maybe (a,b) -> Maybe (c,b)
68−firstf f (Just (a, b)) = Just (f a, b)
69−firstf _ Nothing = Nothing
70−
71−{-
72−-- | Checked multiplication. Calls 'error' if the result would
73−-- overflow.
74−mul :: Int -> Int -> Int
75−#if WORD_SIZE_IN_BITS == 64
76−mul a b = fromIntegral $ fromIntegral a `mul64` fromIntegral b
77−#else
78−mul a b = fromIntegral $ fromIntegral a `mul32` fromIntegral b
79−#endif
80−{-# INLINE mul #-}
81−infixl 7 `mul`
82−
83−-- | Checked multiplication. Calls 'error' if the result would
84−-- overflow.
85−mul64 :: Int64 -> Int64 -> Int64
86−mul64 a b
87− | a >= 0 && b >= 0 = mul64_ a b
88− | a >= 0 = -mul64_ a (-b)
89− | b >= 0 = -mul64_ (-a) b
90− | otherwise = mul64_ (-a) (-b)
91−{-# INLINE mul64 #-}
92−infixl 7 `mul64`
93−
94−mul64_ :: Int64 -> Int64 -> Int64
95−mul64_ a b
96− | ahi > 0 && bhi > 0 = error "overflow"
97− | top > 0x7fffffff = error "overflow"
98− | total < 0 = error "overflow"
99− | otherwise = total
100− where (# ahi, alo #) = (# a `shiftR` 32, a .&. 0xffffffff #)
101− (# bhi, blo #) = (# b `shiftR` 32, b .&. 0xffffffff #)
102− top = ahi * blo + alo * bhi
103− total = (top `shiftL` 32) + alo * blo
104−{-# INLINE mul64_ #-}
105−
106−-- | Checked multiplication. Calls 'error' if the result would
107−-- overflow.
108−mul32 :: Int32 -> Int32 -> Int32
109−mul32 a b = case fromIntegral a * fromIntegral b of
110− ab | ab < min32 || ab > max32 -> error "overflow"
111− | otherwise -> fromIntegral ab
112− where min32 = -0x80000000 :: Int64
113− max32 = 0x7fffffff
114−{-# INLINE mul32 #-}
115−infixl 7 `mul32`
116−-}
jsaddle/src-ghc/Data/JSString/Text.hsdeleted−52
@@ -1,52 +0,0 @@
1−{- | Conversion between 'Data.Text.Text' and 'Data.JSString.JSString' -}
2−
3−module Data.JSString.Text
4− ( textToJSString
5− , textFromJSString
6− , lazyTextToJSString
7− , lazyTextFromJSString
8− , textFromJSVal
9− , lazyTextFromJSVal
10− ) where
11−
12−import GHCJS.Prim.Internal (JSVal)
13−
14−import Data.Coerce (coerce)
15−import qualified Data.Text as T
16−import qualified Data.Text.Lazy as TL
17−
18−import Data.JSString.Internal.Type
19−
20−import Language.Javascript.JSaddle.Types (JSM, GHCJSPure(..))
21−import Language.Javascript.JSaddle.Native.Internal
22− (valueToString)
23−
24−textToJSString :: T.Text -> JSString
25−textToJSString = coerce
26−{-# INLINE textToJSString #-}
27−
28−textFromJSString :: JSString -> T.Text
29−textFromJSString = coerce
30−{-# INLINE textFromJSString #-}
31−
32−lazyTextToJSString :: TL.Text -> JSString
33−lazyTextToJSString = coerce . TL.toStrict
34−{-# INLINE lazyTextToJSString #-}
35−
36−lazyTextFromJSString :: JSString -> TL.Text
37−lazyTextFromJSString = TL.fromStrict . coerce
38−{-# INLINE lazyTextFromJSString #-}
39−
40−-- | returns the empty Text if not a string
41−textFromJSVal :: JSVal -> GHCJSPure T.Text
42−textFromJSVal j = GHCJSPure $ textFromJSString <$> valToJSString j
43−{-# INLINE textFromJSVal #-}
44−
45−-- | returns the empty Text if not a string
46−lazyTextFromJSVal :: JSVal -> GHCJSPure TL.Text
47−lazyTextFromJSVal j = GHCJSPure $ lazyTextFromJSString <$> valToJSString j
48−{-# INLINE lazyTextFromJSVal #-}
49−
50−valToJSString :: JSVal -> JSM JSString
51−valToJSString = valueToString
52−{-# INLINE valToJSString #-}
jsaddle/src-ghc/GHCJS/Buffer.hsdeleted−117
@@ -1,117 +0,0 @@
1−module GHCJS.Buffer
2− ( Buffer
3− , MutableBuffer
4− , create
5− , createFromArrayBuffer
6− , thaw, freeze, clone
7− -- * JavaScript properties
8− , byteLength
9− , getArrayBuffer
10− , getUint8Array
11− , getUint16Array
12− , getInt32Array
13− , getDataView
14− , getFloat32Array
15− , getFloat64Array
16− -- * bytestring
17− , toByteString, fromByteString
18− ) where
19−
20−import GHCJS.Buffer.Types
21−
22−import Control.Lens.Operators ((^.))
23−
24−import Data.ByteString (ByteString)
25−import qualified Data.ByteString as BS
26−import qualified Data.ByteString.Base64 as B64 (encode, decode)
27−import Data.Text.Encoding (encodeUtf8, decodeUtf8)
28−
29−import qualified JavaScript.TypedArray.Internal.Types as I
30−import JavaScript.TypedArray.ArrayBuffer.Internal (SomeArrayBuffer(..))
31−import JavaScript.TypedArray.DataView.Internal (SomeDataView(..))
32−
33−import GHCJS.Marshal (FromJSVal(..))
34−import Language.Javascript.JSaddle.Types (JSM, GHCJSPure(..), ghcjsPure)
35−import Language.Javascript.JSaddle.Object (js, js2, jsg1, jsg3)
36−
37−create :: Int -> JSM MutableBuffer
38−create n | n >= 0 = SomeBuffer <$> jsg1 "h$newByteArray" n
39− | otherwise = error "create: negative size"
40−{-# INLINE create #-}
41−
42−createFromArrayBuffer :: SomeArrayBuffer any -> GHCJSPure (SomeBuffer any)
43−createFromArrayBuffer (SomeArrayBuffer buf) = GHCJSPure $ SomeBuffer <$> jsg1 "h$wrapBuffer" buf
44−{-# INLINE createFromArrayBuffer #-}
45−
46−getArrayBuffer :: SomeBuffer any -> GHCJSPure (SomeArrayBuffer any)
47−getArrayBuffer (SomeBuffer buf) = GHCJSPure $ SomeArrayBuffer <$> buf ^. js "buf"
48−{-# INLINE getArrayBuffer #-}
49−
50−getInt32Array :: SomeBuffer any -> GHCJSPure (I.SomeInt32Array any)
51−getInt32Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "i3"
52−{-# INLINE getInt32Array #-}
53−
54−getUint8Array :: SomeBuffer any -> GHCJSPure (I.SomeUint8Array any)
55−getUint8Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "u8"
56−{-# INLINE getUint8Array #-}
57−
58−getUint16Array :: SomeBuffer any -> GHCJSPure (I.SomeUint16Array any)
59−getUint16Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "u1"
60−{-# INLINE getUint16Array #-}
61−
62−getFloat32Array :: SomeBuffer any -> GHCJSPure (I.SomeFloat32Array any)
63−getFloat32Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "f3"
64−{-# INLINE getFloat32Array #-}
65−
66−getFloat64Array :: SomeBuffer any -> GHCJSPure (I.SomeFloat64Array any)
67−getFloat64Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "f6"
68−{-# INLINE getFloat64Array #-}
69−
70−getDataView :: SomeBuffer any -> GHCJSPure (SomeDataView any)
71−getDataView (SomeBuffer buf) = GHCJSPure $ SomeDataView <$> buf ^. js "dv"
72−{-# INLINE getDataView #-}
73−
74−freeze :: MutableBuffer -> JSM Buffer
75−freeze = js_clone
76−{-# INLINE freeze #-}
77−
78−thaw :: Buffer -> JSM MutableBuffer
79−thaw = js_clone
80−{-# INLINE thaw #-}
81−
82−clone :: MutableBuffer -> JSM (SomeBuffer any2)
83−clone = js_clone
84−{-# INLINE clone #-}
85−
86−fromByteString :: ByteString -> GHCJSPure (Buffer, Int, Int)
87−fromByteString bs = GHCJSPure $ do
88− buffer <- SomeBuffer <$> jsg1 "h$newByteArrayFromBase64String" (decodeUtf8 $ B64.encode bs)
89− return (buffer, 0, BS.length bs)
90−{-# INLINE fromByteString #-}
91−
92−-- | Wrap a 'Buffer' into a 'ByteString' using the given offset
93−-- and length.
94−toByteString :: Int -> Maybe Int -> Buffer -> GHCJSPure ByteString
95−toByteString off mbLen buf = GHCJSPure $ do
96− bufLen <- ghcjsPure $ byteLength buf
97− case mbLen of
98− _ | off < 0 -> error "toByteString: negative offset"
99− | off > bufLen -> error "toByteString: offset past end of buffer"
100− Just len | len < 0 -> error "toByteString: negative length"
101− | len > bufLen - off -> error "toByteString: length past end of buffer"
102− | otherwise -> ghcjsPure $ unsafeToByteString off len buf
103− Nothing -> ghcjsPure $ unsafeToByteString off (bufLen - off) buf
104−
105−unsafeToByteString :: Int -> Int -> Buffer -> GHCJSPure ByteString
106−unsafeToByteString off len (SomeBuffer buf) = GHCJSPure $ do
107− b64 <- jsg3 "h$byteArrayToBase64String" off len buf >>= fromJSValUnchecked
108− return $ case B64.decode (encodeUtf8 b64) of
109− Left err -> error $ "unsafeToByteString base 64 decode error :" ++ err
110− Right bs -> bs
111−
112−byteLength :: SomeBuffer any -> GHCJSPure Int
113−byteLength (SomeBuffer buf) = GHCJSPure $ buf ^. js "len" >>= fromJSValUnchecked
114−{-# INLINE byteLength #-}
115−
116−js_clone :: SomeBuffer any1 -> JSM (SomeBuffer any2)
117−js_clone (SomeBuffer buf) = SomeBuffer <$> jsg1 "h$wrapBuffer" (buf ^. js "buf" ^. js2 "slice" (buf ^. js "u8" ^. js "byteOffset") (buf ^. js "len"))
jsaddle/src-ghc/GHCJS/Buffer/Types.hsdeleted−11
@@ -1,11 +0,0 @@
1−{-# LANGUAGE DataKinds, KindSignatures, PolyKinds #-}
2−
3−module GHCJS.Buffer.Types where
4−
5−import GHCJS.Types
6−import GHCJS.Internal.Types
7−
8−newtype SomeBuffer (a :: MutabilityType s) = SomeBuffer JSVal
9−
10−type Buffer = SomeBuffer Immutable
11−type MutableBuffer = SomeBuffer Mutable
jsaddle/src-ghc/GHCJS/Concurrent.hsdeleted−22
@@ -1,22 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−
3−module GHCJS.Concurrent ( OnBlocked(..)
4− , WouldBlockException(..)
5− ) where
6−
7−import GHCJS.Prim
8−
9−import Data.Data
10−
11−{- |
12− The runtime tries to run synchronous threads to completion. Sometimes it's
13− not possible to continue running a thread, for example when the thread
14− tries to take an empty 'MVar'. The runtime can then either throw a
15− 'WouldBlockException', aborting the blocking action, or continue the
16− thread asynchronously.
17− -}
18−
19−data OnBlocked = ContinueAsync -- ^ continue the thread asynchronously if blocked
20− | ThrowWouldBlock -- ^ throw 'WouldBlockException' if blocked
21− deriving (Data, Typeable, Enum, Show, Eq, Ord)
22−
jsaddle/src-ghc/GHCJS/Foreign.hsdeleted−64
@@ -1,64 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−-----------------------------------------------------------------------------
3−--
4−-- Module : Language.Javascript.JSaddle.Value
5−-- Copyright : (c) Hamish Mackenzie
6−-- License : MIT
7−--
8−-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
9−--
10−-- |
11−--
12−-----------------------------------------------------------------------------
13−module GHCJS.Foreign (
14− jsTrue
15− , jsFalse
16− , jsNull
17− , toJSBool
18−-- , fromJSBool
19− , jsUndefined
20− , isTruthy
21− , isNull
22− , isUndefined
23− , isObject
24− , isFunction
25− , isString
26− , isBoolean
27− , isSymbol
28− , isNumber
29− , JSType(..)
30− , jsTypeOf
31−) where
32−
33−import GHCJS.Foreign.Internal
34−import Language.Javascript.JSaddle.Types (JSVal(..), GHCJSPure(..))
35−import Language.Javascript.JSaddle.Object (jsg1)
36−import GHCJS.Marshal (FromJSVal(..))
37−
38−isObject :: JSVal -> GHCJSPure Bool
39−isObject v = GHCJSPure $ jsg1 "h$isObject" v >>= fromJSValUnchecked
40−{-# INLINE isObject #-}
41−
42−isFunction :: JSVal -> GHCJSPure Bool
43−isFunction v = GHCJSPure $ jsg1 "h$isFunction" v >>= fromJSValUnchecked
44−{-# INLINE isFunction #-}
45−
46−isString :: JSVal -> GHCJSPure Bool
47−isString v = GHCJSPure $ jsg1 "h$isString" v >>= fromJSValUnchecked
48−{-# INLINE isString #-}
49−
50−isBoolean :: JSVal -> GHCJSPure Bool
51−isBoolean v = GHCJSPure $ jsg1 "h$isBoolean" v >>= fromJSValUnchecked
52−{-# INLINE isBoolean #-}
53−
54−isSymbol :: JSVal -> GHCJSPure Bool
55−isSymbol v = GHCJSPure $ jsg1 "h$isSymbol" v >>= fromJSValUnchecked
56−{-# INLINE isSymbol #-}
57−
58−isNumber :: JSVal -> GHCJSPure Bool
59−isNumber v = GHCJSPure $ jsg1 "h$isNumber" v >>= fromJSValUnchecked
60−{-# INLINE isNumber #-}
61−
62−jsTypeOf :: JSVal -> GHCJSPure JSType
63−jsTypeOf v = GHCJSPure $ toEnum <$> (jsg1 "h$jsonTypeOf" v >>= fromJSValUnchecked)
64−{-# INLINE jsTypeOf #-}
jsaddle/src-ghc/GHCJS/Foreign/Internal.hsdeleted−67
@@ -1,67 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.Javascript.JSaddle.Value
4−-- Copyright : (c) Hamish Mackenzie
5−-- License : MIT
6−--
7−-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
8−--
9−-- |
10−--
11−-----------------------------------------------------------------------------
12−module GHCJS.Foreign.Internal (
13− jsTrue
14− , jsFalse
15− , jsNull
16− , toJSBool
17−-- , fromJSBool
18− , jsUndefined
19− , isTruthy
20− , isNull
21− , isUndefined
22− , JSType(..)
23−) where
24−
25−import Language.Javascript.JSaddle.Types (JSVal(..), GHCJSPure(..))
26−import Language.Javascript.JSaddle.Native.Internal
27− (valueToBool)
28−import Data.Typeable (Typeable)
29−import GHCJS.Prim (isNull, isUndefined)
30−import System.IO.Unsafe (unsafePerformIO)
31−import Data.IORef (newIORef)
32−
33−jsTrue :: JSVal
34−jsTrue = JSVal . unsafePerformIO $ newIORef 3
35−{-# NOINLINE jsTrue #-}
36−
37−jsFalse :: JSVal
38−jsFalse = JSVal . unsafePerformIO $ newIORef 2
39−{-# NOINLINE jsFalse #-}
40−
41−jsNull :: JSVal
42−jsNull = JSVal . unsafePerformIO $ newIORef 0
43−{-# NOINLINE jsNull #-}
44−
45−toJSBool :: Bool -> JSVal
46−toJSBool b = JSVal . unsafePerformIO . newIORef $ if b then 3 else 2
47−{-# NOINLINE toJSBool #-}
48−
49−jsUndefined :: JSVal
50−jsUndefined = JSVal . unsafePerformIO $ newIORef 1
51−{-# NOINLINE jsUndefined #-}
52−
53−isTruthy :: JSVal -> GHCJSPure Bool
54−isTruthy = GHCJSPure . valueToBool
55−{-# INLINE isTruthy #-}
56−
57−-- types returned by JS typeof operator
58−data JSType = Undefined
59− | Object
60− | Boolean
61− | Number
62− | String
63− | Symbol
64− | Function
65− | Other -- ^ implementation dependent
66− deriving (Show, Eq, Ord, Enum, Typeable)
67−
jsaddle/src-ghc/GHCJS/Internal/Types.hsdeleted−16
@@ -1,16 +0,0 @@
1−module GHCJS.Internal.Types ( IsJSVal(..)
2− , jsval
3− , MutabilityType(..)
4− , Mutable
5− , Immutable
6− , IsItMutable(..)
7− , Mutability
8− ) where
9−
10−import Language.Javascript.JSaddle.Types
11−import Language.Javascript.JSaddle.Native.Internal (stringToValue)
12−
13−instance IsJSVal JSString where
14− jsval_ a = GHCJSPure $ stringToValue a
15− {-# INLINE jsval_ #-}
16−
jsaddle/src-ghc/GHCJS/Marshal.hs+36−37
@@ -17,23 +17,19 @@ import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
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)
21import Data.Word (Word8, Word16, Word32, Word)
20import Data.Word (Word8, Word16, Word32, Word)
22
21
23import GHC.Prim
22import GHC.Prim
24
23
25−import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), ghcjsPure)
24+import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), Command(ValueToJSONValue), Result(ValueToJSONValueResult))
26−import Language.Javascript.JSaddle.Native.Internal
25+import Language.Javascript.JSaddle.Native (withToJSVal)
27− (valueToJSONValue, jsonValueToValue, valueToNumber)
26+import Language.Javascript.JSaddle.Run(sendCommand)
28−
29−import GHCJS.Types (JSString, isUndefined, isNull)
30−import GHCJS.Foreign.Internal (isTruthy)
31−import GHCJS.Marshal.Pure ()
32−
33−import JavaScript.Array (fromListIO)
34−import qualified JavaScript.Array as A (read)
35−
36import GHCJS.Marshal.Internal
27import GHCJS.Marshal.Internal
28+import GHCJS.Marshal.Pure ()
29+import Language.Javascript.JSaddle.Value (isUndefinedIO, valToNumber,
30+ valToBool, valMakeJSON)
31+import Language.Javascript.JSaddle.Array (fromListIO)
32+import qualified Language.Javascript.JSaddle.Array as A (read)
37
33
38instance FromJSVal JSVal where
34instance FromJSVal JSVal where
39 fromJSValUnchecked x = return x
35 fromJSValUnchecked x = return x
@@ -46,62 +42,65 @@ instance FromJSVal () where
46 fromJSVal = fromJSVal_pure
42 fromJSVal = fromJSVal_pure
47-- {-# INLINE fromJSVal #-}
43-- {-# INLINE fromJSVal #-}
48instance FromJSVal Bool where
44instance FromJSVal Bool where
49− fromJSValUnchecked = ghcjsPure . isTruthy
45+ fromJSValUnchecked = valToBool
50 {-# INLINE fromJSValUnchecked #-}
46 {-# INLINE fromJSValUnchecked #-}
51− fromJSVal = fmap Just . ghcjsPure . isTruthy
47+ fromJSVal = fmap Just . valToBool
52 {-# INLINE fromJSVal #-}
48 {-# INLINE fromJSVal #-}
53instance FromJSVal Int where
49instance FromJSVal Int where
54− fromJSValUnchecked = fmap round . valueToNumber
50+ fromJSValUnchecked = fmap round . valToNumber
55 {-# INLINE fromJSValUnchecked #-}
51 {-# INLINE fromJSValUnchecked #-}
56− fromJSVal = fmap (Just . round) . valueToNumber
52+ fromJSVal = fmap (Just . round) . valToNumber
57 {-# INLINE fromJSVal #-}
53 {-# INLINE fromJSVal #-}
58instance FromJSVal Int8 where
54instance FromJSVal Int8 where
59− fromJSValUnchecked = fmap round . valueToNumber
55+ fromJSValUnchecked = fmap round . valToNumber
60 {-# INLINE fromJSValUnchecked #-}
56 {-# INLINE fromJSValUnchecked #-}
61− fromJSVal = fmap (Just . round) . valueToNumber
57+ fromJSVal = fmap (Just . round) . valToNumber
62 {-# INLINE fromJSVal #-}
58 {-# INLINE fromJSVal #-}
63instance FromJSVal Int16 where
59instance FromJSVal Int16 where
64− fromJSValUnchecked = fmap round . valueToNumber
60+ fromJSValUnchecked = fmap round . valToNumber
65 {-# INLINE fromJSValUnchecked #-}
61 {-# INLINE fromJSValUnchecked #-}
66− fromJSVal = fmap (Just . round) . valueToNumber
62+ fromJSVal = fmap (Just . round) . valToNumber
67 {-# INLINE fromJSVal #-}
63 {-# INLINE fromJSVal #-}
68instance FromJSVal Int32 where
64instance FromJSVal Int32 where
69− fromJSValUnchecked = fmap round . valueToNumber
65+ fromJSValUnchecked = fmap round . valToNumber
70 {-# INLINE fromJSValUnchecked #-}
66 {-# INLINE fromJSValUnchecked #-}
71− fromJSVal = fmap (Just . round) . valueToNumber
67+ fromJSVal = fmap (Just . round) . valToNumber
72 {-# INLINE fromJSVal #-}
68 {-# INLINE fromJSVal #-}
73instance FromJSVal Word where
69instance FromJSVal Word where
74− fromJSValUnchecked = fmap round . valueToNumber
70+ fromJSValUnchecked = fmap round . valToNumber
75 {-# INLINE fromJSValUnchecked #-}
71 {-# INLINE fromJSValUnchecked #-}
76− fromJSVal = fmap (Just . round) . valueToNumber
72+ fromJSVal = fmap (Just . round) . valToNumber
77 {-# INLINE fromJSVal #-}
73 {-# INLINE fromJSVal #-}
78instance FromJSVal Word8 where
74instance FromJSVal Word8 where
79− fromJSValUnchecked = fmap round . valueToNumber
75+ fromJSValUnchecked = fmap round . valToNumber
80 {-# INLINE fromJSValUnchecked #-}
76 {-# INLINE fromJSValUnchecked #-}
81− fromJSVal = fmap (Just . round) . valueToNumber
77+ fromJSVal = fmap (Just . round) . valToNumber
82 {-# INLINE fromJSVal #-}
78 {-# INLINE fromJSVal #-}
83instance FromJSVal Word16 where
79instance FromJSVal Word16 where
84− fromJSValUnchecked = fmap round . valueToNumber
80+ fromJSValUnchecked = fmap round . valToNumber
85 {-# INLINE fromJSValUnchecked #-}
81 {-# INLINE fromJSValUnchecked #-}
86− fromJSVal = fmap (Just . round) . valueToNumber
82+ fromJSVal = fmap (Just . round) . valToNumber
87 {-# INLINE fromJSVal #-}
83 {-# INLINE fromJSVal #-}
88instance FromJSVal Word32 where
84instance FromJSVal Word32 where
89− fromJSValUnchecked = fmap round . valueToNumber
85+ fromJSValUnchecked = fmap round . valToNumber
90 {-# INLINE fromJSValUnchecked #-}
86 {-# INLINE fromJSValUnchecked #-}
91− fromJSVal = fmap (Just . round) . valueToNumber
87+ fromJSVal = fmap (Just . round) . valToNumber
92 {-# INLINE fromJSVal #-}
88 {-# INLINE fromJSVal #-}
93instance FromJSVal Float where
89instance FromJSVal Float where
94− fromJSValUnchecked = fmap realToFrac . valueToNumber
90+ fromJSValUnchecked = fmap realToFrac . valToNumber
95 {-# INLINE fromJSValUnchecked #-}
91 {-# INLINE fromJSValUnchecked #-}
96− fromJSVal = fmap (Just . realToFrac) . valueToNumber
92+ fromJSVal = fmap (Just . realToFrac) . valToNumber
97 {-# INLINE fromJSVal #-}
93 {-# INLINE fromJSVal #-}
98instance FromJSVal Double where
94instance FromJSVal Double where
99− fromJSValUnchecked = valueToNumber
95+ fromJSValUnchecked = valToNumber
100 {-# INLINE fromJSValUnchecked #-}
96 {-# INLINE fromJSValUnchecked #-}
101− fromJSVal = fmap Just . valueToNumber
97+ fromJSVal = fmap Just . valToNumber
102 {-# INLINE fromJSVal #-}
98 {-# INLINE fromJSVal #-}
103instance FromJSVal AE.Value where
99instance FromJSVal AE.Value where
104− fromJSVal r = Just <$> valueToJSONValue r
100+ fromJSVal r =
101+ withToJSVal r $ \rval -> do
102+ ~(ValueToJSONValueResult result) <- sendCommand (ValueToJSONValue rval)
103+ return $ Just result
105 {-# INLINE fromJSVal #-}
104 {-# INLINE fromJSVal #-}
106instance (FromJSVal a, FromJSVal b) => FromJSVal (a,b) where
105instance (FromJSVal a, FromJSVal b) => FromJSVal (a,b) where
107 fromJSVal r = runMaybeT $ (,) <$> jf r 0 <*> jf r 1
106 fromJSVal r = runMaybeT $ (,) <$> jf r 0 <*> jf r 1
@@ -128,7 +127,7 @@ instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJ
128jf :: FromJSVal a => JSVal -> Int -> MaybeT JSM a
127jf :: FromJSVal a => JSVal -> Int -> MaybeT JSM a
129jf r n = MaybeT $ do
128jf r n = MaybeT $ do
130 r' <- A.read n (SomeJSArray r)
129 r' <- A.read n (SomeJSArray r)
131− ghcjsPure (isUndefined r) >>= \case
130+ isUndefinedIO r >>= \case
132 True -> return Nothing
131 True -> return Nothing
133 False -> fromJSVal r'
132 False -> fromJSVal r'
134
133
@@ -165,5 +164,5 @@ arr7 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSM JSVal
165arr7 a b c d e f g = coerce <$> fromListIO [a,b,c,d,e,f,g]
164arr7 a b c d e f g = coerce <$> fromListIO [a,b,c,d,e,f,g]
166
165
167toJSVal_aeson :: AE.ToJSON a => a -> JSM JSVal
166toJSVal_aeson :: AE.ToJSON a => a -> JSM JSVal
168−toJSVal_aeson = jsonValueToValue . AE.toJSON
167+toJSVal_aeson = valMakeJSON . AE.toJSON
169
168
jsaddle/src-ghc/GHCJS/Marshal/Internal.hs+32−66
@@ -1,21 +1,21 @@
1−{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, DefaultSignatures,
1+{-# LANGUAGE 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 ( FromJSVal(..)
6+module GHCJS.Marshal.Internal (
7+ FromJSVal(..)
7− , ToJSVal(..)
8+ , ToJSVal(..)
8− , PToJSVal(..)
9+ , PToJSVal(..)
9− , PFromJSVal(..)
10+ , PFromJSVal(..)
10− , Purity(..)
11+ , Purity(..)
11− , toJSVal_generic
12+ , toJSVal_generic
12− , fromJSVal_generic
13+ , fromJSVal_generic
13− , toJSVal_pure
14+ , toJSVal_pure
14− , fromJSVal_pure
15+ , fromJSVal_pure
15− , fromJSValUnchecked_pure
16+ , fromJSValUnchecked_pure
16− ) where
17+ ) where
17−
18+
18−import Control.Applicative
19import Control.Monad
19import Control.Monad
20
20
21import Data.Data
21import Data.Data
@@ -25,17 +25,11 @@ import qualified Data.Text as T (pack)
25
25
26import GHC.Generics
26import GHC.Generics
27
27
28−import qualified GHCJS.Prim.Internal as Prim
28+import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), MutableJSArray, JSString)
29−import qualified GHCJS.Foreign.Internal as F
29+import Language.Javascript.JSaddle.Foreign (jsNull, jsTrue, isUndefinedIO)
30−import GHCJS.Types
31−
32−import qualified Data.JSString.Internal.Type as JSS
33−
34−import qualified JavaScript.Object.Internal as OI (Object(..), create, setProp, getProp)
35−import qualified JavaScript.Array.Internal as AI (SomeJSArray(..), create, push, read, fromListIO, toListIO)
36−
37−import Language.Javascript.JSaddle.Types (JSM, MutableJSArray, GHCJSPure(..), ghcjsPure, ghcjsPureMap, JSadddleHasCallStack)
38import Language.Javascript.JSaddle.String (textToStr)
30import Language.Javascript.JSaddle.String (textToStr)
31+import qualified JavaScript.Object.Internal as OI (Object(..), create, setProp, getProp)
32+import qualified JavaScript.Array.Internal as AI (create, push, read, fromListIO, toListIO)
39
33
40data Purity = PureShared -- ^ conversion is pure even if the original value is shared
34data Purity = PureShared -- ^ conversion is pure even if the original value is shared
41 | PureExclusive -- ^ conversion is pure if the we only convert once
35 | PureExclusive -- ^ conversion is pure if the we only convert once
@@ -55,53 +49,25 @@ class ToJSVal a where
55 toJSValListOf :: [a] -> JSM JSVal
49 toJSValListOf :: [a] -> JSM JSVal
56 toJSValListOf = fmap coerce . AI.fromListIO <=< mapM toJSVal
50 toJSValListOf = fmap coerce . AI.fromListIO <=< mapM toJSVal
57
51
58− -- default toJSVal :: PToJSVal a => a -> JSM (JSVal a)
59− -- toJSVal x = return (pToJSVal x)
60−
61 default toJSVal :: (Generic a, GToJSVal (Rep a ())) => a -> JSM JSVal
52 default toJSVal :: (Generic a, GToJSVal (Rep a ())) => a -> JSM JSVal
62 toJSVal = toJSVal_generic id
53 toJSVal = toJSVal_generic id
63
54
64−fromJustWithStack :: JSadddleHasCallStack => Maybe a -> a
65−fromJustWithStack Nothing = error "fromJSValUnchecked: fromJSVal result was Nothing"
66−fromJustWithStack (Just x) = x
67−
68class FromJSVal a where
55class FromJSVal a where
69 fromJSVal :: JSVal -> JSM (Maybe a)
56 fromJSVal :: JSVal -> JSM (Maybe a)
70
57
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
81 fromJSValUnchecked :: JSVal -> JSM a
58 fromJSValUnchecked :: JSVal -> JSM a
82 fromJSValUnchecked = fmap fromJust . fromJSVal
59 fromJSValUnchecked = fmap fromJust . fromJSVal
83−#endif
84 {-# INLINE fromJSValUnchecked #-}
60 {-# INLINE fromJSValUnchecked #-}
85
61
86 fromJSValListOf :: JSVal -> JSM (Maybe [a])
62 fromJSValListOf :: JSVal -> JSM (Maybe [a])
87 fromJSValListOf = fmap sequence . (mapM fromJSVal <=< AI.toListIO . coerce) -- fixme should check that it's an array
63 fromJSValListOf = fmap sequence . (mapM fromJSVal <=< AI.toListIO . coerce) -- fixme should check that it's an array
88
64
89−#if MIN_VERSION_base(4,9,0) && defined(JSADDLE_HAS_CALL_STACK)
90− fromJSValUncheckedListOf :: JSadddleHasCallStack => JSVal -> JSM [a]
91−#else
92 fromJSValUncheckedListOf :: JSVal -> JSM [a]
65 fromJSValUncheckedListOf :: JSVal -> JSM [a]
93−#endif
94 fromJSValUncheckedListOf = mapM fromJSValUnchecked <=< AI.toListIO . coerce
66 fromJSValUncheckedListOf = mapM fromJSValUnchecked <=< AI.toListIO . coerce
95
67
96− -- default fromJSVal :: PFromJSVal a => JSVal a -> JSM (Maybe a)
97− -- fromJSVal x = return (Just (pFromJSVal x))
98−
99 default fromJSVal :: (Generic a, GFromJSVal (Rep a ())) => JSVal -> JSM (Maybe a)
68 default fromJSVal :: (Generic a, GFromJSVal (Rep a ())) => JSVal -> JSM (Maybe a)
100 fromJSVal = fromJSVal_generic id
69 fromJSVal = fromJSVal_generic id
101
70
102− -- default fromJSValUnchecked :: PFromJSVal a => a -> IO a
103− -- fromJSValUnchecked x = return (pFromJSVal x)
104−
105-- -----------------------------------------------------------------------------
71-- -----------------------------------------------------------------------------
106
72
107class GToJSVal a where
73class GToJSVal a where
@@ -126,8 +92,8 @@ instance (GToJSVal (a p), GToJSVal (b p)) => GToJSVal ((a :+: b) p) where
126 gToJSVal f _ (L1 x) = gToJSVal f True x
92 gToJSVal f _ (L1 x) = gToJSVal f True x
127 gToJSVal f _ (R1 x) = gToJSVal f True x
93 gToJSVal f _ (R1 x) = gToJSVal f True x
128
94
129−instance (Datatype c, GToJSVal (a p)) => GToJSVal (M1 D c a p) where
95+instance (GToJSVal (a p)) => GToJSVal (M1 D c a p) where
130− gToJSVal f b m@(M1 x) = gToJSVal f b x
96+ gToJSVal f b (M1 x) = gToJSVal f b x
131
97
132instance (Constructor c, GToJSVal (a p)) => GToJSVal (M1 C c a p) where
98instance (Constructor c, GToJSVal (a p)) => GToJSVal (M1 C c a p) where
133 gToJSVal f True m@(M1 x) = do
99 gToJSVal f True m@(M1 x) = do
@@ -143,7 +109,7 @@ instance (GToJSArr (a p), GToJSArr (b p), GToJSProp (a p), GToJSProp (b p)) => G
143 gToJSProp f obj' xy
109 gToJSProp f obj' xy
144 return obj'
110 return obj'
145 gToJSVal f False xy = do
111 gToJSVal f False xy = do
146− arr@(AI.SomeJSArray arr') <- AI.create
112+ arr@(SomeJSArray arr') <- AI.create
147 gToJSArr f arr xy
113 gToJSArr f arr xy
148 return arr'
114 return arr'
149
115
@@ -167,10 +133,10 @@ instance GToJSVal (a p) => GToJSArr (M1 S c a p) where
167 AI.push r a
133 AI.push r a
168
134
169instance GToJSVal (V1 p) where
135instance GToJSVal (V1 p) where
170− gToJSVal _ _ _ = return Prim.jsNull
136+ gToJSVal _ _ _ = return jsNull
171
137
172instance GToJSVal (U1 p) where
138instance GToJSVal (U1 p) where
173− gToJSVal _ _ _ = return F.jsTrue
139+ gToJSVal _ _ _ = return jsTrue
174
140
175toJSVal_generic :: forall a . (Generic a, GToJSVal (Rep a ()))
141toJSVal_generic :: forall a . (Generic a, GToJSVal (Rep a ()))
176 => (String -> String) -> a -> JSM JSVal
142 => (String -> String) -> a -> JSM JSVal
@@ -197,26 +163,26 @@ instance GFromJSVal (f p) => GFromJSVal (Rec1 f p) where
197 gFromJSVal f b r = gFromJSVal f b r
163 gFromJSVal f b r = gFromJSVal f b r
198
164
199instance (GFromJSVal (a p), GFromJSVal (b p)) => GFromJSVal ((a :+: b) p) where
165instance (GFromJSVal (a p), GFromJSVal (b p)) => GFromJSVal ((a :+: b) p) where
200− gFromJSVal f b r = do
166+ gFromJSVal f _b r = do
201 l <- gFromJSVal f True r
167 l <- gFromJSVal f True r
202 case l of
168 case l of
203 Just x -> return (L1 <$> Just x)
169 Just x -> return (L1 <$> Just x)
204 Nothing -> fmap R1 <$> gFromJSVal f True r
170 Nothing -> fmap R1 <$> gFromJSVal f True r
205
171
206−instance (Datatype c, GFromJSVal (a p)) => GFromJSVal (M1 D c a p) where
172+instance GFromJSVal (a p) => GFromJSVal (M1 D c a p) where
207 gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r
173 gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r
208
174
209instance forall c a p . (Constructor c, GFromJSVal (a p)) => GFromJSVal (M1 C c a p) where
175instance forall c a p . (Constructor c, GFromJSVal (a p)) => GFromJSVal (M1 C c a p) where
210 gFromJSVal f True r = do
176 gFromJSVal f True r = do
211 r' <- OI.getProp (packJSS . f $ conName (undefined :: M1 C c a p)) (OI.Object r)
177 r' <- OI.getProp (packJSS . f $ conName (undefined :: M1 C c a p)) (OI.Object r)
212− ghcjsPure (isUndefined r') >>= \case
178+ isUndefinedIO r' >>= \case
213 True -> return Nothing
179 True -> return Nothing
214 False -> fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r'
180 False -> 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
181 gFromJSVal f _ r = fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r
216
182
217instance (GFromJSArr (a p), GFromJSArr (b p), GFromJSProp (a p), GFromJSProp (b p)) => GFromJSVal ((a :*: b) p) where
183instance (GFromJSArr (a p), GFromJSArr (b p), GFromJSProp (a p), GFromJSProp (b p)) => GFromJSVal ((a :*: b) p) where
218 gFromJSVal f True r = gFromJSProp f r
184 gFromJSVal f True r = gFromJSProp f r
219− gFromJSVal f False r = fmap fst <$> gFromJSArr f (AI.SomeJSArray r) 0
185+ gFromJSVal f False r = fmap fst <$> gFromJSArr f (SomeJSArray r) 0
220
186
221instance GFromJSVal (a p) => GFromJSVal (M1 S c a p) where
187instance GFromJSVal (a p) => GFromJSVal (M1 S c a p) where
222 gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r
188 gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r
@@ -231,7 +197,7 @@ instance (GFromJSProp (a p), GFromJSProp (b p)) => GFromJSProp ((a :*: b) p) whe
231instance forall c a p . (Selector c, GFromJSVal (a p)) => GFromJSProp (M1 S c a p) where
197instance forall c a p . (Selector c, GFromJSVal (a p)) => GFromJSProp (M1 S c a p) where
232 gFromJSProp f o = do
198 gFromJSProp f o = do
233 p <- OI.getProp (packJSS . f $ selName (undefined :: M1 S c a p)) (OI.Object o)
199 p <- OI.getProp (packJSS . f $ selName (undefined :: M1 S c a p)) (OI.Object o)
234− ghcjsPure (isUndefined p) >>= \case
200+ isUndefinedIO p >>= \case
235 True -> return Nothing
201 True -> return Nothing
236 False -> fmap M1 <$> gFromJSVal f False p
202 False -> fmap M1 <$> gFromJSVal f False p
237
203
@@ -248,7 +214,7 @@ instance (GFromJSArr (a p), GFromJSArr (b p)) => GFromJSArr ((a :*: b) p) where
248instance (GFromJSVal (a p)) => GFromJSArr (M1 S c a p) where
214instance (GFromJSVal (a p)) => GFromJSArr (M1 S c a p) where
249 gFromJSArr f o n = do
215 gFromJSArr f o n = do
250 r <- AI.read n o
216 r <- AI.read n o
251− ghcjsPure (isUndefined r) >>= \case
217+ isUndefinedIO r >>= \case
252 True -> return Nothing
218 True -> return Nothing
253 False -> fmap ((,n+1) . M1) <$> gFromJSVal f False r
219 False -> fmap ((,n+1) . M1) <$> gFromJSVal f False r
254
220
@@ -265,15 +231,15 @@ fromJSVal_generic f x = fmap to <$> (gFromJSVal f False x :: JSM (Maybe (Rep a (
265-- -----------------------------------------------------------------------------
231-- -----------------------------------------------------------------------------
266
232
267fromJSVal_pure :: PFromJSVal a => JSVal -> JSM (Maybe a)
233fromJSVal_pure :: PFromJSVal a => JSVal -> JSM (Maybe a)
268−fromJSVal_pure = return . Just . pFromJSVal
234+fromJSVal_pure x = return (Just (pFromJSVal x))
269{-# INLINE fromJSVal_pure #-}
235{-# INLINE fromJSVal_pure #-}
270
236
271fromJSValUnchecked_pure :: PFromJSVal a => JSVal -> JSM a
237fromJSValUnchecked_pure :: PFromJSVal a => JSVal -> JSM a
272−fromJSValUnchecked_pure = return . pFromJSVal
238+fromJSValUnchecked_pure x = return (pFromJSVal x)
273{-# INLINE fromJSValUnchecked_pure #-}
239{-# INLINE fromJSValUnchecked_pure #-}
274
240
275toJSVal_pure :: PToJSVal a => a -> JSM JSVal
241toJSVal_pure :: PToJSVal a => a -> JSM JSVal
276−toJSVal_pure = return . pToJSVal
242+toJSVal_pure x = return (pToJSVal x)
277{-# INLINE toJSVal_pure #-}
243{-# INLINE toJSVal_pure #-}
278
244
279-- -----------------------------------------------------------------------------
245-- -----------------------------------------------------------------------------
jsaddle/src-ghc/GHCJS/Marshal/Pure.hs+6−5
@@ -1,11 +1,12 @@
1{-# OPTIONS_GHC -fno-warn-orphans #-}
1{-# OPTIONS_GHC -fno-warn-orphans #-}
2−module GHCJS.Marshal.Pure ( PFromJSVal(..)
2+module GHCJS.Marshal.Pure
3+ ( PFromJSVal(..)
3− , PToJSVal(..)
4+ , PToJSVal(..)
4− ) where
5+ ) where
5
6
6−import GHCJS.Types
7−import GHCJS.Foreign.Internal (jsFalse, jsTrue)
8import GHCJS.Marshal.Internal
7import GHCJS.Marshal.Internal
8+import Language.Javascript.JSaddle.Types (JSVal(..))
9+import Language.Javascript.JSaddle.Foreign (jsFalse, jsTrue)
9
10
10instance PFromJSVal JSVal where pFromJSVal = id
11instance PFromJSVal JSVal where pFromJSVal = id
11 {-# INLINE pFromJSVal #-}
12 {-# INLINE pFromJSVal #-}
jsaddle/src-ghc/GHCJS/Prim.hsdeleted−84
@@ -1,84 +0,0 @@
1−{-# LANGUAGE MagicHash #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4−
5−module GHCJS.Prim ( module GHCJS.Prim.Internal
6− , fromJSString
7− , toJSString
8− , isNull
9− , isUndefined
10− ) where
11−
12−import GHCJS.Prim.Internal
13−--import Data.Int (Int64)
14−--import Data.Typeable (Typeable)
15−--import Unsafe.Coerce (unsafeCoerce)
16−
17−--import Data.Aeson (ToJSON(..), FromJSON(..))
18−import qualified Data.Text as T (unpack, pack)
19−import Data.JSString.Text (textFromJSVal)
20−
21−--import GHC.Prim
22−--import qualified GHC.Exception as Ex
23−--import qualified GHC.Exts as Exts
24−
25−import Language.Javascript.JSaddle.Types (JSVal(..), JSString(..), GHCJSPure(..), ghcjsPureMap)
26−import qualified Language.Javascript.JSaddle.Native.Internal as N
27− (stringToValue, isNull, isUndefined)
28−{- | Low-level conversion utilities for packages that cannot
29− depend on ghcjs-base
30− -}
31−
32−fromJSString :: JSVal -> GHCJSPure String
33−fromJSString = ghcjsPureMap T.unpack . textFromJSVal
34−{-# INLINE fromJSString #-}
35−
36−toJSString :: String -> GHCJSPure JSVal
37−toJSString s = GHCJSPure $ N.stringToValue (JSString $ T.pack s)
38−{-# INLINE toJSString #-}
39−
40−--fromJSArray :: JSVal -> IO [JSVal]
41−--fromJSArray = unsafeCoerce . js_fromJSArray
42−--{-# INLINE fromJSArray #-}
43−--
44−--toJSArray :: [JSVal] -> IO JSVal
45−--toJSArray = js_toJSArray . unsafeCoerce . seqList
46−--{-# INLINE toJSArray #-}
47−--
48−--{- | returns zero if the JSVal does not contain a number
49−-- -}
50−--fromJSInt :: JSVal -> Int
51−--fromJSInt = js_fromJSInt
52−--{-# INLINE fromJSInt #-}
53−--
54−--toJSInt :: Int -> JSVal
55−--toJSInt = js_toJSInt
56−--{-# INLINE toJSInt #-}
57−--
58−
59−isNull :: JSVal -> GHCJSPure Bool
60−isNull = GHCJSPure . N.isNull
61−{-# INLINE isNull #-}
62−
63−isUndefined :: JSVal -> GHCJSPure Bool
64−isUndefined = GHCJSPure . N.isUndefined
65−{-# INLINE isUndefined #-}
66−
67−--getProp :: JSVal -> String -> IO JSVal
68−--getProp o p = js_getProp o (unsafeCoerce $ seqList p)
69−--{-# INLINE getProp #-}
70−--
71−--getProp' :: JSVal -> JSVal -> IO JSVal
72−--getProp' o p = js_getProp' o p
73−--{-# INLINE getProp' #-}
74−--
75−---- reduce the spine and all list elements to whnf
76−--seqList :: [a] -> [a]
77−--seqList xs = go xs `seq` xs
78−-- where go (x:xs) = x `seq` go xs
79−-- go [] = ()
80−--
81−--seqListSpine :: [a] -> [a]
82−--seqListSpine xs = go xs `seq` xs
83−-- where go (x:xs) = go xs
84−-- go [] = ()
jsaddle/src-ghc/GHCJS/Prim/Internal.hsdeleted−68
@@ -1,68 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3−
4−module GHCJS.Prim.Internal ( JSVal(..)
5− , JSValueRef
6− , JSException(..)
7− , WouldBlockException(..)
8− , mkJSException
9− , jsNull
10− ) where
11−
12−import Control.DeepSeq (NFData(..))
13−import Data.Int (Int64)
14−import Data.Typeable (Typeable)
15−import Unsafe.Coerce (unsafeCoerce)
16−
17−import Data.Aeson (ToJSON(..), FromJSON(..))
18−
19−import qualified GHC.Exception as Ex
20−import Data.IORef (newIORef, IORef)
21−import System.IO.Unsafe (unsafePerformIO)
22−
23−-- A reference to a particular JavaScript value inside the JavaScript context
24−type JSValueRef = Int64
25−
26−{-
27− JSVal is a boxed type that can be used as FFI
28− argument or result.
29−-}
30−newtype JSVal = JSVal (IORef JSValueRef)
31−
32−instance NFData JSVal where
33− rnf x = x `seq` ()
34−
35−
36−{-
37− When a JavaScript exception is raised inside
38− a safe or interruptible foreign call, it is converted
39− to a JSException
40− -}
41−data JSException = JSException JSVal String
42− deriving (Typeable)
43−
44−instance Ex.Exception JSException
45−
46−instance Show JSException where
47− show (JSException _ xs) = "JavaScript exception: " ++ xs
48−
49−mkJSException :: JSVal -> IO JSException
50−mkJSException ref =
51− return (JSException (unsafeCoerce ref) "")
52−
53−jsNull :: JSVal
54−jsNull = JSVal . unsafePerformIO $ newIORef 0
55−{-# NOINLINE jsNull #-}
56−
57−{- | If a synchronous thread tries to do something that can only
58− be done asynchronously, and the thread is set up to not
59− continue asynchronously, it receives this exception.
60− -}
61−data WouldBlockException = WouldBlockException
62− deriving (Typeable)
63−
64−instance Show WouldBlockException where
65− show _ = "thread would block"
66−
67−instance Ex.Exception WouldBlockException
68−
jsaddle/src-ghc/GHCJS/Types.hsdeleted−60
@@ -1,60 +0,0 @@
1−{-# LANGUAGE EmptyDataDecls #-}
2−{-# LANGUAGE MagicHash #-}
3−{-# LANGUAGE BangPatterns #-}
4−
5−module GHCJS.Types ( JSVal
6− , WouldBlockException(..)
7− , JSException(..)
8− , IsJSVal
9− , jsval
10− , isNull
11− , isUndefined
12− , nullRef
13− , JSString
14− , mkRef
15− , Ref#
16−-- , toPtr
17−-- , fromPtr
18− , JSRef
19− ) where
20−
21−import Data.JSString.Internal.Type (JSString)
22−import GHCJS.Internal.Types
23−
24−import GHCJS.Prim
25−
26−import GHC.Int
27−import GHC.Types
28−import GHC.Prim
29−import GHC.Ptr
30−import GHC.IORef
31−import GHC.IO.Unsafe (unsafePerformIO)
32−
33−import Control.DeepSeq
34−import Unsafe.Coerce
35−
36−type Ref# = IORef Int64
37−
38−mkRef :: Ref# -> JSVal
39−mkRef = JSVal
40−{-# INLINE mkRef #-}
41−
42−nullRef :: JSVal
43−nullRef = JSVal . unsafePerformIO $ newIORef 0
44−{-# NOINLINE nullRef #-}
45−
46−--toPtr :: JSVal -> Ptr a
47−--toPtr (JSVal x) = unsafeCoerce (Ptr' x 0#)
48−--{-# INLINE toPtr #-}
49−--
50−--fromPtr :: Ptr a -> JSVal
51−--fromPtr p = js_ptrVal p
52−--{-# INLINE fromPtr #-}
53−--
54−--data Ptr' a = Ptr' ByteArray# Int#
55−
56−-- | This is a deprecated copmatibility wrapper for the old JSRef type.
57−--
58−-- See https://github.com/ghcjs/ghcjs/issues/421
59−type JSRef a = JSVal
60−{-# DEPRECATED JSRef "Use JSVal instead, or a more specific newtype wrapper of JSVal " #-}
jsaddle/src-ghc/JavaScript/Array/Internal.hs+20−33
@@ -1,59 +1,46 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module JavaScript.Array.Internal
2module JavaScript.Array.Internal
3− ( SomeJSArray(..)
4− , JSArray
5− , MutableJSArray
6− , STJSArray
7− , create
3+ ( create
8− , fromList
9 , fromListIO
4 , fromListIO
10− , toList
11 , toListIO
5 , toListIO
12− , index
13 , read
6 , read
14 , push
7 , push
15 ) where
8 ) where
16
9
17import Prelude hiding(read)
10import Prelude hiding(read)
18import Control.Monad (void)
11import Control.Monad (void)
19−import GHCJS.Types (JSVal)
20−import Data.JSString.Internal.Type (JSString(..))
21−import Language.Javascript.JSaddle.Types (JSM, SomeJSArray(..), JSArray, MutableJSArray, STJSArray, Object(..), GHCJSPure(..))
12+import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), MutableJSArray, Object(..), JSString(..))
22import Language.Javascript.JSaddle.Native.Internal
13import Language.Javascript.JSaddle.Native.Internal
23− (newArray, getPropertyByName, getPropertyAtIndex, callAsFunction, valueToNumber)
14+ (withObject, withJSVal, withJSString, withJSVals)
15+import Language.Javascript.JSaddle.Run
16+ (Command(..), Result(..), AsyncCommand(..), sendCommand, sendLazyCommand)
24
17
25create :: JSM MutableJSArray
18create :: JSM MutableJSArray
26−create = SomeJSArray <$> newArray []
19+create = SomeJSArray <$> sendLazyCommand (NewArray [])
27{-# INLINE create #-}
20{-# INLINE create #-}
28
21
29−fromList :: [JSVal] -> GHCJSPure (SomeJSArray m)
30−fromList = GHCJSPure . fromListIO
31−{-# INLINE fromList #-}
32−
33fromListIO :: [JSVal] -> JSM (SomeJSArray m)
22fromListIO :: [JSVal] -> JSM (SomeJSArray m)
34−fromListIO xs = SomeJSArray <$> newArray xs
23+fromListIO xs = withJSVals xs $ \xs' -> SomeJSArray <$> sendLazyCommand (NewArray xs')
35{-# INLINE fromListIO #-}
24{-# INLINE fromListIO #-}
36
25
37−toList :: SomeJSArray m -> GHCJSPure [JSVal]
38−toList = GHCJSPure . toListIO
39−{-# INLINE toList #-}
40−
41toListIO :: SomeJSArray m -> JSM [JSVal]
26toListIO :: SomeJSArray m -> JSM [JSVal]
42−toListIO (SomeJSArray x) = do
27+toListIO (SomeJSArray x) =
43− len <- getPropertyByName (JSString "length") (Object x) >>= valueToNumber
28+ withObject (Object x) $ \this -> do
44− mapM (`getPropertyAtIndex` Object x) [0..round len - 1]
29+ l <- withJSString (JSString "length") $ sendLazyCommand . GetPropertyByName this
30+ withJSVal l $ \l' -> do
31+ ~(ValueToNumberResult len) <- sendCommand (ValueToNumber l')
32+ mapM (sendLazyCommand . GetPropertyAtIndex this) [0..round len - 1]
45{-# INLINE toListIO #-}
33{-# INLINE toListIO #-}
46
34
47−index :: Int -> SomeJSArray m -> GHCJSPure JSVal
48−index n = GHCJSPure . read n
49−{-# INLINE index #-}
50−
51read :: Int -> SomeJSArray m -> JSM JSVal
35read :: Int -> SomeJSArray m -> JSM JSVal
52−read n (SomeJSArray x) = getPropertyAtIndex n $ Object x
36+read n (SomeJSArray x) =
37+ withObject (Object x) $ \this -> sendLazyCommand $ GetPropertyAtIndex this n
53{-# INLINE read #-}
38{-# INLINE read #-}
54
39
55push :: JSVal -> MutableJSArray -> JSM ()
40push :: JSVal -> MutableJSArray -> JSM ()
56−push e (SomeJSArray x) = void $ do
41+push e (SomeJSArray x) =
57− f <- getPropertyByName (JSString "push") (Object x)
42+ void $ withJSVal e $ \e' ->
58− void $ callAsFunction (Object f) (Object x) [e]
43+ withObject (Object x) $ \this -> do
44+ f <- withJSString (JSString "push") $ sendLazyCommand . GetPropertyByName this
45+ withObject (Object f) $ \f' -> sendLazyCommand $ CallAsFunction f' this [e']
59{-# INLINE push #-}
46{-# INLINE push #-}
jsaddle/src-ghc/JavaScript/Object.hsdeleted−10
@@ -1,10 +0,0 @@
1−module JavaScript.Object ( Object
2− , create
3− , getProp, unsafeGetProp
4− , setProp, unsafeSetProp
5− -- , allProps
6− , listProps
7− -- , isInstanceOf
8− ) where
9−
10−import JavaScript.Object.Internal
jsaddle/src-ghc/JavaScript/Object/Internal.hs+22−26
@@ -7,47 +7,43 @@ module JavaScript.Object.Internal
7 , unsafeGetProp
7 , unsafeGetProp
8 , setProp
8 , setProp
9 , unsafeSetProp
9 , unsafeSetProp
10−-- , isInstanceOf
10+-- , isInstanceOfIO
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− (newEmptyObject, propertyNames, getPropertyByName, setPropertyByName)
15+ (withObject, withJSString, withJSVal, wrapJSString)
16+import Language.Javascript.JSaddle.Run
17+ (Command(..), AsyncCommand(..), Result(..), sendCommand, sendLazyCommand, sendAsyncCommand)
16
18
17−-- | create an empty object
18create :: JSM Object
19create :: JSM Object
19−create = newEmptyObject
20+create = Object <$> sendLazyCommand NewEmptyObject
20−{-# INLINE create #-}
21−
22−--allProps :: Object -> JSM JSArray
23−--allProps o = js_allProps o
24−--{-# INLINE allProps #-}
25
21
26listProps :: Object -> JSM [JSString]
22listProps :: Object -> JSM [JSString]
27−listProps = propertyNames
23+listProps this =
24+ withObject this $ \rthis -> do
25+ ~(PropertyNamesResult result) <- sendCommand $ PropertyNames rthis
26+ mapM wrapJSString result
28{-# INLINE listProps #-}
27{-# INLINE listProps #-}
29
28
30−{- | get a property from an object. If accessing the property results in
29+unsafeGetProp :: JSString -> Object -> JSM JSVal
31− an exception, the exception is converted to a JSException. Since exception
30+unsafeGetProp name this =
32− handling code prevents some optimizations in some JS engines, you may want
31+ withObject this $ \rthis ->
32+ withJSString name $ sendLazyCommand . GetPropertyByName rthis
33− to use unsafeGetProp instead
33+{-# INLINE unsafeGetProp #-}
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−unsafeGetProp :: JSString -> Object -> JSM JSVal
39+unsafeSetProp :: JSString -> JSVal -> Object -> JSM ()
40−unsafeGetProp = getPropertyByName
40+unsafeSetProp name val this =
41−{-# INLINE unsafeGetProp #-}
41+ withObject this $ \rthis ->
42+ withJSString name $ \rname ->
43+ withJSVal val $ \rval ->
44+ sendAsyncCommand $ SetPropertyByName rthis rname rval
45+{-# INLINE unsafeSetProp #-}
42
46
43setProp :: JSString -> JSVal -> Object -> JSM ()
47setProp :: JSString -> JSVal -> Object -> JSM ()
44setProp = unsafeSetProp
48setProp = unsafeSetProp
45{-# INLINE setProp #-}
49{-# INLINE setProp #-}
46−
47−unsafeSetProp :: JSString -> JSVal -> Object -> JSM ()
48−unsafeSetProp = setPropertyByName
49−{-# INLINE unsafeSetProp #-}
50−
51−--isInstanceOf :: Object -> JSVal -> GHCJSPure Bool
52−--isInstanceOf o s = js_isInstanceOf o s
53−--{-# INLINE isInstanceOf #-}
jsaddle/src-ghc/JavaScript/TypedArray.hsdeleted−19
@@ -1,19 +0,0 @@
1−module JavaScript.TypedArray
2− ( TypedArray(..)
3− , Int8Array, Int16Array, Int32Array
4− , Uint8Array, Uint16Array, Uint32Array
5− , Uint8ClampedArray, Float32Array, Float64Array
6− , length
7− , byteLength
8− , byteOffset
9− , buffer
10− , subarray
11− , set
12− , unsafeSet
13− ) where
14−
15−import Prelude ()
16−
17−import JavaScript.TypedArray.Internal
18−import JavaScript.TypedArray.Internal.Types
19−
jsaddle/src-ghc/JavaScript/TypedArray/ArrayBuffer.hsdeleted−51
@@ -1,51 +0,0 @@
1−module JavaScript.TypedArray.ArrayBuffer
2− ( ArrayBuffer
3− , MutableArrayBuffer
4− , freeze, unsafeFreeze
5− , thaw, unsafeThaw
6− , byteLengthIO
7− ) where
8−
9−import Control.Lens.Operators ((^.))
10−
11−import GHCJS.Marshal (fromJSValUnchecked)
12−
13−import Language.Javascript.JSaddle.Types (JSM)
14−import Language.Javascript.JSaddle.Object (jsg, new, js, js1, js2)
15−import JavaScript.TypedArray.ArrayBuffer.Internal
16−
17−create :: Int -> JSM MutableArrayBuffer
18−create n = SomeArrayBuffer <$> new (jsg "ArrayBuffer") [n]
19−{-# INLINE create #-}
20−
21−{- | Create an immutable 'ArrayBuffer' by copying a 'MutableArrayBuffer' -}
22−freeze :: MutableArrayBuffer -> JSM ArrayBuffer
23−freeze (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js1 "slice" (0 :: Int)
24−{-# INLINE freeze #-}
25−
26−{- | Create an immutable 'ArrayBuffer' from a 'MutableArrayBuffer' without
27− copying. The result shares the buffer with the argument, not modify
28− the data in the 'MutableArrayBuffer' after freezing
29− -}
30−unsafeFreeze :: MutableArrayBuffer -> JSM ArrayBuffer
31−unsafeFreeze (SomeArrayBuffer b) = pure (SomeArrayBuffer b)
32−{-# INLINE unsafeFreeze #-}
33−
34−{- | Create a 'MutableArrayBuffer' by copying an immutable 'ArrayBuffer' -}
35−thaw :: ArrayBuffer -> JSM MutableArrayBuffer
36−thaw (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js1 "slice" (0 :: Int)
37−{-# INLINE thaw #-}
38−
39−unsafeThaw :: ArrayBuffer -> JSM MutableArrayBuffer
40−unsafeThaw (SomeArrayBuffer b) = pure (SomeArrayBuffer b)
41−{-# INLINE unsafeThaw #-}
42−
43−sliceIO :: Int -> Maybe Int -> SomeArrayBuffer any -> JSM (SomeArrayBuffer any)
44−sliceIO begin (Just end) (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js2 "slice" begin end
45−sliceIO begin _ (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js1 "slice" begin
46−{-# INLINE sliceIO #-}
47−
48−byteLengthIO :: SomeArrayBuffer any -> JSM Int
49−byteLengthIO (SomeArrayBuffer b) = b ^. js "byteLength" >>= fromJSValUnchecked
50−{-# INLINE byteLengthIO #-}
51−
jsaddle/src-ghc/JavaScript/TypedArray/ArrayBuffer/Internal.hsdeleted−33
@@ -1,33 +0,0 @@
1−{-# LANGUAGE GHCForeignImportPrim #-}
2−{-# LANGUAGE MagicHash #-}
3−{-# LANGUAGE UnboxedTuples #-}
4−{-# LANGUAGE MagicHash #-}
5−{-# LANGUAGE TypeSynonymInstances #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE DataKinds #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE DeriveDataTypeable #-}
10−
11−module JavaScript.TypedArray.ArrayBuffer.Internal where
12−
13−import GHCJS.Types
14−
15−import GHCJS.Internal.Types
16−import GHCJS.Marshal.Pure
17−
18−import GHC.Exts (State#)
19−
20−import Data.Typeable
21−
22−newtype SomeArrayBuffer (a :: MutabilityType s) =
23− SomeArrayBuffer JSVal deriving Typeable
24−instance IsJSVal (SomeArrayBuffer m)
25−
26−type ArrayBuffer = SomeArrayBuffer Immutable
27−type MutableArrayBuffer = SomeArrayBuffer Mutable
28−type STArrayBuffer s = SomeArrayBuffer (STMutable s)
29−
30−instance PToJSVal MutableArrayBuffer where
31− pToJSVal (SomeArrayBuffer b) = b
32−instance PFromJSVal MutableArrayBuffer where
33− pFromJSVal = SomeArrayBuffer
jsaddle/src-ghc/JavaScript/TypedArray/ArrayBuffer/Type.hsdeleted−6
@@ -1,6 +0,0 @@
1−module JavaScript.TypedArray.ArrayBuffer.Type where
2−
3−import GHCJS.Prim
4−
5−
6−
jsaddle/src-ghc/JavaScript/TypedArray/DataView/Internal.hsdeleted−147
@@ -1,147 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE JavaScriptFFI #-}
3−{-# LANGUAGE ForeignFunctionInterface #-}
4−{-# LANGUAGE UnliftedFFITypes #-}
5−{-# LANGUAGE GHCForeignImportPrim #-}
6−{-# LANGUAGE MagicHash #-}
7−{-# LANGUAGE UnboxedTuples #-}
8−{-# LANGUAGE DeriveDataTypeable #-}
9−{-# LANGUAGE DataKinds #-}
10−{-# LANGUAGE KindSignatures #-}
11−{-# LANGUAGE PolyKinds #-}
12−
13−module JavaScript.TypedArray.DataView.Internal where
14−
15−import Data.Int
16−import Data.Typeable
17−import Data.Word
18−
19−import GHC.Exts ( State# )
20−
21−import GHCJS.Prim
22−import GHCJS.Internal.Types
23−
24−import JavaScript.TypedArray.ArrayBuffer.Internal
25−
26−newtype SomeDataView (a :: MutabilityType s) = SomeDataView JSVal
27− deriving Typeable
28−
29−type DataView = SomeDataView Immutable
30−type MutableDataView = SomeDataView Mutable
31−type STDataView s = SomeDataView (STMutable s)
32−
33−-- #define JSU foreign import javascript unsafe
34−-- #define JSS foreign import javascript safe
35−--
36−--JSU "new DataView($1)"
37−-- js_dataView1 :: JSVal -> JSVal
38−--JSS "new DataView($2,$1)"
39−-- js_dataView2 :: Int -> JSVal -> SomeDataView m
40−--JSU "new DataView($2,$1)"
41−-- js_unsafeDataView2 :: Int -> JSVal-> SomeDataView m
42−--JSS "new DataView($3,$1,$2)"
43−-- js_dataView :: Int -> Int -> JSVal -> SomeDataView m
44−--JSU "new DataView($3,$1,$2)"
45−-- js_unsafeDataView :: Int -> Int -> JSVal -> JSVal
46−--JSU "new DataView($1.buffer.slice($1.byteOffset, $1.byteLength))"
47−-- js_cloneDataView :: SomeDataView m -> IO (SomeDataView m1)
48−--
49−---- ----------------------------------------------------------------------------
50−---- immutable getters
51−--
52−--JSU "$2.getInt8($1)" js_i_unsafeGetInt8 :: Int -> DataView -> Int8
53−--JSU "$2.getUint8($1)" js_i_unsafeGetUint8 :: Int -> DataView -> Word8
54−--JSU "$2.getInt16($1)" js_i_unsafeGetInt16BE :: Int -> DataView -> Int16
55−--JSU "$2.getInt32($1)" js_i_unsafeGetInt32BE :: Int -> DataView -> Int
56−--JSU "$2.getUint16($1)" js_i_unsafeGetUint16BE :: Int -> DataView -> Word16
57−--JSU "$2.getUint32($1)|0" js_i_unsafeGetUint32BE :: Int -> DataView -> Word
58−--JSU "$2.getFloat32($1)" js_i_unsafeGetFloat32BE :: Int -> DataView -> Double
59−--JSU "$2.getFloat64($1)" js_i_unsafeGetFloat64BE :: Int -> DataView -> Double
60−--JSU "$2.getInt16($1,true)" js_i_unsafeGetInt16LE :: Int -> DataView -> Int16
61−--JSU "$2.getInt32($1,true)" js_i_unsafeGetInt32LE :: Int -> DataView -> Int
62−--JSU "$2.getUint16($1,true)" js_i_unsafeGetUint16LE :: Int -> DataView -> Word16
63−--JSU "$2.getUint32($1,true)|0" js_i_unsafeGetUint32LE :: Int -> DataView -> Word
64−--JSU "$2.getFloat32($1,true)" js_i_unsafeGetFloat32LE :: Int -> DataView -> Double
65−--JSU "$2.getFloat64($1,true)" js_i_unsafeGetFloat64LE :: Int -> DataView -> Double
66−--
67−--JSS "$2.getInt8($1)" js_i_getInt8 :: Int -> DataView -> Int8
68−--JSS "$2.getUint8($1)" js_i_getUint8 :: Int -> DataView -> Word8
69−--JSS "$2.getInt16($1)" js_i_getInt16BE :: Int -> DataView -> Int16
70−--JSS "$2.getInt32($1)" js_i_getInt32BE :: Int -> DataView -> Int
71−--JSS "$2.getUint16($1)" js_i_getUint16BE :: Int -> DataView -> Word16
72−--JSS "$2.getUint32($1)|0" js_i_getUint32BE :: Int -> DataView -> Word
73−--JSS "$2.getFloat32($1)" js_i_getFloat32BE :: Int -> DataView -> Double
74−--JSS "$2.getFloat64($1)" js_i_getFloat64BE :: Int -> DataView -> Double
75−--JSS "$2.getInt16($1,true)" js_i_getInt16LE :: Int -> DataView -> Int16
76−--JSS "$2.getInt32($1,true)" js_i_getInt32LE :: Int -> DataView -> Int
77−--JSS "$2.getUint16($1,true)" js_i_getUint16LE :: Int -> DataView -> Word16
78−--JSS "$2.getUint32($1,true)|0" js_i_getUint32LE :: Int -> DataView -> Word
79−--JSS "$2.getFloat32($1,true)" js_i_getFloat32LE :: Int -> DataView -> Double
80−--JSS "$2.getFloat64($1,true)" js_i_getFloat64LE :: Int -> DataView -> Double
81−--
82−---- ----------------------------------------------------------------------------
83−---- mutable getters
84−--
85−--JSU "$2.getInt8($1)" js_m_unsafeGetInt8 :: Int -> SomeDataView m -> State# s -> (# State# s, Int8 #)
86−--JSU "$2.getUint8($1)" js_m_unsafeGetUint8 :: Int -> SomeDataView m -> State# s -> (# State# s, Word8 #)
87−--JSU "$2.getInt16($1)" js_m_unsafeGetInt16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)
88−--JSU "$2.getInt32($1)" js_m_unsafeGetInt32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)
89−--JSU "$2.getUint16($1)" js_m_unsafeGetUint16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)
90−--JSU "$2.getUint32($1)|0" js_m_unsafeGetUint32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)
91−--JSU "$2.getFloat32($1)" js_m_unsafeGetFloat32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
92−--JSU "$2.getFloat64($1)" js_m_unsafeGetFloat64BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
93−--JSU "$2.getInt16($1,true)" js_m_unsafeGetInt16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)
94−--JSU "$2.getInt32($1,true)" js_m_unsafeGetInt32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)
95−--JSU "$2.getUint16($1,true)" js_m_unsafeGetUint16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)
96−--JSU "$2.getUint32($1,true)|0" js_m_unsafeGetUint32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)
97−--JSU "$2.getFloat32($1,true)" js_m_unsafeGetFloat32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
98−--JSU "$2.getFloat64($1,true)" js_m_unsafeGetFloat64LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
99−--
100−--JSS "$2.getInt8($1)" js_m_getInt8 :: Int -> SomeDataView m -> State# s -> (# State# s, Int8 #)
101−--JSS "$2.getUint8($1)" js_m_getUint8 :: Int -> SomeDataView m -> State# s -> (# State# s, Word8 #)
102−--JSS "$2.getInt16($1)" js_m_getInt16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)
103−--JSS "$2.getInt32($1)" js_m_getInt32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)
104−--JSS "$2.getUint16($1)" js_m_getUint16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)
105−--JSS "$2.getUint32($1)|0" js_m_getUint32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)
106−--JSS "$2.getFloat32($1)" js_m_getFloat32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
107−--JSS "$2.getFloat64($1)" js_m_getFloat64BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
108−--JSS "$2.getInt16($1,true)" js_m_getInt16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)
109−--JSS "$2.getInt32($1,true)" js_m_getInt32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)
110−--JSS "$2.getUint16($1,true)" js_m_getUint16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)
111−--JSS "$2.getUint32($1,true)|0" js_m_getUint32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)
112−--JSS "$2.getFloat32($1,true)" js_m_getFloat32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
113−--JSS "$2.getFloat64($1,true)" js_m_getFloat64LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
114−--
115−---- ----------------------------------------------------------------------------
116−---- mutable setters
117−--
118−--JSU "$3.setInt8($1,$2)" js_unsafeSetInt8 :: Int -> Int8 -> SomeDataView m -> State# s -> (# State# s, () #)
119−--JSU "$3.setUint8($1,$2)" js_unsafeSetUint8 :: Int -> Word8 -> SomeDataView m -> State# s -> (# State# s, () #)
120−--JSU "$3.setInt16($1,$2)" js_unsafeSetInt16BE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)
121−--JSU "$3.setInt32($1,$2)" js_unsafeSetInt32BE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)
122−--JSU "$3.setUint16($1,$2)" js_unsafeSetUint16BE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)
123−--JSU "$3.setUint32($1,$2)" js_unsafeSetUint32BE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)
124−--JSU "$3.setFloat32($1,$2)" js_unsafeSetFloat32BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
125−--JSU "$3.setFloat64($1,$2)" js_unsafeSetFloat64BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
126−--JSU "$3.setInt16($1,$2,true)" js_unsafeSetInt16LE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)
127−--JSU "$3.setInt32($1,$2,true)" js_unsafeSetInt32LE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)
128−--JSU "$3.setUint16($1,$2,true)" js_unsafeSetUint16LE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)
129−--JSU "$3.setUint32($1,$2,true)" js_unsafeSetUint32LE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)
130−--JSU "$3.setFloat32($1,$2,true)" js_unsafeSetFloat32LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
131−--JSU "$3.setFloat64($1,$2,true)" js_unsafeSetFloat64LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
132−--
133−--JSS "$3.setInt8($1,$2)" js_setInt8 :: Int -> Int8 -> SomeDataView m -> State# s -> (# State# s, () #)
134−--JSS "$3.setUint8($1,$2)" js_setUint8 :: Int -> Word8 -> SomeDataView m -> State# s -> (# State# s, () #)
135−--JSS "$3.setInt16($1,$2)" js_setInt16BE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)
136−--JSS "$3.setInt32($1,$2)" js_setInt32BE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)
137−--JSS "$3.setUint16($1,$2)" js_setUint16BE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)
138−--JSS "$3.setUint32($1,$2)" js_setUint32BE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)
139−--JSS "$3.setFloat32($1,$2)" js_setFloat32BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
140−--JSS "$3.setFloat64($1,$2)" js_setFloat64BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
141−--JSS "$3.setInt16($1,$2,true)" js_setInt16LE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)
142−--JSS "$3.setInt32($1,$2,true)" js_setInt32LE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)
143−--JSS "$3.setUint16($1,$2,true)" js_setUint16LE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)
144−--JSS "$3.setUint32($1,$2,true)" js_setUint32LE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)
145−--JSS "$3.setFloat32($1,$2,true)" js_setFloat32LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
146−--JSS "$3.setFloat64($1,$2,true)" js_setFloat64LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
147−
jsaddle/src-ghc/JavaScript/TypedArray/Immutable.hsdeleted−1
@@ -1 +0,0 @@
1−module JavaScript.TypedArray.Immutable where
jsaddle/src-ghc/JavaScript/TypedArray/Internal.hsdeleted−344
@@ -1,344 +0,0 @@
1−{-# LANGUAGE TypeFamilies #-}
2−{-# LANGUAGE TypeSynonymInstances #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE DataKinds #-}
5−{-# LANGUAGE PolyKinds #-}
6−
7−module JavaScript.TypedArray.Internal where
8−
9−import Prelude hiding ((!!))
10−
11−import GHC.Int
12−import GHC.Word
13−
14−import GHCJS.Internal.Types
15−
16−import Control.Monad (void)
17−import Control.Lens.Operators ((^.))
18−
19−import GHCJS.Marshal (fromJSValUnchecked)
20−
21−import JavaScript.Array.Internal (SomeJSArray(..))
22−import JavaScript.TypedArray.ArrayBuffer
23−import JavaScript.TypedArray.ArrayBuffer.Internal (SomeArrayBuffer(..))
24−import JavaScript.TypedArray.Internal.Types
25−
26−import Language.Javascript.JSaddle.Types (JSM, GHCJSPure(..))
27−import Language.Javascript.JSaddle.Object (js, jsg, js1, js2, new, (!!), (<##))
28−
29−elemSize :: SomeTypedArray e m -> GHCJSPure Int
30−elemSize (SomeTypedArray a) = GHCJSPure $ a ^. js "BYTES_PER_ELEMENT" >>= fromJSValUnchecked
31−{-# INLINE [1] elemSize #-}
32−{-# RULES "elemSizeUint8Clamped" forall (x :: SomeUint8ClampedArray m). elemSize x = GHCJSPure $ return 1 #-}
33−{-# RULES "elemSizeUint8" forall (x :: SomeUint8Array m). elemSize x = GHCJSPure $ return 1 #-}
34−{-# RULES "elemSizeUint16" forall (x :: SomeUint16Array m). elemSize x = GHCJSPure $ return 2 #-}
35−{-# RULES "elemSizeUint32" forall (x :: SomeUint32Array m). elemSize x = GHCJSPure $ return 4 #-}
36−{-# RULES "elemSizeInt8" forall (x :: SomeInt8Array m). elemSize x = GHCJSPure $ return 1 #-}
37−{-# RULES "elemSizeInt16" forall (x :: SomeInt16Array m). elemSize x = GHCJSPure $ return 2 #-}
38−{-# RULES "elemSizeInt32" forall (x :: SomeInt32Array m). elemSize x = GHCJSPure $ return 4 #-}
39−{-# RULES "elemSizeFloat32" forall (x :: SomeFloat32Array m). elemSize x = GHCJSPure $ return 4 #-}
40−{-# RULES "elemSizeFloat64" forall (x :: SomeFloat64Array m). elemSize x = GHCJSPure $ return 8 #-}
41−
42−instance TypedArray IOInt8Array where
43− index = indexI8
44− unsafeIndex = unsafeIndexI8
45− setIndex i x = setIndexI i (fromIntegral x)
46− unsafeSetIndex i x = unsafeSetIndexI i (fromIntegral x)
47− indexOf s x = indexOfI s (fromIntegral x)
48− lastIndexOf s x = lastIndexOfI s (fromIntegral x)
49− create l = SomeTypedArray <$> new (jsg "Int8Array") [l]
50− fromArray = int8ArrayFrom
51− fromArrayBuffer = undefined
52−
53−instance TypedArray IOInt16Array where
54− index = indexI16
55− unsafeIndex = unsafeIndexI16
56− setIndex i x = setIndexI i (fromIntegral x)
57− unsafeSetIndex i x = unsafeSetIndexI i (fromIntegral x)
58− indexOf s x = indexOfI s (fromIntegral x)
59− lastIndexOf s x = lastIndexOfI s (fromIntegral x)
60− create l = SomeTypedArray <$> new (jsg "Int16Array") [l]
61− fromArray = int16ArrayFrom
62− fromArrayBuffer = undefined
63−
64−instance TypedArray IOInt32Array where
65− index = indexI
66− unsafeIndex = unsafeIndexI
67− setIndex = setIndexI
68− unsafeSetIndex = unsafeSetIndexI
69− indexOf = indexOfI
70− lastIndexOf = lastIndexOfI
71− create l = SomeTypedArray <$> new (jsg "Int32Array") [l]
72− fromArray = int32ArrayFrom
73− fromArrayBuffer = undefined
74−
75−instance TypedArray IOUint8ClampedArray where
76− index = indexW8
77− unsafeIndex = unsafeIndexW8
78− setIndex i x = setIndexW i (fromIntegral x)
79− unsafeSetIndex i x = unsafeSetIndexW i (fromIntegral x)
80− indexOf s x = indexOfW s (fromIntegral x)
81− lastIndexOf s x = lastIndexOfW s (fromIntegral x)
82− create l = SomeTypedArray <$> new (jsg "Uint8ClampedArray") [l]
83− fromArray = uint8ClampedArrayFrom
84− fromArrayBuffer = undefined
85−
86−instance TypedArray IOUint8Array where
87− index = indexW8
88− unsafeIndex = unsafeIndexW8
89− setIndex i x = setIndexW i (fromIntegral x)
90− unsafeSetIndex i x = unsafeSetIndexW i (fromIntegral x)
91− indexOf s x = indexOfW s (fromIntegral x)
92− lastIndexOf s x = lastIndexOfW s (fromIntegral x)
93− create l = SomeTypedArray <$> new (jsg "Uint8Array") [l]
94− fromArray = uint8ArrayFrom
95− fromArrayBuffer = undefined
96−
97−instance TypedArray IOUint16Array where
98− index = indexW16
99− unsafeIndex = unsafeIndexW16
100− setIndex i x = setIndexW i (fromIntegral x)
101− unsafeSetIndex i x = unsafeSetIndexW i (fromIntegral x)
102− indexOf s x = indexOfW s (fromIntegral x)
103− lastIndexOf s x = lastIndexOfW s (fromIntegral x)
104− create l = SomeTypedArray <$> new (jsg "Uint16Array") [l]
105− fromArray = uint16ArrayFrom
106− fromArrayBuffer = undefined
107−
108−instance TypedArray IOUint32Array where
109− index = indexW
110− unsafeIndex = unsafeIndexW
111− setIndex = setIndexW
112− unsafeSetIndex = unsafeSetIndexW
113− indexOf = indexOfW
114− lastIndexOf = lastIndexOfW
115− create l = SomeTypedArray <$> new (jsg "Uint32Array") [l]
116− fromArray = uint32ArrayFrom
117− fromArrayBuffer = undefined
118−
119−instance TypedArray IOFloat32Array where
120− index = indexD
121− unsafeIndex = unsafeIndexD
122− setIndex = setIndexD
123− unsafeSetIndex = unsafeSetIndexD
124− indexOf = indexOfD
125− lastIndexOf = lastIndexOfD
126− create l = SomeTypedArray <$> new (jsg "Float32Array") [l]
127− fromArray = float32ArrayFrom
128− fromArrayBuffer = undefined
129−
130−instance TypedArray IOFloat64Array where
131− index = indexD
132− unsafeIndex = unsafeIndexD
133− setIndex = setIndexD
134− unsafeSetIndex = unsafeSetIndexD
135− indexOf = indexOfD
136− lastIndexOf = lastIndexOfD
137− create l = SomeTypedArray <$> new (jsg "Float64Array") [l]
138− fromArray = float64ArrayFrom
139− fromArrayBuffer = undefined
140−
141−
142−class TypedArray a where
143− unsafeIndex :: Int -> a -> JSM (Elem a)
144− index :: Int -> a -> JSM (Elem a)
145− unsafeSetIndex :: Int -> Elem a -> a -> JSM ()
146− setIndex :: Int -> Elem a -> a -> JSM ()
147− create :: Int -> JSM a
148− fromArray :: SomeJSArray m -> JSM a
149− fromArrayBuffer :: MutableArrayBuffer -> Int -> Maybe Int -> JSM a
150− indexOf :: Int -> Elem a -> a -> JSM Int
151− lastIndexOf :: Int -> Elem a -> a -> JSM Int
152−
153−-- -----------------------------------------------------------------------------
154−
155−indexI :: Int -> SomeTypedArray e m -> JSM Int
156−indexI i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
157−{-# INLINE indexI #-}
158−
159−indexI16 :: Int -> SomeTypedArray e m -> JSM Int16
160−indexI16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
161−{-# INLINE indexI16 #-}
162−
163−indexI8 :: Int -> SomeTypedArray e m -> JSM Int8
164−indexI8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
165−{-# INLINE indexI8 #-}
166−
167−indexW :: Int -> SomeTypedArray e m -> JSM Word
168−indexW i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
169−{-# INLINE indexW #-}
170−
171−indexW16 :: Int -> SomeTypedArray e m -> JSM Word16
172−indexW16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
173−{-# INLINE indexW16 #-}
174−
175−indexW8 :: Int -> SomeTypedArray e m -> JSM Word8
176−indexW8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
177−{-# INLINE indexW8 #-}
178−
179−indexD :: Int -> SomeTypedArray e m -> JSM Double
180−indexD i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
181−{-# INLINE indexD #-}
182−
183−-- -----------------------------------------------------------------------------
184−
185−unsafeIndexI :: Int -> SomeTypedArray e m -> JSM Int
186−unsafeIndexI i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
187−{-# INLINE unsafeIndexI #-}
188−
189−unsafeIndexI16 :: Int -> SomeTypedArray e m -> JSM Int16
190−unsafeIndexI16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
191−{-# INLINE unsafeIndexI16 #-}
192−
193−unsafeIndexI8 :: Int -> SomeTypedArray e m -> JSM Int8
194−unsafeIndexI8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
195−{-# INLINE unsafeIndexI8 #-}
196−
197−unsafeIndexW :: Int -> SomeTypedArray e m -> JSM Word
198−unsafeIndexW i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
199−{-# INLINE unsafeIndexW #-}
200−
201−unsafeIndexW16 :: Int -> SomeTypedArray e m -> JSM Word16
202−unsafeIndexW16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
203−{-# INLINE unsafeIndexW16 #-}
204−
205−unsafeIndexW8 :: Int -> SomeTypedArray e m -> JSM Word8
206−unsafeIndexW8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
207−{-# INLINE unsafeIndexW8 #-}
208−
209−unsafeIndexD :: Int -> SomeTypedArray e m -> JSM Double
210−unsafeIndexD i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
211−{-# INLINE unsafeIndexD #-}
212−
213−-- -----------------------------------------------------------------------------
214−
215−int8ArrayFrom :: SomeJSArray m0 -> JSM (SomeInt8Array m1)
216−int8ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Int8Array" ^. js1 "from" a
217−{-# INLINE int8ArrayFrom #-}
218−
219−int16ArrayFrom :: SomeJSArray m0 -> JSM (SomeInt16Array m1)
220−int16ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Int16Array" ^. js1 "from" a
221−{-# INLINE int16ArrayFrom #-}
222−
223−int32ArrayFrom :: SomeJSArray m0 -> JSM (SomeInt32Array m1)
224−int32ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Int32Array" ^. js1 "from" a
225−{-# INLINE int32ArrayFrom #-}
226−
227−uint8ArrayFrom :: SomeJSArray m0 -> JSM (SomeUint8Array m1)
228−uint8ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint8Array" ^. js1 "from" a
229−{-# INLINE uint8ArrayFrom #-}
230−
231−uint8ClampedArrayFrom :: SomeJSArray m0 -> JSM (SomeUint8ClampedArray m1)
232−uint8ClampedArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint8ClampedArray" ^. js1 "from" a
233−{-# INLINE uint8ClampedArrayFrom #-}
234−
235−uint16ArrayFrom :: SomeJSArray m0 -> JSM (SomeUint16Array m1)
236−uint16ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint16Array" ^. js1 "from" a
237−{-# INLINE uint16ArrayFrom #-}
238−
239−uint32ArrayFrom :: SomeJSArray m0 -> JSM (SomeUint32Array m1)
240−uint32ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint32Array" ^. js1 "from" a
241−{-# INLINE uint32ArrayFrom #-}
242−
243−float32ArrayFrom :: SomeJSArray m0 -> JSM (SomeFloat32Array m1)
244−float32ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Float32Array" ^. js1 "from" a
245−{-# INLINE float32ArrayFrom #-}
246−
247−float64ArrayFrom :: SomeJSArray m0 -> JSM (SomeFloat64Array m1)
248−float64ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Float64Array" ^. js1 "from" a
249−{-# INLINE float64ArrayFrom #-}
250−
251−-- -----------------------------------------------------------------------------
252−
253−setIndexI :: Mutability m ~ IsMutable
254− => Int -> Int -> SomeTypedArray e m -> JSM ()
255−setIndexI i x (SomeTypedArray a) = (a <## i) x
256−{-# INLINE setIndexI #-}
257−
258−unsafeSetIndexI :: Mutability m ~ IsMutable
259− => Int -> Int -> SomeTypedArray e m -> JSM ()
260−unsafeSetIndexI i x (SomeTypedArray a) = (a <## i) x
261−{-# INLINE unsafeSetIndexI #-}
262−
263−setIndexW :: Mutability m ~ IsMutable
264− => Int -> Word -> SomeTypedArray e m -> JSM ()
265−setIndexW i x (SomeTypedArray a) = (a <## i) x
266−{-# INLINE setIndexW #-}
267−
268−unsafeSetIndexW :: Mutability m ~ IsMutable
269− => Int -> Word -> SomeTypedArray e m -> JSM ()
270−unsafeSetIndexW i x (SomeTypedArray a) = (a <## i) x
271−{-# INLINE unsafeSetIndexW #-}
272−
273−setIndexD :: Mutability m ~ IsMutable
274− => Int -> Double -> SomeTypedArray e m -> JSM ()
275−setIndexD i x (SomeTypedArray a) = (a <## i) x
276−{-# INLINE setIndexD #-}
277−
278−unsafeSetIndexD :: Mutability m ~ IsMutable
279− => Int -> Double -> SomeTypedArray e m -> JSM ()
280−unsafeSetIndexD i x (SomeTypedArray a) = (a <## i) x
281−{-# INLINE unsafeSetIndexD #-}
282−
283−indexOfI :: Mutability m ~ IsMutable
284− => Int -> Int -> SomeTypedArray e m -> JSM Int
285−indexOfI s x (SomeTypedArray a) = a ^. js2 "indexOf" x s >>= fromJSValUnchecked
286−{-# INLINE indexOfI #-}
287−
288−indexOfW :: Int -> Word -> SomeTypedArray e m -> JSM Int
289−indexOfW s x (SomeTypedArray a) = a ^. js2 "indexOf" x s >>= fromJSValUnchecked
290−{-# INLINE indexOfW #-}
291−
292−indexOfD :: Int -> Double -> SomeTypedArray e m -> JSM Int
293−indexOfD s x (SomeTypedArray a) = a ^. js2 "indexOf" x s >>= fromJSValUnchecked
294−{-# INLINE indexOfD #-}
295−
296−lastIndexOfI :: Int -> Int -> SomeTypedArray e m -> JSM Int
297−lastIndexOfI s x (SomeTypedArray a) = a ^. js2 "lastIndexOf" x s >>= fromJSValUnchecked
298−{-# INLINE lastIndexOfI #-}
299−
300−lastIndexOfW :: Int -> Word -> SomeTypedArray e m -> JSM Int
301−lastIndexOfW s x (SomeTypedArray a) = a ^. js2 "lastIndexOf" x s >>= fromJSValUnchecked
302−{-# INLINE lastIndexOfW #-}
303−
304−lastIndexOfD :: Int -> Double -> SomeTypedArray e m -> JSM Int
305−lastIndexOfD s x (SomeTypedArray a) = a ^. js2 "lastIndexOf" x s >>= fromJSValUnchecked
306−{-# INLINE lastIndexOfD #-}
307−
308−-- -----------------------------------------------------------------------------
309−-- non-class operations usable for all typed array
310−{-| length of the typed array in elements -}
311−length :: SomeTypedArray e m -> GHCJSPure Int
312−length (SomeTypedArray a) = GHCJSPure $ a ^. js "length" >>= fromJSValUnchecked
313−{-# INLINE length #-}
314−
315−{-| length of the array in bytes -}
316−byteLength :: SomeTypedArray e m -> GHCJSPure Int
317−byteLength (SomeTypedArray a) = GHCJSPure $ a ^. js "byteLength" >>= fromJSValUnchecked
318−{-# INLINE byteLength #-}
319−
320−{-| offset of the array in the buffer -}
321−byteOffset :: SomeTypedArray e m -> GHCJSPure Int
322−byteOffset (SomeTypedArray a) = GHCJSPure $ a ^. js "byteOffset" >>= fromJSValUnchecked
323−{-# INLINE byteOffset #-}
324−
325−{-| the underlying buffer of the array -}
326−buffer :: SomeTypedArray e m -> GHCJSPure (SomeArrayBuffer m)
327−buffer (SomeTypedArray a) = GHCJSPure $ SomeArrayBuffer <$> a ^. js "buffer"
328−{-# INLINE buffer #-}
329−
330−{-| create a view of the existing array -}
331−subarray :: Int -> Int -> SomeTypedArray e m -> GHCJSPure (SomeTypedArray e m)
332−subarray begin end (SomeTypedArray a) = GHCJSPure$ SomeTypedArray <$> a ^. js2 "subarray" begin end
333−{-# INLINE subarray #-}
334−
335−-- fixme convert JSException to Haskell exception
336−{-| copy the elements of one typed array to another -}
337−set :: Int -> SomeTypedArray e m -> SomeTypedArray e1 Mutable -> GHCJSPure ()
338−set offset (SomeTypedArray src) (SomeTypedArray dest) = GHCJSPure $ void $ dest ^. js2 "set" offset src
339−{-# INLINE set #-}
340−
341−unsafeSet :: Int -> SomeTypedArray e m -> SomeTypedArray e1 Mutable -> GHCJSPure ()
342−unsafeSet offset (SomeTypedArray src) (SomeTypedArray dest) = GHCJSPure $ void $ dest ^. js2 "set" offset src
343−{-# INLINE unsafeSet #-}
344−
jsaddle/src-ghc/JavaScript/TypedArray/Internal/Types.hsdeleted−121
@@ -1,121 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE TypeFamilies #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE PolyKinds #-}
5−
6−module JavaScript.TypedArray.Internal.Types where
7−
8−import GHCJS.Types
9−import GHCJS.Internal.Types
10−import Language.Javascript.JSaddle (IsJSVal)
11−
12−import Data.Int
13−import Data.Typeable
14−import Data.Word
15−
16−newtype SomeTypedArray (e :: TypedArrayElem) (m :: MutabilityType s) =
17− SomeTypedArray JSVal deriving Typeable
18−instance IsJSVal (SomeTypedArray e m)
19−
20−{-
21−newtype SomeSTTypedArray s e = SomeSTTypedArray JSVal
22− deriving (Typeable)
23−-}
24−
25−type SomeSTTypedArray s (e :: TypedArrayElem) = SomeTypedArray e (STMutable s)
26−
27−-- -----------------------------------------------------------------------------
28−
29−data TypedArrayElem = Int8Elem
30− | Int16Elem
31− | Int32Elem
32− | Uint8Elem
33− | Uint16Elem
34− | Uint32Elem
35− | Uint8ClampedElem
36− | Float32Elem
37− | Float64Elem
38−
39−-- -----------------------------------------------------------------------------
40−
41−type SomeInt8Array = SomeTypedArray Int8Elem
42−type SomeInt16Array = SomeTypedArray Int16Elem
43−type SomeInt32Array = SomeTypedArray Int32Elem
44−
45−type SomeUint8Array = SomeTypedArray Uint8Elem
46−type SomeUint16Array = SomeTypedArray Uint16Elem
47−type SomeUint32Array = SomeTypedArray Uint32Elem
48−
49−type SomeFloat32Array = SomeTypedArray Float32Elem
50−type SomeFloat64Array = SomeTypedArray Float64Elem
51−
52−type SomeUint8ClampedArray = SomeTypedArray Uint8ClampedElem
53−
54−-- -----------------------------------------------------------------------------
55−
56−type Int8Array = SomeInt8Array Immutable
57−type Int16Array = SomeInt16Array Immutable
58−type Int32Array = SomeInt32Array Immutable
59−
60−type Uint8Array = SomeUint8Array Immutable
61−type Uint16Array = SomeUint16Array Immutable
62−type Uint32Array = SomeUint32Array Immutable
63−
64−type Uint8ClampedArray = SomeUint8ClampedArray Immutable
65−
66−type Float32Array = SomeFloat32Array Immutable
67−type Float64Array = SomeFloat64Array Immutable
68−
69−-- -----------------------------------------------------------------------------
70−
71−type IOInt8Array = SomeInt8Array Mutable
72−type IOInt16Array = SomeInt16Array Mutable
73−type IOInt32Array = SomeInt32Array Mutable
74−
75−type IOUint8Array = SomeUint8Array Mutable
76−type IOUint16Array = SomeUint16Array Mutable
77−type IOUint32Array = SomeUint32Array Mutable
78−
79−type IOUint8ClampedArray = SomeUint8ClampedArray Mutable
80−
81−type IOFloat32Array = SomeFloat32Array Mutable
82−type IOFloat64Array = SomeFloat64Array Mutable
83−
84−-- -----------------------------------------------------------------------------
85−
86−type STInt8Array s = SomeSTTypedArray s Int8Elem
87−type STInt16Array s = SomeSTTypedArray s Int16Elem
88−type STInt32Array s = SomeSTTypedArray s Int32Elem
89−
90−type STUint8Array s = SomeSTTypedArray s Uint8Elem
91−type STUint16Array s = SomeSTTypedArray s Uint16Elem
92−type STUint32Array s = SomeSTTypedArray s Uint32Elem
93−
94−type STFloat32Array s = SomeSTTypedArray s Float32Elem
95−type STFloat64Array s = SomeSTTypedArray s Float64Elem
96−
97−type STUint8ClampedArray s = SomeSTTypedArray s Uint8ClampedElem
98−
99−-- -----------------------------------------------------------------------------
100−
101−type family Elem x where
102− Elem (SomeUint8Array m) = Word8
103− Elem (SomeUint8ClampedArray m) = Word8
104− Elem (SomeUint16Array m) = Word16
105− Elem (SomeUint32Array m) = Word
106− Elem (SomeInt8Array m) = Int8
107− Elem (SomeInt16Array m) = Int16
108− Elem (SomeInt32Array m) = Int
109− Elem (SomeFloat32Array m) = Double
110− Elem (SomeFloat64Array m) = Double
111−
112− Elem (STUint8Array s) = Word8
113− Elem (STUint8ClampedArray s) = Word8
114− Elem (STUint16Array s) = Word16
115− Elem (STUint32Array s) = Word
116− Elem (STInt8Array s) = Int8
117− Elem (STInt16Array s) = Int16
118− Elem (STInt32Array s) = Int
119− Elem (STFloat32Array s) = Double
120− Elem (STFloat64Array s) = Double
121−
jsaddle/src/Language/Javascript/JSaddle.hs+6−5
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1-----------------------------------------------------------------------------
2-----------------------------------------------------------------------------
2--
3--
3-- Module : Language.Javascript.JSaddle
4-- Module : Language.Javascript.JSaddle
@@ -9,7 +10,7 @@
9-- | This package provides an EDSL for calling JavaScript that
10-- | This package provides an EDSL for calling JavaScript that
10-- can be used both from GHCJS and GHC. When using GHC
11-- can be used both from GHCJS and GHC. When using GHC
11-- the application is run using Warp and WebSockets to
12-- the application is run using Warp and WebSockets to
12−-- drive a small JavaScript helper.
13+-- drive a small JavaScipt helper.
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14
15
15module Language.Javascript.JSaddle (
16module Language.Javascript.JSaddle (
@@ -35,10 +36,10 @@ module Language.Javascript.JSaddle (
35 --
36 --
36 -- Where it makes sense code examples are given in two forms. One
37 -- Where it makes sense code examples are given in two forms. One
37 -- that uses 'eval' to run a purely JavaScript version and one that
38 -- that uses 'eval' to run a purely JavaScript version and one that
38− -- uses more of the JSaddle EDSL feature being demonstrated.
39+ -- uses more of the JSaddle EDSL feature being demonstated.
39
40
40 -- * Calling Haskell from JavaScript
41 -- * Calling Haskell from JavaScript
41− -- | You can call back into Haskell from JavaScript using 'fun' to
42+ -- | You can call back into haskell from JavaScript using 'fun' to
42 -- convert a Haskell function in the JSM monad into a javascript
43 -- convert a Haskell function in the JSM monad into a javascript
43 -- value.
44 -- value.
44
45
@@ -52,8 +53,8 @@ module Language.Javascript.JSaddle (
52 -- and the server will run the Haskell code. The JSaddle parts will
53 -- and the server will run the Haskell code. The JSaddle parts will
53 -- be executed by sending commands back to the browser.
54 -- be executed by sending commands back to the browser.
54
55
55− -- Although the JavaScript code is executed in the strict order
56+ -- Although the code JavaScript code is executed in the the strict order
56− -- set out by the EDSL it is done asynchronously to the Haskell code.
57+ -- set out by the EDSL it done asynchonously to the Haskell code.
57 -- This improves the performance by reducing the number of round trips
58 -- This improves the performance by reducing the number of round trips
58 -- needed between the Haskell and JavaScript code.
59 -- needed between the Haskell and JavaScript code.
59
60
jsaddle/src-ghc/JavaScript/Array.hs → jsaddle/src/Language/Javascript/JSaddle/Array.hsrenamed+23−36
@@ -1,6 +1,17 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE TypeSynonymInstances #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE Rank2Types #-}
6+#ifdef ghcjs_HOST_OS
7+{-# LANGUAGE ForeignFunctionInterface #-}
8+{-# LANGUAGE JavaScriptFFI #-}
9+{-# OPTIONS_GHC -Wno-dodgy-exports -Wno-dodgy-imports #-}
10+#endif
11+{-# OPTIONS_GHC -fno-warn-orphans #-}
1-----------------------------------------------------------------------------
12-----------------------------------------------------------------------------
2--
13--
3−-- Module : JavaScript.Array
14+-- Module : Language.Javascript.JSaddle.Object
4-- Copyright : (c) Hamish Mackenzie
15-- Copyright : (c) Hamish Mackenzie
5-- License : MIT
16-- License : MIT
6--
17--
@@ -9,19 +20,17 @@
9-- | Interface to JavaScript array
20-- | Interface to JavaScript array
10--
21--
11-----------------------------------------------------------------------------
22-----------------------------------------------------------------------------
12−module JavaScript.Array
23+
24+module Language.Javascript.JSaddle.Array
13 ( SomeJSArray(..)
25 ( SomeJSArray(..)
14 , JSArray
26 , JSArray
15 , MutableJSArray
27 , MutableJSArray
16 , create
28 , create
17 , length
29 , length
18 , lengthIO
30 , lengthIO
19− , null
31+ , nullIO
20− , fromList
21 , fromListIO
32 , fromListIO
22− , toList
23 , toListIO
33 , toListIO
24− , index, (!)
25 , read
34 , read
26 , write
35 , write
27 , append
36 , append
@@ -30,11 +39,8 @@ module JavaScript.Array
30 , unshift
39 , unshift
31 , shift
40 , shift
32 , reverse
41 , reverse
33− , take
34 , takeIO
42 , takeIO
35− , drop
36 , dropIO
43 , dropIO
37− , slice
38 , sliceIO
44 , sliceIO
39 , freeze
45 , freeze
40 , unsafeFreeze
46 , unsafeFreeze
@@ -42,34 +48,30 @@ module JavaScript.Array
42 , unsafeThaw
48 , unsafeThaw
43 ) where
49 ) where
44
50
45−import Prelude hiding (length, drop, read, take, reverse, null)
51+import Prelude hiding (read, reverse, null)
46import Control.Monad (void)
52import Control.Monad (void)
47import Language.Javascript.JSaddle.Types
53import Language.Javascript.JSaddle.Types
48 (JSM, JSVal, SomeJSArray(..), JSArray,
54 (JSM, JSVal, SomeJSArray(..), JSArray,
49− MutableJSArray, GHCJSPure(..))
55+ MutableJSArray)
50import Control.Lens.Operators ((^.))
56import Control.Lens.Operators ((^.))
51−import Language.Javascript.JSaddle.Object (js2, js0, (<##), js1, js)
57+import Language.Javascript.JSaddle.Object (js2, js0, (##), js1, js)
52import Language.Javascript.JSaddle.Value (valToNumber)
58import Language.Javascript.JSaddle.Value (valToNumber)
53−import JavaScript.Array.Internal (create, fromList, fromListIO, toList, toListIO, index, read, push)
59+import JavaScript.Array.Internal (create, fromListIO, toListIO, read, push)
54−
55−length :: SomeJSArray m -> GHCJSPure Int
56−length = GHCJSPure . lengthIO
57−{-# INLINE length #-}
58
60
59lengthIO :: SomeJSArray m -> JSM Int
61lengthIO :: SomeJSArray m -> JSM Int
60lengthIO (SomeJSArray x) = round <$> (x ^. js "length" >>= valToNumber)
62lengthIO (SomeJSArray x) = round <$> (x ^. js "length" >>= valToNumber)
61{-# INLINE lengthIO #-}
63{-# INLINE lengthIO #-}
62
64
63−null :: SomeJSArray m -> GHCJSPure Bool
65+nullIO :: SomeJSArray m -> JSM Bool
64−null = GHCJSPure . fmap (== 0) . lengthIO
66+nullIO = fmap (== 0) . lengthIO
65−{-# INLINE null #-}
67+{-# INLINE nullIO #-}
66
68
67append :: SomeJSArray m -> SomeJSArray m -> JSM (SomeJSArray m1)
69append :: SomeJSArray m -> SomeJSArray m -> JSM (SomeJSArray m1)
68append (SomeJSArray x) (SomeJSArray y) = SomeJSArray <$> x ^. js1 "concat" y
70append (SomeJSArray x) (SomeJSArray y) = SomeJSArray <$> x ^. js1 "concat" y
69{-# INLINE append #-}
71{-# INLINE append #-}
70
72
71write :: Int -> JSVal -> MutableJSArray -> JSM ()
73write :: Int -> JSVal -> MutableJSArray -> JSM ()
72−write n e (SomeJSArray x) = void $ (x <## n) e
74+write n e (SomeJSArray x) = void $ (x ## n) e
73{-# INLINE write #-}
75{-# INLINE write #-}
74
76
75pop :: MutableJSArray -> JSM JSVal
77pop :: MutableJSArray -> JSM JSVal
@@ -88,26 +90,14 @@ reverse :: MutableJSArray -> JSM ()
88reverse (SomeJSArray x) = void $ x ^. js0 "reverse"
90reverse (SomeJSArray x) = void $ x ^. js0 "reverse"
89{-# INLINE reverse #-}
91{-# INLINE reverse #-}
90
92
91−take :: Int -> SomeJSArray m -> GHCJSPure (SomeJSArray m1)
92−take n = GHCJSPure . takeIO n
93−{-# INLINE take #-}
94−
95takeIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1)
93takeIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1)
96takeIO n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" (0::Int) n
94takeIO n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" (0::Int) n
97{-# INLINE takeIO #-}
95{-# INLINE takeIO #-}
98
96
99−drop :: Int -> SomeJSArray m -> GHCJSPure (SomeJSArray m1)
100−drop n = GHCJSPure . dropIO n
101−{-# INLINE drop #-}
102−
103dropIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1)
97dropIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1)
104dropIO n (SomeJSArray x) = SomeJSArray <$> x ^. js1 "slice1" n
98dropIO n (SomeJSArray x) = SomeJSArray <$> x ^. js1 "slice1" n
105{-# INLINE dropIO #-}
99{-# INLINE dropIO #-}
106
100
107−slice :: Int -> Int -> JSArray -> GHCJSPure (SomeJSArray m1)
108−slice s n = GHCJSPure . sliceIO s n
109−{-# INLINE slice #-}
110−
111sliceIO :: Int -> Int -> JSArray -> JSM (SomeJSArray m1)
101sliceIO :: Int -> Int -> JSArray -> JSM (SomeJSArray m1)
112sliceIO s n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" s n
102sliceIO s n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" s n
113{-# INLINE sliceIO #-}
103{-# INLINE sliceIO #-}
@@ -128,7 +118,4 @@ unsafeThaw :: JSArray -> JSM MutableJSArray
128unsafeThaw (SomeJSArray x) = pure (SomeJSArray x)
118unsafeThaw (SomeJSArray x) = pure (SomeJSArray x)
129{-# INLINE unsafeThaw #-}
119{-# INLINE unsafeThaw #-}
130
120
131−(!) :: JSArray -> Int -> GHCJSPure JSVal
132−x ! n = GHCJSPure $ read n x
133−{-# INLINE (!) #-}
134
121
jsaddle/src/Language/Javascript/JSaddle/Debug.hsdeleted−48
@@ -1,48 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−-----------------------------------------------------------------------------
4−--
5−-- Module : Language.Javascript.JSaddle.WebSockets
6−-- Copyright : (c) Hamish Mackenzie
7−-- License : MIT
8−--
9−-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.Javascript.JSaddle.Debug (
16− contexts
17− , addContext
18− , removeContext
19− , runOnAll
20− , runOnAll_
21−) where
22−
23−import Language.Javascript.JSaddle
24− (runJSM, askJSM, JSM, JSContextRef(..))
25−import Data.IORef (readIORef, atomicModifyIORef', newIORef, IORef)
26−import System.IO.Unsafe (unsafePerformIO)
27−import Data.Monoid ((<>))
28−import Control.Monad.IO.Class (MonadIO(..))
29−import Data.Int (Int64)
30−
31−contexts :: IORef [JSContextRef]
32−contexts = unsafePerformIO $ newIORef []
33−{-# NOINLINE contexts #-}
34−
35−addContext :: JSM ()
36−addContext = do
37− ctx <- askJSM
38− liftIO $ atomicModifyIORef' contexts $ \c -> (c <> [ctx], ())
39−
40−removeContext :: MonadIO m => Int64 -> m ()
41−removeContext cid =
42− liftIO $ atomicModifyIORef' contexts $ \c -> (filter ((/= cid) . contextId) c, ())
43−
44−runOnAll :: MonadIO m => JSM a -> m [a]
45−runOnAll f = liftIO (readIORef contexts) >>= mapM (runJSM f)
46−
47−runOnAll_ :: MonadIO m => JSM a -> m ()
48−runOnAll_ f = liftIO (readIORef contexts) >>= mapM_ (runJSM f)
jsaddle/src/Language/Javascript/JSaddle/Evaluate.hs+7−3
@@ -27,7 +27,9 @@ import Control.Monad.IO.Class (MonadIO(..))
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− (evaluateScript)
30+ (withJSString)
31+import Language.Javascript.JSaddle.Run
32+ (AsyncCommand(..), sendLazyCommand)
31#endif
33#endif
32import Language.Javascript.JSaddle.Marshal.String (ToJSString(..))
34import Language.Javascript.JSaddle.Marshal.String (ToJSString(..))
33import Language.Javascript.JSaddle.Monad (JSM)
35import Language.Javascript.JSaddle.Monad (JSM)
@@ -50,8 +52,10 @@ eval :: (ToJSString script)
50 -> JSM JSVal
52 -> JSM JSVal
51#ifdef ghcjs_HOST_OS
53#ifdef ghcjs_HOST_OS
52eval script = liftIO $ js_eval (toJSString script)
54eval script = liftIO $ js_eval (toJSString script)
53−foreign import javascript safe "$r = eval($1);"
55+foreign import javascript unsafe "$r = eval($1);"
54 js_eval :: JSString -> IO JSVal
56 js_eval :: JSString -> IO JSVal
55#else
57#else
56−eval = evaluateScript . toJSString
58+eval script = do
59+ let rscript = toJSString script
60+ withJSString rscript $ sendLazyCommand . EvaluateScript
57#endif
61#endif
jsaddle/src/Language/Javascript/JSaddle/Exception.hs+1−6
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
3-----------------------------------------------------------------------------
2-----------------------------------------------------------------------------
4--
3--
@@ -18,11 +17,7 @@ module Language.Javascript.JSaddle.Exception (
18) where
17) where
19
18
20import qualified Control.Exception as E (Exception)
19import qualified Control.Exception as E (Exception)
21−#ifdef ghcjs_HOST_OS
20+import Language.Javascript.JSaddle.Types (JSVal)
22−import GHCJS.Prim (JSVal)
23−#else
24−import GHCJS.Prim.Internal (JSVal)
25−#endif
26import Data.Typeable (Typeable)
21import Data.Typeable (Typeable)
27
22
28newtype JSException = JSException JSVal deriving (Typeable)
23newtype JSException = JSException JSVal deriving (Typeable)
jsaddle/src/Language/Javascript/JSaddle/Foreign.hsnew file+99
@@ -0,0 +1,99 @@
1+{-# LANGUAGE CPP #-}
2+-----------------------------------------------------------------------------
3+--
4+-- Module : Language.Javascript.JSaddle.Value
5+-- Copyright : (c) Hamish Mackenzie
6+-- License : MIT
7+--
8+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
9+--
10+-- | This module is like `GHCJS.Foreign` but some functions are in
11+--
12+-----------------------------------------------------------------------------
13+module Language.Javascript.JSaddle.Foreign (
14+ jsTrue
15+ , jsFalse
16+ , jsNull
17+ , toJSBool
18+-- , fromJSBoolIO
19+ , jsUndefined
20+ , isTruthyIO
21+ , isNullIO
22+ , isUndefinedIO
23+-- , isObjectIO
24+-- , isFunctionIO
25+-- , isStringIO
26+-- , isBooleanIO
27+-- , isSymbolIO
28+-- , isNumberIO
29+) where
30+
31+#ifdef ghcjs_HOST_OS
32+import Language.Javascript.JSaddle.Types (JSM, JSVal)
33+import GHCJS.Foreign (toJSBool, isTruthy, jsNull, jsUndefined, jsTrue, jsFalse, isNull, isUndefined)
34+#else
35+import Language.Javascript.JSaddle.Types (JSM, JSVal(..))
36+import Language.Javascript.JSaddle.Native.Internal
37+ (withJSVal)
38+import Language.Javascript.JSaddle.Run
39+ (Command(..), Result(..), sendCommand)
40+#endif
41+
42+#ifndef ghcjs_HOST_OS
43+jsTrue :: JSVal
44+jsTrue = JSVal 3
45+{-# INLINE jsTrue #-}
46+
47+jsFalse :: JSVal
48+jsFalse = JSVal 2
49+{-# INLINE jsFalse #-}
50+
51+jsNull :: JSVal
52+jsNull = JSVal 0
53+{-# INLINE jsNull #-}
54+
55+toJSBool :: Bool -> JSVal
56+toJSBool b = JSVal $ if b then 3 else 2
57+{-# INLINE toJSBool #-}
58+
59+jsUndefined :: JSVal
60+jsUndefined = JSVal 1
61+{-# INLINE jsUndefined #-}
62+#endif
63+
64+isTruthyIO :: JSVal -> JSM Bool
65+#ifdef ghcjs_HOST_OS
66+isTruthyIO = return . isTruthy
67+#else
68+isTruthyIO (JSVal 0) = return False -- null
69+isTruthyIO (JSVal 1) = return False -- undefined
70+isTruthyIO (JSVal 2) = return False -- false
71+isTruthyIO (JSVal 3) = return True -- true
72+isTruthyIO v = withJSVal v $ \rval -> do
73+ ~(ValueToBoolResult result) <- sendCommand (ValueToBool rval)
74+ return result
75+#endif
76+{-# INLINE isTruthyIO #-}
77+
78+isNullIO :: JSVal -> JSM Bool
79+#ifdef ghcjs_HOST_OS
80+isNullIO = return . isNull
81+#else
82+isNullIO (JSVal 0) = return True
83+isNullIO v = withJSVal v $ \rval -> do
84+ ~(IsNullResult result) <- sendCommand $ IsNull rval
85+ return result
86+#endif
87+{-# INLINE isNullIO #-}
88+
89+isUndefinedIO :: JSVal -> JSM Bool
90+#ifdef ghcjs_HOST_OS
91+isUndefinedIO = return . isUndefined
92+#else
93+isUndefinedIO (JSVal 1) = return True
94+isUndefinedIO v = withJSVal v $ \rval -> do
95+ ~(IsUndefinedResult result) <- sendCommand $ IsUndefined rval
96+ return result
97+#endif
98+{-# INLINE isUndefinedIO #-}
99+
jsaddle/src/Language/Javascript/JSaddle/Helper.hsdeleted−30
@@ -1,30 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−module Language.Javascript.JSaddle.Helper where
3−
4−import GHCJS.Types (JSVal)
5−import Language.Javascript.JSaddle.Types (JSM)
6−
7−#ifdef ghcjs_HOST_OS
8−import GHCJS.Marshal.Pure (pFromJSVal, pToJSVal)
9−import JavaScript.TypedArray.ArrayBuffer (MutableArrayBuffer)
10−#else
11−import JavaScript.TypedArray.ArrayBuffer.Internal (MutableArrayBuffer, SomeArrayBuffer(..))
12−#endif
13−
14−-- | Helper function needed because there is no FromJSVal instance for MutableArrayBuffer
15−mutableArrayBufferFromJSVal :: JSVal -> JSM MutableArrayBuffer
16−#ifdef ghcjs_HOST_OS
17−mutableArrayBufferFromJSVal = return . pFromJSVal
18−#else
19−mutableArrayBufferFromJSVal = return . SomeArrayBuffer
20−#endif
21−{-# INLINE mutableArrayBufferFromJSVal #-}
22−
23−-- | Helper function needed because there is no ToJSVal instance for MutableArrayBuffer
24−mutableArrayBufferToJSVal :: MutableArrayBuffer -> JSM JSVal
25−#ifdef ghcjs_HOST_OS
26−mutableArrayBufferToJSVal = return . pToJSVal
27−#else
28−mutableArrayBufferToJSVal (SomeArrayBuffer v) = return v
29−#endif
30−{-# INLINE mutableArrayBufferToJSVal #-}
jsaddle/src/Language/Javascript/JSaddle/Monad.hs+26−3
@@ -38,12 +38,13 @@ module Language.Javascript.JSaddle.Monad (
38 , bracket
38 , bracket
39) where
39) where
40
40
41+import Prelude hiding (read)
41#ifndef ghcjs_HOST_OS
42#ifndef ghcjs_HOST_OS
42−import Control.Monad.Trans.Reader (runReaderT, ask)
43+import Control.Monad.Trans.Reader (runReaderT, ask, ReaderT(..))
43#endif
44#endif
44import Control.Monad.IO.Class (MonadIO(..))
45import Control.Monad.IO.Class (MonadIO(..))
45−import Control.Monad.Catch (catch, bracket)
46+import qualified Control.Exception as E (Exception, catch, bracket)
46−import Language.Javascript.JSaddle.Types (JSM(..), MonadJSM, liftJSM, JSContextRef)
47+import Language.Javascript.JSaddle.Types (JSM(..), MonadJSM, liftJSM, JSContextRef(..))
47import Language.Javascript.JSaddle.Run (syncPoint, syncAfter, waitForAnimationFrame, nextAnimationFrame)
48import Language.Javascript.JSaddle.Run (syncPoint, syncAfter, waitForAnimationFrame, nextAnimationFrame)
48
49
49-- | Gets the JavaScript context from the monad
50-- | Gets the JavaScript context from the monad
@@ -65,3 +66,25 @@ runJSM f = liftIO . runReaderT (unJSM f)
65-- | Alternative version of 'runJSM'
66-- | Alternative version of 'runJSM'
66runJSaddle :: MonadIO m => JSContextRef -> JSM a -> m a
67runJSaddle :: MonadIO m => JSContextRef -> JSM a -> m a
67runJSaddle = flip runJSM
68runJSaddle = flip runJSM
69+
70+
71+-- | Wrapped version of 'E.catch' that runs in a MonadIO that works
72+-- a bit better with 'JSM'
73+catch :: E.Exception e
74+ => JSM b
75+ -> (e -> JSM b)
76+ -> JSM b
77+t `catch` c = do
78+ r <- askJSM
79+ liftIO (runJSM (syncAfter t) r `E.catch` \e -> runJSM (c e) r)
80+
81+-- | Wrapped version of 'E.bracket' that runs in a MonadIO that works
82+-- a bit better with 'JSM'
83+bracket :: JSM a -> (a -> JSM b) -> (a -> JSM c) -> JSM c
84+bracket aquire release f = do
85+ r <- askJSM
86+ liftIO $ E.bracket
87+ (runJSM (syncAfter aquire) r)
88+ (\x -> runJSM (syncAfter $ release x) r)
89+ (\x -> runJSM (syncAfter $ f x) r)
90+
jsaddle/src/Language/Javascript/JSaddle/Native.hs+6−1
@@ -11,7 +11,12 @@
11-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
12
12
13module Language.Javascript.JSaddle.Native (
13module Language.Javascript.JSaddle.Native (
14− module Language.Javascript.JSaddle.Native.Internal
14+ wrapJSVal
15+ , wrapJSString
16+ , withJSVal
17+ , withJSVals
18+ , withObject
19+ , withJSString
15 , withToJSVal
20 , withToJSVal
16) where
21) where
17
22
jsaddle/src/Language/Javascript/JSaddle/Native/Internal.hs+23−212
@@ -1,6 +1,3 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE MagicHash #-}
3−{-# LANGUAGE UnboxedTuples #-}
4-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
5--
2--
6-- Module : Language.Javascript.JSaddle.Native
3-- Module : Language.Javascript.JSaddle.Native
@@ -20,234 +17,48 @@ module Language.Javascript.JSaddle.Native.Internal (
20 , withJSVals
17 , withJSVals
21 , withObject
18 , withObject
22 , withJSString
19 , 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
48) where
20) where
49
21
22+import Control.Monad.Trans.Reader (ask)
50import Control.Monad.IO.Class (MonadIO(..))
23import Control.Monad.IO.Class (MonadIO(..))
51−
52−import Data.Aeson (Value)
53−
54import Language.Javascript.JSaddle.Types
24import Language.Javascript.JSaddle.Types
55− (AsyncCommand(..), JSM(..), JSString(..), addCallback,
25+ (JSContextRef(..), AsyncCommand(..), JSM(..), JSString(..),
56− Object(..), JSVal(..), JSValueForSend(..), JSCallAsFunction,
26+ Object(..), JSVal(..), JSValueReceived(..), JSValueForSend(..),
57 JSStringReceived(..), JSStringForSend(..), JSObjectForSend(..))
27 JSStringReceived(..), JSStringForSend(..), JSObjectForSend(..))
58−import Language.Javascript.JSaddle.Monad (askJSM)
28+import System.Mem.Weak (addFinalizer)
59−import Language.Javascript.JSaddle.Run
29+import Control.Monad.Primitive (touch)
60− (Command(..), Result(..), sendCommand,
30+import Control.Monad (when)
61− sendAsyncCommand, sendLazyCommand, wrapJSVal)
31+
62−import GHC.IORef (IORef(..), readIORef)
32+wrapJSVal :: JSValueReceived -> JSM JSVal
63−import GHC.STRef (STRef(..))
33+wrapJSVal (JSValueReceived ref) = do
64−import GHC.IO (IO(..))
34+ -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
65−import GHC.Base (touch#)
35+ let result = JSVal ref
36+ when (ref >= 5) $ do
37+ ctx <- JSM ask
38+ liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref
39+ return result
66
40
67wrapJSString :: MonadIO m => JSStringReceived -> m JSString
41wrapJSString :: MonadIO m => JSStringReceived -> m JSString
68wrapJSString (JSStringReceived ref) = return $ JSString ref
42wrapJSString (JSStringReceived ref) = return $ JSString ref
69
43
70−touchIORef :: IORef a -> IO ()
71−touchIORef (IORef (STRef r#)) = IO $ \s -> case touch# r# s of s' -> (# s', () #)
72−
73withJSVal :: MonadIO m => JSVal -> (JSValueForSend -> m a) -> m a
44withJSVal :: MonadIO m => JSVal -> (JSValueForSend -> m a) -> m a
74−withJSVal (JSVal ref) f = do
45+withJSVal v@(JSVal ref) f =
75− result <- (f . JSValueForSend) =<< liftIO (readIORef ref)
46+ do result <- f (JSValueForSend ref)
76− liftIO $ touchIORef ref
47+ liftIO $ touch v
77 return result
48 return result
78
49
79withJSVals :: MonadIO m => [JSVal] -> ([JSValueForSend] -> m a) -> m a
50withJSVals :: MonadIO m => [JSVal] -> ([JSValueForSend] -> m a) -> m a
80withJSVals v f =
51withJSVals v f =
81− do result <- f =<< mapM (\(JSVal ref) -> liftIO $ JSValueForSend <$> readIORef ref) v
52+ do result <- f (map (\(JSVal ref) -> JSValueForSend ref) v)
82− liftIO $ mapM_ (\(JSVal ref) -> touchIORef ref) v
53+ liftIO $ mapM_ touch v
83 return result
54 return result
84
55
85withObject :: MonadIO m => Object -> (JSObjectForSend -> m a) -> m a
56withObject :: MonadIO m => Object -> (JSObjectForSend -> m a) -> m a
86withObject (Object o) f = withJSVal o (f . JSObjectForSend)
57withObject (Object o) f = withJSVal o (f . JSObjectForSend)
87
58
88withJSString :: MonadIO m => JSString -> (JSStringForSend -> m a) -> m a
59withJSString :: MonadIO m => JSString -> (JSStringForSend -> m a) -> m a
89−withJSString (JSString ref) f = f (JSStringForSend ref)
60+withJSString v@(JSString ref) f =
90−
61+ do result <- f (JSStringForSend ref)
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
62+ liftIO $ touch v
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)
207 return result
63 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 #-}
247
64
248−propertyNames :: Object -> JSM [JSString]
249−propertyNames this =
250− withObject this $ \rthis -> do
251− ~(PropertyNamesResult result) <- sendCommand $ PropertyNames rthis
252− mapM wrapJSString result
253−{-# INLINE propertyNames #-}
jsaddle/src/Language/Javascript/JSaddle/Null.hsdeleted−56
@@ -1,56 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−-----------------------------------------------------------------------------
4−--
5−-- Module : Language.Javascript.JSaddle.WebSockets
6−-- Copyright : (c) Hamish Mackenzie
7−-- License : MIT
8−--
9−-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.Javascript.JSaddle.Null (
16− run
17−) where
18−
19−import Language.Javascript.JSaddle.Types
20− (BatchResults(..), JSM, JSStringReceived(..), Batch(..),
21− Results(..), Result(..), Command(..))
22−import Control.Concurrent.Chan (readChan, writeChan, newChan)
23−import Language.Javascript.JSaddle.Run (runJavaScript)
24−import Control.Concurrent (forkIO)
25−import Control.Monad (forever)
26−import Data.Aeson (Value(..))
27−import Data.Maybe (mapMaybe)
28−
29−-- | This is for performance testing JSaddle code that does not need to
30−-- to read anything back from the JavaScript context.
31−-- Anthing that does try to read will get JS null, 0 or "" back (depending
32−-- on how the value is read).
33−run :: JSM () -> IO ()
34−run f = do
35− batches <- newChan
36− (processResult, _processSyncResult, start) <- runJavaScript (writeChan batches) f
37− _ <- forkIO $ forever $
38− readChan batches >>= \case
39− Batch commands _ batchNumber ->
40− processResult $ BatchResults batchNumber . Success [] $ mapMaybe (\case
41− Left _ -> Nothing
42− Right command -> Just $
43− case command of
44− DeRefVal _ -> DeRefValResult 0 ""
45− ValueToBool _ -> ValueToBoolResult False
46− ValueToNumber _ -> ValueToNumberResult 0
47− ValueToString _ -> ValueToStringResult (JSStringReceived "")
48− ValueToJSON _ -> ValueToJSONResult (JSStringReceived "null")
49− ValueToJSONValue _ -> ValueToJSONValueResult Null
50− IsNull _ -> IsNullResult True
51− IsUndefined _ -> IsUndefinedResult False
52− StrictEqual _ _ -> StrictEqualResult False
53− InstanceOf _ _ -> InstanceOfResult False
54− PropertyNames _ -> PropertyNamesResult []
55− Sync -> SyncResult) commands
56− start
jsaddle/src/Language/Javascript/JSaddle/Object.hs+28−54
@@ -66,7 +66,6 @@ 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
70 , freeFunction
69 , freeFunction
71 , fun
70 , fun
72 , JSCallAsFunction
71 , JSCallAsFunction
@@ -103,7 +102,7 @@ import Data.Coerce (coerce)
103#ifdef ghcjs_HOST_OS
102#ifdef ghcjs_HOST_OS
104import GHCJS.Types (nullRef)
103import GHCJS.Types (nullRef)
105import GHCJS.Foreign.Callback
104import GHCJS.Foreign.Callback
106− (releaseCallback, syncCallback2, asyncCallback2, OnBlocked(..), Callback)
105+ (releaseCallback, syncCallback2, OnBlocked(..), Callback)
107import GHCJS.Marshal (ToJSVal(..))
106import GHCJS.Marshal (ToJSVal(..))
108import JavaScript.Array (MutableJSArray)
107import JavaScript.Array (MutableJSArray)
109import qualified JavaScript.Array as Array (toListIO, fromListIO)
108import qualified JavaScript.Array as Array (toListIO, fromListIO)
@@ -116,13 +115,14 @@ import Language.Javascript.JSaddle.Types
116#else
115#else
117import GHCJS.Marshal.Internal (ToJSVal(..))
116import GHCJS.Marshal.Internal (ToJSVal(..))
118import Language.Javascript.JSaddle.Native
117import Language.Javascript.JSaddle.Native
119− (newAsyncCallback, newSyncCallback, callAsFunction, callAsConstructor)
118+ (withJSVals, withObject)
119+import Language.Javascript.JSaddle.Run
120+ (AsyncCommand(..), sendLazyCommand)
120import Language.Javascript.JSaddle.Monad (askJSM, JSM)
121import Language.Javascript.JSaddle.Monad (askJSM, JSM)
121import Language.Javascript.JSaddle.Types
122import Language.Javascript.JSaddle.Types
122− (JSValueForSend(..), AsyncCommand(..), JSString, Object(..),
123+ (JSString, Object(..), SomeJSArray(..),
123− SomeJSArray(..), JSVal(..), JSCallAsFunction, JSContextRef(..))
124+ JSVal(..), JSCallAsFunction, JSContextRef(..))
124import JavaScript.Object.Internal (create, listProps)
125import JavaScript.Object.Internal (create, listProps)
125−import Language.Javascript.JSaddle.Run (sendAsyncCommand)
126#endif
126#endif
127import JavaScript.Array.Internal (fromListIO)
127import JavaScript.Array.Internal (fromListIO)
128import Language.Javascript.JSaddle.Value (valToObject)
128import Language.Javascript.JSaddle.Value (valToObject)
@@ -132,8 +132,6 @@ import Language.Javascript.JSaddle.Arguments (MakeArgs(..))
132import Control.Monad.IO.Class (MonadIO(..))
132import Control.Monad.IO.Class (MonadIO(..))
133import Language.Javascript.JSaddle.Properties
133import Language.Javascript.JSaddle.Properties
134import Control.Lens (IndexPreservingGetter, to)
134import Control.Lens (IndexPreservingGetter, to)
135−import Data.IORef (newIORef, readIORef)
136−import System.IO.Unsafe (unsafePerformIO)
137
135
138-- $setup
136-- $setup
139-- >>> import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
137-- >>> import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
@@ -281,7 +279,6 @@ jsgf name = global # name
281-- > jsg0 name = jsgf name ()
279-- > jsg0 name = jsgf name ()
282--
280--
283-- >>> testJSaddle $ jsg0 "globalFunc" >>= valToText
281-- >>> testJSaddle $ jsg0 "globalFunc" >>= valToText
284−-- A JavaScript exception was thrown! (may not reach Haskell code)
285-- TypeError:...undefine...
282-- TypeError:...undefine...
286jsg0 :: (ToJSString name) => name -> JSM JSVal
283jsg0 :: (ToJSString name) => name -> JSM JSVal
287jsg0 name = jsgf name ()
284jsg0 name = jsgf name ()
@@ -439,16 +436,9 @@ newtype Function = Function {functionObject :: Object}
439#endif
436#endif
440
437
441
438
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−
447-- ^ Make a JavaScript function object that wraps a Haskell function.
439-- ^ 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`).
450function :: JSCallAsFunction -- ^ Haskell function to call
440function :: JSCallAsFunction -- ^ Haskell function to call
451− -> JSM Function -- ^ Returns a JavaScript function object that will
441+ -> JSM Function -- ^ Returns a JavaScript function object that will
452 -- call the Haskell one when it is called
442 -- call the Haskell one when it is called
453#ifdef ghcjs_HOST_OS
443#ifdef ghcjs_HOST_OS
454function f = do
444function f = do
@@ -456,26 +446,13 @@ function f = do
456 rargs <- Array.toListIO (coerce args)
446 rargs <- Array.toListIO (coerce args)
457 f this this rargs -- TODO pass function object through
447 f this this rargs -- TODO pass function object through
458 Function callback <$> makeFunctionWithCallback callback
448 Function callback <$> makeFunctionWithCallback callback
449+foreign import javascript unsafe "$r = function () { $1(this, arguments); }"
450+ makeFunctionWithCallback :: Callback (JSVal -> JSVal -> IO ()) -> IO Object
459#else
451#else
460function f = do
452function f = do
461− object <- newSyncCallback f
453+ object <- Object <$> sendLazyCommand NewCallback
462− return $ Function object
454+ add <- addCallback <$> askJSM
463−#endif
455+ liftIO $ add object f
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
479 return $ Function object
456 return $ Function object
480#endif
457#endif
481
458
@@ -484,16 +461,9 @@ freeFunction :: Function -> JSM ()
484freeFunction (Function callback _) = liftIO $
461freeFunction (Function callback _) = liftIO $
485 releaseCallback callback
462 releaseCallback callback
486#else
463#else
487−freeFunction (Function (Object (JSVal objectRef))) = do
464+freeFunction (Function object) = do
488− -- By now the callback should ideally have been removed from whatever
465+ free <- freeCallback <$> askJSM
489− -- events it was added to.
466+ liftIO $ free object
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))
497#endif
467#endif
498
468
499instance ToJSVal Function where
469instance ToJSVal Function where
@@ -526,12 +496,13 @@ array args = do
526 Object . coerce <$> fromListIO rargs
496 Object . coerce <$> fromListIO rargs
527
497
528-- | JavaScript's global object
498-- | JavaScript's global object
499+global :: Object
529#ifdef ghcjs_HOST_OS
500#ifdef ghcjs_HOST_OS
501+global = js_window
530−foreign import javascript unsafe "$r = globalThis"
502+foreign import javascript unsafe "$r = window"
531− global :: Object
503+ js_window :: Object
532#else
504#else
533−global :: Object
505+global = Object (JSVal 4)
534−global = Object . JSVal . unsafePerformIO $ newIORef 4
535#endif
506#endif
536
507
537-- | Get a list containing the property names present on a given object
508-- | Get a list containing the property names present on a given object
@@ -556,12 +527,14 @@ objCallAsFunction :: MakeArgs args
556objCallAsFunction f this args = do
527objCallAsFunction f this args = do
557 rargs <- makeArgs args >>= liftIO . Array.fromListIO
528 rargs <- makeArgs args >>= liftIO . Array.fromListIO
558 liftIO $ js_apply f this rargs
529 liftIO $ js_apply f this rargs
559−foreign import javascript safe "$r = $1.apply($2, $3)"
530+foreign import javascript unsafe "$r = $1.apply($2, $3)"
560 js_apply :: Object -> Object -> MutableJSArray -> IO JSVal
531 js_apply :: Object -> Object -> MutableJSArray -> IO JSVal
561#else
532#else
562objCallAsFunction f this args = do
533objCallAsFunction f this args = do
563 rargs <- makeArgs args
534 rargs <- makeArgs args
564− callAsFunction f this rargs
535+ withObject f $ \rfunction ->
536+ withObject this $ \rthis ->
537+ withJSVals rargs $ sendLazyCommand . CallAsFunction rfunction rthis
565#endif
538#endif
566
539
567-- | Call a JavaScript object as a constructor. Consider using 'new'.
540-- | Call a JavaScript object as a constructor. Consider using 'new'.
@@ -576,7 +549,7 @@ objCallAsConstructor :: MakeArgs args
576objCallAsConstructor f args = do
549objCallAsConstructor f args = do
577 rargs <- makeArgs args >>= liftIO . Array.fromListIO
550 rargs <- makeArgs args >>= liftIO . Array.fromListIO
578 liftIO $ js_new f rargs
551 liftIO $ js_new f rargs
579−foreign import javascript safe "\
552+foreign import javascript unsafe "\
580 switch($2.length) {\
553 switch($2.length) {\
581 case 0 : $r = new $1(); break;\
554 case 0 : $r = new $1(); break;\
582 case 1 : $r = new $1($2[0]); break;\
555 case 1 : $r = new $1($2[0]); break;\
@@ -603,7 +576,8 @@ foreign import javascript safe "\
603#else
576#else
604objCallAsConstructor f args = do
577objCallAsConstructor f args = do
605 rargs <- makeArgs args
578 rargs <- makeArgs args
606− callAsConstructor f rargs
579+ withObject f $ \rfunction ->
580+ withJSVals rargs $ sendLazyCommand . CallAsConstructor rfunction
607#endif
581#endif
608
582
609-- >>> testJSaddle $ strictEqual nullObject (eval "null")
583-- >>> testJSaddle $ strictEqual nullObject (eval "null")
@@ -612,5 +586,5 @@ nullObject :: Object
612#ifdef ghcjs_HOST_OS
586#ifdef ghcjs_HOST_OS
613nullObject = Object nullRef
587nullObject = Object nullRef
614#else
588#else
615−nullObject = Object . JSVal . unsafePerformIO $ newIORef 0
589+nullObject = Object (JSVal 0)
616#endif
590#endif
jsaddle/src/Language/Javascript/JSaddle/Run.hs+64−174
@@ -1,9 +1,6 @@
1−{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
3{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
5−{-# LANGUAGE MagicHash #-}
6−{-# LANGUAGE UnboxedTuples #-}
7-----------------------------------------------------------------------------
4-----------------------------------------------------------------------------
8--
5--
9-- Module : Language.Javascript.JSaddle.Run
6-- Module : Language.Javascript.JSaddle.Run
@@ -22,7 +19,6 @@ module Language.Javascript.JSaddle.Run (
22 , syncAfter
19 , syncAfter
23 , waitForAnimationFrame
20 , waitForAnimationFrame
24 , nextAnimationFrame
21 , nextAnimationFrame
25− , enableLogging
26#ifndef ghcjs_HOST_OS
22#ifndef ghcjs_HOST_OS
27 -- * Functions used to implement JSaddle using JSON messaging
23 -- * Functions used to implement JSaddle using JSON messaging
28 , runJavaScript
24 , runJavaScript
@@ -32,72 +28,61 @@ module Language.Javascript.JSaddle.Run (
32 , sendCommand
28 , sendCommand
33 , sendLazyCommand
29 , sendLazyCommand
34 , sendAsyncCommand
30 , sendAsyncCommand
35− , wrapJSVal
36#endif
31#endif
37) where
32) where
38
33
39#ifdef ghcjs_HOST_OS
34#ifdef ghcjs_HOST_OS
40−import Language.Javascript.JSaddle.Types (JSM, syncPoint, syncAfter)
35+import Language.Javascript.JSaddle.Types (JSM)
41import qualified JavaScript.Web.AnimationFrame as GHCJS
36import qualified JavaScript.Web.AnimationFrame as GHCJS
42 (waitForAnimationFrame)
37 (waitForAnimationFrame)
43#else
38#else
44−import Control.Exception (throwIO, evaluate)
39+import Control.Exception (throwIO)
45−import Control.Monad (void, when, zipWithM_)
40+import Control.Monad (void, forever, zipWithM_)
46import Control.Monad.IO.Class (MonadIO(..))
41import Control.Monad.IO.Class (MonadIO(..))
47import Control.Monad.Trans.Reader (ask, runReaderT)
42import Control.Monad.Trans.Reader (ask, runReaderT)
48import Control.Monad.STM (atomically)
43import Control.Monad.STM (atomically)
49−import Control.Concurrent (forkIO, myThreadId)
44+import Control.Concurrent (forkIO)
50import Control.Concurrent.STM.TChan
45import Control.Concurrent.STM.TChan
51 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
46 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
52import Control.Concurrent.STM.TVar
47import Control.Concurrent.STM.TVar
53− (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
48+ (writeTVar, readTVar, readTVarIO, modifyTVar, newTVarIO)
54import Control.Concurrent.MVar
49import Control.Concurrent.MVar
55− (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)
50+ (MVar, MVar, putMVar, takeMVar, newEmptyMVar)
56
51
57import System.IO.Unsafe (unsafeInterleaveIO)
52import System.IO.Unsafe (unsafeInterleaveIO)
58−import System.Mem.Weak (addFinalizer)
59−import System.Random
60
53
61−import GHC.Base (IO(..), mkWeak#)
62−import GHC.Conc (ThreadId(..))
63import Data.Monoid ((<>))
54import Data.Monoid ((<>))
64−import qualified Data.Text as T (unpack, pack)
55+import qualified Data.Text as T (unpack)
65−import qualified Data.Map as M (lookup, delete, insert, empty, size)
56+import qualified Data.Map as M (lookup, delete, insert, empty)
66−import qualified Data.Set as S (empty, member, insert, delete)
67import Data.Time.Clock (getCurrentTime,diffUTCTime)
57import Data.Time.Clock (getCurrentTime,diffUTCTime)
68−import Data.IORef
69− (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)
70
58
71import Language.Javascript.JSaddle.Types
59import Language.Javascript.JSaddle.Types
72− (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
60+ (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),
73− Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand)
61+ Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
74import Language.Javascript.JSaddle.Exception (JSException(..))
62import Language.Javascript.JSaddle.Exception (JSException(..))
63+import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
75−import Control.DeepSeq (force, deepseq)
64+import Control.DeepSeq (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_)
82#endif
65#endif
83
66
67+-- | Forces execution of pending asyncronous code
68+syncPoint :: JSM ()
84−#ifndef ghcjs_HOST_OS
69+#ifdef ghcjs_HOST_OS
85−#if MIN_VERSION_base(4,11,0)
70+syncPoint = return ()
86−currentBytesUsed = gcdetails_live_bytes . gc
87#else
71#else
88−getRTSStatsEnabled = getGCStatsEnabled
72+syncPoint = do
89−getRTSStats = getGCStats
73+ SyncResult <- sendCommand Sync
90−#endif
74+ return ()
91#endif
75#endif
92
76
93−-- | Enable (or disable) JSaddle logging
77+-- | Forces execution of pending asyncronous code after performing `f`
94−enableLogging :: Bool -> JSM ()
78+syncAfter :: JSM a -> JSM a
95#ifdef ghcjs_HOST_OS
79#ifdef ghcjs_HOST_OS
96−enableLogging _ = return ()
80+syncAfter = id
97#else
81#else
98−enableLogging v = do
82+syncAfter f = do
99− f <- doEnableLogging <$> JSM ask
83+ result <- f
100− liftIO $ f v
84+ syncPoint
85+ return result
101#endif
86#endif
102
87
103-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
88-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
@@ -125,12 +110,17 @@ nextAnimationFrame f = do
125 syncAfter (f t)
110 syncAfter (f t)
126
111
127#ifndef ghcjs_HOST_OS
112#ifndef ghcjs_HOST_OS
113+sendCommand :: Command -> JSM Result
114+sendCommand cmd = do
115+ s <- doSendCommand <$> JSM ask
116+ liftIO $ s cmd
117+
128sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
118sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
129sendLazyCommand cmd = do
119sendLazyCommand cmd = do
130 nextRefTVar <- nextRef <$> JSM ask
120 nextRefTVar <- nextRef <$> JSM ask
131 n <- liftIO . atomically $ do
121 n <- liftIO . atomically $ do
132 n <- subtract 1 <$> readTVar nextRefTVar
122 n <- subtract 1 <$> readTVar nextRefTVar
133− writeTVar nextRefTVar $! n
123+ writeTVar nextRefTVar n
134 return n
124 return n
135 s <- doSendAsyncCommand <$> JSM ask
125 s <- doSendAsyncCommand <$> JSM ask
136 liftIO $ s (cmd $ JSValueForSend n)
126 liftIO $ s (cmd $ JSValueForSend n)
@@ -141,112 +131,48 @@ sendAsyncCommand cmd = do
141 s <- doSendAsyncCommand <$> JSM ask
131 s <- doSendAsyncCommand <$> JSM ask
142 liftIO $ s cmd
132 liftIO $ s cmd
143
133
144−runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
134+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ())
145runJavaScript sendBatch entryPoint = do
135runJavaScript sendBatch entryPoint = do
146− contextId' <- randomIO
147 startTime' <- getCurrentTime
136 startTime' <- getCurrentTime
148− recvMVar <- newEmptyMVar
137+ recvChan <- newTChanIO
149− lastAsyncBatch <- newEmptyMVar
150 commandChan <- newTChanIO
138 commandChan <- newTChanIO
151 callbacks <- newTVarIO M.empty
139 callbacks <- newTVarIO M.empty
152 nextRef' <- newTVarIO 0
140 nextRef' <- newTVarIO 0
153− finalizerThreads' <- newMVar S.empty
154− animationFrameHandlers' <- newMVar []
155− loggingEnabled <- newIORef False
156− liveRefs' <- newMVar S.empty
157 let ctx = JSContextRef {
141 let ctx = JSContextRef {
158− contextId = contextId'
159− , startTime = startTime'
142+ startTime = startTime'
160− , doSendCommand = \cmd -> cmd `deepseq` do
143+ , doSendCommand = \cmd -> cmd `deepseq` do
161− result <- newEmptyMVar
144+ result <- newEmptyMVar
162− atomically $ writeTChan commandChan (Right (cmd, result))
145+ atomically $ writeTChan commandChan (Right (cmd, result))
163− unsafeInterleaveIO $
146+ unsafeInterleaveIO $
164− takeMVar result >>= \case
147+ takeMVar result >>= \case
165− (ThrowJSValue v) -> do
166− jsval <- wrapJSVal' ctx v
167− throwIO $ JSException jsval
148+ (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
168− r -> return r
149+ r -> return r
169− , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
150+ , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
170− , addCallback = \(Object (JSVal ioref)) cb -> do
171− val <- readIORef ioref
172− atomically $ modifyTVar' callbacks (M.insert val cb)
151+ , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar callbacks (M.insert val cb)
173− , nextRef = nextRef'
152+ , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar callbacks (M.delete val)
174− , doEnableLogging = atomicWriteIORef loggingEnabled
153+ , nextRef = nextRef'
175− , finalizerThreads = finalizerThreads'
176− , animationFrameHandlers = animationFrameHandlers'
177− , liveRefs = liveRefs'
178− }
154+ }
179− processResults :: Bool -> Results -> IO ()
180− processResults syncCallbacks = \case
155+ let processResults = \case
181 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
156 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
182− (Callback n br (JSValueReceived fNumber) f this a) -> do
157+ (Callback f this a) -> do
183− putMVar recvMVar (n, br)
184− f' <- runReaderT (unJSM $ wrapJSVal f) ctx
158+ f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
185 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
159 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
186 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
160 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
187− logInfo (("Call " <> show fNumber <> " ") <>)
188 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
161 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
189 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
162 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
190− Just cb -> void . forkIO $ do
191− runReaderT (unJSM $ cb f' this' args) ctx
163+ Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
192− when syncCallbacks $
164+ m -> atomically $ writeTChan recvChan m
193− doSendAsyncCommand ctx EndSyncBlock
194− Duplicate nBatch nExpected -> do
195− putStrLn $ "Error : Unexpected Duplicate. syncCallbacks=" <> show syncCallbacks <>
196− " nBatch=" <> show nBatch <> " nExpected=" <> show nExpected
197− void $ doSendCommand ctx Sync
198− BatchResults n br -> putMVar recvMVar (n, br)
199− asyncResults :: Results -> IO ()
200− asyncResults results =
201− void . forkIO $ processResults False results
202− syncResults :: Results -> IO Batch
203− syncResults results = do
204− void . forkIO $ processResults True results
205− readMVar lastAsyncBatch
206− logInfo s =
207− readIORef loggingEnabled >>= \case
208− True -> do
209− currentBytesUsedStr <- getRTSStatsEnabled >>= \case
210− True -> show . currentBytesUsed <$> getRTSStats
211− False -> return "??"
212− cbCount <- M.size <$> readTVarIO callbacks
213− putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "
214− False -> return ()
215− _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->
216− readBatch nBatch commandChan >>= \case
165+ _ <- forkIO . forever $ readBatch commandChan >>= \case
217− (batch@(Batch cmds _ _), resultMVars) -> do
166+ (batch, resultMVars) -> do
218− logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
219− _ <- tryTakeMVar lastAsyncBatch
220− putMVar lastAsyncBatch batch
221 sendBatch batch
167 sendBatch batch
222− takeResult recvMVar nBatch >>= \case
168+ atomically (readTChan recvChan) >>= \case
223− (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"
224− (_, Success callbacksToFree results)
225− | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
226− | otherwise -> do
227− zipWithM_ putMVar resultMVars results
169+ Success results -> 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)
170+ Failure results exception -> zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
236− forM_ callbacksToFree $ \(JSValueReceived val) ->
171+ _ -> error "Unexpected jsaddle results"
237− atomically (modifyTVar' callbacks (M.delete val))
238− return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)
172+ return (processResults, runReaderT (unJSM entryPoint) ctx)
239 where
173 where
240− numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m ()
241− numberForeverFromM_ !n f = do
242− _ <- f n
243− numberForeverFromM_ (succ n) f
244− takeResult recvMVar nBatch =
245− takeMVar recvMVar >>= \case
246− (n, _) | n < nBatch -> takeResult recvMVar nBatch
247− r -> return r
248− readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
174+ readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
249− readBatch nBatch chan = do
175+ readBatch chan = do
250 first <- atomically $ readTChan chan -- We want at least one command to send
176 first <- atomically $ readTChan chan -- We want at least one command to send
251 loop first ([], [])
177 loop first ([], [])
252 where
178 where
@@ -257,55 +183,19 @@ runJavaScript sendBatch entryPoint = do
257 let cmds = Right syncCmd:cmds'
183 let cmds = Right syncCmd:cmds'
258 resultMVars = resultMVar:resultMVars'
184 resultMVars = resultMVar:resultMVars'
259 atomically (tryReadTChan chan) >>= \case
185 atomically (tryReadTChan chan) >>= \case
260− Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
186+ Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
261 Just cmd -> loop cmd (cmds, resultMVars)
187 Just cmd -> loop cmd (cmds, resultMVars)
262 loop (Left asyncCmd) (cmds', resultMVars) = do
188 loop (Left asyncCmd) (cmds', resultMVars) = do
263 let cmds = Left asyncCmd:cmds'
189 let cmds = Left asyncCmd:cmds'
264 atomically (tryReadTChan chan) >>= \case
190 atomically (tryReadTChan chan) >>= \case
265− Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
191+ Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
266 Just cmd -> loop cmd (cmds, resultMVars)
192 Just cmd -> loop cmd (cmds, resultMVars)
267 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
193 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
268 loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
194 loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
269 loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =
195 loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =
270− return (Batch (reverse (Right Sync:cmds)) True nBatch, reverse (resultMVar:resultMVars))
196+ return (Batch (reverse (Right Sync:cmds)) True, reverse (resultMVar:resultMVars))
271 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
197 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
272 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
198 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
273 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
199 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
274 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
200 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
275−
276−addThreadFinalizer :: ThreadId -> IO () -> IO ()
277−addThreadFinalizer t@(ThreadId t#) (IO finalizer) =
278− IO $ \s -> case mkWeak# t# t finalizer s of { (# s1, _ #) -> (# s1, () #) }
279−
280−
281−wrapJSVal :: JSValueReceived -> JSM JSVal
282−wrapJSVal v = do
283− ctx <- JSM ask
284− liftIO $ wrapJSVal' ctx v
285−
286−wrapJSVal' :: JSContextRef -> JSValueReceived -> IO JSVal
287−wrapJSVal' ctx (JSValueReceived n) = do
288− ref <- liftIO $ newIORef n
289− when (n >= 5 || n < 0) $
290−#ifdef JSADDLE_CHECK_WRAPJSVAL
291− do lr <- takeMVar $ liveRefs ctx
292− if n `S.member` lr
293− then do
294− putStrLn $ "JS Value Ref " <> show n <> " already wrapped"
295− putMVar (liveRefs ctx) lr
296− else putMVar (liveRefs ctx) =<< evaluate (S.insert n lr)
297−#endif
298− void . mkWeakIORef ref $ do
299− ft <- takeMVar $ finalizerThreads ctx
300− t <- myThreadId
301− let tname = T.pack $ show t
302− doSendAsyncCommand ctx $ FreeRef tname $ JSValueForSend n
303− if tname `S.member` ft
304− then putMVar (finalizerThreads ctx) ft
305− else do
306− addThreadFinalizer t $ do
307− modifyMVar (finalizerThreads ctx) $ \s -> return (S.delete tname s, ())
308− doSendAsyncCommand ctx $ FreeRefs tname
309− putMVar (finalizerThreads ctx) =<< evaluate (S.insert tname ft)
310− return (JSVal ref)
311#endif
201#endif
jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+56−186
@@ -13,6 +13,7 @@
13
13
14module Language.Javascript.JSaddle.Run.Files (
14module Language.Javascript.JSaddle.Run.Files (
15 indexHtml
15 indexHtml
16+ , jsaddleJs
16 , initState
17 , initState
17 , runBatch
18 , runBatch
18 , ghcjsHelpers
19 , ghcjsHelpers
@@ -30,38 +31,25 @@ indexHtml =
30 \</head>\n\
31 \</head>\n\
31 \<body>\n\
32 \<body>\n\
32 \</body>\n\
33 \</body>\n\
33− \<script src=\"/jsaddle.js\"></script>\n\
34+ \<script src=\"jsaddle.js\"></script>\n\
34 \</html>"
35 \</html>"
35
36
36initState :: ByteString
37initState :: ByteString
37initState = "\
38initState = "\
38 \ var jsaddle_values = new Map();\n\
39 \ 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, globalThis);\n\
44+ \ jsaddle_values.set(4, window);\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\
50 \"
46 \"
51
47
52−runBatch :: (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString
48+runBatch :: (ByteString -> ByteString) -> ByteString
53−runBatch send sendSync = "\
49+runBatch send = "\
54− \ var runBatch = function(firstBatch, initialSyncDepth) {\n\
55 \ var processBatch = function(timestamp) {\n\
50 \ var processBatch = function(timestamp) {\n\
56− \ var batch = firstBatch;\n\
57− \ var callbacksToFree = [];\n\
58− \ var results = [];\n\
51+ \ var results = [];\n\
59− \ inCallback++;\n\
60− \ try {\n\
52+ \ try {\n\
61− \ syncDepth = initialSyncDepth || 0;\n\
62− \ for(;;){\n\
63− \ if(batch[2] === expectedBatch) {\n\
64− \ expectedBatch++;\n\
65 \ var nCommandsLength = batch[0].length;\n\
53 \ var nCommandsLength = batch[0].length;\n\
66 \ for (var nCommand = 0; nCommand != nCommandsLength; nCommand++) {\n\
54 \ for (var nCommand = 0; nCommand != nCommandsLength; nCommand++) {\n\
67 \ var cmd = batch[0][nCommand];\n\
55 \ var cmd = batch[0][nCommand];\n\
@@ -69,15 +57,7 @@ runBatch send sendSync = "\
69 \ var d = cmd.Left;\n\
57 \ var d = cmd.Left;\n\
70 \ switch (d.tag) {\n\
58 \ switch (d.tag) {\n\
71 \ case \"FreeRef\":\n\
59 \ case \"FreeRef\":\n\
72− \ var refsToFree = jsaddle_free.get(d.contents[0]) || [];\n\
73− \ refsToFree.push(d.contents[1]);\n\
74− \ jsaddle_free.set(d.contents[0], refsToFree);\n\
75− \ break;\n\
76− \ case \"FreeRefs\":\n\
77− \ var refsToFree = jsaddle_free.get(d.contents) || [];\n\
78− \ for(var nRef = 0; nRef != refsToFree.length; nRef++)\n\
79− \ jsaddle_values.delete(refsToFree[nRef]);\n\
80− \ jsaddle_free.delete(d.contents);\n\
60+ \ jsaddle_values.delete(d.contents);\n\
81 \ break;\n\
61 \ break;\n\
82 \ case \"SetPropertyByName\":\n\
62 \ case \"SetPropertyByName\":\n\
83 \ jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]);\n\
63 \ jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]);\n\
@@ -93,10 +73,6 @@ runBatch send sendSync = "\
93 \ var n = d.contents[1];\n\
73 \ var n = d.contents[1];\n\
94 \ jsaddle_values.set(n, d.contents[0]);\n\
74 \ jsaddle_values.set(n, d.contents[0]);\n\
95 \ break;\n\
75 \ 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\
100 \ case \"GetPropertyByName\":\n\
76 \ case \"GetPropertyByName\":\n\
101 \ var n = d.contents[2];\n\
77 \ var n = d.contents[2];\n\
102 \ jsaddle_values.set(n, jsaddle_values.get(d.contents[0])[d.contents[1]]);\n\
78 \ jsaddle_values.set(n, jsaddle_values.get(d.contents[0])[d.contents[1]]);\n\
@@ -113,12 +89,10 @@ runBatch send sendSync = "\
113 \ var n = d.contents;\n\
89 \ var n = d.contents;\n\
114 \ jsaddle_values.set(n, {});\n\
90 \ jsaddle_values.set(n, {});\n\
115 \ break;\n\
91 \ break;\n\
116− \ case \"NewAsyncCallback\":\n\
92+ \ case \"NewCallback\":\n\
117 \ (function() {\n\
93 \ (function() {\n\
118 \ var nFunction = d.contents;\n\
94 \ var nFunction = d.contents;\n\
119− \ var func = function() {\n\
120− \ var nFunctionInFunc = ++jsaddle_index;\n\
121− \ jsaddle_values.set(nFunctionInFunc, func);\n\
95+ \ jsaddle_values.set(nFunction, function() {\n\
122 \ var nThis = ++jsaddle_index;\n\
96 \ var nThis = ++jsaddle_index;\n\
123 \ jsaddle_values.set(nThis, this);\n\
97 \ jsaddle_values.set(nThis, this);\n\
124 \ var args = [];\n\
98 \ var args = [];\n\
@@ -127,41 +101,8 @@ runBatch send sendSync = "\
127 \ jsaddle_values.set(nArg, arguments[i]);\n\
101 \ jsaddle_values.set(nArg, arguments[i]);\n\
128 \ args[i] = nArg;\n\
102 \ args[i] = nArg;\n\
129 \ }\n\
103 \ }\n\
130− \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n\
104+ \ " <> send "{\"tag\": \"Callback\", \"contents\": [nFunction, nThis, args]}" <> "\n\
131− \ };\n\
105+ \ })})();\n\
132− \ jsaddle_values.set(nFunction, func);\n\
133− \ })();\n\
134− \ break;\n\
135− \ case \"NewSyncCallback\":\n\
136− \ (function() {\n\
137− \ var nFunction = d.contents;\n\
138− \ var func = function() {\n\
139− \ var nFunctionInFunc = ++jsaddle_index;\n\
140− \ jsaddle_values.set(nFunctionInFunc, func);\n\
141− \ var nThis = ++jsaddle_index;\n\
142− \ jsaddle_values.set(nThis, this);\n\
143− \ var args = [];\n\
144− \ for (var i = 0; i != arguments.length; i++) {\n\
145− \ var nArg = ++jsaddle_index;\n\
146− \ jsaddle_values.set(nArg, arguments[i]);\n\
147− \ args[i] = nArg;\n\
148− \ }\n" <> (
149− case sendSync of
150− Just s ->
151− " if(inCallback > 0) {\n\
152− \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n\
153− \ } else {\n\
154− \ runBatch(" <> s "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> ", 1);\n\
155− \ }\n"
156− Nothing ->
157− " " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n"
158− ) <>
159− " };\n\
160− \ jsaddle_values.set(nFunction, func);\n\
161− \ })();\n\
162− \ break;\n\
163− \ case \"FreeCallback\":\n\
164− \ callbacksToFree.push(d.contents);\n\
165 \ break;\n\
106 \ break;\n\
166 \ case \"CallAsFunction\":\n\
107 \ case \"CallAsFunction\":\n\
167 \ var n = d.contents[3];\n\
108 \ var n = d.contents[3];\n\
@@ -204,15 +145,9 @@ runBatch send sendSync = "\
204 \ jsaddle_values.set(n, d.contents[0].map(function(v){return jsaddle_values.get(v);}));\n\
145 \ jsaddle_values.set(n, d.contents[0].map(function(v){return jsaddle_values.get(v);}));\n\
205 \ break;\n\
146 \ break;\n\
206 \ case \"SyncWithAnimationFrame\":\n\
147 \ case \"SyncWithAnimationFrame\":\n\
207− \ var n = d.contents;\n\
148+ \ var n = d.contents[0];\n\
208 \ jsaddle_values.set(n, timestamp);\n\
149 \ jsaddle_values.set(n, timestamp);\n\
209 \ break;\n\
150 \ break;\n\
210− \ case \"StartSyncBlock\":\n\
211− \ syncDepth++;\n\
212− \ break;\n\
213− \ case \"EndSyncBlock\":\n\
214− \ syncDepth--;\n\
215− \ break;\n\
216 \ default:\n\
151 \ default:\n\
217 \ " <> send "{\"tag\": \"ProtocolError\", \"contents\": e.data}" <> "\n\
152 \ " <> send "{\"tag\": \"ProtocolError\", \"contents\": e.data}" <> "\n\
218 \ return;\n\
153 \ return;\n\
@@ -247,7 +182,7 @@ runBatch send sendSync = "\
247 \ (v === true ) ? [3, \"\"] :\n\
182 \ (v === true ) ? [3, \"\"] :\n\
248 \ (typeof v === \"number\") ? [-1, v.toString()] :\n\
183 \ (typeof v === \"number\") ? [-1, v.toString()] :\n\
249 \ (typeof v === \"string\") ? [-2, v]\n\
184 \ (typeof v === \"string\") ? [-2, v]\n\
250− \ : [-3, \"\"];\n\
185+ \ : [n, \"\"];\n\
251 \ results.push({\"tag\": \"DeRefValResult\", \"contents\": c});\n\
186 \ results.push({\"tag\": \"DeRefValResult\", \"contents\": c});\n\
252 \ break;\n\
187 \ break;\n\
253 \ case \"IsNull\":\n\
188 \ case \"IsNull\":\n\
@@ -275,66 +210,55 @@ runBatch send sendSync = "\
275 \ }\n\
210 \ }\n\
276 \ }\n\
211 \ }\n\
277 \ }\n\
212 \ }\n\
278− \ if(syncDepth <= 0) {\n\
213+ \ " <> send "{\"tag\": \"Success\", \"contents\": results}" <> "\n\
279− \ lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": [callbacksToFree, results]}];\n\
214+ \ }\n\
280− \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> "\n\
215+ \ catch (err) {\n\
281− \ break;\n\
216+ \ var n = ++jsaddle_index;\n\
282− \ } else {\n" <> (
217+ \ jsaddle_values.set(n, err);\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\
218+ \ " <> send "{\"tag\": \"Failure\", \"contents\": [results,n]}" <> "\n\
309− \ break;\n"
310− ) <>
311− " }\n\
312− \ }\n\
313 \ }\n\
219 \ }\n\
314− \ }\n\
315− \ catch (err) {\n\
316− \ var n = ++jsaddle_index;\n\
317− \ jsaddle_values.set(n, err);\n\
318− \ console.log(err);\n\
319− \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Failure\", \"contents\": [callbacksToFree, results, n, String(err)]}]}" <> "\n\
320− \ }\n\
321− \ if(inCallback == 1) {\n\
322− \ while(asyncBatch !== null) {\n\
323− \ var b = asyncBatch;\n\
324− \ asyncBatch = null;\n\
325− \ if(b[2] == expectedBatch) runBatch(b);\n\
326− \ }\n\
327− \ }\n\
328− \ inCallback--;\n\
329 \ };\n\
220 \ };\n\
330− \ if(batch[1] && (initialSyncDepth || 0) === 0) {\n\
221+ \ if(batch[1]) {\n\
331 \ window.requestAnimationFrame(processBatch);\n\
222 \ window.requestAnimationFrame(processBatch);\n\
332 \ }\n\
223 \ }\n\
333 \ else {\n\
224 \ else {\n\
334 \ processBatch(window.performance ? window.performance.now() : null);\n\
225 \ processBatch(window.performance ? window.performance.now() : null);\n\
335 \ }\n\
226 \ }\n\
336− \ };\n\
227+ \"
337− \ runBatch(batch);\n\
228+
229+-- Use this to generate this string for embedding
230+-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy
231+jsaddleJs :: ByteString
232+jsaddleJs = "\
233+ \if(typeof global !== \"undefined\") {\n\
234+ \ global.window = global;\n\
235+ \ global.WebSocket = require('ws');\n\
236+ \}\n\
237+ \\n\
238+ \var connect = function() {\n\
239+ \ var wsaddress =\n\
240+ \ typeof window.location === \"undefined\"\n\
241+ \ ? \"ws://localhost:3709/\"\n\
242+ \ : window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\");\n\
243+ \\n\
244+ \ var ws = new WebSocket(wsaddress);\n\
245+ \\n\
246+ \ ws.onopen = function(e) {\n\
247+ \ " <> initState <> "\
248+ \\n\
249+ \ ws.onmessage = function(e) {\n\
250+ \ var batch = JSON.parse(e.data);\n\
251+ \\n\
252+ \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));") <> "\
253+ \ };\n\
254+ \ };\n\
255+ \ ws.onerror = function() {\n\
256+ \ setTimeout(connect, 1000);\n\
257+ \ };\n\
258+ \}\n\
259+ \\n\
260+ \ " <> ghcjsHelpers <> "\
261+ \connect();\n\
338 \"
262 \"
339
263
340ghcjsHelpers :: ByteString
264ghcjsHelpers :: ByteString
@@ -405,58 +329,4 @@ ghcjsHelpers = "\
405 \ }\n\
329 \ }\n\
406 \\n\
330 \\n\
407 \}\n\
331 \}\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\
462 \"
332 \"
jsaddle/src/Language/Javascript/JSaddle/Types.hs+45−239
@@ -1,20 +1,18 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2#ifdef ghcjs_HOST_OS
2#ifdef ghcjs_HOST_OS
3+{-# LANGUAGE ConstraintKinds #-}
3{-# OPTIONS_GHC -Wno-dodgy-exports #-}
4{-# OPTIONS_GHC -Wno-dodgy-exports #-}
4#else
5#else
5{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE UndecidableInstances #-}
7{-# LANGUAGE UndecidableInstances #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE DeriveGeneric #-}
9{-# LANGUAGE DeriveGeneric #-}
10+{-# LANGUAGE DefaultSignatures #-}
9{-# LANGUAGE DataKinds #-}
11{-# LANGUAGE DataKinds #-}
12+{-# LANGUAGE KindSignatures #-}
10{-# LANGUAGE PolyKinds #-}
13{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE FlexibleContexts #-}
14{-# LANGUAGE FlexibleContexts #-}
12−{-# LANGUAGE DefaultSignatures #-}
13−{-# LANGUAGE ImplicitParams #-}
14#endif
15#endif
15−{-# LANGUAGE ConstraintKinds #-}
16−{-# LANGUAGE KindSignatures #-}
17−{-# LANGUAGE AllowAmbiguousTypes #-}
18-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
19--
17--
20-- Module : Language.Javascript.JSaddle.Types
18-- Module : Language.Javascript.JSaddle.Types
@@ -36,41 +34,20 @@ module Language.Javascript.JSaddle.Types (
36 , MonadJSM(..)
34 , MonadJSM(..)
37 , liftJSM
35 , liftJSM
38
36
39− -- * Pure GHCJS functions
40− , GHCJSPure(..)
41− , ghcjsPure
42− , ghcjsPureMap
43− , ghcjsPureId
44−
45 -- * JavaScript Value Types
37 -- * JavaScript Value Types
46 , JSVal(..)
38 , JSVal(..)
47− , IsJSVal(..)
39+ , IsJSVal
48 , jsval
40 , jsval
49 , SomeJSArray(..)
41 , SomeJSArray(..)
50 , JSArray
42 , JSArray
51 , MutableJSArray
43 , MutableJSArray
52− , STJSArray
53 , Object(..)
44 , Object(..)
54 , JSString(..)
45 , JSString(..)
55 , Nullable(..)
46 , Nullable(..)
56 , JSCallAsFunction
47 , JSCallAsFunction
57
48
58− -- * Debugging
59− , JSadddleHasCallStack
60−
61− -- * Sync JSM
62− , syncPoint
63− , syncAfter
64−
65−#ifndef ghcjs_HOST_OS
66− , sendCommand
67−
68 -- * JavaScript Context Commands
49 -- * JavaScript Context Commands
69− , MutabilityType(..)
50+#ifndef ghcjs_HOST_OS
70− , Mutable
71− , Immutable
72− , IsItMutable(..)
73− , Mutability
74 , JSValueReceived(..)
51 , JSValueReceived(..)
75 , JSValueForSend(..)
52 , JSValueForSend(..)
76 , JSStringReceived(..)
53 , JSStringReceived(..)
@@ -80,7 +57,6 @@ module Language.Javascript.JSaddle.Types (
80 , Command(..)
57 , Command(..)
81 , Batch(..)
58 , Batch(..)
82 , Result(..)
59 , Result(..)
83− , BatchResults(..)
84 , Results(..)
60 , Results(..)
85#endif
61#endif
86) where
62) where
@@ -89,48 +65,26 @@ import Control.Monad.IO.Class (MonadIO(..))
89#ifdef ghcjs_HOST_OS
65#ifdef ghcjs_HOST_OS
90import GHCJS.Types
66import GHCJS.Types
91import JavaScript.Object.Internal (Object(..))
67import JavaScript.Object.Internal (Object(..))
92−import JavaScript.Array.Internal (SomeJSArray(..), JSArray, MutableJSArray, STJSArray)
68+import JavaScript.Array.Internal (SomeJSArray(..), JSArray, MutableJSArray)
93import GHCJS.Nullable (Nullable(..))
69import GHCJS.Nullable (Nullable(..))
94#else
70#else
95−import GHCJS.Prim.Internal (JSVal(..), JSValueRef)
96−import Data.JSString.Internal.Type (JSString(..))
97import Control.DeepSeq (NFData(..))
71import Control.DeepSeq (NFData(..))
98−import Control.Monad.Catch (MonadThrow, MonadCatch(..), MonadMask(..))
99−import Control.Monad.Trans.Cont (ContT(..))
100−import Control.Monad.Trans.Error (Error(..), ErrorT(..))
101−import Control.Monad.Trans.Except (ExceptT(..))
102−import Control.Monad.Trans.Identity (IdentityT(..))
103−import Control.Monad.Trans.List (ListT(..))
104−import Control.Monad.Trans.Maybe (MaybeT(..))
105−import Control.Monad.Trans.Reader (ReaderT(..), ask)
72+import Control.Monad.Trans.Reader (ReaderT(..))
106−import Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))
107−import Control.Monad.Trans.RWS.Strict as Strict (RWST(..))
73+import Control.Monad.Trans.State.Lazy (StateT(..))
108−import Control.Monad.Trans.State.Lazy as Lazy (StateT(..))
109−import Control.Monad.Trans.State.Strict as Strict (StateT(..))
74+import qualified Control.Monad.Trans.State.Strict as Strict
110−import Control.Monad.Trans.Writer.Lazy as Lazy (WriterT(..))
75+ (StateT(..))
111−import Control.Monad.Trans.Writer.Strict as Strict (WriterT(..))
112import Control.Monad.Trans.Class (MonadTrans(..))
76import Control.Monad.Trans.Class (MonadTrans(..))
113import Control.Monad.Fix (MonadFix)
77import Control.Monad.Fix (MonadFix)
114import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))
78import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))
115import Control.Concurrent.STM.TVar (TVar)
79import Control.Concurrent.STM.TVar (TVar)
116−import Control.Concurrent.MVar (MVar)
80+import Data.Coerce (Coercible, coerce)
117import Data.Int (Int64)
81import Data.Int (Int64)
118−import Data.Set (Set)
119import Data.Text (Text)
82import Data.Text (Text)
120import Data.Time.Clock (UTCTime(..))
83import Data.Time.Clock (UTCTime(..))
121import Data.Typeable (Typeable)
84import Data.Typeable (Typeable)
122−import Data.Coerce (coerce, Coercible)
123import Data.Aeson
85import Data.Aeson
124 (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..), Value)
86 (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..), Value)
125import GHC.Generics (Generic)
87import 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)
134#endif
88#endif
135
89
136-- | Identifies a JavaScript execution context.
90-- | Identifies a JavaScript execution context.
@@ -141,16 +95,12 @@ import GHC.Exts (Constraint)
141type JSContextRef = ()
95type JSContextRef = ()
142#else
96#else
143data JSContextRef = JSContextRef {
97data JSContextRef = JSContextRef {
144− contextId :: Int64
145− , startTime :: UTCTime
98+ startTime :: UTCTime
146− , doSendCommand :: Command -> IO Result
99+ , doSendCommand :: Command -> IO Result
147− , doSendAsyncCommand :: AsyncCommand -> IO ()
100+ , doSendAsyncCommand :: AsyncCommand -> IO ()
148− , addCallback :: Object -> JSCallAsFunction -> IO ()
101+ , addCallback :: Object -> JSCallAsFunction -> IO ()
102+ , freeCallback :: Object -> IO ()
149− , nextRef :: TVar JSValueRef
103+ , nextRef :: TVar JSValueRef
150− , doEnableLogging :: Bool -> IO ()
151− , finalizerThreads :: MVar (Set Text)
152− , animationFrameHandlers :: MVar [Double -> JSM ()]
153− , liveRefs :: MVar (Set Int64)
154}
104}
155#endif
105#endif
156
106
@@ -166,96 +116,8 @@ data JSContextRef = JSContextRef {
166type JSM = IO
116type JSM = IO
167#else
117#else
168newtype JSM a = JSM { unJSM :: ReaderT JSContextRef IO a }
118newtype JSM a = JSM { unJSM :: ReaderT JSContextRef IO a }
169− deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadThrow, MonadUnliftIO, Fail.MonadFail)
119+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
170−
171−instance MonadCatch JSM where
172− t `catch` c = JSM (unJSM (syncAfter t) `catch` \e -> unJSM (c e))
173−
174−instance MonadMask JSM where
175− mask a = JSM $ mask $ \unmask -> unJSM (a $ q unmask)
176− where q :: (ReaderT JSContextRef IO a -> ReaderT JSContextRef IO a) -> JSM a -> JSM a
177− q unmask (JSM b) = syncAfter . JSM $ unmask b
178− uninterruptibleMask a =
179− JSM $ uninterruptibleMask $ \unmask -> unJSM (a $ q unmask)
180− where q :: (ReaderT JSContextRef IO a -> ReaderT JSContextRef IO a) -> JSM a -> JSM a
181− q unmask (JSM b) = syncAfter . JSM $ unmask b
182−#if MIN_VERSION_exceptions(0,9,0)
183− generalBracket acquire release use =
184− JSM $ generalBracket
185− (unJSM acquire)
186− (\resource exitCase -> unJSM $ release resource exitCase)
187− (unJSM . syncAfter . use)
188−#endif
189−
190−#endif
191−
192−-- | Forces execution of pending asyncronous code
193−syncPoint :: JSM ()
194−#ifdef ghcjs_HOST_OS
195−syncPoint = return ()
196−#else
197−syncPoint = do
198− SyncResult <- sendCommand Sync
199− return ()
200−#endif
201−
202−-- | Forces execution of pending asyncronous code after performing `f`
203−syncAfter :: JSM a -> JSM a
204−#ifdef ghcjs_HOST_OS
205−syncAfter = id
206−#else
207−syncAfter f = do
208− result <- f
209− syncPoint
210− return result
211−#endif
212−
213−#ifndef ghcjs_HOST_OS
214−sendCommand :: Command -> JSM Result
215−sendCommand cmd = do
216− s <- doSendCommand <$> JSM ask
217− liftIO $ s cmd
218−#endif
219−
220−-- | Type we can give to functions that are pure when using ghcjs, but
221−-- live in JSM when using jsaddle.
222−--
223−-- Some functions that can be pure in GHCJS cannot be implemented in
224−-- a pure way in JSaddle (because we need to know the JSContextRef).
225−-- Instead we implement versions of these functions in that return
226−-- `GHCJSPure a` instead of `a`. To call them in a way that will
227−-- work when compiling with GHCJS use `ghcjsPure`.
228−#ifdef ghcjs_HOST_OS
229−type GHCJSPure a = a
230−#else
231−newtype GHCJSPure a = GHCJSPure (JSM a)
232−#endif
233−
234−-- | Used when you want to call a functions that is pure in GHCJS, but
235−-- lives in the JSM in jsaddle.
236−ghcjsPure :: GHCJSPure a -> JSM a
237−#ifdef ghcjs_HOST_OS
238−ghcjsPure = pure
239−#else
240−ghcjsPure (GHCJSPure x) = x
241−#endif
242−{-# INLINE ghcjsPure #-}
243−
244−ghcjsPureMap :: (a -> b) -> GHCJSPure a -> GHCJSPure b
245−#ifdef ghcjs_HOST_OS
246−ghcjsPureMap = id
247−#else
248−ghcjsPureMap f (GHCJSPure x) = GHCJSPure (f <$> x)
249−#endif
250−{-# INLINE ghcjsPureMap #-}
251−
252−ghcjsPureId :: a -> GHCJSPure a
253−#ifdef ghcjs_HOST_OS
254−ghcjsPureId = id
255−#else
256−ghcjsPureId = GHCJSPure . return
257#endif
120#endif
258−{-# INLINE ghcjsPureId #-}
259
121
260-- | The 'MonadJSM' is to 'JSM' what 'MonadIO' is to 'IO'.
122-- | The 'MonadJSM' is to 'JSM' what 'MonadIO' is to 'IO'.
261-- When using GHCJS it is 'MonadIO'.
123-- When using GHCJS it is 'MonadIO'.
@@ -264,64 +126,21 @@ type MonadJSM = MonadIO
264#else
126#else
265class (Applicative m, MonadIO m) => MonadJSM m where
127class (Applicative m, MonadIO m) => MonadJSM m where
266 liftJSM' :: JSM a -> m a
128 liftJSM' :: JSM a -> m a
267−
268− default liftJSM' :: (MonadJSM m', MonadTrans t, m ~ t m') => JSM a -> m a
269− liftJSM' = lift . (liftJSM' :: MonadJSM m' => JSM a -> m' a)
270− {-# INLINE liftJSM' #-}
129+ {-# MINIMAL liftJSM' #-}
271
130
272instance MonadJSM JSM where
131instance MonadJSM JSM where
273 liftJSM' = id
132 liftJSM' = id
274 {-# INLINE liftJSM' #-}
133 {-# INLINE liftJSM' #-}
275
134
276−instance (MonadJSM m) => MonadJSM (ContT r m) where
135+instance MonadJSM m => MonadJSM (ReaderT e m) where
277− liftJSM' = lift . liftJSM'
278− {-# INLINE liftJSM' #-}
279−
280−instance (Error e, MonadJSM m) => MonadJSM (ErrorT e m) where
281− liftJSM' = lift . liftJSM'
282− {-# INLINE liftJSM' #-}
283−
284−instance (MonadJSM m) => MonadJSM (ExceptT e m) where
285− liftJSM' = lift . liftJSM'
286− {-# INLINE liftJSM' #-}
287−
288−instance (MonadJSM m) => MonadJSM (IdentityT m) where
289− liftJSM' = lift . liftJSM'
290− {-# INLINE liftJSM' #-}
291−
292−instance (MonadJSM m) => MonadJSM (ListT m) where
293− liftJSM' = lift . liftJSM'
294− {-# INLINE liftJSM' #-}
295−
296−instance (MonadJSM m) => MonadJSM (MaybeT m) where
297− liftJSM' = lift . liftJSM'
298− {-# INLINE liftJSM' #-}
299−
300−instance (MonadJSM m) => MonadJSM (ReaderT r m) where
301− liftJSM' = lift . liftJSM'
302− {-# INLINE liftJSM' #-}
303−
304−instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.RWST r w s m) where
305− liftJSM' = lift . liftJSM'
306− {-# INLINE liftJSM' #-}
307−
308−instance (Monoid w, MonadJSM m) => MonadJSM (Strict.RWST r w s m) where
309− liftJSM' = lift . liftJSM'
310− {-# INLINE liftJSM' #-}
311−
312−instance (MonadJSM m) => MonadJSM (Lazy.StateT s m) where
313− liftJSM' = lift . liftJSM'
314− {-# INLINE liftJSM' #-}
315−
316−instance (MonadJSM m) => MonadJSM (Strict.StateT s m) where
317 liftJSM' = lift . liftJSM'
136 liftJSM' = lift . liftJSM'
318 {-# INLINE liftJSM' #-}
137 {-# INLINE liftJSM' #-}
319
138
320−instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.WriterT w m) where
139+instance MonadJSM m => MonadJSM (StateT r m) where
321 liftJSM' = lift . liftJSM'
140 liftJSM' = lift . liftJSM'
322 {-# INLINE liftJSM' #-}
141 {-# INLINE liftJSM' #-}
323
142
324−instance (Monoid w, MonadJSM m) => MonadJSM (Strict.WriterT w m) where
143+instance MonadJSM m => MonadJSM (Strict.StateT r m) where
325 liftJSM' = lift . liftJSM'
144 liftJSM' = lift . liftJSM'
326 {-# INLINE liftJSM' #-}
145 {-# INLINE liftJSM' #-}
327
146
@@ -356,15 +175,23 @@ type JSCallAsFunction = JSVal -- ^ Function object
356 -- as an argument and invoke it from haskell.
175 -- as an argument and invoke it from haskell.
357
176
358#ifndef ghcjs_HOST_OS
177#ifndef ghcjs_HOST_OS
178+-- A reference to a particular JavaScript value inside the JavaScript context
179+type JSValueRef = Int64
180+
181+-- | See 'GHCJS.Prim.JSVal'
182+newtype JSVal = JSVal JSValueRef deriving(Show, ToJSON, FromJSON)
183+
184+instance NFData JSVal where
185+ rnf x = x `seq` ()
359
186
360class IsJSVal a where
187class IsJSVal a where
361− jsval_ :: a -> GHCJSPure JSVal
188+ jsval_ :: a -> JSVal
362
189
363− default jsval_ :: Coercible a JSVal => a -> GHCJSPure JSVal
190+ default jsval_ :: Coercible a JSVal => a -> JSVal
364− jsval_ = GHCJSPure . return . coerce
191+ jsval_ = coerce
365 {-# INLINE jsval_ #-}
192 {-# INLINE jsval_ #-}
366
193
367−jsval :: IsJSVal a => a -> GHCJSPure JSVal
194+jsval :: IsJSVal a => a -> JSVal
368jsval = jsval_
195jsval = jsval_
369{-# INLINE jsval #-}
196{-# INLINE jsval #-}
370
197
@@ -385,22 +212,21 @@ type family Mutability (a :: MutabilityType s) :: IsItMutable where
385
212
386newtype SomeJSArray (m :: MutabilityType s) = SomeJSArray JSVal
213newtype SomeJSArray (m :: MutabilityType s) = SomeJSArray JSVal
387 deriving (Typeable)
214 deriving (Typeable)
388−instance IsJSVal (SomeJSArray m)
389
215
390-- | See 'JavaScript.Array.Internal.JSArray'
216-- | See 'JavaScript.Array.Internal.JSArray'
391type JSArray = SomeJSArray Immutable
217type JSArray = SomeJSArray Immutable
392-- | See 'JavaScript.Array.Internal.MutableJSArray'
218-- | See 'JavaScript.Array.Internal.MutableJSArray'
393type MutableJSArray = SomeJSArray Mutable
219type MutableJSArray = SomeJSArray Mutable
394
220
395−-- | See 'JavaScript.Array.Internal.STJSArray'
396−type STJSArray s = SomeJSArray (STMutable s)
397−
398-- | See 'JavaScript.Object.Internal.Object'
221-- | See 'JavaScript.Object.Internal.Object'
399−newtype Object = Object JSVal
222+newtype Object = Object JSVal deriving(Show, ToJSON, FromJSON)
400
223
401-- | See 'GHCJS.Nullable.Nullable'
224-- | See 'GHCJS.Nullable.Nullable'
402newtype Nullable a = Nullable a
225newtype Nullable a = Nullable a
403
226
227+-- | See 'Data.JSString.Internal.Type'
228+newtype JSString = JSString Text deriving(Show, ToJSON, FromJSON)
229+
404-- | Wrapper used when receiving a 'JSVal' from the JavaScript context
230-- | Wrapper used when receiving a 'JSVal' from the JavaScript context
405newtype JSValueReceived = JSValueReceived JSValueRef deriving(Show, ToJSON, FromJSON)
231newtype JSValueReceived = JSValueReceived JSValueRef deriving(Show, ToJSON, FromJSON)
406
232
@@ -420,8 +246,7 @@ newtype JSStringForSend = JSStringForSend Text deriving(Show, ToJSON, FromJSON,
420instance NFData JSStringForSend
246instance NFData JSStringForSend
421
247
422-- | Command sent to a JavaScript context for execution asynchronously
248-- | Command sent to a JavaScript context for execution asynchronously
423−data AsyncCommand = FreeRef Text JSValueForSend
249+data AsyncCommand = FreeRef JSValueForSend
424− | FreeRefs Text
425 | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend
250 | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend
426 | SetPropertyAtIndex JSObjectForSend Int JSValueForSend
251 | SetPropertyAtIndex JSObjectForSend Int JSValueForSend
427 | StringToValue JSStringForSend JSValueForSend
252 | StringToValue JSStringForSend JSValueForSend
@@ -432,15 +257,11 @@ data AsyncCommand = FreeRef Text JSValueForSend
432 | CallAsFunction JSObjectForSend JSObjectForSend [JSValueForSend] JSValueForSend
257 | CallAsFunction JSObjectForSend JSObjectForSend [JSValueForSend] JSValueForSend
433 | CallAsConstructor JSObjectForSend [JSValueForSend] JSValueForSend
258 | CallAsConstructor JSObjectForSend [JSValueForSend] JSValueForSend
434 | NewEmptyObject JSValueForSend
259 | NewEmptyObject JSValueForSend
435− | NewAsyncCallback JSValueForSend
436− | NewSyncCallback JSValueForSend
437− | FreeCallback JSValueForSend
260+ | NewCallback JSValueForSend
438 | NewArray [JSValueForSend] JSValueForSend
261 | NewArray [JSValueForSend] JSValueForSend
439 | EvaluateScript JSStringForSend JSValueForSend
262 | EvaluateScript JSStringForSend JSValueForSend
440 | SyncWithAnimationFrame JSValueForSend
263 | SyncWithAnimationFrame JSValueForSend
441− | StartSyncBlock
442− | EndSyncBlock
443− deriving (Show, Generic)
264+ deriving (Show, Generic)
444
265
445instance ToJSON AsyncCommand where
266instance ToJSON AsyncCommand where
446 toEncoding = genericToEncoding defaultOptions
267 toEncoding = genericToEncoding defaultOptions
@@ -472,7 +293,7 @@ instance FromJSON Command
472instance NFData Command
293instance NFData Command
473
294
474-- | Batch of commands that can be sent together to the JavaScript context
295-- | Batch of commands that can be sent together to the JavaScript context
475−data Batch = Batch [Either AsyncCommand Command] Bool Int
296+data Batch = Batch [Either AsyncCommand Command] Bool
476 deriving (Show, Generic)
297 deriving (Show, Generic)
477
298
478instance ToJSON Batch where
299instance ToJSON Batch where
@@ -503,18 +324,9 @@ instance ToJSON Result where
503
324
504instance FromJSON Result
325instance FromJSON Result
505
326
506−data BatchResults = Success [JSValueReceived] [Result]
327+data Results = Success [Result]
507− | Failure [JSValueReceived] [Result] JSValueReceived String
328+ | Failure [Result] JSValueReceived
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]
329+ | Callback JSValueReceived JSValueReceived [JSValueReceived]
518 | ProtocolError Text
330 | ProtocolError Text
519 deriving (Show, Generic)
331 deriving (Show, Generic)
520
332
@@ -524,11 +336,5 @@ instance ToJSON Results where
524instance FromJSON Results
336instance FromJSON Results
525#endif
337#endif
526
338
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
533
339
534
340
jsaddle/src/Language/Javascript/JSaddle/Value.hs+88−57
@@ -45,7 +45,7 @@ module Language.Javascript.JSaddle.Value (
45 , showJSValue
45 , showJSValue
46
46
47 -- * Converting JavaScript values
47 -- * Converting JavaScript values
48− , isTruthy
48+ , isTruthyIO
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− , isNull
60+ , isNullIO
61 , valIsNull
61 , valIsNull
62 , jsUndefined
62 , jsUndefined
63 , valUndefined
63 , valUndefined
64− , isUndefined
64+ , isUndefinedIO
65 , valIsUndefined
65 , valIsUndefined
66 , maybeNullOrUndefined
66 , maybeNullOrUndefined
67 , maybeNullOrUndefined'
67 , maybeNullOrUndefined'
@@ -84,31 +84,32 @@ 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)
88
87
89#ifdef ghcjs_HOST_OS
88#ifdef ghcjs_HOST_OS
90import Language.Javascript.JSaddle.Types
89import Language.Javascript.JSaddle.Types
91− (Object(..), JSString(..), JSVal(..), ghcjsPure)
90+ (Object(..), JSString(..), JSVal(..))
92import GHCJS.Marshal (ToJSVal(..))
91import GHCJS.Marshal (ToJSVal(..))
92+import GHCJS.Marshal.Pure (pToJSVal)
93+import Data.JSString.Text (textToJSString)
93#else
94#else
94import Data.Char (chr, ord)
95import Data.Char (chr, ord)
95import Data.Word (Word, Word8, Word16, Word32)
96import Data.Word (Word, Word8, Word16, Word32)
96import Data.Int (Int8, Int16, Int32)
97import Data.Int (Int8, Int16, Int32)
97import GHCJS.Marshal.Internal (ToJSVal(..), FromJSVal(..))
98import GHCJS.Marshal.Internal (ToJSVal(..), FromJSVal(..))
98import Language.Javascript.JSaddle.Types
99import Language.Javascript.JSaddle.Types
99− (Object(..), JSString(..), JSVal(..), ghcjsPure)
100+ (Object(..), JSString(..), JSVal(..))
100import Language.Javascript.JSaddle.Native
101import Language.Javascript.JSaddle.Native
101− (valueToNumber, valueToString, valueToJSON, numberToValue, stringToValue, jsonValueToValue)
102+ (wrapJSString, withJSVal, withObject, withJSString, withToJSVal)
102−import qualified Language.Javascript.JSaddle.Native as N
103− (deRefVal, strictEqual, instanceOf)
104−import Language.Javascript.JSaddle.Run (Result(..))
103+import Language.Javascript.JSaddle.Run
104+ (Command(..), AsyncCommand(..), Result(..), sendCommand,
105+ sendLazyCommand)
105#endif
106#endif
106import Language.Javascript.JSaddle.Monad (JSM)
107import Language.Javascript.JSaddle.Monad (JSM)
107import Language.Javascript.JSaddle.Classes
108import Language.Javascript.JSaddle.Classes
108 (MakeObject(..), MakeArgs(..))
109 (MakeObject(..), MakeArgs(..))
109import Language.Javascript.JSaddle.Marshal.String (ToJSString(..), FromJSString(..))
110import Language.Javascript.JSaddle.Marshal.String (ToJSString(..), FromJSString(..))
110import Language.Javascript.JSaddle.String (strToText, textToStr)
111import Language.Javascript.JSaddle.String (strToText, textToStr)
111−import GHCJS.Foreign.Internal (jsTrue, jsFalse, jsNull, toJSBool, jsUndefined, isTruthy, isNull, isUndefined)
112+import Language.Javascript.JSaddle.Foreign (jsTrue, jsFalse, jsNull, toJSBool, jsUndefined, isTruthyIO, isNullIO, isUndefinedIO)
112
113
113-- $setup
114-- $setup
114-- >>> import Language.Javascript.JSaddle.Test (testJSaddle)
115-- >>> import Language.Javascript.JSaddle.Test (testJSaddle)
@@ -165,7 +166,7 @@ showJSValue (ValObject _) = "object"
165-- >>> testJSaddle $ valToBool "1"
166-- >>> testJSaddle $ valToBool "1"
166-- true
167-- true
167valToBool :: ToJSVal value => value -> JSM Bool
168valToBool :: ToJSVal value => value -> JSM Bool
168−valToBool value = toJSVal value >>= ghcjsPure . isTruthy
169+valToBool value = toJSVal value >>= isTruthyIO
169
170
170-- | Given a JavaScript value get its numeric value.
171-- | Given a JavaScript value get its numeric value.
171-- May throw JSException.
172-- May throw JSException.
@@ -191,7 +192,10 @@ valToNumber :: ToJSVal value => value -> JSM Double
191valToNumber value = jsrefToNumber <$> toJSVal value
192valToNumber value = jsrefToNumber <$> toJSVal value
192foreign import javascript unsafe "$r = Number($1);" jsrefToNumber :: JSVal -> Double
193foreign import javascript unsafe "$r = Number($1);" jsrefToNumber :: JSVal -> Double
193#else
194#else
194−valToNumber value = toJSVal value >>= valueToNumber
195+valToNumber value =
196+ withToJSVal value $ \rval -> do
197+ ~(ValueToNumberResult result) <- sendCommand (ValueToNumber rval)
198+ return result
195#endif
199#endif
196
200
197-- | Given a JavaScript value get its string value (as a JavaScript string).
201-- | Given a JavaScript value get its string value (as a JavaScript string).
@@ -218,7 +222,10 @@ valToStr :: ToJSVal value => value -> JSM JSString
218valToStr value = jsrefToString <$> toJSVal value
222valToStr value = jsrefToString <$> toJSVal value
219foreign import javascript unsafe "$r = $1.toString();" jsrefToString :: JSVal -> JSString
223foreign import javascript unsafe "$r = $1.toString();" jsrefToString :: JSVal -> JSString
220#else
224#else
221−valToStr value = toJSVal value >>= valueToString
225+valToStr value =
226+ withToJSVal value $ \rval -> do
227+ ~(ValueToStringResult result) <- sendCommand (ValueToString rval)
228+ wrapJSString result
222#endif
229#endif
223
230
224-- | Given a JavaScript value get its string value (as a Haskell 'Text').
231-- | Given a JavaScript value get its string value (as a Haskell 'Text').
@@ -269,7 +276,10 @@ valToJSON :: ToJSVal value => value -> JSM JSString
269valToJSON value = jsrefToJSON <$> toJSVal value
276valToJSON value = jsrefToJSON <$> toJSVal value
270foreign import javascript unsafe "$r = $1 === undefined ? \"\" : JSON.stringify($1);" jsrefToJSON :: JSVal -> JSString
277foreign import javascript unsafe "$r = $1 === undefined ? \"\" : JSON.stringify($1);" jsrefToJSON :: JSVal -> JSString
271#else
278#else
272−valToJSON value = toJSVal value >>= valueToJSON
279+valToJSON value =
280+ withToJSVal value $ \rval -> do
281+ ~(ValueToJSONResult result) <- sendCommand (ValueToJSON rval)
282+ wrapJSString result
273#endif
283#endif
274
284
275-- | Given a JavaScript value get its object value.
285-- | Given a JavaScript value get its object value.
@@ -295,7 +305,7 @@ valToObject :: ToJSVal value => value -> JSM Object
295valToObject value = Object <$> toJSVal value
305valToObject value = Object <$> toJSVal value
296
306
297instance MakeObject JSVal where
307instance MakeObject JSVal where
298− makeObject = return . Object
308+ makeObject = valToObject
299
309
300instance ToJSVal Object where
310instance ToJSVal Object where
301 toJSVal (Object r) = return r
311 toJSVal (Object r) = return r
@@ -346,16 +356,16 @@ instance ToJSVal a => ToJSVal (Maybe a) where
346 {-# INLINE toJSVal #-}
356 {-# INLINE toJSVal #-}
347instance FromJSVal a => FromJSVal (Maybe a) where
357instance FromJSVal a => FromJSVal (Maybe a) where
348 fromJSValUnchecked x =
358 fromJSValUnchecked x =
349− ghcjsPure (isUndefined x) >>= \case
359+ isUndefinedIO x >>= \case
350 True -> return Nothing
360 True -> return Nothing
351− False -> ghcjsPure (isNull x) >>= \case
361+ False -> isNullIO x >>= \case
352 True -> return Nothing
362 True -> return Nothing
353 False -> fromJSVal x
363 False -> fromJSVal x
354 {-# INLINE fromJSValUnchecked #-}
364 {-# INLINE fromJSValUnchecked #-}
355 fromJSVal x =
365 fromJSVal x =
356− ghcjsPure (isUndefined x) >>= \case
366+ isUndefinedIO x >>= \case
357 True -> return (Just Nothing)
367 True -> return (Just Nothing)
358− False -> ghcjsPure (isNull x) >>= \case
368+ False -> isNullIO x >>= \case
359 True -> return (Just Nothing)
369 True -> return (Just Nothing)
360 False -> fmap (fmap Just) fromJSVal x
370 False -> fmap (fmap Just) fromJSVal x
361 {-# INLINE fromJSVal #-}
371 {-# INLINE fromJSVal #-}
@@ -372,7 +382,7 @@ instance FromJSVal a => FromJSVal [a] where
372
382
373-- | Test a JavaScript value to see if it is @null@
383-- | Test a JavaScript value to see if it is @null@
374valIsNull :: ToJSVal value => value -> JSM Bool
384valIsNull :: ToJSVal value => value -> JSM Bool
375−valIsNull value = toJSVal value >>= ghcjsPure . isNull
385+valIsNull value = toJSVal value >>= isNullIO
376
386
377----------- undefined ---------------
387----------- undefined ---------------
378-- | An @undefined@ JavaScript value
388-- | An @undefined@ JavaScript value
@@ -395,26 +405,26 @@ instance MakeArgs () where
395
405
396-- | Test a JavaScript value to see if it is @undefined@
406-- | Test a JavaScript value to see if it is @undefined@
397valIsUndefined :: ToJSVal value => value -> JSM Bool
407valIsUndefined :: ToJSVal value => value -> JSM Bool
398−valIsUndefined value = toJSVal value >>= ghcjsPure . isUndefined
408+valIsUndefined value = toJSVal value >>= isUndefinedIO
399
409
400-- | Convert a JSVal to a Maybe JSVal (converting null and undefined to Nothing)
410-- | Convert a JSVal to a Maybe JSVal (converting null and undefined to Nothing)
401maybeNullOrUndefined :: ToJSVal value => value -> JSM (Maybe JSVal)
411maybeNullOrUndefined :: ToJSVal value => value -> JSM (Maybe JSVal)
402maybeNullOrUndefined value = do
412maybeNullOrUndefined value = do
403 rval <- toJSVal value
413 rval <- toJSVal value
404− ghcjsPure (isNull rval) >>= \case
414+ valIsNull rval >>= \case
405 True -> return Nothing
415 True -> return Nothing
406 _ ->
416 _ ->
407− ghcjsPure (isUndefined rval) >>= \case
417+ valIsUndefined rval >>= \case
408 True -> return Nothing
418 True -> return Nothing
409 _ -> return (Just rval)
419 _ -> return (Just rval)
410
420
411maybeNullOrUndefined' :: ToJSVal value => (JSVal -> JSM a) -> value -> JSM (Maybe a)
421maybeNullOrUndefined' :: ToJSVal value => (JSVal -> JSM a) -> value -> JSM (Maybe a)
412maybeNullOrUndefined' f value = do
422maybeNullOrUndefined' f value = do
413 rval <- toJSVal value
423 rval <- toJSVal value
414− ghcjsPure (isNull rval) >>= \case
424+ valIsNull rval >>= \case
415 True -> return Nothing
425 True -> return Nothing
416 _ ->
426 _ ->
417− ghcjsPure (isUndefined rval) >>= \case
427+ valIsUndefined rval >>= \case
418 True -> return Nothing
428 True -> return Nothing
419 _ -> Just <$> f rval
429 _ -> Just <$> f rval
420
430
@@ -438,49 +448,52 @@ instance MakeArgs Bool where
438----------- numbers ---------------
448----------- numbers ---------------
439-- | Make a JavaScript number
449-- | Make a JavaScript number
440valMakeNumber :: Double -> JSM JSVal
450valMakeNumber :: Double -> JSM JSVal
451+#ifdef ghcjs_HOST_OS
441−valMakeNumber = toJSVal
452+valMakeNumber n = toJSVal n
442−{-# INLINE valMakeNumber #-}
453+#else
454+valMakeNumber = sendLazyCommand . NumberToValue
455+#endif
443
456
444#ifndef ghcjs_HOST_OS
457#ifndef ghcjs_HOST_OS
445-- | Makes a JavaScript number
458-- | Makes a JavaScript number
446instance ToJSVal Double where
459instance ToJSVal Double where
447− toJSVal = numberToValue
460+ toJSVal = valMakeNumber
448 {-# INLINE toJSVal #-}
461 {-# INLINE toJSVal #-}
449
462
450instance ToJSVal Float where
463instance ToJSVal Float where
451− toJSVal = numberToValue . realToFrac
464+ toJSVal = valMakeNumber . realToFrac
452 {-# INLINE toJSVal #-}
465 {-# INLINE toJSVal #-}
453
466
454instance ToJSVal Word where
467instance ToJSVal Word where
455− toJSVal = numberToValue . fromIntegral
468+ toJSVal = valMakeNumber . fromIntegral
456 {-# INLINE toJSVal #-}
469 {-# INLINE toJSVal #-}
457
470
458instance ToJSVal Word8 where
471instance ToJSVal Word8 where
459− toJSVal = numberToValue . fromIntegral
472+ toJSVal = valMakeNumber . fromIntegral
460 {-# INLINE toJSVal #-}
473 {-# INLINE toJSVal #-}
461
474
462instance ToJSVal Word16 where
475instance ToJSVal Word16 where
463− toJSVal = numberToValue . fromIntegral
476+ toJSVal = valMakeNumber . fromIntegral
464 {-# INLINE toJSVal #-}
477 {-# INLINE toJSVal #-}
465
478
466instance ToJSVal Word32 where
479instance ToJSVal Word32 where
467− toJSVal = numberToValue . fromIntegral
480+ toJSVal = valMakeNumber . fromIntegral
468 {-# INLINE toJSVal #-}
481 {-# INLINE toJSVal #-}
469
482
470instance ToJSVal Int where
483instance ToJSVal Int where
471− toJSVal = numberToValue . fromIntegral
484+ toJSVal = valMakeNumber . fromIntegral
472 {-# INLINE toJSVal #-}
485 {-# INLINE toJSVal #-}
473
486
474instance ToJSVal Int8 where
487instance ToJSVal Int8 where
475− toJSVal = numberToValue . fromIntegral
488+ toJSVal = valMakeNumber . fromIntegral
476 {-# INLINE toJSVal #-}
489 {-# INLINE toJSVal #-}
477
490
478instance ToJSVal Int16 where
491instance ToJSVal Int16 where
479− toJSVal = numberToValue . fromIntegral
492+ toJSVal = valMakeNumber . fromIntegral
480 {-# INLINE toJSVal #-}
493 {-# INLINE toJSVal #-}
481
494
482instance ToJSVal Int32 where
495instance ToJSVal Int32 where
483− toJSVal = numberToValue . fromIntegral
496+ toJSVal = valMakeNumber . fromIntegral
484 {-# INLINE toJSVal #-}
497 {-# INLINE toJSVal #-}
485#endif
498#endif
486
499
@@ -490,18 +503,25 @@ instance MakeArgs Double where
490
503
491-- | Make a JavaScript string from `Text`
504-- | Make a JavaScript string from `Text`
492valMakeText :: Text -> JSM JSVal
505valMakeText :: Text -> JSM JSVal
506+#ifdef ghcjs_HOST_OS
493−valMakeText = toJSVal . textToJSString
507+valMakeText = return . pToJSVal . textToJSString
494−{-# INLINE valMakeText #-}
508+#else
509+valMakeText text = valMakeString (textToStr text)
510+#endif
495
511
496-- | Make a JavaScript string from `JSString`
512-- | Make a JavaScript string from `JSString`
497valMakeString :: JSString -> JSM JSVal
513valMakeString :: JSString -> JSM JSVal
514+#ifdef ghcjs_HOST_OS
498−valMakeString = toJSVal
515+valMakeString = return . pToJSVal
499−{-# INLINE valMakeString #-}
516+#else
517+valMakeString s =
518+ withJSString s $ sendLazyCommand . StringToValue
519+#endif
500
520
501#ifndef ghcjs_HOST_OS
521#ifndef ghcjs_HOST_OS
502-- | Makes a JavaScript string
522-- | Makes a JavaScript string
503instance ToJSVal Text where
523instance ToJSVal Text where
504− toJSVal = stringToValue . JSString
524+ toJSVal = valMakeText
505 {-# INLINE toJSVal #-}
525 {-# INLINE toJSVal #-}
506instance FromJSVal Text where
526instance FromJSVal Text where
507 fromJSValUnchecked = valToText
527 fromJSValUnchecked = valToText
@@ -517,7 +537,7 @@ instance MakeArgs Text where
517#ifndef ghcjs_HOST_OS
537#ifndef ghcjs_HOST_OS
518-- | Makes a JavaScript string
538-- | Makes a JavaScript string
519instance ToJSVal JSString where
539instance ToJSVal JSString where
520− toJSVal = stringToValue
540+ toJSVal = valMakeString
521 {-# INLINE toJSVal #-}
541 {-# INLINE toJSVal #-}
522instance FromJSVal JSString where
542instance FromJSVal JSString where
523 fromJSValUnchecked = valToStr
543 fromJSValUnchecked = valToStr
@@ -564,12 +584,16 @@ instance FromJSVal Char where
564
584
565-- | Make a JavaScript string from AESON `Value`
585-- | Make a JavaScript string from AESON `Value`
566valMakeJSON :: Value -> JSM JSVal
586valMakeJSON :: Value -> JSM JSVal
587+#ifdef ghcjs_HOST_OS
567valMakeJSON = toJSVal
588valMakeJSON = toJSVal
589+#else
590+valMakeJSON = sendLazyCommand . JSONValueToValue
591+#endif
568
592
569#ifndef ghcjs_HOST_OS
593#ifndef ghcjs_HOST_OS
570-- | Makes a JSON value
594-- | Makes a JSON value
571instance ToJSVal Value where
595instance ToJSVal Value where
572− toJSVal = jsonValueToValue
596+ toJSVal = valMakeJSON
573 {-# INLINE toJSVal #-}
597 {-# INLINE toJSVal #-}
574#endif
598#endif
575
599
@@ -620,16 +644,17 @@ foreign import javascript unsafe "$r = ($1 === undefined)?0:\
620#else
644#else
621deRefVal value = do
645deRefVal value = do
622 v <- toJSVal value
646 v <- toJSVal value
623− result <- N.deRefVal v
647+ withJSVal v $ \rval ->
648+ sendCommand (DeRefVal rval) >>= \result -> return $
624− return $ case result of
649+ case result of
625− DeRefValResult 0 _ -> ValNull
650+ DeRefValResult 0 _ -> ValNull
626− DeRefValResult 1 _ -> ValUndefined
651+ DeRefValResult 1 _ -> ValUndefined
627− DeRefValResult 2 _ -> ValBool False
652+ DeRefValResult 2 _ -> ValBool False
628− DeRefValResult 3 _ -> ValBool True
653+ DeRefValResult 3 _ -> ValBool True
629− DeRefValResult (-1) s -> ValNumber (read (T.unpack s))
654+ DeRefValResult (-1) s -> ValNumber (read (T.unpack s))
630− DeRefValResult (-2) s -> ValString s
655+ DeRefValResult (-2) s -> ValString s
631− DeRefValResult (-3) _ -> ValObject (Object v)
656+ DeRefValResult ref _ -> ValObject (Object (JSVal ref))
632− _ -> error "Unexpected result dereferencing JSaddle value"
657+ _ -> error "Unexpected result dereferencing JSaddle value"
633#endif
658#endif
634
659
635-- | Make a JavaScript value out of a 'JSValue' ADT.
660-- | Make a JavaScript value out of a 'JSValue' ADT.
@@ -688,7 +713,10 @@ strictEqual a b = do
688#ifdef ghcjs_HOST_OS
713#ifdef ghcjs_HOST_OS
689 return $ jsvalueisstrictequal aval bval
714 return $ jsvalueisstrictequal aval bval
690#else
715#else
691− N.strictEqual aval bval
716+ withJSVal aval $ \aref ->
717+ withJSVal bval $ \bref -> do
718+ ~(StrictEqualResult result) <- sendCommand $ StrictEqual aref bref
719+ return result
692#endif
720#endif
693
721
694#ifdef ghcjs_HOST_OS
722#ifdef ghcjs_HOST_OS
@@ -706,7 +734,10 @@ instanceOf value constructor = do
706#ifdef ghcjs_HOST_OS
734#ifdef ghcjs_HOST_OS
707 return $ js_isInstanceOf v c
735 return $ js_isInstanceOf v c
708#else
736#else
709− N.instanceOf v c
737+ withJSVal v $ \rval ->
738+ withObject c $ \c' -> do
739+ ~(InstanceOfResult result) <- sendCommand $ InstanceOf rval c'
740+ return result
710#endif
741#endif
711
742
712
743
nix/hix.nixdeleted−8
@@ -1,8 +0,0 @@
1−{pkgs, ...}:
2−{ modules = [({pkgs, ...}: {
3− packages.webkit2gtk3-javascriptcore.components.library.doHaddock = false;
4− })];
5− shell.buildInputs = [ pkgs.nodejs ];
6− shell.tools.cabal = {};
7− shell.crossPlatforms = p: [ p.ghcjs ];
8−}
travis/build.sh+13−2
@@ -6,8 +6,19 @@ GHCVER=`ghc --numeric-version`
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+
9cabal update
15cabal update
10cabal new-build 'jsaddle-warp:lib:jsaddle-warp' 'jsaddle-warp:test:test-tool'
16cabal new-build 'jsaddle-warp:lib:jsaddle-warp' 'jsaddle-warp:test:test-tool'
11−cd jsaddle-warp
12−GHC_PACKAGE_PATH=/opt/ghc/$GHCVER/lib/ghc-$GHCVER/package.conf.d:~/.cabal/store/ghc-$GHCVER/package.db:../dist-newstyle/packagedb/ghc-$GHCVER ../dist-newstyle/build/x86_64-linux/ghc-$GHCVER/jsaddle-warp-$JSADDLE_WARP_VERSION/t/test-tool/build/test-tool/test-tool ../jsaddle
17+GHC_PACKAGE_PATH=/opt/ghc/$GHCVER/lib/ghc-$GHCVER/package.conf.d:~/.cabal/store/ghc-$GHCVER/package.db:./dist-newstyle/packagedb/ghc-$GHCVER jsaddle_datadir=`pwd` ./dist-newstyle/build/jsaddle-warp-$JSADDLE_WARP_VERSION/build/test-tool/test-tool .
18+
19+# update the cache
20+rm -rf .cabal
21+cp -a /root/.cabal ./
22+rm -rf .ghc
23+cp -a /root/.ghc ./
13
24
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 phantomjs
7+ apt-get -y install happy-1.19.5 alex-3.1.7 nodejs npm
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 phantomjs
7+ apt-get -y install happy-1.19.5 alex-3.1.7 nodejs npm
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 phantomjs
7+ apt-get -y install happy-1.19.5 alex-3.1.7 nodejs npm
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 phantomjs
7+ apt-get -y install happy-1.19.5 alex-3.1.7 nodejs npm
8
8
9RUN mkdir /build
9RUN mkdir /build
10WORKDIR /build
10WORKDIR /build