Skip to content

Commit d7e23c7

Browse files
aantronaantron
committed
Add Lwt.both
1 parent dae4db7 commit d7e23c7

3 files changed

Lines changed: 226 additions & 0 deletions

File tree

‎src/core/lwt.ml‎

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2445,6 +2445,7 @@ sig
24452445
val async : (unit -> _ t) -> unit
24462446
val ignore_result : _ t -> unit
24472447

2448+
val both : 'a t -> 'b t -> ('a * 'b) t
24482449
val join : unit t list -> unit t
24492450

24502451
val choose : 'a t list -> 'a t
@@ -2568,6 +2569,16 @@ struct
25682569

25692570
attach_callback_or_resolve_immediately ps
25702571

2572+
let both p1 p2 =
2573+
let v1 = ref None in
2574+
let v2 = ref None in
2575+
let p1' = bind p1 (fun v -> v1 := Some v; return_unit) in
2576+
let p2' = bind p2 (fun v -> v2 := Some v; return_unit) in
2577+
join [p1'; p2'] |> map (fun () ->
2578+
match !v1, !v2 with
2579+
| Some v1, Some v2 -> v1, v2
2580+
| _ -> assert false)
2581+
25712582

25722583

25732584
(* Maintainer's note: the next few functions are helpers for [choose] and

‎src/core/lwt.mli‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -890,6 +890,8 @@ v}
890890

891891
(** {3 Multiple wait} *)
892892

