Implement promises

packages/promise/js/dune

@@ -0,0 +1,7 @@
+(library
+ (name promise_js)
+ (public_name server-reason-react.promise-js)
+ (modes melange)
+ (libraries melange.js melange.belt)
+ (preprocess
+  (pps melange.ppx)))

packages/promise/js/promise.re

@@ -0,0 +1,95 @@
+/* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
+
+/** Specialized bindings to Promise. Note: For simplicity,
+    this binding does not track the error type, it treat it as an opaque type
+    {[
+
+    ]}
+*/;
+
+type t(+'a);
+type error;
+
+[@bs.new]
+external make:
+  (
+  [@bs.uncurry]
+  ((~resolve: (. 'a) => unit, ~reject: (. exn) => unit) => unit)
+  ) =>
+  t('a) =
+  "Promise";
+
+/* [make (fun resolve reject -> .. )] */
+[@bs.val] [@bs.scope "Promise"] external resolve: 'a => t('a) = "resolve";
+[@bs.val] [@bs.scope "Promise"] external reject: exn => t('a) = "reject";
+
+[@bs.val] [@bs.scope "Promise"]
+external all: array(t('a)) => t(array('a)) = "all";
+
+[@bs.val] [@bs.scope "Promise"]
+external all2: ((t('a0), t('a1))) => t(('a0, 'a1)) = "all";
+
+[@bs.val] [@bs.scope "Promise"]
+external all3: ((t('a0), t('a1), t('a2))) => t(('a0, 'a1, 'a2)) = "all";
+
+[@bs.val] [@bs.scope "Promise"]
+external all4:
+  ((t('a0), t('a1), t('a2), t('a3))) => t(('a0, 'a1, 'a2, 'a3)) =
+  "all";
+
+[@bs.val] [@bs.scope "Promise"]
+external all5:
+  ((t('a0), t('a1), t('a2), t('a3), t('a4))) =>
+  t(('a0, 'a1, 'a2, 'a3, 'a4)) =
+  "all";
+
+[@bs.val] [@bs.scope "Promise"]
+external all6:
+  ((t('a0), t('a1), t('a2), t('a3), t('a4), t('a5))) =>
+  t(('a0, 'a1, 'a2, 'a3, 'a4, 'a5)) =
+  "all";
+
+[@bs.val] [@bs.scope "Promise"]
+external race: array(t('a)) => t('a) = "race";
+
+[@bs.send.pipe: t('a)]
+external then_: ([@bs.uncurry] ('a => t('b))) => t('b) = "then";
+
+[@bs.send.pipe: t('a)]
+external catch: ([@bs.uncurry] (error => t('a))) => t('a) = "catch";
+/* [ p|> catch handler]
+       Note in JS the returned promise type is actually runtime dependent,
+       if promise is rejected, it will pick the [handler] otherwise the original promise,
+       to make it strict we enforce reject handler
+       https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Promise/catch
+   */
+
+/*
+ let errorAsExn (x :  error) (e  : (exn ->'a option))=
+   if Caml_exceptions.isCamlExceptionOrOpenVariant (Obj.magic x ) then
+      e (Obj.magic x)
+   else None
+ [%bs.error?  ]
+ */

packages/promise/js/promise.rei

@@ -0,0 +1,29 @@
+type t(+'a);
+type error;
+
+let make:
+  ((~resolve: (. 'a) => unit, ~reject: (. exn) => unit) => unit) => t('a);
+
+let resolve: 'a => t('a);
+let reject: exn => t('a);
+
+let all: array(t('a)) => t(array('a));
+
+let all2: ((t('a0), t('a1))) => t(('a0, 'a1));
+
+let all3: ((t('a0), t('a1), t('a2))) => t(('a0, 'a1, 'a2));
+
+let all4: ((t('a0), t('a1), t('a2), t('a3))) => t(('a0, 'a1, 'a2, 'a3));
+
+let all5:
+  ((t('a0), t('a1), t('a2), t('a3), t('a4))) =>
+  t(('a0, 'a1, 'a2, 'a3, 'a4));
+
+let all6:
+  ((t('a0), t('a1), t('a2), t('a3), t('a4), t('a5))) =>
+  t(('a0, 'a1, 'a2, 'a3, 'a4, 'a5));
+
+let race: array(t('a)) => t('a);
+
+let then_: ('a => t('b), t('a)) => t('b);
+let catch: (error => t('a), t('a)) => t('a);

packages/promise/native/dune

@@ -0,0 +1,7 @@
+(library
+ (name promise_native)
+ (public_name server-reason-react.promise-native)
+ (wrapped false)
+ (libraries lwt server-reason-react.js server-reason-react.belt)
+ (preprocess
+  (pps lwt_ppx)))

packages/promise/native/promise.re

@@ -0,0 +1,65 @@
+type t(+'a) = Lwt.t('a);
+type error = exn;
+
+let make =
+    (fn: (~resolve: 'a => unit, ~reject: exn => unit) => unit): Lwt.t('a) => {
+  let (promise, resolver) = Lwt.task();
+  let resolve = value => Lwt.wakeup_later(resolver, value);
+  let reject = exn => Lwt.wakeup_later_exn(resolver, exn);
+  fn(~resolve, ~reject);
+  promise;
+};
+
+let resolve = Lwt.return;
+let reject = Lwt.fail;
+
+let all = (promises: array(Lwt.t('a))): Lwt.t(array('a)) =>
+  Lwt.map(Array.of_list, Lwt.all(Array.to_list(promises)));
+
+let all2 = ((a, b)) => {
+  let%lwt res_a = a;
+  let%lwt res_b = b;
+  Lwt.return((res_a, res_b));
+};
+
+let all3 = ((a, b, c)) => {
+  let%lwt res_a = a;
+  let%lwt res_b = b;
+  let%lwt res_c = c;
+  Lwt.return((res_a, res_b, res_c));
+};
+
+let all4 = ((a, b, c, d)) => {
+  let%lwt res_a = a;
+  let%lwt res_b = b;
+  let%lwt res_c = c;
+  let%lwt res_d = d;
+  Lwt.return((res_a, res_b, res_c, res_d));
+};
+
+let all5 = ((a, b, c, d, e)) => {
+  let%lwt res_a = a;
+  let%lwt res_b = b;
+  let%lwt res_c = c;
+  let%lwt res_d = d;
+  let%lwt res_e = e;
+  Lwt.return((res_a, res_b, res_c, res_d, res_e));
+};
+
+let all6 = ((a, b, c, d, e, f)) => {
+  let%lwt res_a = a;
+  let%lwt res_b = b;
+  let%lwt res_c = c;
+  let%lwt res_d = d;
+  let%lwt res_e = e;
+  let%lwt res_f = f;
+  Lwt.return((res_a, res_b, res_c, res_d, res_e, res_f));
+};
+
+let race = (promises: array(Lwt.t('a))): Lwt.t('a) =>
+  Lwt.pick(Array.to_list(promises));
+
+let then_ = (p, fn) => Lwt.bind(fn, p);
+let catch = (handler: exn => Lwt.t('a), promise: Lwt.t('a)): Lwt.t('a) => {
+  Lwt.catch(() => promise, handler);
+};

packages/promise/native/promise.rei

@@ -0,0 +1,29 @@
+type t(+'a);
+type error;
+
+let make:
+  ((~resolve: (. 'a) => unit, ~reject: (. exn) => unit) => unit) => t('a);
+
+let resolve: 'a => t('a);
+let reject: exn => t('a);
+
+let all: array(t('a)) => t(array('a));
+
+let all2: ((t('a0), t('a1))) => t(('a0, 'a1));
+
+let all3: ((t('a0), t('a1), t('a2))) => t(('a0, 'a1, 'a2));
+
+let all4: ((t('a0), t('a1), t('a2), t('a3))) => t(('a0, 'a1, 'a2, 'a3));
+
+let all5:
+  ((t('a0), t('a1), t('a2), t('a3), t('a4))) =>
+  t(('a0, 'a1, 'a2, 'a3, 'a4));
+
+let all6:
+  ((t('a0), t('a1), t('a2), t('a3), t('a4), t('a5))) =>
+  t(('a0, 'a1, 'a2, 'a3, 'a4, 'a5));
+
+let race: array(t('a)) => t('a);
+
+let then_: ('a => t('b), t('a)) => t('b);
+let catch: (error => t('a), t('a)) => t('a);

packages/promise/test/dune

@@ -0,0 +1,6 @@
+(test
+ (name test)
+ (modules :standard)
+ (libraries fmt lwt alcotest alcotest-lwt promise_native)
+ (preprocess
+  (pps lwt_ppx)))

packages/promise/test/test.ml

@@ -0,0 +1,67 @@
+let assert_string left right =
+  Alcotest.check Alcotest.string "should be equal" right left
+
+let assert_list ty left right =
+  Alcotest.check (Alcotest.list ty) "should be equal" right left
+
+let assert_array ty left right =
+  Alcotest.check (Alcotest.array ty) "should be equal" right left
+
+let assert_array_int = assert_array Alcotest.int
+let case title fn = Alcotest_lwt.test_case title `Quick fn
+let promise_to_lwt (p : 'a Promise.t) : 'a Lwt.t = Obj.magic p
+
+let resolve _switch () =
+  let value = "hi" in
+  let resolved = Promise.resolve value in
+  resolved |> promise_to_lwt |> Lwt.map (assert_string value)
+
+let all _switch () =
+  let p0 = Promise.make (fun ~resolve ~reject:_ -> resolve 5) in
+  let p1 = Promise.make (fun ~resolve ~reject:_ -> resolve 10) in
+  let resolved = Promise.all [| p0; p1 |] in
+  resolved |> promise_to_lwt |> Lwt.map (assert_array_int [| 5; 10 |])
+
+let set_timeout callback delay =
+  let _ =
+    Lwt.async (fun () ->
+        let%lwt () = Lwt_unix.sleep delay in
+        callback ();
+        Lwt.return ())
+  in
+  ()
+
+let all_async _switch () =
+  let p0 =
+    Promise.make (fun ~resolve ~reject:_ ->
+        set_timeout (fun () -> resolve 5) 0.5)
+  in
+  let p1 =
+    Promise.make (fun ~resolve ~reject:_ ->
+        set_timeout (fun () -> resolve 99) 0.3)
+  in
+  let resolved = Promise.all [| p0; p1 |] in
+  resolved |> promise_to_lwt |> Lwt.map (assert_array_int [| 5; 99 |])
+
+let race_async _switch () =
+  let p0 =
+    Promise.make (fun ~resolve ~reject:_ ->
+        set_timeout (fun () -> resolve "second") 0.5)
+  in
+  let p1 =
+    Promise.make (fun ~resolve ~reject:_ ->
+        set_timeout (fun () -> resolve "first") 0.3)
+  in
+  let resolved = Promise.race [| p0; p1 |] in
+  resolved |> promise_to_lwt |> Lwt.map (assert_string "first")
+
+let tests =
+  ( "Promise",
+    [
+      case "resolve" resolve;
+      case "all" all;
+      case "all_async" all_async;
+      case "race_async" race_async;
+    ] )
+
+let () = Alcotest_lwt.run "Promise" [ tests ] |> Lwt_main.run