1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
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 ()
|
