Merge https://github.com/ghcjs/ghcjs-base

Author: achirkin

Data/JSString/RegExp.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE GHCForeignImportPrim #-}
 {-# LANGUAGE UnliftedFFITypes #-}
 {-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE MagicHash #-}
 
 module Data.JSString.RegExp ( RegExp
@@ -38,9 +39,11 @@ data Match = Match { matched       :: !JSString  -- ^ the matched string
                    }
 
 create :: REFlags -> JSString -> RegExp
-create flags pat = js_createRE (multiline flags)
-                               (ignoreCase flags)
-                               pat
+create flags pat = js_createRE pat flags'
+  where
+    flags' | multiline flags = if ignoreCase flags then "mi" else "m"
+           | otherwise       = if ignoreCase flags then "i"  else ""
+{-# INLINE create #-}
 
 pattern :: RegExp -> JSString
 pattern re = js_pattern re
@@ -51,8 +54,6 @@ isMultiline re = js_isMultiline re
 isIgnoreCase :: RegExp -> Bool
 isIgnoreCase re = js_isIgnoreCase re
 
-{-# INLINE create #-}
-
 test :: JSString -> RegExp -> Bool
 test x re = js_test x re
 {-# INLINE test #-}
@@ -93,7 +94,7 @@ splitN (I# k) x r = unsafeCoerce (js_split k x r)
 -- ----------------------------------------------------------------------------
 
 foreign import javascript unsafe
-  "new RegExp($1,$2,$3)" js_createRE :: Bool -> Bool -> JSString -> RegExp
+  "new RegExp($1,$2)" js_createRE :: JSString -> JSString -> RegExp
 foreign import javascript unsafe
   "$2.test($1)" js_test :: JSString -> RegExp -> Bool
 foreign import javascript unsafe

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
@@ -30,8 +29,10 @@ import Unsafe.Coerce
 import qualified GHC.Exts as Exts
 
 import GHCJS.Prim
+import GHCJS.Types
 
-type Export a = JSVal
+newtype Export a = Export JSVal
+instance IsJSVal (Export a)
 
 {- |
      Export any Haskell value to a JavaScript reference without evaluating it.
@@ -66,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
@@ -82,10 +83,9 @@ foreign import javascript unsafe
   js_export :: Word64 -> Word64 -> Any -> IO (Export a)
 foreign import javascript unsafe
   "h$derefExport"
-  js_derefExport :: Word64 -> Word64 -> JSVal -> IO JSVal
+  js_derefExport :: Word64 -> Word64 -> Export a -> IO JSVal
 foreign import javascript unsafe
-  "$r = $1;" js_toHeapObject :: JSVal -> Exts.Any
-
+  "$r = $1;" js_toHeapObject :: JSVal -> IO Any
 foreign import javascript unsafe
   "h$releaseExport"
-  js_releaseExport :: JSVal -> IO ()
+  js_releaseExport :: Export a -> IO ()

GHCJS/Types.hs

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

JavaScript/Web/MessageEvent.hs

@@ -4,6 +4,7 @@
   #-}
 
 module JavaScript.Web.MessageEvent ( MessageEvent
+                                   , getData
                                    , MessageEventData(..)
                                    ) where
 
@@ -38,6 +39,5 @@ getData me = case js_getData me of
 
 foreign import javascript unsafe
   "$r2 = $1.data;\
-  \$r1 = typeof $r2 === 'string' ? 1 : ($r2 instanceof ArrayBuffer ? 2 : 3"
+  \$r1 = typeof $r2 === 'string' ? 1 : ($r2 instanceof ArrayBuffer ? 2 : 3)"
   js_getData :: MessageEvent -> (# Int#, JSVal #)
-

jsbits/export.js

@@ -1,24 +1,26 @@
 function h$exportValue(fp1a,fp1b,fp2a,fp2b,o) {
-    var e = { fp1a: fp1a
-            , fp1b: fp1b
-            , fp2a: fp2a
-            , fp2b: fp2b
-            , root: o
-	        , _key: -1
-            };
-    h$retain(e);
-    return e;
+  var e = { fp1a: fp1a
+          , fp1b: fp1b
+          , fp2a: fp2a
+          , fp2b: fp2b
+          , released: false
+          , root: o
+          , _key: -1
+          };
+  h$retain(e);
+  return e;
 }
 
 function h$derefExport(fp1a,fp1b,fp2a,fp2b,e) {
-    if(!e || typeof e !== 'object') return null;
-    if(!e.root) return null;
-    if(fp1a !== e.fp1a || fp1b !== e.fp1b ||
-       fp2a !== e.fp2a || fp2b !== e.fp2b) return null;
-    return e.root;
+  if(!e || typeof e !== 'object') return null;
+  if(e.released) return null;
+  if(fp1a !== e.fp1a || fp1b !== e.fp1b ||
+     fp2a !== e.fp2a || fp2b !== e.fp2b) return null;
+  return e.root;
 }
 
 function h$releaseExport(e) {
-    h$release(e);
-    e.root = null;
+  h$release(e);
+  e.released = true;
+  e.root     = null;
 }

jsbits/text.js

@@ -37,11 +37,12 @@ function h$textFromString(s) {
 
 function h$lazyTextToString(txt) {
     var s = '';
-    while(CONSTR_TAG(txt) === 2) {
-	var h = LAZY_TEXT_CHUNK_HEAD(txt);
-	s += h$textToString(TEXT_ARR(h), TEXT_OFF(h), TEXT_LEN(h));
-	txt = LAZY_TEXT_CHUNK_TAIL(txt);
+    while(LAZY_TEXT_IS_CHUNK(txt)) {
+        var head = LAZY_TEXT_CHUNK_HEAD(txt);
+        s  += h$textToString(DATA_TEXT_ARRAY(head), DATA_TEXT_OFFSET(head), DATA_TEXT_LENGTH(head));
+        txt = LAZY_TEXT_CHUNK_TAIL(txt);
     }
+    return s;
 }
 
 function h$safeTextFromString(x) {