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

3 files changed, 153 insertions, 4 deletions

diff --git a/libraries/base/GHC/JS/Foreign/Callback.hs b/libraries/base/GHC/JS/Foreign/Callback.hs
new file mode 100644
index 0000000000..e40c9257b4
--- /dev/null
+++ b/libraries/base/GHC/JS/Foreign/Callback.hs
@@ -0,0 +1,149 @@
+module GHC.JS.Foreign.Callback
+    ( Callback
+    , OnBlocked(..)
+    , releaseCallback
+      -- * asynchronous callbacks
+    , asyncCallback
+    , asyncCallback1
+    , asyncCallback2
+    , asyncCallback3
+      -- * synchronous callbacks
+    , syncCallback
+    , syncCallback1
+    , syncCallback2
+    , syncCallback3
+      -- * synchronous callbacks that return a value
+    , syncCallback'
+    , syncCallback1'
+    , syncCallback2'
+    , syncCallback3'
+    ) where
+
+import           GHC.JS.Prim
+
+import qualified GHC.Exts as Exts
+
+import           Data.Typeable
+
+import           Unsafe.Coerce
+
+data OnBlocked = ContinueAsync | ThrowWouldBlock deriving (Eq)
+
+newtype Callback a = Callback JSVal deriving Typeable
+
+{- |
+     When you create a callback, the Haskell runtime stores a reference to
+     the exported IO action or function. This means that all data referenced by the
+     exported value stays in memory, even if nothing outside the Haskell runtime
+     holds a reference to to callback.
+     Use 'releaseCallback' to free the reference. Subsequent calls from JavaScript
+     to the callback will result in an exception.
+ -}
+releaseCallback :: Callback a -> IO ()
+releaseCallback x = js_release x
+
+{- | Make a callback (JavaScript function) that runs the supplied IO action in a synchronous
+     thread when called.
+     Call 'releaseCallback' when done with the callback, freeing memory referenced
+     by the IO action.
+ -}
+syncCallback :: OnBlocked                               -- ^ what to do when the thread blocks
+             -> IO ()                                   -- ^ the Haskell action
+             -> IO (Callback (IO ()))                   -- ^ the callback
+syncCallback onBlocked x = js_syncCallback (onBlocked == ContinueAsync) (unsafeCoerce x)
+
+
+{- | Make a callback (JavaScript function) that runs the supplied IO function in a synchronous
+     thread when called. The callback takes one argument that it passes as a JSVal value to
+     the Haskell function.
+     Call 'releaseCallback' when done with the callback, freeing data referenced
+     by the function.
+ -}
+syncCallback1 :: OnBlocked                             -- ^ what to do when the thread blocks
+              -> (JSVal -> IO ())                      -- ^ the Haskell function
+              -> IO (Callback (JSVal -> IO ()))        -- ^ the callback
+syncCallback1 onBlocked x = js_syncCallbackApply (onBlocked == ContinueAsync) 1 (unsafeCoerce x)
+
+
+{- | Make a callback (JavaScript function) that runs the supplied IO function in a synchronous
+     thread when called. The callback takes two arguments that it passes as JSVal values to
+     the Haskell function.
+     Call 'releaseCallback' when done with the callback, freeing data referenced
+     by the function.
+ -}
+syncCallback2 :: OnBlocked                               -- ^ what to do when the thread blocks
+              -> (JSVal -> JSVal -> IO ())               -- ^ the Haskell function
+              -> IO (Callback (JSVal -> JSVal -> IO ())) -- ^ the callback
+syncCallback2 onBlocked x = js_syncCallbackApply (onBlocked == ContinueAsync) 2 (unsafeCoerce x)
+
+{- | Make a callback (JavaScript function) that runs the supplied IO function in a synchronous
+     thread when called. The callback takes three arguments that it passes as JSVal values to
+     the Haskell function.
+     Call 'releaseCallback' when done with the callback, freeing data referenced
+     by the function.
+ -}
+syncCallback3 :: OnBlocked                               -- ^ what to do when the thread blocks
+              -> (JSVal -> JSVal -> JSVal -> IO ())               -- ^ the Haskell function
+              -> IO (Callback (JSVal -> JSVal -> JSVal -> IO ())) -- ^ the callback
+syncCallback3 onBlocked x = js_syncCallbackApply (onBlocked == ContinueAsync) 3 (unsafeCoerce x)
+
+{- | Make a callback (JavaScript function) that runs the supplied IO action in a synchronous
+     thread when called.
+     Call 'releaseCallback' when done with the callback, freeing memory referenced
+     by the IO action.
+ -}
+syncCallback' :: IO JSVal
+              -> IO (Callback (IO JSVal))
+syncCallback' x = js_syncCallbackReturn (unsafeCoerce x)
+
+syncCallback1' :: (JSVal -> IO JSVal)
+               -> IO (Callback (JSVal -> IO JSVal))
+syncCallback1' x = js_syncCallbackApplyReturn 1 (unsafeCoerce x)
+
+syncCallback2' :: (JSVal -> JSVal -> IO JSVal)
+               -> IO (Callback (JSVal -> JSVal -> IO JSVal))
+syncCallback2' x = js_syncCallbackApplyReturn 2 (unsafeCoerce x)
+
+syncCallback3' :: (JSVal -> JSVal -> JSVal -> IO JSVal)
+               -> IO (Callback (JSVal -> JSVal -> JSVal -> IO JSVal))
+syncCallback3' x = js_syncCallbackApplyReturn 3 (unsafeCoerce x)
+
+{- | Make a callback (JavaScript function) that runs the supplied IO action in an asynchronous
+     thread when called.
+     Call 'releaseCallback' when done with the callback, freeing data referenced
+     by the IO action.
+ -}
+asyncCallback :: IO ()              -- ^ the action that the callback runs
+              -> IO (Callback (IO ())) -- ^ the callback
+asyncCallback x = js_asyncCallback (unsafeCoerce x)
+
+asyncCallback1 :: (JSVal -> IO ())            -- ^ the function that the callback calls
+               -> IO (Callback (JSVal -> IO ())) -- ^ the calback
+asyncCallback1 x = js_asyncCallbackApply 1 (unsafeCoerce x)
+
+asyncCallback2 :: (JSVal -> JSVal -> IO ())            -- ^ the Haskell function that the callback calls
+               -> IO (Callback (JSVal -> JSVal -> IO ())) -- ^ the callback
+asyncCallback2 x = js_asyncCallbackApply 2 (unsafeCoerce x)
+
+asyncCallback3 :: (JSVal -> JSVal -> JSVal -> IO ())               -- ^ the Haskell function that the callback calls
+               -> IO (Callback (JSVal -> JSVal -> JSVal -> IO ())) -- ^ the callback
+asyncCallback3 x = js_asyncCallbackApply 3 (unsafeCoerce x)
+
+-- ----------------------------------------------------------------------------
+
+foreign import javascript unsafe "(($1, $2) => { return h$makeCallback(h$runSync, [$1], $2); })"
+  js_syncCallback :: Bool -> Exts.Any -> IO (Callback (IO b))
+foreign import javascript unsafe "(($1) => { return h$makeCallback(h$run, [], $1); })"
+  js_asyncCallback :: Exts.Any -> IO (Callback (IO b))
+foreign import javascript unsafe "(($1) => { return h$makeCallback(h$runSyncReturn, [false], $1); })"
+  js_syncCallbackReturn :: Exts.Any -> IO (Callback (IO JSVal))
+
+foreign import javascript unsafe "(($1, $2, $3) => { return h$makeCallbackApply($2, h$runSync, [$1], $3); })"
+  js_syncCallbackApply :: Bool -> Int -> Exts.Any -> IO (Callback b)
+foreign import javascript unsafe "(($1, $2) => { return h$makeCallbackApply($1, h$run, [], $2); })"
+  js_asyncCallbackApply :: Int -> Exts.Any -> IO (Callback b)
+foreign import javascript unsafe "(($1, $2) => { return h$makeCallbackApply($1, h$runSyncReturn, [false], $2); })"
+  js_syncCallbackApplyReturn :: Int -> Exts.Any -> IO (Callback b)
+
+foreign import javascript unsafe "(($1) => { return h$release($1); })"
+  js_release :: Callback a -> IO ()
diff --git a/libraries/base/GHC/JS/Prim.hs b/libraries/base/GHC/JS/Prim.hs
index 955cadf328..c8160a93c8 100644
--- a/libraries/base/GHC/JS/Prim.hs
+++ b/libraries/base/GHC/JS/Prim.hs
@@ -277,13 +277,13 @@ foreign import javascript unsafe "(($1) => { return ($1 === null); })"
 foreign import javascript unsafe "(($1) => { return ($1 === undefined); })"
   js_isUndefined :: JSVal -> Bool
 
