Base/JS: GHC.JS.Foreign.Callback module (issue 23126)

* Add the Callback module for "exporting" Haskell functions
to be available to plain JavaScript code

* Fix some primitives defined in GHC.JS.Prim

* Add a JavaScript section to the user guide with instructions
on how to use the JavaScript FFI, building up to using Callbacks
to interact with the browser

* Add tests for the JavaScript FFI and Callbacks

23 files changed, 309 insertions, 0 deletions

diff --git a/testsuite/tests/javascript/all.T b/testsuite/tests/javascript/all.T
index 6ff2a7818a..3da7759da5 100644
--- a/testsuite/tests/javascript/all.T
+++ b/testsuite/tests/javascript/all.T
@@ -2,3 +2,16 @@
 setTestOpts(when(not(js_arch()),skip))
 
 test('T23101', normal, compile_and_run, [''])
+
+test('js-ffi-int', normal, compile_and_run, [''])
+test('js-ffi-string', normal, compile_and_run, [''])
+test('js-ffi-null', normal, compile_and_run, [''])
+test('js-ffi-isNull', normal, compile_and_run, [''])
+test('js-ffi-isUndefined', normal, compile_and_run, [''])
+test('js-ffi-array', normal, compile_and_run, [''])
+
+test('js-callback01', normal, compile_and_run, [''])
+test('js-callback02', normal, compile_and_run, [''])
+test('js-callback03', normal, compile_and_run, [''])
+test('js-callback04', js_skip, compile_and_run, [''])
+test('js-callback05', js_skip, compile_and_run, [''])
diff --git a/testsuite/tests/javascript/js-callback01.hs b/testsuite/tests/javascript/js-callback01.hs
new file mode 100644
index 0000000000..df5c990e07
--- /dev/null
+++ b/testsuite/tests/javascript/js-callback01.hs
@@ -0,0 +1,51 @@
+import GHC.JS.Prim
+import GHC.JS.Foreign.Callback
+import Control.Concurrent
+
+foreign import javascript "(() => { console.log('test'); })"
+  js_log0 :: IO ()
+
+foreign import javascript "((x) => { console.log(x); })"
+  js_log1 :: JSVal -> IO ()
+
+foreign import javascript "((x,y) => { console.log(x); console.log(y); })"
+  js_log2 :: JSVal -> JSVal -> IO ()
+
+foreign import javascript "((x,y,z) => { console.log(x); console.log(y); console.log(z); })"
+  js_log3 :: JSVal -> JSVal -> JSVal -> IO ()
+
+foreign import javascript "((f) => { f(); })"
+  js_apply0_ :: Callback (IO ()) -> IO ()
+
+foreign import javascript "((f,x) => { f(x); })"
+  js_apply1_ :: Callback (JSVal -> IO ()) -> JSVal -> IO ()
+
+foreign import javascript "((f,x,y) => { f(x,y); })"
+  js_apply2_ :: Callback (JSVal -> JSVal -> IO ()) -> JSVal -> JSVal -> IO ()
+
+foreign import javascript "((f,x,y,z) => { f(x,y,z); })"
+  js_apply3_ :: Callback (JSVal -> JSVal -> JSVal -> IO ()) -> JSVal -> JSVal -> JSVal -> IO ()
+
+main :: IO ()
+main = do
+  log0  <- syncCallback  ThrowWouldBlock js_log0
+  log1  <- syncCallback1 ThrowWouldBlock js_log1
+  log2  <- syncCallback2 ThrowWouldBlock js_log2
+  log3  <- syncCallback3 ThrowWouldBlock js_log3
+
+  js_apply0_ log0
+  js_apply1_ log1  (toJSString "test1x")
+  js_apply2_ log2  (toJSString "test2x") (toJSString "test2y")
+  js_apply3_ log3  (toJSString "test3x") (toJSString "test3y") (toJSString "test3z")
+
+  log0' <- asyncCallback  js_log0
+  log1' <- asyncCallback1 js_log1
+  log2' <- asyncCallback2 js_log2
+  log3' <- asyncCallback3 js_log3
+
+  js_apply0_ log0'
+  js_apply1_ log1' (toJSString "test")
+  js_apply2_ log2' (toJSString "test") (toJSString "test")
+  js_apply3_ log3' (toJSString "test") (toJSString "test") (toJSString "test")
+
+  threadDelay 1000000 -- Wait long enough for the async actions to complete
diff --git a/testsuite/tests/javascript/js-callback01.stdout b/testsuite/tests/javascript/js-callback01.stdout
new file mode 100644
index 0000000000..7726baf6a4
--- /dev/null
+++ b/testsuite/tests/javascript/js-callback01.stdout
@@ -0,0 +1,14 @@
+test
+test1x
+test2x
+test2y
+test3x
+test3y
+test3z
+test
+test
+test
+test
+test
+test
+test
diff --git a/testsuite/tests/javascript/js-callback02.hs b/testsuite/tests/javascript/js-callback02.hs
new file mode 100644
index 0000000000..3fc8896f54
--- /dev/null
+++ b/testsuite/tests/javascript/js-callback02.hs
@@ -0,0 +1,42 @@
+import GHC.JS.Prim
+import GHC.JS.Foreign.Callback
+
+foreign import javascript "(() => { return 1; })"
+  plus_one0 :: IO JSVal
+
+foreign import javascript "((x) => { return x + 1; })"
+  plus_one1 :: JSVal -> IO JSVal
+
+foreign import javascript "((x,y) => { return x + y + 1; })"
+  plus_one2 :: JSVal -> JSVal -> IO JSVal
+
+foreign import javascript "((x,y,z) => { return x + y + z + 1; })"
+  plus_one3 :: JSVal -> JSVal -> JSVal -> IO JSVal
+
+foreign import javascript "((f) => { return f(); })"
+  js_apply0 :: Callback (IO JSVal) -> IO JSVal
+
+foreign import javascript "((f,x) => { return f(x); })"
+  js_apply1 :: Callback (JSVal -> IO JSVal) -> JSVal -> IO JSVal
+
+foreign import javascript "((f,x,y) => { return f(x,y); })"
+  js_apply2 :: Callback (JSVal -> JSVal -> IO JSVal) -> JSVal -> JSVal -> IO JSVal
+
+foreign import javascript "((f,x,y,z) => { return f(x,y,z); })"
+  js_apply3 :: Callback (JSVal -> JSVal -> JSVal -> IO JSVal) -> JSVal -> JSVal -> JSVal -> IO JSVal
+
+logJSInt :: JSVal -> IO ()
+logJSInt = print . fromJSInt
+
+main :: IO ()
+main = do
+  plusOne0 <- syncCallback'  plus_one0
+  plusOne1 <- syncCallback1' plus_one1
+  plusOne2 <- syncCallback2' plus_one2
+  plusOne3 <- syncCallback3' plus_one3
+
+  logJSInt =<< js_apply0 plusOne0
+  logJSInt =<< js_apply1 plusOne1 (toJSInt 2)
+  logJSInt =<< js_apply2 plusOne2 (toJSInt 2) (toJSInt 3)
+  logJSInt =<< js_apply3 plusOne3 (toJSInt 2) (toJSInt 3) (toJSInt 4)
+  
diff --git a/testsuite/tests/javascript/js-callback02.stdout b/testsuite/tests/javascript/js-callback02.stdout
new file mode 100644
index 0000000000..a49c6e7eba
--- /dev/null
+++ b/testsuite/tests/javascript/js-callback02.stdout
@@ -0,0 +1,4 @@
+1
+3
+6
+10
diff --git a/testsuite/tests/javascript/js-callback03.hs b/testsuite/tests/javascript/js-callback03.hs
new file mode 100644
index 0000000000..311c2634f4
--- /dev/null
+++ b/testsuite/tests/javascript/js-callback03.hs
@@ -0,0 +1,33 @@
+import GHC.JS.Prim
+import GHC.JS.Foreign.Callback
+
+foreign import javascript "((f) => { globalF = f; })"
+  setF :: Callback (JSVal -> IO ()) -> IO ()
+
+foreign import javascript "((x) => { globalF(x); })"
+  callF :: JSVal -> IO ()
+
+foreign import javascript "((x,y) => { return x + y })"
+  js_plus :: JSVal -> JSVal -> IO JSVal
+
+foreign import javascript "((g) => { globalG = g; })"
+  setG :: Callback (JSVal -> JSVal -> IO JSVal) -> IO ()
+
+foreign import javascript "((x,y) => { return globalG(x,y); })"
+  callG :: JSVal -> JSVal -> IO JSVal
+
+main :: IO ()
+main = do
+  -- Set functions globally on the JavaScript side, to be accessed in regular JavaScript code
+  f <- syncCallback1 ThrowWouldBlock (\x -> if isNull x then putStrLn "isNull" else putStrLn "isNotNull")
+  g <- syncCallback2' js_plus
+  setF f
+  setG g
+
+  -- Do other things before using the globally-set functions
+  putStrLn "test"
+
+  -- Use the globally-set functions
+  callF jsNull
+  callF $ toJSString ""
+  print . fromJSInt =<< callG (toJSInt 1) (toJSInt 2)
diff --git a/testsuite/tests/javascript/js-callback03.stdout b/testsuite/tests/javascript/js-callback03.stdout
new file mode 100644
index 0000000000..cbce6a410b
--- /dev/null
+++ b/testsuite/tests/javascript/js-callback03.stdout
@@ -0,0 +1,4 @@
+test
+isNull
+isNotNull
+3
diff --git a/testsuite/tests/javascript/js-callback04.hs b/testsuite/tests/javascript/js-callback04.hs
new file mode 100644
index 0000000000..0aaffabc19
--- /dev/null
+++ b/testsuite/tests/javascript/js-callback04.hs
@@ -0,0 +1,16 @@
+import GHC.JS.Prim
+import GHC.JS.Foreign.Callback
+
+foreign import javascript "(() => { console.log('javascript'); })"
+  js_log :: IO ()
+
+foreign import javascript "((f) => { f(); })"
+  js_apply0_ :: Callback (IO ()) -> IO ()
+
+main :: IO ()
+main = do
+  logH <- syncCallback ThrowWouldBlock (putStrLn "haskell")
+  logJ <- syncCallback ThrowWouldBlock js_log
+
+  js_apply0_ logH
+  js_apply0_ logJ
diff --git a/testsuite/tests/javascript/js-callback04.stdout b/testsuite/tests/javascript/js-callback04.stdout
new file mode 100644
index 0000000000..175b931a71
--- /dev/null
+++ b/testsuite/tests/javascript/js-callback04.stdout
@@ -0,0 +1,2 @@
+haskell
+javascript
diff --git a/testsuite/tests/javascript/js-callback05.hs b/testsuite/tests/javascript/js-callback05.hs
new file mode 100644
index 0000000000..075b151b5c
--- /dev/null
+++ b/testsuite/tests/javascript/js-callback05.hs
@@ -0,0 +1,19 @@
+import GHC.JS.Prim
+import GHC.JS.Foreign.Callback
+import System.IO
+
+foreign import javascript "((f) => { f(); })"
+  js_apply0_ :: Callback (IO ()) -> IO ()
+
+main :: IO ()
+main = do
+  log <- syncCallback ThrowWouldBlock (putStrLn "test" >> hFlush stdout)
+  js_apply0_ log
+  js_apply0_ log
+  
+  log <- syncCallback ThrowWouldBlock (putStrLn "test1" >> hFlush stdout)
+  log <- syncCallback ThrowWouldBlock (putStrLn "test2" >> hFlush stdout)
+  log <- syncCallback ThrowWouldBlock (putStrLn "test3" >> hFlush stdout)
+  js_apply0_ log1
+  js_apply0_ log2
+  js_apply0_ log3
diff --git a/testsuite/tests/javascript/js-callback05.stdout b/testsuite/tests/javascript/js-callback05.stdout
new file mode 100644
index 0000000000..105f88e833
--- /dev/null
+++ b/testsuite/tests/javascript/js-callback05.stdout
@@ -0,0 +1,5 @@
+test
+test
+test1
+test2
+test3
diff --git a/testsuite/tests/javascript/js-ffi-array.hs b/testsuite/tests/javascript/js-ffi-array.hs
new file mode 100644
index 0000000000..00e1e80383
--- /dev/null
+++ b/testsuite/tests/javascript/js-ffi-array.hs
@@ -0,0 +1,18 @@
+import GHC.JS.Prim
+
+foreign import javascript "((xs) => { console.log(xs) })"
+  log_js :: JSVal -> IO ()
+
+foreign import javascript "((xs,i) => { return xs[i]; })"
+  js_index :: JSVal -> JSVal -> JSVal
+
+foreign import javascript "(() => { return ['t','e','s','t']; })"
+  an_array :: JSVal
+
+main :: IO ()
+main = do
+  log_js =<< toJSArray []
+  log_js =<< toJSArray [jsNull, toJSInt 0, toJSString "", toJSInt 1, toJSString "test", toJSInt 2]
+  xs <- toJSArray $ map toJSInt [1..10]
+  log_js $ js_index xs (toJSInt 3)
+  mapM_ log_js =<< fromJSArray an_array
diff --git a/testsuite/tests/javascript/js-ffi-array.stdout b/testsuite/tests/javascript/js-ffi-array.stdout
new file mode 100644
index 0000000000..463db3f694
--- /dev/null
+++ b/testsuite/tests/javascript/js-ffi-array.stdout
@@ -0,0 +1,7 @@
+[]
+[ null, 0, '', 1, 'test', 2 ]
+4
+t
+e
+s
+t
diff --git a/testsuite/tests/javascript/js-ffi-int.hs b/testsuite/tests/javascript/js-ffi-int.hs
new file mode 100644
index 0000000000..bb2effce98
--- /dev/null
+++ b/testsuite/tests/javascript/js-ffi-int.hs
@@ -0,0 +1,16 @@
+import GHC.JS.Prim
+
+foreign import javascript "((x) => { console.log(x); })"
+  log_js_int :: JSVal -> IO ()
+
+foreign import javascript "(() => { return 3; })"
+  an_int :: JSVal
+
+main :: IO ()
+main = do
+  log_js_int (toJSInt 0)
+  log_js_int (toJSInt 1)
+  log_js_int (toJSInt 2)
+  log_js_int an_int
+  print (fromJSInt an_int)
+  print (fromJSInt $ toJSInt 4)
diff --git a/testsuite/tests/javascript/js-ffi-int.stdout b/testsuite/tests/javascript/js-ffi-int.stdout
new file mode 100644
index 0000000000..ccbe3cc6c8
--- /dev/null
+++ b/testsuite/tests/javascript/js-ffi-int.stdout
@@ -0,0 +1,6 @@
+0
+1
+2
+3
+3
+4
diff --git a/testsuite/tests/javascript/js-ffi-isNull.hs b/testsuite/tests/javascript/js-ffi-isNull.hs
new file mode 100644
index 0000000000..cfc6329ca0
--- /dev/null
+++ b/testsuite/tests/javascript/js-ffi-isNull.hs
@@ -0,0 +1,10 @@
+import GHC.JS.Prim
+
+main :: IO ()
+main = do
+  print (isNull jsNull)
+  print (isNull $ toJSString "")
+  print (isNull $ toJSString "test")
+  print (isNull $ toJSInt 0)
+  print (isNull $ toJSInt 1)
+  print (isNull $ toJSInt 2)
diff --git a/testsuite/tests/javascript/js-ffi-isNull.stdout b/testsuite/tests/javascript/js-ffi-isNull.stdout
new file mode 100644
index 0000000000..6928e2fc8f
--- /dev/null
+++ b/testsuite/tests/javascript/js-ffi-isNull.stdout
@@ -0,0 +1,6 @@
+True
+False
+False
+False
+False
+False
diff --git a/testsuite/tests/javascript/js-ffi-isUndefined.hs b/testsuite/tests/javascript/js-ffi-isUndefined.hs
new file mode 100644
index 0000000000..29511d0276
--- /dev/null
+++ b/testsuite/tests/javascript/js-ffi-isUndefined.hs
@@ -0,0 +1,13 @@
+import GHC.JS.Prim
+
+foreign import javascript "((x) => { return undefined; })"
+  js_undefined :: JSVal
+
+main :: IO ()
+main = do
+  print (isUndefined js_undefined)
+  print (isUndefined $ toJSString "")
+  print (isUndefined $ toJSString "test")
+  print (isUndefined $ toJSInt 0)
+  print (isUndefined $ toJSInt 1)
+  print (isUndefined $ toJSInt 2)
diff --git a/testsuite/tests/javascript/js-ffi-isUndefined.stdout b/testsuite/tests/javascript/js-ffi-isUndefined.stdout
new file mode 100644
index 0000000000..6928e2fc8f
--- /dev/null
+++ b/testsuite/tests/javascript/js-ffi-isUndefined.stdout
@@ -0,0 +1,6 @@
+True
+False
+False
+False
+False
+False
diff --git a/testsuite/tests/javascript/js-ffi-null.hs b/testsuite/tests/javascript/js-ffi-null.hs
new file mode 100644
index 0000000000..3724ef7e44
--- /dev/null
+++ b/testsuite/tests/javascript/js-ffi-null.hs
@@ -0,0 +1,7 @@
+import GHC.JS.Prim
+
+foreign import javascript "((x) => { console.log(x); })"
+  log_null :: JSVal -> IO ()
+
+main :: IO ()
+main = log_null jsNull
diff --git a/testsuite/tests/javascript/js-ffi-null.stdout b/testsuite/tests/javascript/js-ffi-null.stdout
new file mode 100644
index 0000000000..19765bd501
--- /dev/null
+++ b/testsuite/tests/javascript/js-ffi-null.stdout
@@ -0,0 +1 @@
+null
diff --git a/testsuite/tests/javascript/js-ffi-string.hs b/testsuite/tests/javascript/js-ffi-string.hs
new file mode 100644
index 0000000000..9e9931e85f
--- /dev/null
+++ b/testsuite/tests/javascript/js-ffi-string.hs
@@ -0,0 +1,13 @@
+import GHC.JS.Prim
+
+foreign import javascript "((x) => { console.log(x); })"
+  log_js_string :: JSVal -> IO ()
+
+foreign import javascript "(() => { return 'a string'; })"
+  a_string :: JSVal
+
+main :: IO ()
+main = do
+  log_js_string (toJSString "test")
+  putStrLn (fromJSString a_string)
+  putStrLn (fromJSString $ toJSString "test")
diff --git a/testsuite/tests/javascript/js-ffi-string.stdout b/testsuite/tests/javascript/js-ffi-string.stdout
new file mode 100644
index 0000000000..9e68839698
--- /dev/null
+++ b/testsuite/tests/javascript/js-ffi-string.stdout
@@ -0,0 +1,3 @@
+test
+a string
+test