fix Export and support Callbacks that return a value

Author: luite

GHCJS/Foreign/Callback.hs

@@ -4,14 +4,21 @@ module GHCJS.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           GHCJS.Concurrent
@@ -88,7 +95,27 @@ syncCallback3 :: OnBlocked                               -- ^ what to do when th
               -> 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.
@@ -118,11 +145,16 @@ foreign import javascript unsafe "h$makeCallback(h$runSync, [$1], $2)"
   js_syncCallback :: Bool -> Exts.Any -> IO (Callback (IO b))
 foreign import javascript unsafe "h$makeCallback(h$run, [], $1)"
   js_asyncCallback :: Exts.Any -> IO (Callback (IO b))
+foreign import javascript unsafe "h$makeCallback(h$runSyncReturn, [false], $1)"
+  js_syncCallbackReturn :: Exts.Any -> IO (Callback (IO JSVal))
 
 foreign import javascript unsafe "h$makeCallbackApply($2, h$runSync, [$1], $3)"
   js_syncCallbackApply :: Bool -> Int -> Exts.Any -> IO (Callback b)
 foreign import javascript unsafe "h$makeCallbackApply($1, h$run, [], $2)"
   js_asyncCallbackApply :: Int -> Exts.Any -> IO (Callback b)
+foreign import javascript unsafe
+  "h$makeCallbackApply($1, h$runSyncReturn, [false], $2)"
+  js_syncCallbackApplyReturn :: Int -> Exts.Any -> IO (Callback b)
 
 foreign import javascript unsafe "h$release"
   js_release :: Callback a -> IO ()

GHCJS/Foreign/Export.hs

@@ -6,7 +6,6 @@
 {-# LANGUAGE UnboxedTuples #-}
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE EmptyDataDecls #-}
-{-# LANGUAGE CPP #-}
 
 {- | 
      Dynamically export Haskell values to JavaScript
@@ -68,7 +67,7 @@ derefExport e = do
   r <- js_derefExport w1 w2 e
   if isNull r
     then return Nothing
-    else unsafeCoerce <$> js_toHeapObject r
+    else Just . unsafeCoerce <$> js_toHeapObject r
 
 {- |
      Release all memory associated with the export. Subsequent calls to
@@ -86,8 +85,7 @@ foreign import javascript unsafe
   "h$derefExport"
   js_derefExport :: Word64 -> Word64 -> Export a -> IO JSVal
 foreign import javascript unsafe
-  "$r = $1;" js_toHeapObject :: JSVal -> IO Exts.Any
-
+  "$r = $1;" js_toHeapObject :: JSVal -> IO Any
 foreign import javascript unsafe
   "h$releaseExport"
   js_releaseExport :: Export a -> IO ()

GHCJS/Types.hs

@@ -6,6 +6,8 @@
 {-# LANGUAGE JavaScriptFFI #-}
 
 module GHCJS.Types ( JSVal
+                   , WouldBlockException(..)
+                   , JSException(..)
                    , IsJSVal
                    , jsval
                    , isNull