diff options
author | Josh Meredith <joshmeredith2008@gmail.com> | 2023-03-06 09:18:03 +0000 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2023-04-13 08:51:09 -0400 |
commit | 27d2978e5412f2bef4448e208182a03137dd5ee8 (patch) | |
tree | 0e98a70f487c9c06061d92338de6fd9da593d3f6 /libraries | |
parent | 8af401ccfbe28d7bbfc493c0097834e9c66a36b0 (diff) | |
download | haskell-27d2978e5412f2bef4448e208182a03137dd5ee8.tar.gz |
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
Diffstat (limited to 'libraries')
-rw-r--r-- | libraries/base/GHC/JS/Foreign/Callback.hs | 149 | ||||
-rw-r--r-- | libraries/base/GHC/JS/Prim.hs | 7 | ||||
-rw-r--r-- | libraries/base/base.cabal | 1 |
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. |