Update promise handling code for jsffi

ghcjs · Aug 15, 2017 · 205e5d4 · 205e5d4
1 parent 187b83e
commit 205e5d4
Show file tree

Hide file tree

Showing 2 changed files with 15 additions and 3 deletions.
diff --git a/Common.hs b/Common.hs
@@ -1063,7 +1063,9 @@ tyRet' _ _ ffi (I.TyApply _ (I.TyInteger LongLong)) _ | ffi = mkTIdent "Double"
 tyRet' _ _ _ (I.TyApply _ (I.TyInteger _)) _ = mkTIdent "Int"
 tyRet' _ _ _ (I.TyObject) _ = mkTIdent "GObject"
 tyRet' _ _ _ (I.TyAny) _ = mkTIdent "JSVal"
-tyRet' pname enums ffi (I.TyPromise t) ext = tyRet' pname enums ffi t ext
+tyRet' pname enums True (I.TyPromise I.TyVoid) ext = mkTIdent "JSVal"
+tyRet' pname enums True (I.TyPromise t) ext = H.HsTyTuple [mkTIdent "JSVal", tyRet' pname enums True t ext]
+tyRet' pname enums False (I.TyPromise t) ext = tyRet' pname enums False t ext
 tyRet' pname enums ffi (I.TySum t) ext = mkTIdent (sumType t)
 tyRet' pname enums ffi (I.TyRecord (I.TyName a _) (I.TyName b _)) ext = H.HsTyApp (H.HsTyApp (mkTIdent "Record") (mkTIdent $ typeFor a)) (mkTIdent $ typeFor b)
 --tyRet' _ enums True (I.TyOptional (I.TyInteger LongLong)) _ = H.HsTyApp (mkTIdent "Nullable") (mkTIdent "Double")

diff --git a/domconv-webkit-jsffi.hs b/domconv-webkit-jsffi.hs
@@ -1376,7 +1376,17 @@ returnType _ (I.TyOptional _) _ _ e =
 --            _ -> error "Issue with wrapType?")
 --          (H.HsQVarOp (mkSymbol "<$>"))
 --          (H.HsParen e)
-returnType enums (I.TyPromise t) ext wrapType e = returnType enums t ext wrapType e
+returnType enums (I.TyPromise I.TyVoid) ext wrapType e =
+        H.HsInfixApp
+          (H.HsParen e)
+          (H.HsQVarOp (mkSymbol ">>="))
+          (mkVar "maybeThrowPromiseRejected")
+returnType enums (I.TyPromise t) ext wrapType e =
+        returnType enums t ext wrapType $
+            H.HsInfixApp
+              (H.HsParen e)
+              (H.HsQVarOp (mkSymbol ">>="))
+              (mkVar "checkPromiseResult")
 --returnType _ (I.TySum _) _ _ e =
 --        H.HsInfixApp
 --          (H.HsParen e)
@@ -1391,7 +1401,7 @@ returnType _ _ _ _ e = e
 
 jsReturn :: I.Type -> JExpr -> String
 jsReturn (I.TyName "Bool" Nothing) e = show $ renderJs [jmacroE| `(e)`?1:0 |]
-jsReturn (I.TyPromise _) e = show $ renderJs [jmacro| `(e)`.then($c); |]
+jsReturn (I.TyPromise _) e = show (renderJs [jmacroE| `(e)` |]) <> ".then(function(s) { $c(null, s);}, function(e) { $c(e, null);});"
 jsReturn _ e = show $ renderJs e
 
 gtkName s =