893+
val both : 'a t -> 'b t -> ('a * 'b) t
894+
893895
val join : (unit t) list -> unit t
894896
(** [Lwt.join ps] returns a promise that is pending until {e all} promises in
895897
the list [ps] become {{: #TYPEt} {e resolved}}.

‎test/core/test_lwt.ml‎

Lines changed: 213 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1892,6 +1892,219 @@ let join_tests = suite "join" [
18921892
]
18931893
let suites = suites @ [join_tests]
18941894

1895+
let both_tests = suite "both" [
1896+
test "both fulfilled" begin fun () ->
1897+
let p = Lwt.both (Lwt.return 1) (Lwt.return 2) in
1898+
state_is (Lwt.Return (1, 2)) p
1899+
end;
1900+
1901+
test "all rejected" begin fun () ->
1902+
let p = Lwt.both (Lwt.fail Exception) (Lwt.fail Exit) in
1903+
state_is (Lwt.Fail Exception) p
1904+
end;
1905+
1906+
test "rejected, fulfilled" begin fun () ->
1907+
let p = Lwt.both (Lwt.fail Exception) (Lwt.return 2) in
1908+
state_is (Lwt.Fail Exception) p
1909+
end;
1910+
1911+
test "fulfilled, rejected" begin fun () ->
1912+
let p = Lwt.both (Lwt.return 1) (Lwt.fail Exception) in
1913+
state_is (Lwt.Fail Exception) p
1914+
end;
1915+
1916+
test "both pending" begin fun () ->
1917+
let p = Lwt.both (fst (Lwt.wait ())) (fst (Lwt.wait ())) in
1918+
state_is Lwt.Sleep p
1919+
end;
1920+
1921+
test "pending, fulfilled" begin fun () ->
1922+
let p = Lwt.both (fst (Lwt.wait ())) (Lwt.return 2) in
1923+
state_is Lwt.Sleep p
1924+
end;
1925+
1926+
test "pending, rejected" begin fun () ->
1927+
let p = Lwt.both (fst (Lwt.wait ())) (Lwt.fail Exception) in
1928+
state_is Lwt.Sleep p
1929+
end;
1930+
1931+
test "fulfilled, pending" begin fun () ->
1932+
let p = Lwt.both (Lwt.return 1) (fst (Lwt.wait ())) in
1933+
state_is Lwt.Sleep p
1934+
end;
1935+
1936+
test "rejected, pending" begin fun () ->
1937+
let p = Lwt.both (Lwt.fail Exception) (fst (Lwt.wait ())) in
1938+
state_is Lwt.Sleep p
1939+
end;
1940+
1941+
test "pending, fulfilled, then fulfilled" begin fun () ->
1942+
let p1, r1 = Lwt.wait () in
1943+
let p = Lwt.both p1 (Lwt.return 2) in
1944+
Lwt.wakeup_later r1 1;
1945+
state_is (Lwt.Return (1, 2)) p
1946+
end;
1947+
1948+
test "pending, rejected, then fulfilled" begin fun () ->
1949+
let p1, r1 = Lwt.wait () in
1950+
let p = Lwt.both p1 (Lwt.fail Exception) in
1951+
Lwt.wakeup_later r1 1;
1952+
state_is (Lwt.Fail Exception) p
1953+
end;
1954+
1955+
test "pending, fulfilled, then rejected" begin fun () ->
1956+
let p1, r1 = Lwt.wait () in
1957+
let p = Lwt.both p1 (Lwt.return 2) in
1958+
Lwt.wakeup_later_exn r1 Exception;
1959+
state_is (Lwt.Fail Exception) p
1960+
end;
1961+
1962+
test "pending, rejected, then rejected" begin fun () ->
1963+
let p1, r1 = Lwt.wait () in
1964+
let p = Lwt.both p1 (Lwt.fail Exception) in
1965+
Lwt.wakeup_later_exn r1 Exit;
1966+
state_is (Lwt.Fail Exception) p
1967+
end;
1968+
1969+
test "fulfilled, pending, then fulfilled" begin fun () ->
1970+
let p2, r2 = Lwt.wait () in
1971+
let p = Lwt.both (Lwt.return 1) p2 in
1972+
Lwt.wakeup_later r2 2;
1973+
state_is (Lwt.Return (1, 2)) p
1974+
end;
1975+
1976+
test "rejected, pending, then fulfilled" begin fun () ->
1977+
let p2, r2 = Lwt.wait () in
1978+
let p = Lwt.both (Lwt.fail Exception) p2 in
1979+
Lwt.wakeup_later r2 2;
1980+
state_is (Lwt.Fail Exception) p
1981+
end;
1982+
1983+
test "fulfilled, pending, then rejected" begin fun () ->
1984+
let p2, r2 = Lwt.wait () in
1985+
let p = Lwt.both (Lwt.return 1) p2 in
1986+
Lwt.wakeup_later_exn r2 Exception;
1987+
state_is (Lwt.Fail Exception) p
1988+
end;
1989+
1990+
test "rejected, pending, then rejected" begin fun () ->
1991+
let p2, r2 = Lwt.wait () in
1992+
let p = Lwt.both (Lwt.fail Exception) p2 in
1993+
Lwt.wakeup_later_exn r2 Exit;
1994+
state_is (Lwt.Fail Exception) p
1995+
end;
1996+
1997+
test "pending, then first fulfilled" begin fun () ->
1998+
let p1, r1 = Lwt.wait () in
1999+
let p = Lwt.both p1 (fst (Lwt.wait ())) in
2000+
Lwt.wakeup_later r1 1;
2001+
state_is Lwt.Sleep p
2002+
end;
2003+
2004+
test "pending, then first rejected" begin fun () ->
2005+
let p1, r1 = Lwt.wait () in
2006+
let p = Lwt.both p1 (fst (Lwt.wait ())) in
2007+
Lwt.wakeup_later_exn r1 Exception;
2008+
state_is Lwt.Sleep p
2009+
end;
2010+
2011+
test "pending, then second fulfilled" begin fun () ->
2012+
let p2, r2 = Lwt.wait () in
2013+
let p = Lwt.both (fst (Lwt.wait ())) p2 in
2014+
Lwt.wakeup_later r2 2;
2015+
state_is Lwt.Sleep p
2016+
end;
2017+
2018+
test "pending, then second rejected" begin fun () ->
2019+
let p2, r2 = Lwt.wait () in
2020+
let p = Lwt.both (fst (Lwt.wait ())) p2 in
2021+
Lwt.wakeup_later_exn r2 Exception;
2022+
state_is Lwt.Sleep p
2023+
end;
2024+
2025+
test "pending, then first fulfilled, then fulfilled" begin fun () ->
2026+
let p1, r1 = Lwt.wait () in
2027+
let p2, r2 = Lwt.wait () in
2028+
let p = Lwt.both p1 p2 in
2029+
Lwt.wakeup_later r1 1;
2030+
Lwt.wakeup_later r2 2;
2031+
state_is (Lwt.Return (1, 2)) p
2032+
end;
2033+
2034+
test "pending, then first fulfilled, then rejected" begin fun () ->
2035+
let p1, r1 = Lwt.wait () in
2036+
let p2, r2 = Lwt.wait () in
2037+
let p = Lwt.both p1 p2 in
2038+
Lwt.wakeup_later r1 1;
2039+
Lwt.wakeup_later_exn r2 Exception;
2040+
state_is (Lwt.Fail Exception) p
2041+
end;
2042+
2043+
test "pending, then first rejected, then fulfilled" begin fun () ->
2044+
let p1, r1 = Lwt.wait () in
2045+
let p2, r2 = Lwt.wait () in
2046+
let p = Lwt.both p1 p2 in
2047+
Lwt.wakeup_later_exn r1 Exception;
2048+
Lwt.wakeup_later r2 2;
2049+
state_is (Lwt.Fail Exception) p
2050+
end;
2051+
2052+
test "pending, then first rejected, then rejected" begin fun () ->
2053+
let p1, r1 = Lwt.wait () in
2054+
let p2, r2 = Lwt.wait () in
2055+
let p = Lwt.both p1 p2 in
2056+
Lwt.wakeup_later_exn r1 Exception;
2057+
Lwt.wakeup_later_exn r2 Exit;
2058+
state_is (Lwt.Fail Exception) p
2059+
end;
2060+
2061+
test "pending, then second fulfilled, then fulfilled" begin fun () ->
2062+
let p1, r1 = Lwt.wait () in
2063+
let p2, r2 = Lwt.wait () in
2064+
let p = Lwt.both p1 p2 in
2065+
Lwt.wakeup_later r2 2;
2066+
Lwt.wakeup_later r1 1;
2067+
state_is (Lwt.Return (1, 2)) p
2068+
end;
2069+
2070+
test "pending, then second fulfilled, then rejected" begin fun () ->
2071+
let p1, r1 = Lwt.wait () in
2072+
let p2, r2 = Lwt.wait () in
2073+
let p = Lwt.both p1 p2 in
2074+
Lwt.wakeup_later r2 2;
2075+
Lwt.wakeup_later_exn r1 Exception;
2076+
state_is (Lwt.Fail Exception) p
2077+
end;
2078+
2079+
test "pending, then second rejected, then fulfilled" begin fun () ->
2080+
let p1, r1 = Lwt.wait () in
2081+
let p2, r2 = Lwt.wait () in
2082+
let p = Lwt.both p1 p2 in
2083+
Lwt.wakeup_later_exn r2 Exception;
2084+
Lwt.wakeup_later r1 1;
2085+
state_is (Lwt.Fail Exception) p
2086+
end;
2087+
2088+
test "pending, then second rejected, then rejected" begin fun () ->
2089+
let p1, r1 = Lwt.wait () in
2090+
let p2, r2 = Lwt.wait () in
2091+
let p = Lwt.both p1 p2 in
2092+
Lwt.wakeup_later_exn r2 Exception;
2093+
Lwt.wakeup_later_exn r1 Exit;
2094+
state_is (Lwt.Fail Exception) p
2095+
end;
2096+
2097+
test "diamond" begin fun () ->
2098+
let p1, r1 = Lwt.wait () in
2099+
let p = Lwt.both p1 p1 in
2100+
Lwt.bind (state_is Lwt.Sleep p) (fun was_pending ->
2101+
Lwt.wakeup_later r1 1;
2102+
Lwt.bind (state_is (Lwt.Return (1, 1)) p) (fun is_fulfilled ->
2103+
Lwt.return (was_pending && is_fulfilled)))
2104+
end;
2105+
]
2106+
let suites = suites @ [both_tests]
2107+
18952108
let choose_tests = suite "choose" [
18962109
test "empty" begin fun () ->
18972110
let p = Lwt.choose [] in

0 commit comments

Comments
 (0)