diff options
Diffstat (limited to 'libraries/base')
| -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 5436c10c14..76018c2016 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. |