diff --git a/dune-project b/dune-project index 7655de0773..bfe19a2026 100644 --- a/dune-project +++ b/dune-project @@ -1 +1 @@ -(lang dune 1.1) +(lang dune 1.8) diff --git a/lwt.opam b/lwt.opam index 6479985c3d..a7ae7f0f96 100644 --- a/lwt.opam +++ b/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. diff --git a/src/core/dune b/src/core/dune index f1f31af979..cbffe63da6 100644 --- a/src/core/dune +++ b/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 @@ {| diff --git a/src/core/lwt.ml b/src/core/lwt.ml index f4f8cd810f..c281dc739f 100644 --- a/src/core/lwt.ml +++ b/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 = diff --git a/src/core/lwt.mli b/src/core/lwt.mli index 82cef6897e..72ce753d21 100644 --- a/src/core/lwt.mli +++ b/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} *) diff --git a/src/core/lwt_result.ml b/src/core/lwt_result.ml index 25e162487e..86e77625b7 100644 --- a/src/core/lwt_result.ml +++ b/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 diff --git a/src/core/lwt_result.mli b/src/core/lwt_result.mli index 491b0a3cb9..ef351377e2 100644 --- a/src/core/lwt_result.mli +++ b/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 diff --git a/test/core/test_lwt_result.ml b/test/core/test_lwt_result.ml index 6ba9857780..9d123bd4ed 100644 --- a/test/core/test_lwt_result.ml +++ b/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)) + ); ]