Repository: ocsigen/lwt (ocaml)

Issue:

Pull request:
Add support for ppx_let
See #667

Patch:
diff --git a/src/core/lwt.ml b/src/core/lwt.ml
index 74c14e82e..caf8c43d7 100644
--- a/src/core/lwt.ml
+++ b/src/core/lwt.ml
@@ -2445,6 +2445,7 @@ sig
   val async : (unit -> _ t) -> unit
   val ignore_result : _ t -> unit
 
+  val both : 'a t -> 'b t -> ('a * 'b) t
   val join : unit t list -> unit t
 
   val choose : 'a t list -> 'a t
@@ -2568,6 +2569,16 @@ struct
 
     attach_callback_or_resolve_immediately ps
 
+  let both p1 p2 =
+    let v1 = ref None in
+    let v2 = ref None in
+    let p1' = bind p1 (fun v -> v1 := Some v; return_unit) in
+    let p2' = bind p2 (fun v -> v2 := Some v; return_unit) in
+    join [p1'; p2'] |> map (fun () ->
+      match !v1, !v2 with
+      | Some v1, Some v2 -> v1, v2
+      | _ -> assert false)
+
 
 
   (* Maintainer's note: the next few functions are helpers for [choose] and
@@ -3061,6 +3072,18 @@ struct
   let (=|<) = map
   let (<&>) p p' = join [p; p']
   let (<?>) p p' = choose [p; p']
+
+  module Let_syntax =
+  struct
+    let return = return
+    let map t ~f = map f t
+    let bind t ~f = bind t f
+    let both = both
+
+    module Open_on_rhs =
+    struct
+    end
+  end
 end
 include Infix
 
diff --git a/src/core/lwt.mli b/src/core/lwt.mli
index 1046f3901..1481b9d48 100644
--- a/src/core/lwt.mli
+++ b/src/core/lwt.mli
@@ -890,6 +890,35 @@ v}
 
 (** {3 Multiple wait} *)
 
