Define let*, and* (#775)

dune-project

@@ -1 +1 @@
-(lang dune 1.1)
+(lang dune 1.8)

lwt.opam

@@ -23,6 +23,7 @@ depends: [
   "dune-configurator"
   "mmap" {>= "1.1.0"} # mmap is needed as long as Lwt supports OCaml < 4.06.0.
   "ocaml" {>= "4.02.0"}
+  ("ocaml" {>= "4.08.0"} | "ocaml-syntax-shims")
   "ocplib-endian"
   "result" # result is needed as long as Lwt supports OCaml 4.02.
   "seq" # seq is needed as long as Lwt supports OCaml < 4.07.0.

src/core/dune

@@ -1,10 +1,20 @@
 (* -*- tuareg -*- *)
 
 let preprocess =
-   match Sys.getenv "BISECT_ENABLE" with
-   | "yes" -> "(preprocess (pps bisect_ppx))"
-   | _ -> ""
-   | exception _ -> ""
+  let older =
+    Scanf.sscanf
+      Sys.ocaml_version
+      "%d.%2d.%s"
+      (fun maj min _ -> maj < 4 || (maj = 4 && min < 8))
+  in
+  let bisect =
+    match Sys.getenv "BISECT_ENABLE" with
+    | "yes" -> "(preprocess (pps bisect_ppx))"
+    | _ -> ""
+    | exception _ -> ""
+  in
+  let future_syntax = "(preprocess (future_syntax))" in
+  if older && bisect = "" then future_syntax else bisect
 
 let () = Jbuild_plugin.V1.send @@ {|
 

src/core/lwt.ml

@@ -3116,6 +3116,11 @@ struct
 end
 include Infix
 
+module Syntax =
+struct
+  let (let*) = bind
+  let (and*) = both
+end
 
 
 module Lwt_result_type =

src/core/lwt.mli

@@ -1397,6 +1397,12 @@ let () =
   end
 end
 
+(** {3 Syntax} *)
+module Syntax :
+sig
+  val (let*) : 'a t -> ('a -> 'b t) -> 'b t
+  val (and*) : 'a t -> 'b t -> ('a * 'b) t
+end
 
 
 (** {3 Pre-allocated promises} *)

src/core/lwt_result.ml

@@ -65,9 +65,34 @@ let bind_lwt_err e f =
       | Error e -> Lwt.bind (f e) fail
       | Ok x -> return x)
 
+let both a b =
+  let s = ref None in
+  let set_once e =
+    match !s with
+    | None -> s:= Some e
+    | Some _ -> ()
+  in
+  let (a,b) = map_err set_once a,map_err set_once b in
+  let some_assert = function
+    | None -> assert false
+    | Some e -> Error e
+  in
+  Lwt.map
+    (function
+      | Ok x, Ok y -> Ok (x,y)
+      | Error _, Ok _
+      | Ok _,Error _ 
+      | Error _, Error _ -> some_assert !s)
+    (Lwt.both a b)
+
 module Infix = struct
   let (>>=) = bind
   let (>|=) e f = map f e
 end
 
+module Syntax = struct
+  let (let*) = bind
+  let (and*) = both
+end
+
 include Infix

src/core/lwt_result.mli

@@ -41,9 +41,23 @@ val bind_lwt_err : ('a,'e1) t -> ('e1 -> 'e2 Lwt.t) -> ('a,'e2) t
 
 val bind_result : ('a,'e) t -> ('a -> ('b,'e) Result.result) -> ('b,'e) t
 
+val both : ('a,'e) t -> ('b,'e) t -> ('a * 'b,'e) 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}}.
+    If only [p_1] is [Error e], the promise returns [Error e],
+    If only [p_2] is [Error e], the promise returns [Error e],
+    If both [p_1] and [p_2] are errors, the error corresponding to the promise that resolved first is returned.
+    *)
+
+
 module Infix : sig
   val (>|=) : ('a,'e) t -> ('a -> 'b) -> ('b,'e) t
   val (>>=) : ('a,'e) t -> ('a -> ('b,'e) t) -> ('b,'e) t
 end
 
+module Syntax : sig
+  val (let*) : ('a,'e) t -> ('a -> ('b,'e) t) -> ('b,'e) t
+  val (and*) : ('a,'e) t -> ('b,'e) t -> ('a * 'b,'e) t
+end
+
 include module type of Infix

test/core/test_lwt_result.ml

@@ -7,6 +7,9 @@ open Test
 
 exception Dummy_error
 
+let state_is =
+  Lwt.debug_state_is
+
 let suite =
   suite "lwt_result" [
     test "maps"
@@ -128,4 +131,58 @@ let suite =
          let f y = Result.Ok (y + 1) in
          Lwt.return (Lwt_result.bind_result x f = Lwt_result.fail 0)
       );
+
+    test "both ok"
+      (fun () ->
+         let p =
+           Lwt_result.both
+             (Lwt_result.return 0)
+             (Lwt_result.return 1)
+         in
+         state_is (Lwt.Return (Result.Ok (0,1))) p
+      );
+
+    test "both only fst error"
+      (fun () ->
+         let p =
+           Lwt_result.both
+             (Lwt_result.fail 0)
+             (Lwt_result.return 1)
+         in
+         state_is (Lwt.Return (Result.Error 0)) p
+      );
+
+    test "both only snd error"
+      (fun () ->
+         let p =
+           Lwt_result.both
+             (Lwt_result.return 0)
+             (Lwt_result.fail 1)
+         in
+         state_is (Lwt.Return (Result.Error 1)) p
+      );
+
+    test "both error, fst"
+      (fun () ->
+         let p2, r2 = Lwt.wait () in
+         let p =
+           Lwt_result.both
+             (Lwt_result.fail 0)
+             p2
+         in
+         Lwt.wakeup_later r2 (Result.Error 1);
+         Lwt.bind p (fun x -> Lwt.return (x = Result.Error 0))
+      );
+
+    test "both error, snd"
+      (fun () ->
+         let p1, r1 = Lwt.wait () in
+         let p =
+           Lwt_result.both
+             p1
+             (Lwt_result.fail 1)
+         in
+         Lwt.wakeup_later r1 (Result.Error 0);
+         Lwt.bind p (fun x -> Lwt.return (x = Result.Error 1))
+      );
   ]