From 57869b9e86561f5890e42a2d0b8ff15385a41085 Mon Sep 17 00:00:00 2001 From: David Sancho Moreno Date: Mon, 14 Aug 2023 12:03:49 +0200 Subject: [PATCH] Vendor aantron/promise under packages/promise --- packages/js/dune | 8 +- packages/js/js.ml | 60 +- packages/js/test.ml | 74 ++- packages/promise/js/promise.re | 457 +++++++++++--- packages/promise/js/promise.rei | 206 ++++++- packages/promise/native/mutableList.re | 112 ++++ packages/promise/native/mutableList.rei | 22 + packages/promise/native/promise.re | 772 ++++++++++++++++++++++-- packages/promise/native/promise.rei | 219 ++++++- packages/promise/test/dune | 6 - packages/promise/test/test.ml | 67 -- server-reason-react.opam | 3 +- 12 files changed, 1744 insertions(+), 262 deletions(-) create mode 100644 packages/promise/native/mutableList.re create mode 100644 packages/promise/native/mutableList.rei delete mode 100644 packages/promise/test/dune delete mode 100644 packages/promise/test/test.ml diff --git a/packages/js/dune b/packages/js/dune index 2e98eaba1..52c8ae2fe 100644 --- a/packages/js/dune +++ b/packages/js/dune @@ -3,9 +3,13 @@ (modules js) (public_name server-reason-react.js) (flags :standard -w -49) - (libraries pcre promise)) + (libraries pcre lwt) + (preprocess + (pps lwt_ppx))) (test (name test) (modules test) - (libraries alcotest server-reason-react.js)) + (libraries alcotest alcotest-lwt lwt server-reason-react.js) + (preprocess + (pps lwt_ppx))) diff --git a/packages/js/js.ml b/packages/js/js.ml index 4ac98a6c7..246d7c5a6 100644 --- a/packages/js/js.ml +++ b/packages/js/js.ml @@ -900,7 +900,65 @@ module String2 = struct end module Promise = struct - include Promise + type +'a t = 'a Lwt.t + type error = exn + + let make (fn : resolve:('a -> unit) -> reject:(exn -> unit) -> unit) : + 'a Lwt.t = + let promise, resolver = Lwt.task () in + let resolve value = Lwt.wakeup_later resolver value in + let reject exn = Lwt.wakeup_later_exn resolver exn in + fn ~resolve ~reject; + promise + + let resolve = Lwt.return + let reject = Lwt.fail + + let all (promises : 'a Lwt.t array) : 'a array Lwt.t = + Lwt.map Stdlib.Array.of_list (Lwt.all (Stdlib.Array.to_list promises)) + + let all2 (a, b) = + let%lwt res_a = a in + let%lwt res_b = b in + Lwt.return (res_a, res_b) + + let all3 (a, b, c) = + let%lwt res_a = a in + let%lwt res_b = b in + let%lwt res_c = c in + Lwt.return (res_a, res_b, res_c) + + let all4 (a, b, c, d) = + let%lwt res_a = a in + let%lwt res_b = b in + let%lwt res_c = c in + let%lwt res_d = d in + Lwt.return (res_a, res_b, res_c, res_d) + + let all5 (a, b, c, d, e) = + let%lwt res_a = a in + let%lwt res_b = b in + let%lwt res_c = c in + let%lwt res_d = d in + let%lwt res_e = e in + 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 in + let%lwt res_b = b in + let%lwt res_c = c in + let%lwt res_d = d in + let%lwt res_e = e in + let%lwt res_f = f in + Lwt.return (res_a, res_b, res_c, res_d, res_e, res_f) + + let race (promises : 'a Lwt.t array) : 'a Lwt.t = + Lwt.pick (Stdlib.Array.to_list promises) + + let then_ p fn = Lwt.bind fn p + + let catch (handler : exn -> 'a Lwt.t) (promise : 'a Lwt.t) : 'a Lwt.t = + Lwt.catch (fun () -> promise) handler end module Date = struct diff --git a/packages/js/test.ml b/packages/js/test.ml index ad71dc249..2002054b4 100644 --- a/packages/js/test.ml +++ b/packages/js/test.ml @@ -4,11 +4,11 @@ let assert_string left right = let assert_option x left right = Alcotest.check (Alcotest.option x) "should be equal" right left -let assert_string_array left right = - Alcotest.check (Alcotest.array Alcotest.string) "should be equal" right left +let assert_array ty left right = + Alcotest.check (Alcotest.array ty) "should be equal" right left -let assert_int_array left right = - Alcotest.check (Alcotest.array Alcotest.int) "should be equal" right left +let assert_string_array = assert_array Alcotest.string +let assert_array_int = assert_array Alcotest.int let assert_dict_entries type_ left right = Alcotest.check @@ -28,7 +28,8 @@ let assert_float left right = let assert_bool left right = Alcotest.check Alcotest.bool "should be equal" right left -let case title (fn : unit -> unit) = Alcotest.test_case title `Quick fn +let case title (fn : unit -> unit) = Alcotest_lwt.test_case_sync title `Quick fn +let case_async title fn = Alcotest_lwt.test_case title `Quick fn let re_tests = ( "Js.Re", @@ -422,9 +423,9 @@ let dict_tests = (Js.Dict.entries (obj ())) [| ("bar", 86); ("foo", 43) |]); case "values" (fun _ -> - assert_int_array (Js.Dict.values (obj ())) [| 86; 43 |]); + assert_array_int (Js.Dict.values (obj ())) [| 86; 43 |]); case "values duplicated" (fun _ -> - assert_int_array (Js.Dict.values (obj_duplicated ())) [| 86; 1; 43 |]); + assert_array_int (Js.Dict.values (obj_duplicated ())) [| 86; 1; 43 |]); case "fromList - []" (fun _ -> assert_int_dict_entries (Js.Dict.entries (Js.Dict.fromList [])) [||]); case "fromList" (fun _ -> @@ -448,5 +449,62 @@ let dict_tests = [| ("book", 50); ("stapler", 70); ("pen", 10) |]); ] ) +let promise_to_lwt (p : 'a Js.Promise.t) : 'a Lwt.t = Obj.magic p + +let resolve _switch () = + let value = "hi" in + let resolved = Js.Promise.resolve value in + resolved |> promise_to_lwt |> Lwt.map (assert_string value) + +let all _switch () = + let p0 = Js.Promise.make (fun ~resolve ~reject:_ -> resolve 5) in + let p1 = Js.Promise.make (fun ~resolve ~reject:_ -> resolve 10) in + let resolved = Js.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 = + Js.Promise.make (fun ~resolve ~reject:_ -> + set_timeout (fun () -> resolve 5) 0.5) + in + let p1 = + Js.Promise.make (fun ~resolve ~reject:_ -> + set_timeout (fun () -> resolve 99) 0.3) + in + let resolved = Js.Promise.all [| p0; p1 |] in + resolved |> promise_to_lwt |> Lwt.map (assert_array_int [| 5; 99 |]) + +let race_async _switch () = + let p0 = + Js.Promise.make (fun ~resolve ~reject:_ -> + set_timeout (fun () -> resolve "second") 0.5) + in + let p1 = + Js.Promise.make (fun ~resolve ~reject:_ -> + set_timeout (fun () -> resolve "first") 0.3) + in + let resolved = Js.Promise.race [| p0; p1 |] in + resolved |> promise_to_lwt |> Lwt.map (assert_string "first") + +let promise_tests = + ( "Promise", + [ + case_async "resolve" resolve; + case_async "all" all; + case_async "all_async" all_async; + case_async "race_async" race_async; + ] ) + let () = - Alcotest.run "Js_tests" [ string2_tests; re_tests; array_tests; dict_tests ] + Alcotest_lwt.run "Promise" + [ promise_tests; string2_tests; re_tests; array_tests; dict_tests ] + |> Lwt_main.run diff --git a/packages/promise/js/promise.re b/packages/promise/js/promise.re index d21334a70..6d9084b2c 100644 --- a/packages/promise/js/promise.re +++ b/packages/promise/js/promise.re @@ -1,95 +1,362 @@ -/* 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? ] - */ +/* This file is part of reason-promise, released under the MIT license. See + LICENSE.md for details, or visit + https://github.com/aantron/promise/blob/master/LICENSE.md. */ + +type rejectable(+'a, +'e); +type never; + +type promise(+'a) = rejectable('a, never); +type t(+'a) = promise('a); + +let onUnhandledException = + ref(exn => { + prerr_endline("Unhandled exception in promise callback:"); + Js.Console.error(exn); + }); + +[%%bs.raw + {| +function PromiseBox(p) { + this.nested = p; +}; + +function unbox(value) { + if (value instanceof PromiseBox) + return value.nested; + else + return value; +} + +function box(value) { + if (value != null && typeof value.then === 'function') + return new PromiseBox(value); + else + return value; +} + +function make(executor) { + return new Promise(function (resolve, reject) { + var boxingResolve = function(value) { + resolve(box(value)); + }; + executor(boxingResolve, reject); + }); +}; + +function resolved(value) { + return Promise.resolve(box(value)); +}; + +function then(promise, callback) { + return promise.then(function (value) { + try { + return callback(unbox(value)); + } + catch (exception) { + onUnhandledException.contents(exception); + return new Promise(function() {}); + } + }); +}; + +function catch_(promise, callback) { + var safeCallback = function (error) { + try { + return callback(error); + } + catch (exception) { + onUnhandledException.contents(exception); + return new Promise(function() {}); + } + }; + + return promise.catch(safeCallback); +}; +|} +]; + +module Js_ = { + type t('a, 'e) = rejectable('a, 'e); + + external relax: promise('a) => rejectable('a, _) = "%identity"; + + [@bs.val] + external jsNew: (('a => unit, 'e => unit) => unit) => rejectable('a, 'e) = + "make"; + + let pending = () => { + let resolve = ref(ignore); + let reject = ref(ignore); + let p = + jsNew((resolve', reject') => { + resolve := resolve'; + reject := reject'; + }); + (p, resolve^, reject^); + }; + + [@bs.val] external resolved: 'a => rejectable('a, _) = "resolved"; + + [@bs.val] + external flatMap: + (rejectable('a, 'e), 'a => rejectable('b, 'e)) => rejectable('b, 'e) = + "then"; + + let map = (promise, callback) => + flatMap(promise, v => resolved(callback(v))); + + let get = (promise, callback) => ignore(map(promise, callback)); + + let tap = (promise, callback) => + map( + promise, + v => { + callback(v); + v; + }, + ); + + [@bs.scope "Promise"] [@bs.val] + external rejected: 'e => rejectable(_, 'e) = "reject"; + + [@bs.val] + external catch: + (rejectable('a, 'e), 'e => rejectable('a, 'e2)) => rejectable('a, 'e2) = + "catch_"; + + [@bs.val] external unbox: 'a => 'a = "unbox"; + + [@bs.scope "Promise"] [@bs.val] external jsAll: 'a => 'b = "all"; + + let allArray = promises => + map(jsAll(promises), promises => Belt.Array.map(promises, unbox)); + + let all = promises => + map(allArray(Belt.List.toArray(promises)), Belt.List.fromArray); + + let all2 = (p1, p2) => jsAll((p1, p2)); + + let all3 = (p1, p2, p3) => jsAll((p1, p2, p3)); + + let all4 = (p1, p2, p3, p4) => jsAll((p1, p2, p3, p4)); + + let all5 = (p1, p2, p3, p4, p5) => jsAll((p1, p2, p3, p4, p5)); + + let all6 = (p1, p2, p3, p4, p5, p6) => jsAll((p1, p2, p3, p4, p5, p6)); + + [@bs.scope "Promise"] [@bs.val] + external jsRace: array(rejectable('a, 'e)) => rejectable('a, 'e) = "race"; + + let race = promises => + if (promises == []) { + raise(Invalid_argument("Promise.race([]) would be pending forever")); + } else { + jsRace(Belt.List.toArray(promises)); + }; + + let toResult = promise => + catch(map(promise, v => Ok(v)), e => resolved(Error(e))); + + let fromResult = promise => + flatMap( + relax(promise), + fun + | Ok(v) => resolved(v) + | Error(e) => rejected(e), + ); + + external fromBsPromise: + Js.Promise.t('a) => rejectable('a, Js.Promise.error) = + "%identity"; + + external toBsPromise: rejectable('a, _) => Js.Promise.t('a) = "%identity"; +}; + +let pending = () => { + let (p, resolve, _) = Js_.pending(); + (p, resolve); +}; + +let exec = executor => { + let (p, resolve) = pending(); + executor(resolve); + p; +}; + +let resolved = Js_.resolved; +let flatMap = Js_.flatMap; +let map = Js_.map; +let get = Js_.get; +let tap = Js_.tap; +let all = Js_.all; +let all2 = Js_.all2; +let all3 = Js_.all3; +let all4 = Js_.all4; +let all5 = Js_.all5; +let all6 = Js_.all6; +let allArray = Js_.allArray; +let race = Js_.race; + +let flatMapOk = (promise, callback) => + flatMap(promise, result => + switch (result) { + | Ok(v) => callback(v) + | Error(_) as error => resolved(error) + } + ); + +let flatMapError = (promise, callback) => + flatMap(promise, result => + switch (result) { + | Ok(_) as ok => resolved(ok) + | Error(e) => callback(e) + } + ); + +let mapOk = (promise, callback) => + map(promise, result => + switch (result) { + | Ok(v) => Ok(callback(v)) + | Error(_) as error => error + } + ); + +let mapError = (promise, callback) => + map(promise, result => + switch (result) { + | Ok(_) as ok => ok + | Error(e) => Error(callback(e)) + } + ); + +let getOk = (promise, callback) => + get(promise, result => + switch (result) { + | Ok(v) => callback(v) + | Error(_) => () + } + ); + +let getError = (promise, callback) => + get(promise, result => + switch (result) { + | Ok(_) => () + | Error(e) => callback(e) + } + ); + +let tapOk = (promise, callback) => { + getOk(promise, callback); + promise; +}; + +let tapError = (promise, callback) => { + getError(promise, callback); + promise; +}; + +let allOkArray = promises => { + let promiseCount = Belt.Array.length(promises); + + if (promiseCount == 0) { + resolved(Ok([||])); + } else { + let resultValues = Belt.Array.make(promiseCount, None); + let resultCount = ref(0); + let (resultPromise, resolve) = pending(); + + let (callbackRemover, removeCallbacks) = pending(); + + promises->Belt.Array.forEachWithIndex((index, promise) + /* Because callbacks are added to the user's promises through calls to the + JS runtime's Promise.race, this function leaks memory if and only if + the JS runtime's Promise functions leak memory. In particular, if one + of the promises resolves with Error(_), the callbacks on the other + promises should be removed. If not done, and long-pending promises are + repeatedly passed to allOk in a loop, they will gradually accumulate + huge lists of stale callbacks. This is also true of Promise.race, so we + rely on the quality of the runtime's Promise.race implementation to + proactively remove these callbacks. */ + => + race([promise, callbackRemover]) + |> ( + wrapped => + get(wrapped, result => + switch (result) { + | Ok(v) => + resultValues->Belt.Array.setExn(index, Some(v)); + incr(resultCount); + if (resultCount^ >= promiseCount) { + resultValues->Belt.Array.map(v => + switch (v) { + | Some(v) => v + | None => assert(false) + } + ) + |> (values => resolve(Ok(values))); + }; + | Error(e) => + resolve(Error(e)); + removeCallbacks(Error(e)); + } + ) + ) + ); + + resultPromise; + }; +}; + +let allOk = promises => + mapOk(allOkArray(Belt.List.toArray(promises)), Belt.List.fromArray); + +let unsafeAllOkArray = Obj.magic(allOkArray); + +let allOk2 = (p1, p2) => unsafeAllOkArray((p1, p2)); + +let allOk3 = (p1, p2, p3) => unsafeAllOkArray((p1, p2, p3)); + +let allOk4 = (p1, p2, p3, p4) => unsafeAllOkArray((p1, p2, p3, p4)); + +let allOk5 = (p1, p2, p3, p4, p5) => unsafeAllOkArray((p1, p2, p3, p4, p5)); + +let allOk6 = (p1, p2, p3, p4, p5, p6) => + unsafeAllOkArray((p1, p2, p3, p4, p5, p6)); + +module Operators = { + let (>|=) = mapOk; + let (>>=) = flatMapOk; +}; + +let flatMapSome = (promise, callback) => + flatMap(promise, option => + switch (option) { + | Some(v) => callback(v) + | None => resolved(None) + } + ); + +let mapSome = (promise, callback) => + map(promise, option => + switch (option) { + | Some(v) => Some(callback(v)) + | None => None + } + ); + +let getSome = (promise, callback) => + get(promise, option => + switch (option) { + | Some(v) => callback(v) + | None => () + } + ); + +let tapSome = (promise, callback) => { + getSome(promise, callback); + promise; +}; + +module PipeFirst = {}; + +module Js = Js_; diff --git a/packages/promise/js/promise.rei b/packages/promise/js/promise.rei index b6bbbe46f..bee1fa51e 100644 --- a/packages/promise/js/promise.rei +++ b/packages/promise/js/promise.rei @@ -1,29 +1,201 @@ -type t(+'a); -type error; +/* This file is part of reason-promise, released under the MIT license. See + LICENSE.md for details, or visit + https://github.com/aantron/promise/blob/master/LICENSE.md. */ -let make: - ((~resolve: (. 'a) => unit, ~reject: (. exn) => unit) => unit) => t('a); +/* Internal type names; don't use these. Instead, use Promise.t and Promise.Js.t + from outside this library. */ +type rejectable(+'a, +'e); /* Internal; use Promise.Js.t. */ +type never; +type promise(+'a) = rejectable('a, never); /* Internal; use Promise.t. */ -let resolve: 'a => t('a); -let reject: exn => t('a); +/* The main, public promise type (Promise.t). */ +type t(+'a) = promise('a); -let all: array(t('a)) => t(array('a)); +/* Making promises. */ +let pending: unit => (promise('a), 'a => unit); -let all2: ((t('a0), t('a1))) => t(('a0, 'a1)); +let resolved: 'a => promise('a); -let all3: ((t('a0), t('a1), t('a2))) => t(('a0, 'a1, 'a2)); +let exec: (('a => unit) => unit) => promise('a); -let all4: ((t('a0), t('a1), t('a2), t('a3))) => t(('a0, 'a1, 'a2, 'a3)); +/* Using promises. */ +let get: (promise('a), 'a => unit) => unit; + +let tap: (promise('a), 'a => unit) => promise('a); + +let map: (promise('a), 'a => 'b) => promise('b); + +let flatMap: (promise('a), 'a => promise('b)) => promise('b); + +/* Compatibility with BuckleScript < 6. */ +type result('a, 'e) = Belt.Result.t('a, 'e); + +/* Results. */ +let getOk: (promise(result('a, 'e)), 'a => unit) => unit; + +let tapOk: + (promise(result('a, 'e)), 'a => unit) => promise(result('a, 'e)); + +let mapOk: (promise(result('a, 'e)), 'a => 'b) => promise(result('b, 'e)); + +let flatMapOk: + (promise(result('a, 'e)), 'a => promise(result('b, 'e))) => + promise(result('b, 'e)); + +let getError: (promise(result('a, 'e)), 'e => unit) => unit; + +let tapError: + (promise(result('a, 'e)), 'e => unit) => promise(result('a, 'e)); + +let mapError: + (promise(result('a, 'e)), 'e => 'e2) => promise(result('a, 'e2)); + +let flatMapError: + (promise(result('a, 'e)), 'e => promise(result('a, 'e2))) => + promise(result('a, 'e2)); + +module Operators: { + [@ocaml.deprecated "Use bs-let"] + let (>|=): + (promise(result('a, 'e)), 'a => 'b) => promise(result('b, 'e)); + + [@ocaml.deprecated "Use bs-let"] + let (>>=): + (promise(result('a, 'e)), 'a => promise(result('b, 'e))) => + promise(result('b, 'e)); +}; + +/* Options. */ +let getSome: (promise(option('a)), 'a => unit) => unit; + +let tapSome: (promise(option('a)), 'a => unit) => promise(option('a)); + +let mapSome: (promise(option('a)), 'a => 'b) => promise(option('b)); + +let flatMapSome: + (promise(option('a)), 'a => promise(option('b))) => promise(option('b)); + +/* Combining promises. */ +let race: list(promise('a)) => promise('a); + +let all: list(promise('a)) => promise(list('a)); + +let allArray: array(promise('a)) => promise(array('a)); + +let all2: (promise('a), promise('b)) => promise(('a, 'b)); + +let all3: + (promise('a), promise('b), promise('c)) => promise(('a, 'b, 'c)); + +let all4: + (promise('a), promise('b), promise('c), promise('d)) => + promise(('a, 'b, 'c, 'd)); let all5: - ((t('a0), t('a1), t('a2), t('a3), t('a4))) => - t(('a0, 'a1, 'a2, 'a3, 'a4)); + (promise('a), promise('b), promise('c), promise('d), promise('e)) => + promise(('a, 'b, 'c, 'd, 'e)); let all6: - ((t('a0), t('a1), t('a2), t('a3), t('a4), t('a5))) => - t(('a0, 'a1, 'a2, 'a3, 'a4, 'a5)); + ( + promise('a), + promise('b), + promise('c), + promise('d), + promise('e), + promise('f) + ) => + promise(('a, 'b, 'c, 'd, 'e, 'f)); + +let allOk: + list(promise(result('a, 'e))) => promise(result(list('a), 'e)); + +let allOkArray: + array(promise(result('a, 'e))) => promise(result(array('a), 'e)); + +let allOk2: + (promise(result('a, 'err)), promise(result('b, 'err))) => + promise(result(('a, 'b), 'err)); + +let allOk3: + ( + promise(result('a, 'err)), + promise(result('b, 'err)), + promise(result('c, 'err)) + ) => + promise(result(('a, 'b, 'c), 'err)); + +let allOk4: + ( + promise(result('a, 'err)), + promise(result('b, 'err)), + promise(result('c, 'err)), + promise(result('d, 'err)) + ) => + promise(result(('a, 'b, 'c, 'd), 'err)); + +let allOk5: + ( + promise(result('a, 'err)), + promise(result('b, 'err)), + promise(result('c, 'err)), + promise(result('d, 'err)), + promise(result('e, 'err)) + ) => + promise(result(('a, 'b, 'c, 'd, 'e), 'err)); + +let allOk6: + ( + promise(result('a, 'err)), + promise(result('b, 'err)), + promise(result('c, 'err)), + promise(result('d, 'err)), + promise(result('e, 'err)), + promise(result('f, 'err)) + ) => + promise(result(('a, 'b, 'c, 'd, 'e, 'f), 'err)); + +/* For writing bindings. */ +module Js: { + type t(+'a, +'e) = rejectable('a, 'e); + + /* Making. */ + let pending: unit => (rejectable('a, 'e), 'a => unit, 'e => unit); + + let resolved: 'a => rejectable('a, 'e); + + let rejected: 'e => rejectable('a, 'e); + + /* Handling fulfillment. */ + let get: (rejectable('a, 'e), 'a => unit) => unit; + + let tap: (rejectable('a, 'e), 'a => unit) => rejectable('a, 'e); + + let map: (rejectable('a, 'e), 'a => 'b) => rejectable('b, 'e); + + let flatMap: + (rejectable('a, 'e), 'a => rejectable('b, 'e)) => rejectable('b, 'e); + + /* Handling rejection. */ + let catch: + (rejectable('a, 'e), 'e => rejectable('a, 'e2)) => rejectable('a, 'e2); + + /* Combining. */ + let all: list(rejectable('a, 'e)) => rejectable(list('a), 'e); + + let race: list(rejectable('a, 'e)) => rejectable('a, 'e); + + /* Conversions. */ + let relax: promise('a) => rejectable('a, 'e); + + let toResult: rejectable('a, 'e) => promise(result('a, 'e)); + + let fromResult: promise(result('a, 'e)) => rejectable('a, 'e); + + let fromBsPromise: Js.Promise.t('a) => rejectable('a, Js.Promise.error); + + let toBsPromise: rejectable('a, _) => Js.Promise.t('a); +}; -let race: array(t('a)) => t('a); +module PipeFirst: {}; -let then_: ('a => t('b), t('a)) => t('b); -let catch: (error => t('a), t('a)) => t('a); +let onUnhandledException: ref(exn => unit); diff --git a/packages/promise/native/mutableList.re b/packages/promise/native/mutableList.re new file mode 100644 index 000000000..b6103c694 --- /dev/null +++ b/packages/promise/native/mutableList.re @@ -0,0 +1,112 @@ +/* This file is part of reason-promise, released under the MIT license. See + LICENSE.md for details, or visit + https://github.com/aantron/promise/blob/master/LICENSE.md. */ + +type node('a) = { + mutable previous: option(node('a)), + mutable next: option(node('a)), + content: 'a, +}; + +type listEnds('a) = { + mutable first: node('a), + mutable last: node('a), +}; + +type list('a) = ref([ | `Empty | `NonEmpty(listEnds('a))]); + +let create = () => ref(`Empty); + +let isEmpty = list => list^ == `Empty; + +let append = (list, value) => + switch (list^) { + | `Empty => + let node = {previous: None, next: None, content: value}; + list := `NonEmpty({first: node, last: node}); + node; + + | `NonEmpty(ends) => + let node = {previous: Some(ends.last), next: None, content: value}; + ends.last.next = Some(node); + ends.last = node; + node; + }; + +let concatenate = (list1, list2) => + switch (list2^) { + | `Empty => + /* If the second list is empty, we can just return the first list, because + it already has the correct final structure, and there is nothing to + do. */ + () + + | `NonEmpty(list2Ends) => + switch (list1^) { + | `Empty => + /* If the second list is non-empty, but the first list is empty, we need + to change the end-of-list references in the first list to point to the + structure of the second list. This is because the caller depends on the + first list having the correct structure after the call. */ + list1 := list2^ + + | `NonEmpty(list1Ends) => + /* Otherwise, we have to splice the ending nodes of the two lists. */ + + list1Ends.last.next = Some(list2Ends.first); + list2Ends.first.previous = Some(list1Ends.last); + list1Ends.last = list2Ends.last; + } + }; + +let iter = (callback, list) => + switch (list^) { + | `Empty => () + + | `NonEmpty(ends) => + let rec loop = node => { + callback(node.content); + switch (node.next) { + | None => () + | Some(nextNode) => loop(nextNode) + }; + }; + + loop(ends.first); + }; + +let remove = (list, node) => { + /* This function is difficult enough to implement and use that it is + probably time to switch representations for callback lists soon. */ + switch (list^) { + | `Empty => () + + | `NonEmpty(ends) => + switch (node.previous) { + | None => + if (ends.first === node) { + switch (node.next) { + | None => list := `Empty + | Some(secondNode) => ends.first = secondNode + }; + } + + | Some(previousNode) => previousNode.next = node.next + }; + + switch (node.next) { + | None => + if (ends.last === node) { + switch (node.previous) { + | None => list := `Empty + | Some(secondToLastNode) => ends.last = secondToLastNode + }; + } + + | Some(nextNode) => nextNode.previous = node.previous + }; + }; + + node.previous = None; + node.next = None; +}; diff --git a/packages/promise/native/mutableList.rei b/packages/promise/native/mutableList.rei new file mode 100644 index 000000000..769150a3e --- /dev/null +++ b/packages/promise/native/mutableList.rei @@ -0,0 +1,22 @@ +/* This file is part of reason-promise, released under the MIT license. See + LICENSE.md for details, or visit + https://github.com/aantron/promise/blob/master/LICENSE.md. */ + +/* Mutable doubly-linked lists, like in a typical imperative language. These are + used for callback lists, because reason-promise needs fast append and fast + deletion of any node in the list, when the reference to the target node is + already be held by the deleting code. */ + +type list('a); +type node('a); + +let create: unit => list('a); +let isEmpty: list(_) => bool; +let append: (list('a), 'a) => node('a); +let iter: ('a => unit, list('a)) => unit; +let remove: (list('a), node('a)) => unit; + +/* Concatenates list1 and list2. Afterwards, the reference list1 has a correct + internal list structure, and the reference list2 should not be used + anymore. */ +let concatenate: (list('a), list('a)) => unit; diff --git a/packages/promise/native/promise.re b/packages/promise/native/promise.re index 035f31bc4..418eed7a7 100644 --- a/packages/promise/native/promise.re +++ b/packages/promise/native/promise.re @@ -1,65 +1,741 @@ -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); +/* This file is part of reason-promise, released under the MIT license. See + LICENSE.md for details, or visit + https://github.com/aantron/promise/blob/master/LICENSE.md. */ + +type callbacks('a, 'e) = { + onResolve: MutableList.list('a => unit), + onReject: MutableList.list('e => unit), +}; + +type rejectable('a, 'e) = + ref( + [ + | `Fulfilled('a) + | `Rejected('e) + | `Pending(callbacks('a, 'e)) + | `Merged(rejectable('a, 'e)) + ], + ); + +type never; + +type promise('a) = rejectable('a, never); +type t('a) = promise('a); + +/* The `Merged constructor and this function, underlying, are used to avoid a + memory leak that arises when flatMap is called on promises in a loop. See the + description in the associated test "promise loop memory leak". The rest of + this comment is based on that description. + + The solution to the memory leak is to merge nested promises created on the + second and subsequent iterations of loops into the outer promise created on + the first iteration. This is performed by the internal helper + makePromiseBehaveAs, below. + + When promises are merged, the callback lists of the nested promise are + merged into the callback lists of the outer promise, and afterwards the + nested promise object becomes just a proxy that refers to the outer promise. + As a result, most internal operations on promises have to first call + underlying, in order to find the true merged (outer) promise on which + operations should be performed, rather than working directly on proxies. */ +let rec underlying = p => + switch (p^) { + | `Fulfilled(_) + | `Rejected(_) + | `Pending(_) => p + + | `Merged(p') => + let p'' = underlying(p'); + if (p'' !== p') { + p := `Merged(p''); + }; + p''; + }; + +let onUnhandledException = + ref(exn => { + prerr_endline("Unhandled exception in promise callback:"); + prerr_endline(Printexc.to_string(exn)); + Printexc.print_backtrace(stderr); + }); + +module ReadyCallbacks = { + let callbacks: ref(MutableList.list(unit => unit)) = + ref(MutableList.create()); + + let callbacksPending = () => !MutableList.isEmpty(callbacks^); + + let defer = (callback, value) => + MutableList.append(callbacks^, () => callback(value)) |> ignore; + + let deferMultiple = (newCallbacks, value) => + newCallbacks |> MutableList.iter(callback => defer(callback, value)); + + type snapshot = MutableList.list(unit => unit); + + let snapshot = () => { + let theSnapshot = callbacks^; + callbacks := MutableList.create(); + theSnapshot; + }; + + let isEmpty = snapshot => MutableList.isEmpty(snapshot); + + let call = snapshot => snapshot |> MutableList.iter(callback => callback()); +}; + +let newInternal = () => + ref( + `Pending({ + onResolve: MutableList.create(), + onReject: MutableList.create(), + }), + ); + +let resolveInternal = (p, value) => + switch ((underlying(p))^) { + | `Fulfilled(_) + | `Rejected(_) => () + | `Pending(callbacks) => + ReadyCallbacks.deferMultiple(callbacks.onResolve, value); + p := `Fulfilled(value); + | `Merged(_) => + /* This case is impossible, because we called underyling on the promise, + above. */ + assert(false) + }; + +let rejectInternal = (p, error) => + switch ((underlying(p))^) { + | `Fulfilled(_) + | `Rejected(_) => () + | `Pending(callbacks) => + ReadyCallbacks.deferMultiple(callbacks.onReject, error); + p := `Rejected(error); + | `Merged(_) => + /* This case is impossible, because we called underyling on the promise, + above. */ + assert(false) + }; + +let resolved = value => ref(`Fulfilled(value)); + +let rejected = error => ref(`Rejected(error)); + +let makePromiseBehaveAs = (outerPromise, nestedPromise) => { + let underlyingNested = underlying(nestedPromise); + + switch (underlyingNested^) { + | `Fulfilled(value) => resolveInternal(outerPromise, value) + | `Rejected(error) => rejectInternal(outerPromise, error) + + | `Pending(callbacks) => + let underlyingOuter = underlying(outerPromise); + switch (underlyingOuter^) { + | `Fulfilled(_) + | `Rejected(_) => + /* These two cases are impossible, because if makePromiseBehaveAs is + called, flatMap or catch_ called the callback that was passed to it, so + the outer promise is still pending. It is this function which resolves + the outer promise. */ + assert(false) + + | `Pending(outerCallbacks) => + MutableList.concatenate(outerCallbacks.onResolve, callbacks.onResolve); + MutableList.concatenate(outerCallbacks.onReject, callbacks.onReject); + underlyingNested := `Merged(underlyingOuter); + + | `Merged(_) => + /* This case is impossible, because we called underlying above. */ + assert(false) + }; + + | `Merged(_) => + /* Impossible because we are working on the underlying promise. */ + assert(false) + }; +}; + +let flatMap = (promise, callback) => { + let outerPromise = newInternal(); + + let onResolve = value => + switch (callback(value)) { + | exception exn => ignore(onUnhandledException^(exn)) + | nestedPromise => makePromiseBehaveAs(outerPromise, nestedPromise) + }; + + switch ((underlying(promise))^) { + | `Fulfilled(value) => ReadyCallbacks.defer(onResolve, value) + | `Rejected(error) => rejectInternal(outerPromise, error) + + | `Pending(callbacks) => + MutableList.append(callbacks.onResolve, onResolve) |> ignore; + MutableList.append(callbacks.onReject, rejectInternal(outerPromise)) + |> ignore; + + | `Merged(_) => + /* This case is impossible, cause of the call to underlying above. */ + assert(false) + }; + + outerPromise; +}; + +let map = (promise, mapper) => + flatMap(promise, value => resolved(mapper(value))); + +let get = (promise, callback) => ignore(map(promise, callback)); + +let tap = (promise, callback) => { + get(promise, callback); + promise; +}; + +let catch = (promise, callback) => { + let outerPromise = newInternal(); + + let onReject = error => + switch (callback(error)) { + | exception exn => ignore(onUnhandledException^(exn)) + | nestedPromise => makePromiseBehaveAs(outerPromise, nestedPromise) + }; + + switch ((underlying(promise))^) { + | `Fulfilled(value) => resolveInternal(outerPromise, value) + | `Rejected(error) => ReadyCallbacks.defer(onReject, error) + + | `Pending(callbacks) => + MutableList.append(callbacks.onResolve, resolveInternal(outerPromise)) + |> ignore; + MutableList.append(callbacks.onReject, onReject) |> ignore; + + | `Merged(_) => + /* This case is impossible, because of the call to underlying above. */ + assert(false) + }; + + outerPromise; +}; + +/* Promise.all and Promise.race have to remove callbacks in some circumstances; + see test/native/test_ffi.re for details. */ +module CallbackRemovers = { + let empty = () => ref([]); + + let call = removers => { + removers^ |> List.iter(remover => remover()); + removers := []; + }; + + let add = (removers, promise, whichList, callbackNode) => { + let remover = () => + switch ((underlying(promise))^) { + | `Pending(callbacks) => + MutableList.remove(whichList(callbacks), callbackNode) + | _ => () + }; + + removers := [remover, ...removers^]; + }; +}; + +let all = promises => { + let callbackRemovers = CallbackRemovers.empty(); + + let finalPromise = newInternal(); + let unresolvedPromiseCount = ref(List.length(promises)); + let results = ref([]); + + let onResolve = (cell, value) => { + cell := Some(value); + unresolvedPromiseCount := unresolvedPromiseCount^ - 1; + if (unresolvedPromiseCount^ == 0) { + results^ + |> List.map(cell => + switch (cell^) { + | None => assert(false) + | Some(value) => value + } + ) + |> resolveInternal(finalPromise); + }; + }; + + let rejectFinalPromise = error => { + CallbackRemovers.call(callbackRemovers); + rejectInternal(finalPromise, error); + }; + + results := + promises + |> List.map(promise => { + let cell = ref(None); + + switch ((underlying(promise))^) { + | `Fulfilled(value) => + /* It's very important to defer here instead of resolving the final + promise immediately. Doing the latter will cause the callback removal + mechanism to forget about removing callbacks which will be added later + in the iteration over the promise list. It is possible to resolve + immediately but then the code has to be changed, probably to perform + two passes over the promise list. */ + ReadyCallbacks.defer(onResolve(cell), value) + | `Rejected(error) => + ReadyCallbacks.defer(rejectFinalPromise, error) + + | `Pending(callbacks) => + let callbackNode = + MutableList.append(callbacks.onResolve, onResolve(cell)); + CallbackRemovers.add( + callbackRemovers, + promise, + callbacks => callbacks.onResolve, + callbackNode, + ); + + let callbackNode = + MutableList.append(callbacks.onReject, rejectFinalPromise); + CallbackRemovers.add( + callbackRemovers, + promise, + callbacks => callbacks.onReject, + callbackNode, + ); + + | `Merged(_) => + /* Impossible because of the call to underlying above. */ + assert(false) + }; + + cell; + }); + + finalPromise; +}; + +let allArray = promises => map(all(Array.to_list(promises)), Array.of_list); + +/* Not a "legitimate" implementation. To get a legitimate one, the tricky parts + of "all," above, should be factoed out. */ +let all2 = (p1, p2) => { + let promises = [Obj.magic(p1), Obj.magic(p2)]; + map( + all(promises), + fun + | [v1, v2] => (Obj.magic(v1), Obj.magic(v2)) + | _ => assert(false), + ); +}; + +let all3 = (p1, p2, p3) => { + let promises = [Obj.magic(p1), Obj.magic(p2), Obj.magic(p3)]; + map( + all(promises), + fun + | [v1, v2, v3] => (Obj.magic(v1), Obj.magic(v2), Obj.magic(v3)) + | _ => assert(false), + ); +}; + +let all4 = (p1, p2, p3, p4) => { + let promises = [ + Obj.magic(p1), + Obj.magic(p2), + Obj.magic(p3), + Obj.magic(p4), + ]; + map( + all(promises), + fun + | [v1, v2, v3, v4] => ( + Obj.magic(v1), + Obj.magic(v2), + Obj.magic(v3), + Obj.magic(v4), + ) + | _ => assert(false), + ); +}; + +let all5 = (p1, p2, p3, p4, p5) => { + let promises = [ + Obj.magic(p1), + Obj.magic(p2), + Obj.magic(p3), + Obj.magic(p4), + Obj.magic(p5), + ]; + map( + all(promises), + fun + | [v1, v2, v3, v4, v5] => ( + Obj.magic(v1), + Obj.magic(v2), + Obj.magic(v3), + Obj.magic(v4), + Obj.magic(v5), + ) + | _ => assert(false), + ); +}; + +let all6 = (p1, p2, p3, p4, p5, p6) => { + let promises = [ + Obj.magic(p1), + Obj.magic(p2), + Obj.magic(p3), + Obj.magic(p4), + Obj.magic(p5), + Obj.magic(p6), + ]; + map( + all(promises), + fun + | [v1, v2, v3, v4, v5, v6] => ( + Obj.magic(v1), + Obj.magic(v2), + Obj.magic(v3), + Obj.magic(v4), + Obj.magic(v5), + Obj.magic(v6), + ) + | _ => assert(false), + ); +}; + +let race = promises => { + if (promises == []) { + raise(Invalid_argument("Promise.race([]) would be pending forever")); + }; + + let callbackRemovers = CallbackRemovers.empty(); + + let finalPromise = newInternal(); + let resolveFinalPromise = value => { + CallbackRemovers.call(callbackRemovers); + resolveInternal(finalPromise, value); + }; + let rejectFinalPromise = error => { + CallbackRemovers.call(callbackRemovers); + rejectInternal(finalPromise, error); + }; + + promises + |> List.iter(promise => + switch ((underlying(promise))^) { + | `Fulfilled(value) => + ReadyCallbacks.defer(resolveFinalPromise, value) + | `Rejected(error) => ReadyCallbacks.defer(rejectFinalPromise, error) + + | `Pending(callbacks) => + let callbackNode = + MutableList.append(callbacks.onResolve, resolveFinalPromise); + CallbackRemovers.add( + callbackRemovers, + promise, + callbacks => callbacks.onResolve, + callbackNode, + ); + + let callbackNode = + MutableList.append(callbacks.onReject, rejectFinalPromise); + CallbackRemovers.add( + callbackRemovers, + promise, + callbacks => callbacks.onReject, + callbackNode, + ); + + | `Merged(_) => + /* Impossible, because of the call to underlying above. */ + assert(false) + } + ); + + finalPromise; +}; + +let flatMapOk = (promise, callback) => + flatMap( + promise, + fun + | Result.Ok(value) => callback(value) + | Result.Error(_) as error => resolved(error), + ); + +let flatMapError = (promise, callback) => + flatMap( + promise, + fun + | Result.Ok(_) as ok => resolved(ok) + | Result.Error(error) => callback(error), + ); + +let mapOk = (promise, callback) => + map( + promise, + fun + | Result.Ok(value) => Result.Ok(callback(value)) + | Result.Error(_) as error => error, + ); + +let mapError = (promise, callback) => + map( + promise, + fun + | Result.Ok(_) as ok => ok + | Result.Error(error) => Result.Error(callback(error)), + ); + +let getOk = (promise, callback) => + get( + promise, + fun + | Result.Ok(value) => callback(value) + | Result.Error(_) => (), + ); + +let getError = (promise, callback) => + get( + promise, + fun + | Result.Ok(_) => () + | Result.Error(error) => callback(error), + ); + +let tapOk = (promise, callback) => { + getOk(promise, callback); + promise; +}; + +let tapError = (promise, callback) => { + getError(promise, callback); + promise; +}; + +module Operators = { + let (>|=) = mapOk; + let (>>=) = flatMapOk; +}; + +let flatMapSome = (promise, callback) => + flatMap( + promise, + fun + | Some(value) => callback(value) + | None => resolved(None), + ); + +let mapSome = (promise, callback) => + map( + promise, + fun + | Some(value) => Some(callback(value)) + | None => None, + ); + +let getSome = (promise, callback) => + get( + promise, + fun + | Some(value) => callback(value) + | None => (), + ); + +let tapSome = (promise, callback) => { + getSome(promise, callback); promise; }; -let resolve = Lwt.return; -let reject = Lwt.fail; +module Js = { + type t('a, 'e) = rejectable('a, 'e); -let all = (promises: array(Lwt.t('a))): Lwt.t(array('a)) => - Lwt.map(Array.of_list, Lwt.all(Array.to_list(promises))); + external relax: promise('a) => rejectable('a, _) = "%identity"; -let all2 = ((a, b)) => { - let%lwt res_a = a; - let%lwt res_b = b; - Lwt.return((res_a, res_b)); + let pending = () => { + let p = newInternal(); + let resolve = resolveInternal(p); + let reject = rejectInternal(p); + (p, resolve, reject); + }; + + let resolved = resolved; + let rejected = rejected; + let flatMap = flatMap; + let map = map; + let get = get; + let tap = tap; + let catch = catch; + let all = all; + let race = race; + + let toResult = promise => + catch(map(promise, v => Result.Ok(v)), e => resolved(Result.Error(e))); + + let fromResult = promise => + flatMap( + relax(promise), + fun + | Result.Ok(v) => resolved(v) + | Result.Error(e) => rejected(e), + ); }; -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 pending = () => { + let (p, resolve, _) = Js.pending(); + (p, resolve); }; -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 exec = executor => { + let (p, resolve) = pending(); + executor(resolve); + p; }; -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 allOkArray = promises => { + let promiseCount = Array.length(promises); + + if (promiseCount == 0) { + resolved(Result.Ok([||])); + } else { + let resultValues = Array.make(promiseCount, None); + let resultCount = ref(0); + let (resultPromise, resolve) = pending(); + + let (callbackRemover, removeCallbacks) = pending(); + + promises + |> Array.iteri((index, promise) + /* Because callbacks are added to the user's promises through calls to the + JS runtime's Promise.race, this function leaks memory if and only if + the JS runtime's Promise functions leak memory. In particular, if one + of the promises resolves with Error(_), the callbacks on the other + promises should be removed. If not done, and long-pending promises are + repeatedly passed to allOk in a loop, they will gradually accumulate + huge lists of stale callbacks. This is also true of Promise.race, so we + rely on the quality of the runtime's Promise.race implementation to + proactively remove these callbacks. */ + => + race([promise, callbackRemover]) + |> ( + wrapped => + get(wrapped, result => + switch (result) { + | Result.Ok(v) => + resultValues[index] = Some(v); + incr(resultCount); + if (resultCount^ >= promiseCount) { + resultValues + |> Array.map(v => + switch (v) { + | Some(v) => v + | None => assert(false) + } + ) + |> (values => resolve(Result.Ok(values))); + }; + | Result.Error(e) => + resolve(Result.Error(e)); + removeCallbacks(Result.Error(e)); + } + ) + ) + ); + + resultPromise; + }; }; -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 allOk = promises => + mapOk(allOkArray(Array.of_list(promises)), Array.to_list); + +let allOk2 = (p1, p2) => { + let promises = [|Obj.magic(p1), Obj.magic(p2)|]; + mapOk( + allOkArray(promises), + fun + | [|v1, v2|] => (Obj.magic(v1), Obj.magic(v2)) + | _ => assert(false), + ); }; -let race = (promises: array(Lwt.t('a))): Lwt.t('a) => - Lwt.pick(Array.to_list(promises)); +let allOk3 = (p1, p2, p3) => { + let promises = [|Obj.magic(p1), Obj.magic(p2), Obj.magic(p3)|]; + mapOk( + allOkArray(promises), + fun + | [|v1, v2, v3|] => (Obj.magic(v1), Obj.magic(v2), Obj.magic(v3)) + | _ => assert(false), + ); +}; + +let allOk4 = (p1, p2, p3, p4) => { + let promises = [| + Obj.magic(p1), + Obj.magic(p2), + Obj.magic(p3), + Obj.magic(p4), + |]; + mapOk( + allOkArray(promises), + fun + | [|v1, v2, v3, v4|] => ( + Obj.magic(v1), + Obj.magic(v2), + Obj.magic(v3), + Obj.magic(v4), + ) + | _ => assert(false), + ); +}; + +let allOk5 = (p1, p2, p3, p4, p5) => { + let promises = [| + Obj.magic(p1), + Obj.magic(p2), + Obj.magic(p3), + Obj.magic(p4), + Obj.magic(p5), + |]; + mapOk( + allOkArray(promises), + fun + | [|v1, v2, v3, v4, v5|] => ( + Obj.magic(v1), + Obj.magic(v2), + Obj.magic(v3), + Obj.magic(v4), + Obj.magic(v5), + ) + | _ => assert(false), + ); +}; + +let allOk6 = (p1, p2, p3, p4, p5, p6) => { + let promises = [| + Obj.magic(p1), + Obj.magic(p2), + Obj.magic(p3), + Obj.magic(p4), + Obj.magic(p5), + Obj.magic(p6), + |]; + mapOk( + allOkArray(promises), + fun + | [|v1, v2, v3, v4, v5, v6|] => ( + Obj.magic(v1), + Obj.magic(v2), + Obj.magic(v3), + Obj.magic(v4), + Obj.magic(v5), + Obj.magic(v6), + ) + | _ => assert(false), + ); +}; -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); +module PipeFirst = { + let (|.) = (v, f) => f(v); }; diff --git a/packages/promise/native/promise.rei b/packages/promise/native/promise.rei index b6bbbe46f..691910c69 100644 --- a/packages/promise/native/promise.rei +++ b/packages/promise/native/promise.rei @@ -1,29 +1,214 @@ -type t(+'a); -type error; +/* This file is part of reason-promise, released under the MIT license. See + LICENSE.md for details, or visit + https://github.com/aantron/promise/blob/master/LICENSE.md. */ -let make: - ((~resolve: (. 'a) => unit, ~reject: (. exn) => unit) => unit) => t('a); +/* Internal type names; don't use these. Instead, use Promise.t and Promise.Js.t + from outside this library. */ +type rejectable('a, 'e); /* Internal; use Promise.Js.t. */ +type never; +type promise('a) = rejectable('a, never); /* Internal; use Promise.t. */ -let resolve: 'a => t('a); -let reject: exn => t('a); +/* The main, public promise type (Promise.t). */ +type t('a) = promise('a); -let all: array(t('a)) => t(array('a)); +/* Making promises. */ +let pending: unit => (promise('a), 'a => unit); -let all2: ((t('a0), t('a1))) => t(('a0, 'a1)); +let resolved: 'a => promise('a); -let all3: ((t('a0), t('a1), t('a2))) => t(('a0, 'a1, 'a2)); +let exec: (('a => unit) => unit) => promise('a); -let all4: ((t('a0), t('a1), t('a2), t('a3))) => t(('a0, 'a1, 'a2, 'a3)); +/* Using promises. */ +let get: (promise('a), 'a => unit) => unit; + +let tap: (promise('a), 'a => unit) => promise('a); + +let map: (promise('a), 'a => 'b) => promise('b); + +let flatMap: (promise('a), 'a => promise('b)) => promise('b); + +/* Results. */ +let getOk: (promise(result('a, 'e)), 'a => unit) => unit; + +let tapOk: + (promise(result('a, 'e)), 'a => unit) => promise(result('a, 'e)); + +let mapOk: (promise(result('a, 'e)), 'a => 'b) => promise(result('b, 'e)); + +let flatMapOk: + (promise(result('a, 'e)), 'a => promise(result('b, 'e))) => + promise(result('b, 'e)); + +let getError: (promise(result('a, 'e)), 'e => unit) => unit; + +let tapError: + (promise(result('a, 'e)), 'e => unit) => promise(result('a, 'e)); + +let mapError: + (promise(result('a, 'e)), 'e => 'e2) => promise(result('a, 'e2)); + +let flatMapError: + (promise(result('a, 'e)), 'e => promise(result('a, 'e2))) => + promise(result('a, 'e2)); + +module Operators: { + [@ocaml.deprecated "Use the let* syntax"] + let (>|=): + (promise(result('a, 'e)), 'a => 'b) => promise(result('b, 'e)); + + [@ocaml.deprecated "Use the let* syntax"] + let (>>=): + (promise(result('a, 'e)), 'a => promise(result('b, 'e))) => + promise(result('b, 'e)); +}; + +/* Options. */ +let getSome: (promise(option('a)), 'a => unit) => unit; + +let tapSome: (promise(option('a)), 'a => unit) => promise(option('a)); + +let mapSome: (promise(option('a)), 'a => 'b) => promise(option('b)); + +let flatMapSome: + (promise(option('a)), 'a => promise(option('b))) => promise(option('b)); + +/* Combining promises. */ +let race: list(promise('a)) => promise('a); + +let all: list(promise('a)) => promise(list('a)); + +let allArray: array(promise('a)) => promise(array('a)); + +let all2: (promise('a), promise('b)) => promise(('a, 'b)); + +let all3: + (promise('a), promise('b), promise('c)) => promise(('a, 'b, 'c)); + +let all4: + (promise('a), promise('b), promise('c), promise('d)) => + promise(('a, 'b, 'c, 'd)); let all5: - ((t('a0), t('a1), t('a2), t('a3), t('a4))) => - t(('a0, 'a1, 'a2, 'a3, 'a4)); + (promise('a), promise('b), promise('c), promise('d), promise('e)) => + promise(('a, 'b, 'c, 'd, 'e)); let all6: - ((t('a0), t('a1), t('a2), t('a3), t('a4), t('a5))) => - t(('a0, 'a1, 'a2, 'a3, 'a4, 'a5)); + ( + promise('a), + promise('b), + promise('c), + promise('d), + promise('e), + promise('f) + ) => + promise(('a, 'b, 'c, 'd, 'e, 'f)); + +let allOk: + list(promise(result('a, 'e))) => promise(result(list('a), 'e)); + +let allOkArray: + array(promise(result('a, 'e))) => promise(result(array('a), 'e)); + +let allOk2: + (promise(result('a, 'err)), promise(result('b, 'err))) => + promise(result(('a, 'b), 'err)); + +let allOk3: + ( + promise(result('a, 'err)), + promise(result('b, 'err)), + promise(result('c, 'err)) + ) => + promise(result(('a, 'b, 'c), 'err)); + +let allOk4: + ( + promise(result('a, 'err)), + promise(result('b, 'err)), + promise(result('c, 'err)), + promise(result('d, 'err)) + ) => + promise(result(('a, 'b, 'c, 'd), 'err)); + +let allOk5: + ( + promise(result('a, 'err)), + promise(result('b, 'err)), + promise(result('c, 'err)), + promise(result('d, 'err)), + promise(result('e, 'err)) + ) => + promise(result(('a, 'b, 'c, 'd, 'e), 'err)); + +let allOk6: + ( + promise(result('a, 'err)), + promise(result('b, 'err)), + promise(result('c, 'err)), + promise(result('d, 'err)), + promise(result('e, 'err)), + promise(result('f, 'err)) + ) => + promise(result(('a, 'b, 'c, 'd, 'e, 'f), 'err)); + +/* Shouldn't be used; provided for compatibility with Js. */ +module Js: { + type t('a, 'e) = rejectable('a, 'e); + + /* Making. */ + let pending: unit => (rejectable('a, 'e), 'a => unit, 'e => unit); + + let resolved: 'a => rejectable('a, 'e); + + let rejected: 'e => rejectable('a, 'e); + + /* Handling fulfillment. */ + let get: (rejectable('a, 'e), 'a => unit) => unit; + + let tap: (rejectable('a, 'e), 'a => unit) => rejectable('a, 'e); + + let map: (rejectable('a, 'e), 'a => 'b) => rejectable('b, 'e); + + let flatMap: + (rejectable('a, 'e), 'a => rejectable('b, 'e)) => rejectable('b, 'e); + + /* Handling rejection. */ + let catch: + (rejectable('a, 'e), 'e => rejectable('a, 'e2)) => rejectable('a, 'e2); + + /* Combining. */ + let all: list(rejectable('a, 'e)) => rejectable(list('a), 'e); + + let race: list(rejectable('a, 'e)) => rejectable('a, 'e); + + /* Conversions. */ + let relax: promise('a) => rejectable('a, 'e); + + let toResult: rejectable('a, 'e) => promise(result('a, 'e)); + + let fromResult: promise(result('a, 'e)) => rejectable('a, 'e); +}; + +module PipeFirst: { + let (|.): ('a, 'a => 'b) => 'b; +}; + +let onUnhandledException: ref(exn => unit); + +/* This is not part of the public API. It is used by I/O libraries to drive + native promise callbacks on each tick. */ + +module ReadyCallbacks: { + let callbacksPending: unit => bool; -let race: array(t('a)) => t('a); + /* When about to iterate over the ready callbacks, reason-promise first takes + a snapshot of them, and iterates over the snapshot. This is to prevent new + ready callbacks, that may be created by the processing of the current ones, + from being processed immediately. That could lead to I/O loop starvation + and other problems. */ + type snapshot; -let then_: ('a => t('b), t('a)) => t('b); -let catch: (error => t('a), t('a)) => t('a); + let snapshot: unit => snapshot; + let isEmpty: snapshot => bool; + let call: snapshot => unit; +}; diff --git a/packages/promise/test/dune b/packages/promise/test/dune deleted file mode 100644 index a64250255..000000000 --- a/packages/promise/test/dune +++ /dev/null @@ -1,6 +0,0 @@ -(test - (name test) - (modules :standard) - (libraries fmt lwt alcotest alcotest-lwt promise_native) - (preprocess - (pps lwt_ppx))) diff --git a/packages/promise/test/test.ml b/packages/promise/test/test.ml deleted file mode 100644 index aa985edb7..000000000 --- a/packages/promise/test/test.ml +++ /dev/null @@ -1,67 +0,0 @@ -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 diff --git a/server-reason-react.opam b/server-reason-react.opam index 6771d8b1a..d5412b30a 100644 --- a/server-reason-react.opam +++ b/server-reason-react.opam @@ -9,12 +9,13 @@ bug-reports: "https://github.com/ml-in-barcelona/server-reason-react/issues" depends: [ "dune" {>= "3.8"} "ocaml" {>= "4.12.0" & < "5.0.0"} + "reason" {>= "3.8.1"} "melange" "ppxlib" {>= "0.23.0"} - "reason" {>= "3.8.1"} "pcre" {<= "7.5.0"} "promise" {>= "1.1.2"} "lwt" {>= "5.6.0"} + "lwt_ppx" {>= "5.6.0"} "alcotest" {with-test} "alcotest-lwt" {with-test} "fmt" {with-test}