+val both : 'a t -> 'b t -> ('a * 'b) t
+(** [Lwt.both p_1 p_2] returns a promise that is pending until {e both} promises
+    [p_1] and [p_2] become {{: #TYPEt} {e resolved}}.
+
+{[
+let () =
+  let p_1 =
+    let%lwt () = Lwt_unix.sleep 3. in
+    Lwt_io.printl "Three seconds elapsed"
+  in
+
+  let p_2 =
+    let%lwt () = Lwt_unix.sleep 5. in
+    Lwt_io.printl "Five seconds elapsed"
+  in
+
+  let p_3 = Lwt.both p_1 p_2 in
+  Lwt_main.run p_3
+
+(* ocamlfind opt -linkpkg -package lwt_ppx,lwt.unix code.ml && ./a.out *)
+]}
+
+    If both [p_1] and [p_2] become fulfilled, [Lwt.both p_1 p_2] is also
+    fulfilled, with the pair of their final values. Otherwise, if at least one
+    of the two promises becomes rejected, [Lwt.both p_1 p_2] is rejected with
+    the same exception as one such promise, chosen arbitrarily. Note that this
+    occurs only after both promises are resolved, not immediately when the first
+    promise is rejected. *)
+
 val join : (unit t) list -> unit t
 (** [Lwt.join ps] returns a promise that is pending until {e all} promises in
     the list [ps] become {{: #TYPEt} {e resolved}}.
@@ -1237,7 +1266,8 @@ val on_any : 'a t -> ('a -> unit) -> (exn -> unit) -> unit
 
     Of the operators declared in this module, only [>|=] is recommended for new
     code. The only other commonly-used operator is [>>=]. *)
-module Infix : sig
+module Infix :
+sig
   val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
   (** [p >>= f] is the same as {!Lwt.bind}[ p f]. It requires [Lwt.Infix] to be
       opened in scope:
@@ -1301,6 +1331,27 @@ let () =
 
       This operator is obscure and its use is discouraged. It is the same as
       [p >|= f]. *)
+
+  (** This module provides support for {{:https://github.com/janestreet/ppx_let}
+      ppx_let}. *)
+  module Let_syntax :
+  sig
+    val return : 'a -> 'a t
+    (** See {!Lwt.return} *)
+
+    val map : 'a t -> f:('a -> 'b) -> 'b t
+    (** See {!Lwt.map} *)
+
+    val bind : 'a t -> f:('a -> 'b t) -> 'b t
+    (** See {!Lwt.bind} *)
+
+    val both : 'a t -> 'b t -> ('a * 'b) t
+    (** See {!Lwt.both} *)
+
+    module Open_on_rhs :
+    sig
+    end
+  end
 end
 
 


Test patch:
diff --git a/test/core/test_lwt.ml b/test/core/test_lwt.ml
index 7e384939a..f6568b7c5 100644
--- a/test/core/test_lwt.ml
+++ b/test/core/test_lwt.ml
@@ -1892,6 +1892,219 @@ let join_tests = suite "join" [
 ]
 let suites = suites @ [join_tests]
 
+let both_tests = suite "both" [
+  test "both fulfilled" begin fun () ->
+    let p = Lwt.both (Lwt.return 1) (Lwt.return 2) in
+    state_is (Lwt.Return (1, 2)) p
+  end;
+
+  test "all rejected" begin fun () ->
+    let p = Lwt.both (Lwt.fail Exception) (Lwt.fail Exit) in
+    state_is (Lwt.Fail Exception) p
+  end;
+
+  test "rejected, fulfilled" begin fun () ->
+    let p = Lwt.both (Lwt.fail Exception) (Lwt.return 2) in
+    state_is (Lwt.Fail Exception) p
+  end;
+
+  test "fulfilled, rejected" begin fun () ->
+    let p = Lwt.both (Lwt.return 1) (Lwt.fail Exception) in
+    state_is (Lwt.Fail Exception) p
+  end;
+
+  test "both pending" begin fun () ->
+    let p = Lwt.both (fst (Lwt.wait ())) (fst (Lwt.wait ())) in
+    state_is Lwt.Sleep p
+  end;
+
+  test "pending, fulfilled" begin fun () ->
+    let p = Lwt.both (fst (Lwt.wait ())) (Lwt.return 2) in
+    state_is Lwt.Sleep p
+  end;
+
+  test "pending, rejected" begin fun () ->
+    let p = Lwt.both (fst (Lwt.wait ())) (Lwt.fail Exception) in
+    state_is Lwt.Sleep p
+  end;
+
+  test "fulfilled, pending" begin fun () ->
+    let p = Lwt.both (Lwt.return 1) (fst (Lwt.wait ())) in
+    state_is Lwt.Sleep p
+  end;
+
+  test "rejected, pending" begin fun () ->
+    let p = Lwt.both (Lwt.fail Exception) (fst (Lwt.wait ())) in
+    state_is Lwt.Sleep p
+  end;
+
+  test "pending, fulfilled, then fulfilled" begin fun () ->
+    let p1, r1 = Lwt.wait () in
+    let p = Lwt.both p1 (Lwt.return 2) in
+    Lwt.wakeup_later r1 1;
+    state_is (Lwt.Return (1, 2)) p
+  end;
+
+  test "pending, rejected, then fulfilled" begin fun () ->
+    let p1, r1 = Lwt.wait () in
+    let p = Lwt.both p1 (Lwt.fail Exception) in
+    Lwt.wakeup_later r1 1;
+    state_is (Lwt.Fail Exception) p
+  end;
+
+  test "pending, fulfilled, then rejected" begin fun () ->
+    let p1, r1 = Lwt.wait () in
+    let p = Lwt.both p1 (Lwt.return 2) in
+    Lwt.wakeup_later_exn r1 Exception;
+    state_is (Lwt.Fail Exception) p
+  end;
+
+  test "pending, rejected, then rejected" begin fun () ->
+    let p1, r1 = Lwt.wait () in
+    let p = Lwt.both p1 (Lwt.fail Exception) in
+    Lwt.wakeup_later_exn r1 Exit;
+    state_is (Lwt.Fail Exception) p
+  end;
+
+  test "fulfilled, pending, then fulfilled" begin fun () ->
+    let p2, r2 = Lwt.wait () in
+    let p = Lwt.both (Lwt.return 1) p2 in
+    Lwt.wakeup_later r2 2;
+    state_is (Lwt.Return (1, 2)) p
+  end;
+
+  test "rejected, pending, then fulfilled" begin fun () ->
+    let p2, r2 = Lwt.wait () in
+    let p = Lwt.both (Lwt.fail Exception) p2 in
+    Lwt.wakeup_later r2 2;
+    state_is (Lwt.Fail Exception) p
+  end;
+
+  test "fulfilled, pending, then rejected" begin fun () ->
+    let p2, r2 = Lwt.wait () in
+    let p = Lwt.both (Lwt.return 1) p2 in
+    Lwt.wakeup_later_exn r2 Exception;
+    state_is (Lwt.Fail Exception) p
+  end;
+
+  test "rejected, pending, then rejected" begin fun () ->
+    let p2, r2 = Lwt.wait () in
+    let p = Lwt.both (Lwt.fail Exception) p2 in
+    Lwt.wakeup_later_exn r2 Exit;
+    state_is (Lwt.Fail Exception) p
+  end;
+
+  test "pending, then first fulfilled" begin fun () ->
+    let p1, r1 = Lwt.wait () in
+    let p = Lwt.both p1 (fst (Lwt.wait ())) in
+    Lwt.wakeup_later r1 1;
+    state_is Lwt.Sleep p
+  end;
+
+  test "pending, then first rejected" begin fun () ->
+    let p1, r1 = Lwt.wait () in
+    let p = Lwt.both p1 (fst (Lwt.wait ())) in
+    Lwt.wakeup_later_exn r1 Exception;
+    state_is Lwt.Sleep p
+  end;
+
+  test "pending, then second fulfilled" begin fun () ->
+    let p2, r2 = Lwt.wait () in
+    let p = Lwt.both (fst (Lwt.wait ())) p2 in
+    Lwt.wakeup_later r2 2;
+    state_is Lwt.Sleep p
+  end;
+
+  test "pending, then second rejected" begin fun () ->
+    let p2, r2 = Lwt.wait () in
+    let p = Lwt.both (fst (Lwt.wait ())) p2 in
+    Lwt.wakeup_later_exn r2 Exception;
+    state_is Lwt.Sleep p
+  end;
+
+  test "pending, then first fulfilled, then fulfilled" begin fun () ->
+    let p1, r1 = Lwt.wait () in
+    let p2, r2 = Lwt.wait () in
+    let p = Lwt.both p1 p2 in
+    Lwt.wakeup_later r1 1;
+    Lwt.wakeup_later r2 2;
+    state_is (Lwt.Return (1, 2)) p
+  end;
+
+  test "pending, then first fulfilled, then rejected" begin fun () ->
+    let p1, r1 = Lwt.wait () in
+    let p2, r2 = Lwt.wait () in
+    let p = Lwt.both p1 p2 in
+    Lwt.wakeup_later r1 1;
+    Lwt.wakeup_later_exn r2 Exception;
+    state_is (Lwt.Fail Exception) p
+  end;
+
+  test "pending, then first rejected, then fulfilled" begin fun () ->
+    let p1, r1 = Lwt.wait () in
+    let p2, r2 = Lwt.wait () in
+    let p = Lwt.both p1 p2 in
+    Lwt.wakeup_later_exn r1 Exception;
+    Lwt.wakeup_later r2 2;
+    state_is (Lwt.Fail Exception) p
+  end;
+
+  test "pending, then first rejected, then rejected" begin fun () ->
+    let p1, r1 = Lwt.wait () in
+    let p2, r2 = Lwt.wait () in
+    let p = Lwt.both p1 p2 in
+    Lwt.wakeup_later_exn r1 Exception;
+    Lwt.wakeup_later_exn r2 Exit;
+    state_is (Lwt.Fail Exception) p
+  end;
+
+test "pending, then second fulfilled, then fulfilled" begin fun () ->
+    let p1, r1 = Lwt.wait () in
+    let p2, r2 = Lwt.wait () in
+    let p = Lwt.both p1 p2 in
+    Lwt.wakeup_later r2 2;
+    Lwt.wakeup_later r1 1;
+    state_is (Lwt.Return (1, 2)) p
+  end;
+
+  test "pending, then second fulfilled, then rejected" begin fun () ->
+    let p1, r1 = Lwt.wait () in
+    let p2, r2 = Lwt.wait () in
+    let p = Lwt.both p1 p2 in
+    Lwt.wakeup_later r2 2;
+    Lwt.wakeup_later_exn r1 Exception;
+    state_is (Lwt.Fail Exception) p
+  end;
+
+  test "pending, then second rejected, then fulfilled" begin fun () ->
+    let p1, r1 = Lwt.wait () in
+    let p2, r2 = Lwt.wait () in
+    let p = Lwt.both p1 p2 in
+    Lwt.wakeup_later_exn r2 Exception;
+    Lwt.wakeup_later r1 1;
+    state_is (Lwt.Fail Exception) p
+  end;
+
+  test "pending, then second rejected, then rejected" begin fun () ->
+    let p1, r1 = Lwt.wait () in
+    let p2, r2 = Lwt.wait () in
+    let p = Lwt.both p1 p2 in
+    Lwt.wakeup_later_exn r2 Exception;
+    Lwt.wakeup_later_exn r1 Exit;
+    state_is (Lwt.Fail Exception) p
+  end;
+
+  test "diamond" begin fun () ->
+    let p1, r1 = Lwt.wait () in
+    let p = Lwt.both p1 p1 in
+    Lwt.bind (state_is Lwt.Sleep p) (fun was_pending ->
+    Lwt.wakeup_later r1 1;
+    Lwt.bind (state_is (Lwt.Return (1, 1)) p) (fun is_fulfilled ->
+    Lwt.return (was_pending && is_fulfilled)))
+  end;
+]
+let suites = suites @ [both_tests]
+
 let choose_tests = suite "choose" [
   test "empty" begin fun () ->
     let p = Lwt.choose [] in
@@ -3573,6 +3786,50 @@ let suites = suites @ [infix_operator_tests]
 
 
 
+(* Like the infix operator tests, these just check that the necessary functions
+   exist in Lwt.Infix.Let_syntax, and do roughly what they should. We are not
+   testing the full syntax to avoid large dependencies for the test suite. *)
+let ppx_let_tests = suite "ppx_let" [
+  test "return" begin fun () ->
+    let p = Lwt.Infix.Let_syntax.return () in
+    state_is (Lwt.Return ()) p
+  end;
+
+  test "map" begin fun () ->
+    let p = Lwt.Infix.Let_syntax.map (Lwt.return 1) ~f:(fun x -> x + 1) in
+    state_is (Lwt.Return 2) p
+  end;
+
+  test "bind" begin fun () ->
+    let p =
+      Lwt.Infix.Let_syntax.bind
+        (Lwt.return 1) ~f:(fun x -> Lwt.return (x + 1))
+    in
+    state_is (Lwt.Return 2) p
+  end;
+
+  test "both" begin fun () ->
+    let p = Lwt.both (Lwt.return 1) (Lwt.return 2) in
+    state_is (Lwt.Return (1, 2)) p
+  end;
+
+  test "Open_on_rhs" begin fun () ->
+    let module Local =
+      struct
+        module type Empty =
+        sig
+        end
+      end
+    in
+    let x : (module Local.Empty) = (module Lwt.Infix.Let_syntax.Open_on_rhs) in
+    ignore x;
+    Lwt.return true
+  end;
+]
+let suites = suites @ [ppx_let_tests]
+
+
+
 (* Tests for [Lwt.add_task_l] and [Lwt.add_task_r]. *)
 
 let lwt_sequence_contains sequence list =