From 1d07f9a6cecea99a394cd341f1adae4593f28455 Mon Sep 17 00:00:00 2001
From: Cheng Shao <terrorjack@type.dance>
Date: Mon, 25 Dec 2023 08:46:28 +0000
Subject: [PATCH] testsuite: add JSFFI test cases for wasm backend
This commit adds a few test cases for the wasm backend's JSFFI
functionality, as well as a simple README to instruct future
contributors to add new test cases.
---
testsuite/tests/jsffi/README.md | 33 ++++++++++
testsuite/tests/jsffi/all.T | 26 ++++++++
testsuite/tests/jsffi/gameover.hs | 22 +++++++
testsuite/tests/jsffi/gameover.mjs | 8 +++
testsuite/tests/jsffi/gameover.stdout | 2 +
testsuite/tests/jsffi/http.hs | 63 +++++++++++++++++++
testsuite/tests/jsffi/http.mjs | 3 +
testsuite/tests/jsffi/http.stdout | 1 +
testsuite/tests/jsffi/jsffigc.hs | 84 +++++++++++++++++++++++++
testsuite/tests/jsffi/jsffigc.mjs | 16 +++++
testsuite/tests/jsffi/jsffigc.stdout | 7 +++
testsuite/tests/jsffi/jsffioff.hs | 10 +++
testsuite/tests/jsffi/jsffioff.mjs | 4 ++
testsuite/tests/jsffi/jsffioff.stdout | 1 +
testsuite/tests/jsffi/jsffion.hs | 7 +++
testsuite/tests/jsffi/jsffion.mjs | 3 +
testsuite/tests/jsffi/jsffion.stdout | 1 +
testsuite/tests/jsffi/jsffisleep.hs | 78 +++++++++++++++++++++++
testsuite/tests/jsffi/jsffisleep.mjs | 6 ++
testsuite/tests/jsffi/jsffisleep.stdout | 4 ++
testsuite/tests/jsffi/textconv.hs | 52 +++++++++++++++
testsuite/tests/jsffi/textconv.mjs | 3 +
testsuite/tests/jsffi/textconv.stdout | 1 +
23 files changed, 435 insertions(+)
create mode 100644 testsuite/tests/jsffi/README.md
create mode 100644 testsuite/tests/jsffi/all.T
create mode 100644 testsuite/tests/jsffi/gameover.hs
create mode 100644 testsuite/tests/jsffi/gameover.mjs
create mode 100644 testsuite/tests/jsffi/gameover.stdout
create mode 100644 testsuite/tests/jsffi/http.hs
create mode 100644 testsuite/tests/jsffi/http.mjs
create mode 100644 testsuite/tests/jsffi/http.stdout
create mode 100644 testsuite/tests/jsffi/jsffigc.hs
create mode 100644 testsuite/tests/jsffi/jsffigc.mjs
create mode 100644 testsuite/tests/jsffi/jsffigc.stdout
create mode 100644 testsuite/tests/jsffi/jsffioff.hs
create mode 100644 testsuite/tests/jsffi/jsffioff.mjs
create mode 100644 testsuite/tests/jsffi/jsffioff.stdout
create mode 100644 testsuite/tests/jsffi/jsffion.hs
create mode 100644 testsuite/tests/jsffi/jsffion.mjs
create mode 100644 testsuite/tests/jsffi/jsffion.stdout
create mode 100644 testsuite/tests/jsffi/jsffisleep.hs
create mode 100644 testsuite/tests/jsffi/jsffisleep.mjs
create mode 100644 testsuite/tests/jsffi/jsffisleep.stdout
create mode 100644 testsuite/tests/jsffi/textconv.hs
create mode 100644 testsuite/tests/jsffi/textconv.mjs
create mode 100644 testsuite/tests/jsffi/textconv.stdout
diff --git a/testsuite/tests/jsffi/README.md b/testsuite/tests/jsffi/README.md
new file mode 100644
index 00000000000..29abcb61447
--- /dev/null
+++ b/testsuite/tests/jsffi/README.md
@@ -0,0 +1,33 @@
+# Tests for GHC wasm backend's JavaScript FFI
+
+This directory contains tests for JSFFI as implemented in the GHC wasm
+backend. They are skipped if the target platform is not `wasm32`.
+Otherwise, a recent version of `node` (at least `v21.2.0`) is required
+to be in `PATH` for these tests.
+
+## How to add a new test case
+
+Each `testcase` is consisted of the following elements:
+
+- A `test('testcase', ...)` statement in `all.T`, check existing
+ examples there.
+- A `testcase.hs` Haskell module. Since you define your own entry points and
+ link with `-no-hs-main` anyway, add a `module Test where` on top to
+ stop GHC from complaining about the lack of `Main.main`.
+- A `testcase.stdout` standard output file. Note that we mark all
+ tests as `ignore_stderr`, because `node` itself likes to emit a
+ bunch of warning messages to `stderr` which changes from time to
+ time and there's little added value in adding workaround for this
+ issue.
+- A `testcase.mjs` JavaScript ESM module. It has a default export
+ function, which takes the `__exports` object that contains the wasm
+ module exports as its argument. By the time this function is called
+ by the test runner, the wasm instance state has been initialized,
+ and you can call your exported Haskell functions here.
+
+## How to debug when a test case goes wrong
+
+Pass `--keep-test-files` to hadrian test to preserve the crime scene.
+Go to that temporary directory and run
+`/workspace/ghc/utils/jsffi/test-runner.mjs testcase.wasm +RTS ...` to
+rerun the test case.
diff --git a/testsuite/tests/jsffi/all.T b/testsuite/tests/jsffi/all.T
new file mode 100644
index 00000000000..aa84d3d3423
--- /dev/null
+++ b/testsuite/tests/jsffi/all.T
@@ -0,0 +1,26 @@
+def override_target_wrapper(name, opts):
+ opts.target_wrapper = str(
+ config.top.joinpath('..', 'utils', 'jsffi', 'test-runner.mjs').resolve()
+ )
+
+setTestOpts([
+ unless(arch('wasm32'), skip),
+ override_target_wrapper,
+ ignore_stderr,
+ extra_hc_opts('-O2 -no-hs-main -optl-mexec-model=reactor'),
+ extra_ways(['compacting_gc', 'nonmoving', 'sanity'])
+])
+
+test('gameover', [], compile_and_run, ['-optl-Wl,--export=testJSException,--export=testHSException'])
+
+test('http', [], compile_and_run, ['-optl-Wl,--export=main'])
+
+test('jsffigc', [], compile_and_run, ['-optl-Wl,--export=testDynExportFree,--export=testDynExportGC'])
+
+test('jsffioff', [], compile_and_run, ['-optl-Wl,--export=hs_init,--export=main'])
+
+test('jsffion', [], compile_and_run, ['-optl-Wl,--export=main'])
+
+test('jsffisleep', [], compile_and_run, ['-optl-Wl,--export=testWouldBlock,--export=testLazySleep,--export=testThreadDelay,--export=testInterruptingSleep'])
+
+test('textconv', [], compile_and_run, ['-optl-Wl,--export=main'])
diff --git a/testsuite/tests/jsffi/gameover.hs b/testsuite/tests/jsffi/gameover.hs
new file mode 100644
index 00000000000..1aeb49d93f7
--- /dev/null
+++ b/testsuite/tests/jsffi/gameover.hs
@@ -0,0 +1,22 @@
+-- Test that we can catch JavaScript exceptions in Haskell and vice
+-- versa.
+
+module Test where
+
+import Control.Exception
+import GHC.Wasm.Prim
+
+foreign import javascript safe "Promise.reject('game over')"
+ js_game_over :: IO ()
+
+foreign export javascript "testJSException"
+ testJSException :: IO ()
+
+testJSException :: IO ()
+testJSException = catch (evaluate =<< js_game_over) $ \(e :: JSException) -> print e
+
+foreign export javascript "testHSException"
+ testHSException :: IO ()
+
+testHSException :: IO ()
+testHSException = fail "game over"
diff --git a/testsuite/tests/jsffi/gameover.mjs b/testsuite/tests/jsffi/gameover.mjs
new file mode 100644
index 00000000000..8b9ac0d6965
--- /dev/null
+++ b/testsuite/tests/jsffi/gameover.mjs
@@ -0,0 +1,8 @@
+export default async (__exports) => {
+ await __exports.testJSException();
+ try {
+ await __exports.testHSException();
+ } catch (e) {
+ console.log(e.message);
+ }
+};
diff --git a/testsuite/tests/jsffi/gameover.stdout b/testsuite/tests/jsffi/gameover.stdout
new file mode 100644
index 00000000000..27dcc09ab46
--- /dev/null
+++ b/testsuite/tests/jsffi/gameover.stdout
@@ -0,0 +1,2 @@
+JSException "game over"
+user error (game over)
diff --git a/testsuite/tests/jsffi/http.hs b/testsuite/tests/jsffi/http.hs
new file mode 100644
index 00000000000..e85f77a7bcd
--- /dev/null
+++ b/testsuite/tests/jsffi/http.hs
@@ -0,0 +1,63 @@
+-- A nodejs http client/server ping/pong test as a simple integration
+-- test for JSFFI.
+
+{-# LANGUAGE JavaScriptFFI #-}
+
+import GHC.Wasm.Prim
+
+newtype JSModule = JSModule JSVal
+
+newtype JSServer = JSServer JSVal
+
+newtype JSRequest = JSRequest JSVal
+
+newtype JSResponse = JSResponse JSVal
+
+newtype JSFunction = JSFunction JSVal
+
+foreign import javascript safe "import($1)"
+ js_import :: JSString -> IO JSModule
+
+foreign import javascript safe "$1.text($2)"
+ js_req_to_str :: JSModule -> JSRequest -> IO JSString
+
+foreign import javascript unsafe "$1.createServer($2)"
+ js_server_create :: JSModule -> JSFunction -> IO JSServer
+
+foreign import javascript safe "new Promise(res => { $1.listen(0, () => { res($1.address().port); }); })"
+ js_server_listen :: JSServer -> IO Int
+
+foreign import javascript "wrapper"
+ js_mk_req_handler :: (JSRequest -> JSResponse -> IO ()) -> IO JSFunction
+
+foreign import javascript unsafe "$1.writeHead(200, { 'Content-Type': 'text/plain' })"
+ js_resp_write_head :: JSResponse -> IO ()
+
+foreign import javascript unsafe "$1.end($2)"
+ js_resp_end :: JSResponse -> JSString -> IO ()
+
+foreign import javascript safe "const r = await fetch($1, {method: 'POST', body: $2}); return r.text();"
+ js_fetch_post :: JSString -> JSString -> IO JSString
+
+foreign import javascript unsafe "$1.close()"
+ js_server_close :: JSServer -> IO ()
+
+foreign import javascript unsafe "console.log($1)"
+ js_print :: JSString -> IO ()
+
+foreign export javascript "main"
+ main :: IO ()
+
+main :: IO ()
+main = do
+ http <- js_import $ toJSString "node:http"
+ stream_consumers <- js_import $ toJSString "node:stream/consumers"
+ req_handler <- js_mk_req_handler $ \req resp -> do
+ req_str <- fromJSString <$> js_req_to_str stream_consumers req
+ js_resp_write_head resp
+ js_resp_end resp $ toJSString $ "pong: " <> req_str
+ server <- js_server_create http req_handler
+ port <- js_server_listen server
+ pong <- js_fetch_post (toJSString $ "http://localhost:" <> show port) (toJSString "ping")
+ js_print pong
+ js_server_close server
diff --git a/testsuite/tests/jsffi/http.mjs b/testsuite/tests/jsffi/http.mjs
new file mode 100644
index 00000000000..56ef3fdeef4
--- /dev/null
+++ b/testsuite/tests/jsffi/http.mjs
@@ -0,0 +1,3 @@
+export default async (__exports) => {
+ await __exports.main();
+}
diff --git a/testsuite/tests/jsffi/http.stdout b/testsuite/tests/jsffi/http.stdout
new file mode 100644
index 00000000000..fa64931af9b
--- /dev/null
+++ b/testsuite/tests/jsffi/http.stdout
@@ -0,0 +1 @@
+pong: ping
diff --git a/testsuite/tests/jsffi/jsffigc.hs b/testsuite/tests/jsffi/jsffigc.hs
new file mode 100644
index 00000000000..7b0f89798ae
--- /dev/null
+++ b/testsuite/tests/jsffi/jsffigc.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE MagicHash #-}
+
+module Test where
+
+import Data.Maybe
+import GHC.Exts
+import GHC.Wasm.Prim
+import GHC.Weak
+import System.Mem
+
+type BinOp a = a -> a -> a
+
+foreign import javascript "wrapper"
+ js_from_hs :: BinOp Int -> IO JSVal
+
+-- This must be safe since we intend to call back into Haskell again.
+foreign import javascript safe "dynamic"
+ js_to_hs :: JSVal -> BinOp Int
+
+foreign import javascript "wrapper"
+ js_mk_cont :: IO () -> IO JSVal
+
+foreign export javascript "testDynExportFree"
+ testDynExportFree :: Int -> Int -> Int -> IO ()
+
+-- JSVal uses Weak# under the hood for garbage collection support,
+-- this exposes the internal Weak# to observe the liveliness of
+-- JSVal#. Do not use this in your own codebase since this is purely
+-- an implementation detail of JSVal and subject to change!
+jsvalWeak :: JSVal -> Weak JSVal
+jsvalWeak (JSVal _ w _) = Weak $ unsafeCoerce# Weak w
+
+probeWeak :: Weak v -> IO ()
+probeWeak wk = print =<< isJust <$> deRefWeak wk
+
+testDynExportFree :: Int -> Int -> Int -> IO ()
+testDynExportFree x y z = do
+ -- fn must be a dynamically created Haskell function closure.
+ let fn a b = a * b + z
+ -- wk_fn observe the liveliness of fn
+ wk_fn <- mkWeak fn () Nothing
+ cb <- js_from_hs fn
+ -- wk_js observe the liveliness of the JavaScript callback on the
+ -- Haskell heap. Make sure it's eagerly evaluated and isn't a thunk
+ -- that retains cb.
+ let !wk_js = jsvalWeak cb
+ print $ js_to_hs cb x y
+ -- Eagerly drop references to both the JavaScript callback and the
+ -- Haskell function closure.
+ freeJSVal cb
+ performGC
+ -- Now both should be dead.
+ probeWeak wk_js
+ probeWeak wk_fn
+
+foreign export javascript "testDynExportGC"
+ testDynExportGC :: Int -> Int -> Int -> IO JSVal
+
+testDynExportGC :: Int -> Int -> Int -> IO JSVal
+testDynExportGC x y z = do
+ let fn a b = a * b + z
+ wk_fn <- mkWeak fn () Nothing
+ cb <- js_from_hs fn
+ let !wk_js = jsvalWeak cb
+ print $ js_to_hs cb x y
+ -- Why performGC twice? The first run gathers some C finalizers
+ -- which will be invoked in the second run to free the JSVal
+ -- references. It's an implementation detail of the GHC RTS.
+ performGC
+ performGC
+ -- Should be dead now, cb is recycled at this point.
+ probeWeak wk_js
+ -- Should be alive, despite cb is gone in the Haskell heap, it may
+ -- still be alive in the JavaScript side so we can't drop fn!
+ probeWeak wk_fn
+ -- Return a continuation to be called after the JavaScript side
+ -- finishes garbage collection.
+ js_mk_cont $ do
+ -- The JavaScript FinalizerRegistry logic only frees the stable
+ -- pointer that pins fn. So we need to invoke Haskell garbage
+ -- collection again.
+ performGC
+ -- Dead, finally.
+ probeWeak wk_fn
diff --git a/testsuite/tests/jsffi/jsffigc.mjs b/testsuite/tests/jsffi/jsffigc.mjs
new file mode 100644
index 00000000000..3178a8a83a0
--- /dev/null
+++ b/testsuite/tests/jsffi/jsffigc.mjs
@@ -0,0 +1,16 @@
+function sleep(t) {
+ return new Promise(res => setTimeout(res, t));
+}
+
+async function reallyGC() {
+ gc(); // Only exposed by the --expose-gc V8 option
+ await sleep(1024); // For some reason, this is needed for the FinalizationRegistry logic to actually work
+}
+
+export default async (__exports) => {
+ await __exports.testDynExportFree(114, 514, 1919810);
+
+ const cont = await __exports.testDynExportGC(114, 514, 1919810);
+ await reallyGC();
+ await cont();
+};
diff --git a/testsuite/tests/jsffi/jsffigc.stdout b/testsuite/tests/jsffi/jsffigc.stdout
new file mode 100644
index 00000000000..374bce0895b
--- /dev/null
+++ b/testsuite/tests/jsffi/jsffigc.stdout
@@ -0,0 +1,7 @@
+1978406
+False
+False
+1978406
+False
+True
+False
diff --git a/testsuite/tests/jsffi/jsffioff.hs b/testsuite/tests/jsffi/jsffioff.hs
new file mode 100644
index 00000000000..ebef5a552b4
--- /dev/null
+++ b/testsuite/tests/jsffi/jsffioff.hs
@@ -0,0 +1,10 @@
+import GHC.TopHandler
+import GHC.Wasm.Prim
+
+foreign export ccall "main"
+ main :: IO ()
+
+main :: IO ()
+main = do
+ print isJSFFIUsed
+ flushStdHandles
diff --git a/testsuite/tests/jsffi/jsffioff.mjs b/testsuite/tests/jsffi/jsffioff.mjs
new file mode 100644
index 00000000000..4da7c2309f0
--- /dev/null
+++ b/testsuite/tests/jsffi/jsffioff.mjs
@@ -0,0 +1,4 @@
+export default (__exports) => {
+ __exports.hs_init(0, 0);
+ __exports.main();
+}
diff --git a/testsuite/tests/jsffi/jsffioff.stdout b/testsuite/tests/jsffi/jsffioff.stdout
new file mode 100644
index 00000000000..bc59c12aa16
--- /dev/null
+++ b/testsuite/tests/jsffi/jsffioff.stdout
@@ -0,0 +1 @@
+False
diff --git a/testsuite/tests/jsffi/jsffion.hs b/testsuite/tests/jsffi/jsffion.hs
new file mode 100644
index 00000000000..4b99a0e2ae3
--- /dev/null
+++ b/testsuite/tests/jsffi/jsffion.hs
@@ -0,0 +1,7 @@
+import GHC.Wasm.Prim
+
+foreign export javascript "main"
+ main :: IO ()
+
+main :: IO ()
+main = print isJSFFIUsed
diff --git a/testsuite/tests/jsffi/jsffion.mjs b/testsuite/tests/jsffi/jsffion.mjs
new file mode 100644
index 00000000000..56ef3fdeef4
--- /dev/null
+++ b/testsuite/tests/jsffi/jsffion.mjs
@@ -0,0 +1,3 @@
+export default async (__exports) => {
+ await __exports.main();
+}
diff --git a/testsuite/tests/jsffi/jsffion.stdout b/testsuite/tests/jsffi/jsffion.stdout
new file mode 100644
index 00000000000..0ca95142bb7
--- /dev/null
+++ b/testsuite/tests/jsffi/jsffion.stdout
@@ -0,0 +1 @@
+True
diff --git a/testsuite/tests/jsffi/jsffisleep.hs b/testsuite/tests/jsffi/jsffisleep.hs
new file mode 100644
index 00000000000..8e9c6852643
--- /dev/null
+++ b/testsuite/tests/jsffi/jsffisleep.hs
@@ -0,0 +1,78 @@
+module Test where
+
+import Control.Concurrent
+import Control.Exception
+import Data.Foldable
+import Data.Traversable
+import GHC.TopHandler
+import GHC.Wasm.Prim
+
+-- Same thing used internally by threadDelay when JSFFI is used
+foreign import javascript safe "new Promise(res => setTimeout(res, $1 / 1000))"
+ js_lazy_sleep :: Int -> IO ()
+
+foreign export ccall "testWouldBlock"
+ testWouldBlock :: IO ()
+
+-- When a Haskell function exported via C FFI attempts to block on an
+-- async JSFFI import, a WouldBlockException will be thrown. Also note
+-- that we need to explicitly flushStdHandles, which is required for
+-- non-main exports in C FFI. In JSFFI, it's always done automatically
+-- for every export though.
+testWouldBlock :: IO ()
+testWouldBlock = catch (threadDelay 1000000) $ \WouldBlockException -> do
+ print WouldBlockException
+ flushStdHandles
+
+foreign export javascript "testLazySleep"
+ testLazySleep :: Int -> Int -> IO ()
+
+-- If async JSFFI import blocks the caller eagerly, then this would
+-- sleep for t*n milliseconds, causing a noticable delay when running
+-- this test case.
+testLazySleep :: Int -> Int -> IO ()
+testLazySleep t n = do
+ thunks <- for [1..n] $ \_ -> js_lazy_sleep t
+ for_ thunks evaluate
+ putStrLn "zzzzzzz"
+
+foreign export javascript "testThreadDelay"
+ testThreadDelay :: Int -> Int -> IO ()
+
+-- Some folks may still prefer to wrap their async JSFFI imports to
+-- always block on waiting for the result and only expose the wrapper
+-- functions. So doing concurrent requests would require forking a
+-- thread per request. Which is also fine.
+testThreadDelay :: Int -> Int -> IO ()
+testThreadDelay t n = do
+ mvars <- for [1..n] $ \_ -> newEmptyMVar
+ for_ mvars $ \mv -> forkFinally (threadDelay t) $ putMVar mv
+ for_ mvars takeMVar
+ putStrLn "i sleep"
+
+foreign export javascript "testInterruptingSleep"
+ testInterruptingSleep :: IO ()
+
+-- When a thread is blocked waiting for an async JSFFI import call to
+-- return, it can be interrupted by a Haskell async exception. The
+-- async exception will not magically cancel the pending JavaScript
+-- Promise, nor will it enqueue the target thread for execution. Only
+-- when that Promise actually resolves or rejects, the thread will be
+-- waken up again.
+--
+-- The current way JSFFI handles async exception is not completely
+-- satisfactory, but it's a good enough balance between implementation
+-- difficulty and ease of usage.
+testInterruptingSleep :: IO ()
+testInterruptingSleep = do
+ mv <- newEmptyMVar
+ tid <- forkIO $ catch (threadDelay 1000000 *> putMVar mv (Right ())) $ \(e :: SomeException) -> putMVar mv $ Left e
+ -- Without this, the thread we forked earlier likely have not even
+ -- performed the call yet. It will be interrupted and silently
+ -- dropped without a chance to be waken up, so the MVar will remain
+ -- empty and this thread will also be suspended without waking up,
+ -- eventually propagating as a "never fulfilled top-level await"
+ -- error to the JavaScript host.
+ threadDelay 1000
+ killThread tid
+ print =<< takeMVar mv
diff --git a/testsuite/tests/jsffi/jsffisleep.mjs b/testsuite/tests/jsffi/jsffisleep.mjs
new file mode 100644
index 00000000000..687e483ae4d
--- /dev/null
+++ b/testsuite/tests/jsffi/jsffisleep.mjs
@@ -0,0 +1,6 @@
+export default async (__exports) => {
+ __exports.testWouldBlock();
+ await __exports.testLazySleep(1000000, 1024);
+ await __exports.testThreadDelay(1000000, 1024);
+ await __exports.testInterruptingSleep();
+}
diff --git a/testsuite/tests/jsffi/jsffisleep.stdout b/testsuite/tests/jsffi/jsffisleep.stdout
new file mode 100644
index 00000000000..6aa5bcb432d
--- /dev/null
+++ b/testsuite/tests/jsffi/jsffisleep.stdout
@@ -0,0 +1,4 @@
+WouldBlockException
+zzzzzzz
+i sleep
+Left thread killed
diff --git a/testsuite/tests/jsffi/textconv.hs b/testsuite/tests/jsffi/textconv.hs
new file mode 100644
index 00000000000..d7ca3581cc3
--- /dev/null
+++ b/testsuite/tests/jsffi/textconv.hs
@@ -0,0 +1,52 @@
+-- This test demonstrates how to convert between Text and JSString.
+-- Ideally this would be a part of GHC.Wasm.Prim, but that module
+-- can't use anything from text. Hopefully the code here can be
+-- properly adopted somewhere else.
+
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+import Data.Array.Byte
+import Data.Coerce
+import Data.Text.Internal
+import qualified Data.Text.IO.Utf8 as T
+import GHC.Exts
+import GHC.IO
+import GHC.Wasm.Prim
+
+newtype JSUint8Array = JSUint8Array JSVal
+
+foreign import javascript unsafe "(new TextEncoder()).encode($1)"
+ js_str_encode :: JSString -> IO JSUint8Array
+
+foreign import javascript unsafe "$1.byteLength"
+ js_buf_len :: JSUint8Array -> IO Int
+
+foreign import javascript unsafe "(new Uint8Array(__exports.memory.buffer, $2, $1.byteLength)).set($1)"
+ js_from_buf :: JSUint8Array -> Ptr a -> IO ()
+
+foreign import javascript unsafe "(new TextDecoder('utf-8', {fatal: true})).decode(new Uint8Array(__exports.memory.buffer, $1, $2))"
+ js_to_str :: Ptr a -> Int -> IO JSString
+
+textFromJSString :: JSString -> Text
+textFromJSString str = unsafeDupablePerformIO $ do
+ buf <- js_str_encode str
+ I# len# <- js_buf_len buf
+ IO $ \s0 -> case newByteArray# len# s0 of
+ (# s1, mba# #) -> case unIO (js_from_buf buf (Ptr (mutableByteArrayContents# mba#))) s1 of
+ (# s2, _ #) -> case unIO (freeJSVal (coerce buf)) s2 of
+ (# s3, _ #) -> case unsafeFreezeByteArray# mba# s3 of
+ (# s4, ba# #) -> (# s4, Text (ByteArray ba#) 0 (I# len#) #)
+
+textToJSString :: Text -> JSString
+textToJSString (Text (ByteArray ba#) (I# off#) (I# len#)) = unsafeDupablePerformIO $
+ IO $ \s0 -> case newPinnedByteArray# len# s0 of
+ (# s1, mba# #) -> case copyByteArray# ba# off# mba# 0# len# s1 of
+ s2 -> keepAlive# mba# s2 $ unIO $ js_to_str (Ptr (mutableByteArrayContents# mba#)) $ I# len#
+
+foreign export javascript "main"
+ main :: IO ()
+
+main :: IO ()
+main = T.putStrLn $ textFromJSString $ textToJSString "lorem ipsum"
diff --git a/testsuite/tests/jsffi/textconv.mjs b/testsuite/tests/jsffi/textconv.mjs
new file mode 100644
index 00000000000..56ef3fdeef4
--- /dev/null
+++ b/testsuite/tests/jsffi/textconv.mjs
@@ -0,0 +1,3 @@
+export default async (__exports) => {
+ await __exports.main();
+}
diff --git a/testsuite/tests/jsffi/textconv.stdout b/testsuite/tests/jsffi/textconv.stdout
new file mode 100644
index 00000000000..01a59b011a4
--- /dev/null
+++ b/testsuite/tests/jsffi/textconv.stdout
@@ -0,0 +1 @@
+lorem ipsum
--
GitLab