-foreign import javascript unsafe "(($1) => { return ($r = typeof($1) === 'number' ? ($1|0) : 0;); })"
+foreign import javascript unsafe "(($1) => { return (typeof($1) === 'number' ? ($1|0) : 0); })"
   js_fromJSInt :: JSVal -> Int
 
-foreign import javascript unsafe "(($1) => { return ($r = $1;); })"
+foreign import javascript unsafe "(($1) => { return $1; })"
   js_toJSInt :: Int -> JSVal
 
-foreign import javascript unsafe "$r = null;"
+foreign import javascript unsafe "(() => { return null; })"
   js_null :: JSVal
 
 foreign import javascript unsafe "(($1,$2) => { return $1[h$fromHsString($2)]; })"
@@ -307,7 +307,6 @@ foreign import javascript unsafe "(($1,$2_1,$2_2) => { return $1[h$decodeUtf8z($
 foreign import javascript unsafe "(($1_1,$1_2) => { return h$decodeUtf8z($1_1, $1_2); })"
   js_unpackJSStringUtf8## :: Addr# -> State# s -> (# State# s, JSVal# #)
 
-
 foreign import javascript unsafe "(($1_1, $1_2) => { return h$decodeUtf8z($1_1,$1_2); })"
   js_unsafeUnpackJSStringUtf8## :: Addr# -> JSVal#
 
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index fa329b9213..2cde69b3df 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -475,6 +475,7 @@ Library
             GHC.JS.Prim
             GHC.JS.Prim.Internal
             GHC.JS.Prim.Internal.Build
+            GHC.JS.Foreign.Callback
 
     -- We need to set the unit id to base (without a version number)
     -- as it's magic.