From 0aa0e75ace37f079f816a3739efadf6c9f6132e3 Mon Sep 17 00:00:00 2001 From: Sora Morimoto Date: Tue, 7 Dec 2021 11:28:08 +0900 Subject: [PATCH 1/2] Upgrade dune to 2.0 Signed-off-by: Sora Morimoto --- dune-project | 2 +- src/unix/dune | 270 ++++++++++++++++++----------------- test/core/dune | 10 +- test/domain/dune | 8 +- test/packaging/dune/ppx/dune | 3 +- test/ppx/dune | 13 +- test/ppx_let/dune | 10 +- test/react/dune | 7 +- test/unix/dune | 29 ++-- 9 files changed, 184 insertions(+), 168 deletions(-) diff --git a/dune-project b/dune-project index bfe19a2026..929c696e56 100644 --- a/dune-project +++ b/dune-project @@ -1 +1 @@ -(lang dune 1.8) +(lang dune 2.0) diff --git a/src/unix/dune b/src/unix/dune index 80b2917e68..a53ea5fadf 100644 --- a/src/unix/dune +++ b/src/unix/dune @@ -44,139 +44,143 @@ let () = Jbuild_plugin.V1.send @@ {| (wrapped false) (libraries bigarray lwt mmap ocplib-endian.bigstring threads unix) |} ^ preprocess ^ {| - (c_names - lwt_unix_stubs - lwt_libev_stubs - lwt_process_stubs - unix_readable - unix_writable - unix_madvise - unix_get_page_size - windows_get_page_size - unix_mincore - unix_read - unix_pread - windows_read - windows_pread - unix_bytes_read - windows_bytes_read - unix_write - unix_pwrite - windows_write - windows_pwrite - unix_bytes_write - windows_bytes_write - unix_readv_writev_utils - unix_iov_max - unix_writev - unix_writev_job - unix_readv - unix_readv_job - unix_send - unix_bytes_send - unix_recv - unix_bytes_recv - unix_recvfrom - unix_bytes_recvfrom - unix_sendto - unix_sendto_byte - unix_bytes_sendto - unix_bytes_sendto_byte - unix_recv_send_utils - unix_recv_msg - unix_send_msg - unix_send_msg_byte - unix_get_credentials - unix_mcast_utils - unix_mcast_set_loop - unix_mcast_set_ttl - unix_mcast_modify_membership - unix_wait4 - unix_get_cpu - unix_get_affinity - unix_set_affinity - unix_guess_blocking_job - unix_wait_mincore_job - unix_open_job - unix_read_job - unix_pread_job - windows_read_job - windows_pread_job - unix_bytes_read_job - windows_bytes_read_job - unix_write_job - windows_write_job - unix_pwrite_job - windows_pwrite_job - unix_bytes_write_job - windows_bytes_write_job - unix_stat_job_utils - unix_stat_job - unix_stat_64_job - unix_lstat_job - unix_lstat_64_job - unix_fstat_job - unix_fstat_64_job - unix_utimes_job - unix_isatty_job - unix_opendir_job - unix_closedir_job - unix_valid_dir - unix_invalidate_dir - unix_rewinddir_job - unix_readdir_job - unix_readdir_n_job - unix_readlink_job - unix_lockf_job - unix_getlogin_job - unix_get_pw_gr_nam_id_job - unix_get_network_information_utils - unix_gethostname_job - unix_gethostbyname_job - unix_gethostbyaddr_job - unix_getprotoby_getservby_job - unix_getaddrinfo_job - unix_getnameinfo_job - unix_bind_job - unix_getcwd_job - unix_termios_conversion - unix_tcgetattr_job - unix_tcsetattr_job - windows_is_socket - windows_fsync_job - windows_system_job - windows_not_available - unix_not_available - unix_access_job - unix_chdir_job - unix_chmod_job - unix_chown_job - unix_chroot_job - unix_close_job - unix_fchmod_job - unix_fchown_job - unix_fdatasync_job - unix_fsync_job - unix_ftruncate_job - unix_link_job - unix_lseek_job - unix_mkdir_job - unix_mkfifo_job - unix_rename_job - unix_rmdir_job - unix_symlink_job - unix_tcdrain_job - unix_tcflow_job - unix_tcflush_job - unix_tcsendbreak_job - unix_truncate_job - unix_unlink_job - unix_somaxconn - windows_somaxconn - unix_accept4 - ) + (foreign_stubs + (language c) + (names + lwt_libev_stubs + lwt_process_stubs + lwt_unix_stubs + unix_accept4 + unix_access_job + unix_bind_job + unix_bytes_read + unix_bytes_read_job + unix_bytes_recv + unix_bytes_recvfrom + unix_bytes_send + unix_bytes_sendto + unix_bytes_sendto_byte + unix_bytes_write + unix_bytes_write_job + unix_chdir_job + unix_chmod_job + unix_chown_job + unix_chroot_job + unix_close_job + unix_closedir_job + unix_fchmod_job + unix_fchown_job + unix_fdatasync_job + unix_fstat_64_job + unix_fstat_job + unix_fsync_job + unix_ftruncate_job + unix_get_affinity + unix_get_cpu + unix_get_credentials + unix_get_network_information_utils + unix_get_page_size + unix_get_pw_gr_nam_id_job + unix_getaddrinfo_job + unix_getcwd_job + unix_gethostbyaddr_job + unix_gethostbyname_job + unix_gethostname_job + unix_getlogin_job + unix_getnameinfo_job + unix_getprotoby_getservby_job + unix_guess_blocking_job + unix_invalidate_dir + unix_iov_max + unix_isatty_job + unix_link_job + unix_lockf_job + unix_lseek_job + unix_lstat_64_job + unix_lstat_job + unix_madvise + unix_mcast_modify_membership + unix_mcast_set_loop + unix_mcast_set_ttl + unix_mcast_utils + unix_mincore + unix_mkdir_job + unix_mkfifo_job + unix_not_available + unix_open_job + unix_opendir_job + unix_pread + unix_pread_job + unix_pwrite + unix_pwrite_job + unix_read + unix_read_job + unix_readable + unix_readdir_job + unix_readdir_n_job + unix_readlink_job + unix_readv + unix_readv_job + unix_readv_writev_utils + unix_recv + unix_recv_msg + unix_recv_send_utils + unix_recvfrom + unix_rename_job + unix_rewinddir_job + unix_rmdir_job + unix_send + unix_send_msg + unix_send_msg_byte + unix_sendto + unix_sendto_byte + unix_set_affinity + unix_somaxconn + unix_stat_64_job + unix_stat_job + unix_stat_job_utils + unix_symlink_job + unix_tcdrain_job + unix_tcflow_job + unix_tcflush_job + unix_tcgetattr_job + unix_tcsendbreak_job + unix_tcsetattr_job + unix_termios_conversion + unix_truncate_job + unix_unlink_job + unix_utimes_job + unix_valid_dir + unix_wait_mincore_job + unix_wait4 + unix_writable + unix_write + unix_write_job + unix_writev + unix_writev_job + windows_bytes_read + windows_bytes_read_job + windows_bytes_write + windows_bytes_write_job + windows_fsync_job + windows_get_page_size + windows_is_socket + windows_not_available + windows_pread + windows_pread_job + windows_pwrite + windows_pwrite_job + windows_read + windows_read_job + windows_somaxconn + windows_system_job + windows_write + windows_write_job) + (flags + (:include unix_c_flags.sexp)) + (include_dirs .)) (install_c_headers lwt_features lwt_config lwt_unix) - (c_flags -I. (:include unix_c_flags.sexp)) - (c_library_flags (:include unix_c_library_flags.sexp))) + (c_library_flags + (:include unix_c_library_flags.sexp))) |} diff --git a/test/core/dune b/test/core/dune index e5e0e8c45c..f57af55eae 100644 --- a/test/core/dune +++ b/test/core/dune @@ -2,9 +2,11 @@ (name main) (libraries lwttester) (preprocess (future_syntax)) - (flags (:standard -w +A-40-42))) + (flags + (:standard -w +A-40-42))) -(alias - (name runtest) +(rule + (alias runtest) (package lwt) - (action (run %{exe:main.exe}))) + (action + (run %{exe:main.exe}))) diff --git a/test/domain/dune b/test/domain/dune index 9e4ee5eb35..50096974da 100644 --- a/test/domain/dune +++ b/test/domain/dune @@ -2,8 +2,8 @@ (name main) (libraries lwt_domain lwttester tester)) -(alias - (name runtest) +(rule + (alias runtest) (package lwt_domain) - (action (run %{exe:main.exe})) -) + (action + (run %{exe:main.exe}))) diff --git a/test/packaging/dune/ppx/dune b/test/packaging/dune/ppx/dune index 0f5c7809d6..fd6021f26f 100644 --- a/test/packaging/dune/ppx/dune +++ b/test/packaging/dune/ppx/dune @@ -1,4 +1,5 @@ (executable (name user) (libraries lwt) - (preprocess (pps lwt_ppx))) + (preprocess + (pps lwt_ppx))) diff --git a/test/ppx/dune b/test/ppx/dune index c90d449533..9dcca60152 100644 --- a/test/ppx/dune +++ b/test/ppx/dune @@ -1,10 +1,13 @@ (executable (name main) (libraries lwttester) - (preprocess (pps lwt_ppx)) - (flags (:standard -warn-error -22))) + (preprocess + (pps lwt_ppx)) + (flags + (:standard -warn-error -22))) -(alias - (name runtest) +(rule + (alias runtest) (package lwt_ppx) - (action (run %{exe:main.exe}))) + (action + (run %{exe:main.exe}))) diff --git a/test/ppx_let/dune b/test/ppx_let/dune index 71b4e5c5ba..24b1935b66 100644 --- a/test/ppx_let/dune +++ b/test/ppx_let/dune @@ -1,9 +1,11 @@ (executable (name test) - (preprocess (pps ppx_let)) + (preprocess + (pps ppx_let)) (libraries lwt lwt.unix)) -(alias - (name runtest) +(rule + (alias runtest) (package lwt_ppx_let) - (action (run %{exe:test.exe}))) + (action + (run %{exe:test.exe}))) diff --git a/test/react/dune b/test/react/dune index 7d236bf6b6..078a3ead98 100644 --- a/test/react/dune +++ b/test/react/dune @@ -2,7 +2,8 @@ (name main) (libraries lwt_react lwttester)) -(alias - (name runtest) +(rule + (alias runtest) (package lwt_react) - (action (run %{exe:main.exe}))) + (action + (run %{exe:main.exe}))) diff --git a/test/unix/dune b/test/unix/dune index 8d961a234d..69a1c86491 100644 --- a/test/unix/dune +++ b/test/unix/dune @@ -1,12 +1,15 @@ (rule (targets test_lwt_unix.ml) - (deps (:ml test_lwt_unix.cppo.ml)) - (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{ml} -o %{targets}))) + (deps + (:ml test_lwt_unix.cppo.ml)) + (action + (run %{bin:cppo} -V OCAML:%{ocaml_version} %{ml} -o %{targets}))) (library (name tester) (libraries lwt lwttester) - (modules (:standard \ main luv_main) )) + (modules + (:standard \ main luv_main))) (executable (name main) @@ -18,16 +21,16 @@ (libraries lwt lwt_luv lwttester tester) (modules luv_main)) -(alias - (name runtest) +(rule + (alias runtest) (package lwt) - (action (run %{exe:main.exe})) - (deps bytes_io_data) -) + (action + (run %{exe:main.exe})) + (deps bytes_io_data)) -(alias - (name runtest_libuv) +(rule + (alias runtest_libuv) (package lwt) - (action (run %{exe:luv_main.exe})) - (deps bytes_io_data) -) + (action + (run %{exe:luv_main.exe})) + (deps bytes_io_data)) From e243d9103cb0da231b4a94c497131b86161747ac Mon Sep 17 00:00:00 2001 From: Sora Morimoto Date: Tue, 7 Dec 2021 12:00:43 +0900 Subject: [PATCH 2/2] Enable ocamlformat Signed-off-by: Sora Morimoto --- .ocamlformat | 5 + src/core/lwt.ml | 2283 +++--- src/core/lwt.mli | 1310 ++- src/core/lwt_condition.ml | 18 +- src/core/lwt_condition.mli | 43 +- src/core/lwt_list.ml | 156 +- src/core/lwt_list.mli | 15 +- src/core/lwt_mutex.ml | 24 +- src/core/lwt_mutex.mli | 40 +- src/core/lwt_mvar.ml | 61 +- src/core/lwt_mvar.mli | 25 +- src/core/lwt_pool.ml | 107 +- src/core/lwt_pool.mli | 111 +- src/core/lwt_pqueue.ml | 128 +- src/core/lwt_pqueue.mli | 90 +- src/core/lwt_result.ml | 90 +- src/core/lwt_result.mli | 63 +- src/core/lwt_seq.ml | 126 +- src/core/lwt_seq.mli | 143 +- src/core/lwt_sequence.ml | 127 +- src/core/lwt_sequence.mli | 123 +- src/core/lwt_stream.ml | 1029 +-- src/core/lwt_stream.mli | 260 +- src/core/lwt_switch.ml | 54 +- src/core/lwt_switch.mli | 68 +- src/domain/lwt_domain.ml | 38 +- src/domain/lwt_domain.mli | 130 +- src/ppx/ppx_lwt.ml | 447 +- src/ppx/ppx_lwt.mli | 253 +- src/react/lwt_react.mli | 220 +- src/unix/config/discover.ml | 936 ++- src/unix/luv/lwt_luv.ml | 128 +- src/unix/luv/lwt_luv.mli | 2 +- src/unix/lwt_bytes.ml | 187 +- src/unix/lwt_bytes.mli | 163 +- src/unix/lwt_config.ml | 12 +- src/unix/lwt_engine.ml | 634 +- src/unix/lwt_engine.mli | 282 +- src/unix/lwt_fmt.ml | 56 +- src/unix/lwt_fmt.mli | 78 +- src/unix/lwt_gc.ml | 88 +- src/unix/lwt_gc.mli | 21 +- src/unix/lwt_io.ml | 1683 ++-- src/unix/lwt_io.mli | 603 +- src/unix/lwt_main.ml | 157 +- src/unix/lwt_main.mli | 123 +- src/unix/lwt_preemptive.ml | 121 +- src/unix/lwt_preemptive.mli | 78 +- src/unix/lwt_process.ml | 445 +- src/unix/lwt_process.mli | 534 +- src/unix/lwt_sys.ml | 11 +- src/unix/lwt_sys.mli | 42 +- src/unix/lwt_throttle.ml | 90 +- src/unix/lwt_throttle.mli | 9 +- src/unix/lwt_timeout.ml | 69 +- src/unix/lwt_timeout.mli | 13 +- test/core/main.ml | 31 +- test/core/test_lwt.ml | 7974 +++++++++---------- test/core/test_lwt_condition.ml | 112 +- test/core/test_lwt_list.ml | 990 +-- test/core/test_lwt_mutex.ml | 188 +- test/core/test_lwt_mvar.ml | 143 +- test/core/test_lwt_pool.ml | 395 +- test/core/test_lwt_result.ml | 347 +- test/core/test_lwt_seq.ml | 709 +- test/core/test_lwt_sequence.ml | 694 +- test/core/test_lwt_stream.ml | 892 +-- test/core/test_lwt_switch.ml | 325 +- test/domain/main.ml | 5 +- test/domain/test_lwt_domain.ml | 153 +- test/packaging/dune/core/user.ml | 3 +- test/packaging/dune/preemptive/user.ml | 3 +- test/packaging/dune/unix/user.ml | 3 +- test/packaging/ocamlfind/core/user.ml | 3 +- test/packaging/ocamlfind/preemptive/user.ml | 3 +- test/packaging/ocamlfind/unix/user.ml | 3 +- test/ppx/main.ml | 252 +- test/ppx_expect/cases/let_1.ml | 2 +- test/ppx_expect/cases/let_2.ml | 2 +- test/ppx_expect/cases/let_3.ml | 2 +- test/ppx_expect/cases/let_4.ml | 2 +- test/ppx_expect/cases/match_1.ml | 7 +- test/ppx_expect/cases/match_2.ml | 7 +- test/ppx_expect/cases/match_3.ml | 7 +- test/ppx_expect/cases/match_4.ml | 10 +- test/ppx_expect/cases/try_1.ml | 5 +- test/ppx_expect/cases/try_2.ml | 5 +- test/ppx_expect/cases/try_3.ml | 5 +- test/ppx_expect/main.ml | 52 +- test/ppx_let/test.ml | 5 +- test/react/main.ml | 7 +- test/react/test_lwt_event.ml | 239 +- test/react/test_lwt_signal.ml | 114 +- test/test.ml | 331 +- test/test.mli | 13 +- test/test_unix.ml | 5 +- test/test_unix.mli | 2 - test/unix/luv_main.ml | 27 +- test/unix/main.ml | 25 +- test/unix/test_lwt_bytes.ml | 1385 ++-- test/unix/test_lwt_engine.ml | 125 +- test/unix/test_lwt_fmt.ml | 87 +- test/unix/test_lwt_io.ml | 1113 ++- test/unix/test_lwt_io_non_block.ml | 70 +- test/unix/test_lwt_process.ml | 29 +- test/unix/test_lwt_timeout.ml | 488 +- test/unix/test_mcast.ml | 77 +- test/unix/test_sleep_and_timeout.ml | 153 +- 108 files changed, 14497 insertions(+), 17284 deletions(-) create mode 100644 .ocamlformat diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000000..eee1fa9bdc --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,5 @@ +version=0.20.0 +profile=conventional +break-infix=fit-or-vertical +parse-docstrings=true +module-item-spacing=compact diff --git a/src/core/lwt.ml b/src/core/lwt.ml index 9dd731bf7b..0d16b27fcb 100644 --- a/src/core/lwt.ml +++ b/src/core/lwt.ml @@ -1,8 +1,6 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (* Reading guide Welcome to the implementation of the Lwt core! This is a big file, but we @@ -79,8 +77,6 @@ Enjoy! *) - - (* Overview In this file, there is a "model" function -- [Lwt.bind] -- which pulls @@ -342,8 +338,6 @@ If you've made it this far, you are an Lwt expert! Rejoice! *) - - (* Suppress warning 4, "fragile pattern matching," in this file only, due to https://github.com/ocaml/ocaml/issues/7451 @@ -351,36 +345,31 @@ This can be removed if/when Lwt requires a minimum OCaml version 4.05. *) [@@@ocaml.warning "-4"] - - (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] -module Lwt_sequence = Lwt_sequence -[@@@ocaml.warning "+3"] +module Lwt_sequence = Lwt_sequence +[@@@ocaml.warning "+3"] (* Some sequence-associated storage types Sequence-associated storage is defined and documented later, in module [Sequence_associated_storage]. However, the following types are mentioned in the definition of [promise], so they must be defined here first. *) -module Storage_map = - Map.Make - (struct - type t = int - let compare = compare - end) -type storage = (unit -> unit) Storage_map.t +module Storage_map = Map.Make (struct + type t = int + let compare = compare +end) +type storage = (unit -> unit) Storage_map.t -module Main_internal_types = -struct +module Main_internal_types = struct (* Phantom types for use with types [promise] and [state]. These are never constructed; the purpose of the constructors is to prove to the type checker that these types are distinct from each other. Warning 37, "unused @@ -390,25 +379,20 @@ struct type underlying = private Underlying_and_this_constructor_is_not_used type proxy = private Proxy_and_this_constructor_is_not_used - type resolved = private Resolved_and_this_constructor_is_not_used type pending = private Pending_and_this_constructor_is_not_used [@@@ocaml.warning "+37"] - - (* Promises proper. *) - type ('a, 'u, 'c) promise = { - mutable state : ('a, 'u, 'c) state; - } + type ('a, 'u, 'c) promise = { mutable state : ('a, 'u, 'c) state } and (_, _, _) state = - | Fulfilled : 'a -> ('a, underlying, resolved) state - | Rejected : exn -> ( _, underlying, resolved) state - | Pending : 'a callbacks -> ('a, underlying, pending) state - | Proxy : ('a, _, 'c) promise -> ('a, proxy, 'c) state + | Fulfilled : 'a -> ('a, underlying, resolved) state + | Rejected : exn -> (_, underlying, resolved) state + | Pending : 'a callbacks -> ('a, underlying, pending) state + | Proxy : ('a, _, 'c) promise -> ('a, proxy, 'c) state (* Note: @@ -437,50 +421,43 @@ struct point, and/or casts to (1) get the correct typing and (2) document the potential state change for readers of the code. *) - - (* Callback information for pending promises. *) - and 'a callbacks = { mutable regular_callbacks : 'a regular_callback_list; - mutable cancel_callbacks : 'a cancel_callback_list; - mutable how_to_cancel : how_to_cancel; + mutable cancel_callbacks : 'a cancel_callback_list; + mutable how_to_cancel : how_to_cancel; mutable cleanups_deferred : int; } and 'a regular_callback = 'a resolved_state -> unit - and cancel_callback = unit -> unit - and 'a resolved_state = ('a, underlying, resolved) state and how_to_cancel = - | Not_cancelable : how_to_cancel - | Cancel_this_promise : how_to_cancel - | Propagate_cancel_to_one : (_, _, _) promise -> how_to_cancel + | Not_cancelable : how_to_cancel + | Cancel_this_promise : how_to_cancel + | Propagate_cancel_to_one : (_, _, _) promise -> how_to_cancel | Propagate_cancel_to_several : (_, _, _) promise list -> how_to_cancel and 'a regular_callback_list = | Regular_callback_list_empty | Regular_callback_list_concat of - 'a regular_callback_list * 'a regular_callback_list - | Regular_callback_list_implicitly_removed_callback of - 'a regular_callback + 'a regular_callback_list * 'a regular_callback_list + | Regular_callback_list_implicitly_removed_callback of 'a regular_callback | Regular_callback_list_explicitly_removable_callback of - 'a regular_callback option ref + 'a regular_callback option ref and _ cancel_callback_list = - | Cancel_callback_list_empty : - _ cancel_callback_list + | Cancel_callback_list_empty : _ cancel_callback_list | Cancel_callback_list_concat : - 'a cancel_callback_list * 'a cancel_callback_list -> - 'a cancel_callback_list + 'a cancel_callback_list * 'a cancel_callback_list + -> 'a cancel_callback_list | Cancel_callback_list_callback : - storage * cancel_callback -> - _ cancel_callback_list + storage * cancel_callback + -> _ cancel_callback_list | Cancel_callback_list_remove_sequence_node : - ('a, _, _) promise Lwt_sequence.node -> - 'a cancel_callback_list + ('a, _, _) promise Lwt_sequence.node + -> 'a cancel_callback_list (* Notes: @@ -540,12 +517,10 @@ struct - The [cleanups_deferred] field is explained in module [Pending_callbacks]. *) end -open Main_internal_types - +open Main_internal_types -module Public_types = -struct +module Public_types = struct type +'a t type -'a u (* The contravariance of resolvers is, technically, unsound due to the @@ -557,12 +532,12 @@ struct let to_public_promise : ('a, _, _) promise -> 'a t = Obj.magic let to_public_resolver : ('a, _, _) promise -> 'a u = Obj.magic - type _ packed_promise = - | Internal : ('a, _, _) promise -> 'a packed_promise - [@@ocaml.unboxed] + type _ packed_promise = Internal : ('a, _, _) promise -> 'a packed_promise + [@@ocaml.unboxed] let to_internal_promise (p : 'a t) : 'a packed_promise = Internal (Obj.magic p) + let to_internal_resolver (r : 'a u) : 'a packed_promise = Internal (Obj.magic r) @@ -581,8 +556,6 @@ struct be optimized away even on older versions of OCaml that don't have Flambda and don't support [[@@ocaml.unboxed]]. *) - - (* Internal name of the public [+'a Lwt.result]. The public name is defined later in the module. This is to avoid potential confusion with [Pervasives.result]/[Result.result], as the public name would not be @@ -594,57 +567,52 @@ struct | Result.Ok x -> Fulfilled x | Result.Error exn -> Rejected exn end -include Public_types - +include Public_types -module Basic_helpers : -sig +module Basic_helpers : sig val identical : ('a, _, _) promise -> ('a, _, _) promise -> bool val underlying : ('a, 'u, 'c) promise -> ('a, underlying, 'c) promise type ('a, 'u, 'c) state_changed = | State_may_have_changed of ('a, 'u, 'c) promise - [@@ocaml.unboxed] + [@@ocaml.unboxed] + val set_promise_state : ('a, _, _) promise -> ('a, 'u, 'c) state -> ('a, 'u, 'c) state_changed type 'a may_now_be_proxy = | State_may_now_be_pending_proxy : - ('a, _, pending) promise -> 'a may_now_be_proxy - [@@ocaml.unboxed] + ('a, _, pending) promise + -> 'a may_now_be_proxy + [@@ocaml.unboxed] + val may_now_be_proxy : ('a, underlying, pending) promise -> 'a may_now_be_proxy -end = -struct +end = struct (* Checks physical equality ([==]) of two internal promises. Unlike [==], does not force unification of their invariants. *) - let identical p1 p2 = - (to_public_promise p1) == (to_public_promise p2) + let identical p1 p2 = to_public_promise p1 == to_public_promise p2 (* [underlying p] evaluates to the underlying promise of [p]. If multiple [Proxy _] links are traversed, [underlying] updates all the proxies to point immediately to their final underlying promise. *) - let rec underlying - : type u c. ('a, u, c) promise -> ('a, underlying, c) promise = - fun p -> - + let rec underlying : + type u c. ('a, u, c) promise -> ('a, underlying, c) promise = + fun p -> match p.state with | Fulfilled _ -> (p : (_, underlying, _) promise) | Rejected _ -> p | Pending _ -> p | Proxy p' -> - let p'' = underlying p' in - if not (identical p'' p') then - p.state <- Proxy p''; - p'' - - + let p'' = underlying p' in + if not (identical p'' p') then p.state <- Proxy p''; + p'' type ('a, 'u, 'c) state_changed = | State_may_have_changed of ('a, 'u, 'c) promise - [@@ocaml.unboxed] + [@@ocaml.unboxed] let set_promise_state p state = let p : (_, _, _) promise = Obj.magic p in @@ -680,12 +648,11 @@ struct signature that is a near-duplicate of [Main_internal_types], or some abuse of functors. *) - - type 'a may_now_be_proxy = | State_may_now_be_pending_proxy : - ('a, _, pending) promise -> 'a may_now_be_proxy - [@@ocaml.unboxed] + ('a, _, pending) promise + -> 'a may_now_be_proxy + [@@ocaml.unboxed] let may_now_be_proxy p = State_may_now_be_pending_proxy p @@ -732,22 +699,20 @@ struct [State_may_have_changed _] seems to be optimized away even on old versions of OCaml. *) end -open Basic_helpers - +open Basic_helpers -module Sequence_associated_storage : -sig +module Sequence_associated_storage : sig (* Public interface *) type 'v key + val new_key : unit -> _ key val get : 'v key -> 'v option val with_value : 'v key -> 'v option -> (unit -> 'b) -> 'b (* Internal interface *) val current_storage : storage ref -end = -struct +end = struct (* The idea behind sequence-associated storage is to preserve some values during a call to [bind] or other sequential composition operation, and restore those values in the callback function: @@ -774,39 +739,33 @@ struct Maintainer's note: I think using this mechanism should be discouraged in new code. *) - type 'v key = { - id : int; - mutable value : 'v option; - } + type 'v key = { id : int; mutable value : 'v option } let next_key_id = ref 0 let new_key () = let id = !next_key_id in next_key_id := id + 1; - {id = id; value = None} + { id; value = None } let current_storage = ref Storage_map.empty let get key = - if Storage_map.mem key.id !current_storage then begin + if Storage_map.mem key.id !current_storage then ( let refresh = Storage_map.find key.id !current_storage in refresh (); let value = key.value in key.value <- None; - value - end - else - None + value) + else None let with_value key value f = let new_storage = match value with | Some _ -> - let refresh = fun () -> key.value <- value in - Storage_map.add key.id refresh !current_storage - | None -> - Storage_map.remove key.id !current_storage + let refresh () = key.value <- value in + Storage_map.add key.id refresh !current_storage + | None -> Storage_map.remove key.id !current_storage in let saved_storage = !current_storage in @@ -819,52 +778,48 @@ struct current_storage := saved_storage; raise exn end -include Sequence_associated_storage - +include Sequence_associated_storage -module Pending_callbacks : -sig +module Pending_callbacks : sig (* Mutating callback lists attached to pending promises *) val add_implicitly_removed_callback : 'a callbacks -> 'a regular_callback -> unit + val add_explicitly_removable_callback_to_each_of : 'a t list -> 'a regular_callback -> unit + val add_explicitly_removable_callback_and_give_remove_function : 'a t list -> 'a regular_callback -> cancel_callback + val add_cancel_callback : 'a callbacks -> cancel_callback -> unit val merge_callbacks : from:'a callbacks -> into:'a callbacks -> unit -end = -struct +end = struct let concat_regular_callbacks l1 l2 = - begin match l1, l2 with + match[@ocaml.warning "-4"] (l1, l2) with | Regular_callback_list_empty, _ -> l2 | _, Regular_callback_list_empty -> l1 | _, _ -> Regular_callback_list_concat (l1, l2) - end [@ocaml.warning "-4"] let concat_cancel_callbacks l1 l2 = - begin match l1, l2 with + match[@ocaml.warning "-4"] (l1, l2) with | Cancel_callback_list_empty, _ -> l2 | _, Cancel_callback_list_empty -> l1 | _, _ -> Cancel_callback_list_concat (l1, l2) - end [@ocaml.warning "-4"] (* In a callback list, filters out cells of explicitly removable callbacks that have been removed. *) let rec clean_up_callback_cells = function - | Regular_callback_list_explicitly_removable_callback {contents = None} -> - Regular_callback_list_empty - - | Regular_callback_list_explicitly_removable_callback {contents = Some _} - | Regular_callback_list_implicitly_removed_callback _ - | Regular_callback_list_empty as callbacks -> - callbacks - + | Regular_callback_list_explicitly_removable_callback { contents = None } -> + Regular_callback_list_empty + | ( Regular_callback_list_explicitly_removable_callback { contents = Some _ } + | Regular_callback_list_implicitly_removed_callback _ + | Regular_callback_list_empty ) as callbacks -> + callbacks | Regular_callback_list_concat (l1, l2) -> - let l1 = clean_up_callback_cells l1 in - let l2 = clean_up_callback_cells l2 in - concat_regular_callbacks l1 l2 + let l1 = clean_up_callback_cells l1 in + let l2 = clean_up_callback_cells l2 in + concat_regular_callbacks l1 l2 (* See [clear_explicitly_removable_callback_cell] and [merge_callbacks]. *) let cleanup_throttle = 42 @@ -893,35 +848,33 @@ struct (* Go through the promises the cell had originally been added to, and either defer a cleanup, or actually clean up their callback lists. *) - ps |> List.iter (fun p -> - let Internal p = to_internal_promise p in - match (underlying p).state with - (* Some of the promises may already have been resolved at the time this - function is called. *) - | Fulfilled _ -> () - | Rejected _ -> () - - | Pending callbacks -> - match callbacks.regular_callbacks with - (* If the promise has only one regular callback, and it is removable, it - must have been the cell cleared in this function, above. In that - case, just set its callback list to empty. *) - | Regular_callback_list_explicitly_removable_callback _ -> - callbacks.regular_callbacks <- Regular_callback_list_empty - - (* Maintainer's note: I think this function shouldn't try to trigger a - cleanup in the first two cases, but I am preserving them for now, as - this is how the code was written in the past. *) - | Regular_callback_list_empty - | Regular_callback_list_implicitly_removed_callback _ - | Regular_callback_list_concat _ -> - let cleanups_deferred = callbacks.cleanups_deferred + 1 in - if cleanups_deferred > cleanup_throttle then begin - callbacks.cleanups_deferred <- 0; - callbacks.regular_callbacks <- - clean_up_callback_cells callbacks.regular_callbacks - end else - callbacks.cleanups_deferred <- cleanups_deferred) + ps + |> List.iter (fun p -> + let (Internal p) = to_internal_promise p in + match (underlying p).state with + (* Some of the promises may already have been resolved at the time this + function is called. *) + | Fulfilled _ -> () + | Rejected _ -> () + | Pending callbacks -> ( + match callbacks.regular_callbacks with + (* If the promise has only one regular callback, and it is removable, it + must have been the cell cleared in this function, above. In that + case, just set its callback list to empty. *) + | Regular_callback_list_explicitly_removable_callback _ -> + callbacks.regular_callbacks <- Regular_callback_list_empty + (* Maintainer's note: I think this function shouldn't try to trigger a + cleanup in the first two cases, but I am preserving them for now, as + this is how the code was written in the past. *) + | Regular_callback_list_empty + | Regular_callback_list_implicitly_removed_callback _ + | Regular_callback_list_concat _ -> + let cleanups_deferred = callbacks.cleanups_deferred + 1 in + if cleanups_deferred > cleanup_throttle then ( + callbacks.cleanups_deferred <- 0; + callbacks.regular_callbacks <- + clean_up_callback_cells callbacks.regular_callbacks) + else callbacks.cleanups_deferred <- cleanups_deferred)) (* Concatenates both kinds of callbacks on [~from] to the corresponding lists of [~into]. The callback lists on [~from] are *not* then cleared, because @@ -935,39 +888,37 @@ struct [clear_explicitly_removable_callback_cell]. *) let merge_callbacks ~from ~into = let regular_callbacks = - concat_regular_callbacks into.regular_callbacks from.regular_callbacks in + concat_regular_callbacks into.regular_callbacks from.regular_callbacks + in let cleanups_deferred = into.cleanups_deferred + from.cleanups_deferred in let regular_callbacks, cleanups_deferred = if cleanups_deferred > cleanup_throttle then - clean_up_callback_cells regular_callbacks, 0 - else - regular_callbacks, cleanups_deferred + (clean_up_callback_cells regular_callbacks, 0) + else (regular_callbacks, cleanups_deferred) in let cancel_callbacks = - concat_cancel_callbacks into.cancel_callbacks from.cancel_callbacks in + concat_cancel_callbacks into.cancel_callbacks from.cancel_callbacks + in into.regular_callbacks <- regular_callbacks; into.cancel_callbacks <- cancel_callbacks; into.cleanups_deferred <- cleanups_deferred - - (* General, internal, function for adding a regular callback. *) let add_regular_callback_list_node callbacks node = callbacks.regular_callbacks <- - match callbacks.regular_callbacks with - | Regular_callback_list_empty -> - node - | Regular_callback_list_implicitly_removed_callback _ - | Regular_callback_list_explicitly_removable_callback _ - | Regular_callback_list_concat _ as existing -> - Regular_callback_list_concat (node, existing) + (match callbacks.regular_callbacks with + | Regular_callback_list_empty -> node + | ( Regular_callback_list_implicitly_removed_callback _ + | Regular_callback_list_explicitly_removable_callback _ + | Regular_callback_list_concat _ ) as existing -> + Regular_callback_list_concat (node, existing)) let add_implicitly_removed_callback callbacks f = - add_regular_callback_list_node - callbacks (Regular_callback_list_implicitly_removed_callback f) + add_regular_callback_list_node callbacks + (Regular_callback_list_implicitly_removed_callback f) (* Adds [callback] as removable to each promise in [ps]. The first promise in [ps] to trigger [callback] removes [callback] from the other promises; this @@ -984,12 +935,13 @@ struct in let node = Regular_callback_list_explicitly_removable_callback cell in - ps |> List.iter (fun p -> - let Internal p = to_internal_promise p in - match (underlying p).state with - | Pending callbacks -> add_regular_callback_list_node callbacks node - | Fulfilled _ -> assert false - | Rejected _ -> assert false); + ps + |> List.iter (fun p -> + let (Internal p) = to_internal_promise p in + match (underlying p).state with + | Pending callbacks -> add_regular_callback_list_node callbacks node + | Fulfilled _ -> assert false + | Rejected _ -> assert false); cell @@ -1007,21 +959,17 @@ struct let node = Cancel_callback_list_callback (!current_storage, f) in callbacks.cancel_callbacks <- - match callbacks.cancel_callbacks with - | Cancel_callback_list_empty -> - node - + (match callbacks.cancel_callbacks with + | Cancel_callback_list_empty -> node | Cancel_callback_list_callback _ | Cancel_callback_list_remove_sequence_node _ | Cancel_callback_list_concat _ -> - Cancel_callback_list_concat (node, callbacks.cancel_callbacks) + Cancel_callback_list_concat (node, callbacks.cancel_callbacks)) end -open Pending_callbacks - +open Pending_callbacks -module Resolution_loop : -sig +module Resolution_loop : sig (* All user-provided callbacks are called by Lwt only through this module. It tracks the current callback stack depth, and decides whether each callback call should be deferred or not. *) @@ -1032,20 +980,20 @@ sig ?maximum_callback_nesting_depth:int -> ('a, underlying, pending) promise -> 'a resolved_state -> - ('a, underlying, resolved) state_changed + ('a, underlying, resolved) state_changed val run_callbacks_or_defer_them : ?allow_deferring:bool -> ?maximum_callback_nesting_depth:int -> - ('a callbacks) -> + 'a callbacks -> 'a resolved_state -> - unit + unit val run_callback_or_defer_it : ?run_immediately_and_ensure_tail_call:bool -> callback:(unit -> 'a) -> if_deferred:(unit -> 'a * 'b regular_callback * 'b resolved_state) -> - 'a + 'a val handle_with_async_exception_hook : ('a -> unit) -> 'a -> unit @@ -1056,8 +1004,7 @@ sig exception Canceled val async_exception_hook : (exn -> unit) ref -end = -struct +end = struct (* When Lwt needs to call a callback, it enters the resolution loop. This typically happens when Lwt sets the state of one promise to [Fulfilled _] or [Rejected _]. The callbacks that were attached to the promise when it @@ -1136,31 +1083,24 @@ struct immediately, without blocking on I/O. A complete program that does I/O calls [Lwt_main.run]. See "No I/O" in the Overview. *) - - let async_exception_hook = ref (fun exn -> - prerr_string "Fatal error: exception "; - prerr_string (Printexc.to_string exn); - prerr_char '\n'; - Printexc.print_backtrace stderr; - flush stderr; - exit 2) + prerr_string "Fatal error: exception "; + prerr_string (Printexc.to_string exn); + prerr_char '\n'; + Printexc.print_backtrace stderr; + flush stderr; + exit 2) let handle_with_async_exception_hook f v = (* Note that this function does not care if [f] evaluates to a promise. In particular, if [f v] evaluates to [p] and [p] is already rejected or will be reject later, it is not the responsibility of this function to pass the exception to [!async_exception_hook]. *) - try f v - with exn -> !async_exception_hook exn - - + try f v with exn -> !async_exception_hook exn exception Canceled - - (* Runs the callbacks (formerly) associated to a promise. Cancel callbacks are run first, if the promise was canceled. These are followed by regular callbacks. @@ -1169,30 +1109,23 @@ struct set to [Fulfilled _] or [Rejected _], so the callbacks are no longer reachable through the promise reference. This is why the direct [callbacks] record must be given to this function. *) - let run_callbacks - (callbacks : 'a callbacks) - (result : 'a resolved_state) : unit = - + let run_callbacks (callbacks : 'a callbacks) (result : 'a resolved_state) : + unit = let run_cancel_callbacks fs = let rec iter_callback_list fs rest = match fs with - | Cancel_callback_list_empty -> - iter_list rest + | Cancel_callback_list_empty -> iter_list rest | Cancel_callback_list_callback (storage, f) -> - current_storage := storage; - handle_with_async_exception_hook f (); - iter_list rest + current_storage := storage; + handle_with_async_exception_hook f (); + iter_list rest | Cancel_callback_list_remove_sequence_node node -> - Lwt_sequence.remove node; - iter_list rest + Lwt_sequence.remove node; + iter_list rest | Cancel_callback_list_concat (fs, fs') -> - iter_callback_list fs (fs'::rest) - + iter_callback_list fs (fs' :: rest) and iter_list rest = - match rest with - | [] -> () - | fs::rest -> iter_callback_list fs rest - + match rest with [] -> () | fs :: rest -> iter_callback_list fs rest in iter_callback_list fs [] @@ -1201,26 +1134,21 @@ struct let run_regular_callbacks fs = let rec iter_callback_list fs rest = match fs with - | Regular_callback_list_empty -> - iter_list rest + | Regular_callback_list_empty -> iter_list rest | Regular_callback_list_implicitly_removed_callback f -> - f result; - iter_list rest + f result; + iter_list rest | Regular_callback_list_explicitly_removable_callback - {contents = None} -> - iter_list rest + { contents = None } -> + iter_list rest | Regular_callback_list_explicitly_removable_callback - {contents = Some f} -> - f result; - iter_list rest + { contents = Some f } -> + f result; + iter_list rest | Regular_callback_list_concat (fs, fs') -> - iter_callback_list fs (fs'::rest) - + iter_callback_list fs (fs' :: rest) and iter_list rest = - match rest with - | [] -> () - | fs::rest -> iter_callback_list fs rest - + match rest with [] -> () | fs :: rest -> iter_callback_list fs rest in iter_callback_list fs [] @@ -1233,19 +1161,15 @@ struct | Rejected _ -> false | Fulfilled _ -> false in - if is_canceled then - run_cancel_callbacks callbacks.cancel_callbacks; + if is_canceled then run_cancel_callbacks callbacks.cancel_callbacks; run_regular_callbacks callbacks.regular_callbacks - - let default_maximum_callback_nesting_depth = 42 - let current_callback_nesting_depth = ref 0 type deferred_callbacks = - Deferred : ('a callbacks * 'a resolved_state) -> deferred_callbacks - [@@ocaml.unboxed] + | Deferred : ('a callbacks * 'a resolved_state) -> deferred_callbacks + [@@ocaml.unboxed] let deferred_callbacks : deferred_callbacks Queue.t = Queue.create () @@ -1259,12 +1183,11 @@ struct storage_snapshot let leave_resolution_loop (storage_snapshot : storage) : unit = - if !current_callback_nesting_depth = 1 then begin + if !current_callback_nesting_depth = 1 then while not (Queue.is_empty deferred_callbacks) do - let Deferred (callbacks, result) = Queue.pop deferred_callbacks in + let (Deferred (callbacks, result)) = Queue.pop deferred_callbacks in run_callbacks callbacks result - done - end; + done; current_callback_nesting_depth := !current_callback_nesting_depth - 1; current_storage := storage_snapshot @@ -1284,13 +1207,9 @@ struct if !current_callback_nesting_depth <> 0 then leave_resolution_loop Storage_map.empty - - - let run_callbacks_or_defer_them - ?(allow_deferring = true) + let run_callbacks_or_defer_them ?(allow_deferring = true) ?(maximum_callback_nesting_depth = default_maximum_callback_nesting_depth) callbacks result = - let should_defer = allow_deferring && !current_callback_nesting_depth >= maximum_callback_nesting_depth @@ -1298,36 +1217,30 @@ struct if should_defer then Queue.push (Deferred (callbacks, result)) deferred_callbacks - else - run_in_resolution_loop (fun () -> - run_callbacks callbacks result) + else run_in_resolution_loop (fun () -> run_callbacks callbacks result) let resolve ?allow_deferring ?maximum_callback_nesting_depth p result = - let Pending callbacks = p.state in + let (Pending callbacks) = p.state in let p = set_promise_state p result in - run_callbacks_or_defer_them - ?allow_deferring ?maximum_callback_nesting_depth callbacks result; + run_callbacks_or_defer_them ?allow_deferring ?maximum_callback_nesting_depth + callbacks result; p - let run_callback_or_defer_it - ?(run_immediately_and_ensure_tail_call = false) - ~callback:f - ~if_deferred = - - if run_immediately_and_ensure_tail_call then - f () - + let run_callback_or_defer_it ?(run_immediately_and_ensure_tail_call = false) + ~callback:f ~if_deferred = + if run_immediately_and_ensure_tail_call then f () else let should_defer = !current_callback_nesting_depth - >= default_maximum_callback_nesting_depth + >= default_maximum_callback_nesting_depth in - if should_defer then begin + if should_defer then ( let immediate_result, deferred_callback, deferred_result = - if_deferred () in + if_deferred () + in let deferred_record = { regular_callbacks = @@ -1335,88 +1248,74 @@ struct deferred_callback; cancel_callbacks = Cancel_callback_list_empty; how_to_cancel = Not_cancelable; - cleanups_deferred = 0 + cleanups_deferred = 0; } in Queue.push - (Deferred (deferred_record, deferred_result)) deferred_callbacks; - immediate_result - end - else - run_in_resolution_loop (fun () -> - f ()) + (Deferred (deferred_record, deferred_result)) + deferred_callbacks; + immediate_result) + else run_in_resolution_loop (fun () -> f ()) end -include Resolution_loop - +include Resolution_loop -module Resolving : -sig +module Resolving : sig val wakeup_later_result : 'a u -> 'a lwt_result -> unit val wakeup_later : 'a u -> 'a -> unit val wakeup_later_exn : _ u -> exn -> unit - val wakeup_result : 'a u -> 'a lwt_result -> unit val wakeup : 'a u -> 'a -> unit val wakeup_exn : _ u -> exn -> unit - val cancel : 'a t -> unit -end = -struct +end = struct (* Note that this function deviates from the "ideal" callback deferral behavior: it runs callbacks directly on the current stack. It should therefore be possible to cause a stack overflow using this function. *) let wakeup_general api_function_name r result = - let Internal p = to_internal_resolver r in + let (Internal p) = to_internal_resolver r in let p = underlying p in match p.state with - | Rejected Canceled -> - () - | Fulfilled _ -> - Printf.ksprintf invalid_arg "Lwt.%s" api_function_name - | Rejected _ -> - Printf.ksprintf invalid_arg "Lwt.%s" api_function_name - + | Rejected Canceled -> () + | Fulfilled _ -> Printf.ksprintf invalid_arg "Lwt.%s" api_function_name + | Rejected _ -> Printf.ksprintf invalid_arg "Lwt.%s" api_function_name | Pending _ -> - let result = state_of_result result in - let State_may_have_changed p = resolve ~allow_deferring:false p result in - ignore p + let result = state_of_result result in + let (State_may_have_changed p) = + resolve ~allow_deferring:false p result + in + ignore p let wakeup_result r result = wakeup_general "wakeup_result" r result let wakeup r v = wakeup_general "wakeup" r (Result.Ok v) let wakeup_exn r exn = wakeup_general "wakeup_exn" r (Result.Error exn) let wakeup_later_general api_function_name r result = - let Internal p = to_internal_resolver r in + let (Internal p) = to_internal_resolver r in let p = underlying p in match p.state with - | Rejected Canceled -> - () - | Fulfilled _ -> - Printf.ksprintf invalid_arg "Lwt.%s" api_function_name - | Rejected _ -> - Printf.ksprintf invalid_arg "Lwt.%s" api_function_name - + | Rejected Canceled -> () + | Fulfilled _ -> Printf.ksprintf invalid_arg "Lwt.%s" api_function_name + | Rejected _ -> Printf.ksprintf invalid_arg "Lwt.%s" api_function_name | Pending _ -> - let result = state_of_result result in - let State_may_have_changed p = - resolve ~maximum_callback_nesting_depth:1 p result in - ignore p + let result = state_of_result result in + let (State_may_have_changed p) = + resolve ~maximum_callback_nesting_depth:1 p result + in + ignore p let wakeup_later_result r result = wakeup_later_general "wakeup_later_result" r result - let wakeup_later r v = - wakeup_later_general "wakeup_later" r (Result.Ok v) - let wakeup_later_exn r exn = - wakeup_later_general "wakeup_later_exn" r (Result.Error exn) + let wakeup_later r v = wakeup_later_general "wakeup_later" r (Result.Ok v) + let wakeup_later_exn r exn = + wakeup_later_general "wakeup_later_exn" r (Result.Error exn) - type packed_callbacks = - | Packed : _ callbacks -> packed_callbacks - [@@ocaml.unboxed] + type packed_callbacks = Packed : _ callbacks -> packed_callbacks + [@@ocaml.unboxed] (* Note that this function deviates from the "ideal" callback deferral behavior: it runs callbacks directly on the current stack. It should @@ -1436,54 +1335,51 @@ struct phase. These callbacks propagate cancellation forwards to any dependent promises. See "Cancellation" in the Overview. *) let propagate_cancel : (_, _, _) promise -> packed_callbacks list = - fun p -> - let rec cancel_and_collect_callbacks : - 'a 'u 'c. packed_callbacks list -> ('a, 'u, 'c) promise -> - packed_callbacks list = - fun (type c) callbacks_accumulator (p : (_, _, c) promise) -> - - let p = underlying p in - match p.state with - (* If the promise is not still pending, it can't be canceled. *) - | Fulfilled _ -> - callbacks_accumulator - | Rejected _ -> - callbacks_accumulator - - | Pending callbacks -> - match callbacks.how_to_cancel with - | Not_cancelable -> - callbacks_accumulator - | Cancel_this_promise -> - let State_may_have_changed p = - set_promise_state p canceled_result in - ignore p; - (Packed callbacks)::callbacks_accumulator - | Propagate_cancel_to_one p' -> - cancel_and_collect_callbacks callbacks_accumulator p' - | Propagate_cancel_to_several ps -> - List.fold_left cancel_and_collect_callbacks callbacks_accumulator ps + fun p -> + let rec cancel_and_collect_callbacks + : 'a 'u 'c. + packed_callbacks list -> + ('a, 'u, 'c) promise -> + packed_callbacks list = + fun (type c) callbacks_accumulator (p : (_, _, c) promise) -> + let p = underlying p in + match p.state with + (* If the promise is not still pending, it can't be canceled. *) + | Fulfilled _ -> callbacks_accumulator + | Rejected _ -> callbacks_accumulator + | Pending callbacks -> ( + match callbacks.how_to_cancel with + | Not_cancelable -> callbacks_accumulator + | Cancel_this_promise -> + let (State_may_have_changed p) = + set_promise_state p canceled_result + in + ignore p; + Packed callbacks :: callbacks_accumulator + | Propagate_cancel_to_one p' -> + cancel_and_collect_callbacks callbacks_accumulator p' + | Propagate_cancel_to_several ps -> + List.fold_left cancel_and_collect_callbacks + callbacks_accumulator ps) in cancel_and_collect_callbacks [] p in - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in let callbacks = propagate_cancel p in - callbacks |> List.iter (fun (Packed callbacks) -> - run_callbacks_or_defer_them - ~allow_deferring:false callbacks canceled_result) + callbacks + |> List.iter (fun (Packed callbacks) -> + run_callbacks_or_defer_them ~allow_deferring:false callbacks + canceled_result) end -include Resolving - +include Resolving -module Trivial_promises : -sig +module Trivial_promises : sig val return : 'a -> 'a t val fail : exn -> _ t val of_result : 'a lwt_result -> 'a t - val return_unit : unit t val return_true : bool t val return_false : bool t @@ -1492,20 +1388,12 @@ sig val return_ok : 'a -> ('a, _) Result.result t val return_error : 'e -> (_, 'e) Result.result t val return_nil : _ list t - val fail_with : string -> _ t val fail_invalid_arg : string -> _ t -end = -struct - let return v = - to_public_promise {state = Fulfilled v} - - let of_result result = - to_public_promise {state = state_of_result result} - - let fail exn = - to_public_promise {state = Rejected exn} - +end = struct + let return v = to_public_promise { state = Fulfilled v } + let of_result result = to_public_promise { state = state_of_result result } + let fail exn = to_public_promise { state = Rejected exn } let return_unit = return () let return_none = return None let return_some x = return (Some x) @@ -1514,47 +1402,41 @@ struct let return_false = return false let return_ok x = return (Result.Ok x) let return_error x = return (Result.Error x) - - let fail_with msg = - to_public_promise {state = Rejected (Failure msg)} + let fail_with msg = to_public_promise { state = Rejected (Failure msg) } let fail_invalid_arg msg = - to_public_promise {state = Rejected (Invalid_argument msg)} + to_public_promise { state = Rejected (Invalid_argument msg) } end -include Trivial_promises - +include Trivial_promises -module Pending_promises : -sig +module Pending_promises : sig (* Internal *) val new_pending : how_to_cancel:how_to_cancel -> ('a, underlying, pending) promise + val propagate_cancel_to_several : _ t list -> how_to_cancel (* Initial pending promises (public) *) val wait : unit -> 'a t * 'a u val task : unit -> 'a t * 'a u - val waiter_of_wakener : 'a u -> 'a t - val add_task_r : 'a u Lwt_sequence.t -> 'a t val add_task_l : 'a u Lwt_sequence.t -> 'a t - val protected : 'a t -> 'a t val no_cancel : 'a t -> 'a t -end = -struct +end = struct let new_pending ~how_to_cancel = let state = - Pending { - regular_callbacks = Regular_callback_list_empty; - cancel_callbacks = Cancel_callback_list_empty; - how_to_cancel; - cleanups_deferred = 0; - } + Pending + { + regular_callbacks = Regular_callback_list_empty; + cancel_callbacks = Cancel_callback_list_empty; + how_to_cancel; + cleanups_deferred = 0; + } in - {state} + { state } let propagate_cancel_to_several ps = (* Using a dirty cast here to avoid rebuilding the list :( Not bothering @@ -1564,29 +1446,22 @@ struct let cast_promise_list : 'a t list -> ('a, _, _) promise list = Obj.magic in Propagate_cancel_to_several (cast_promise_list ps) - - let wait () = let p = new_pending ~how_to_cancel:Not_cancelable in - to_public_promise p, to_public_resolver p + (to_public_promise p, to_public_resolver p) let task () = let p = new_pending ~how_to_cancel:Cancel_this_promise in - to_public_promise p, to_public_resolver p - - + (to_public_promise p, to_public_resolver p) let waiter_of_wakener r = - let Internal r = to_internal_resolver r in + let (Internal r) = to_internal_resolver r in let p = r in to_public_promise p - - - let cast_sequence_node - (node : 'a u Lwt_sequence.node) - (_actual_content:('a, 'u, 'c) promise) - : ('a, 'u, 'c) promise Lwt_sequence.node = + let cast_sequence_node (node : 'a u Lwt_sequence.node) + (_actual_content : ('a, 'u, 'c) promise) : + ('a, 'u, 'c) promise Lwt_sequence.node = Obj.magic node let add_task_r sequence = @@ -1594,9 +1469,8 @@ struct let node = Lwt_sequence.add_r (to_public_resolver p) sequence in let node = cast_sequence_node node p in - let Pending callbacks = p.state in - callbacks.cancel_callbacks <- - Cancel_callback_list_remove_sequence_node node; + let (Pending callbacks) = p.state in + callbacks.cancel_callbacks <- Cancel_callback_list_remove_sequence_node node; to_public_promise p @@ -1605,86 +1479,81 @@ struct let node = Lwt_sequence.add_l (to_public_resolver p) sequence in let node = cast_sequence_node node p in - let Pending callbacks = p.state in - callbacks.cancel_callbacks <- - Cancel_callback_list_remove_sequence_node node; + let (Pending callbacks) = p.state in + callbacks.cancel_callbacks <- Cancel_callback_list_remove_sequence_node node; to_public_promise p - - let protected p = - let Internal p_internal = to_internal_promise p in + let (Internal p_internal) = to_internal_promise p in match (underlying p_internal).state with | Fulfilled _ -> p | Rejected _ -> p - | Pending _ -> - let p' = new_pending ~how_to_cancel:Cancel_this_promise in - - let callback p_result = - let State_may_now_be_pending_proxy p' = may_now_be_proxy p' in - let p' = underlying p' in - (* In this callback, [p'] will either still itself be pending, or it - will have become a proxy for a pending promise. The reasoning for - this is almost the same as in the comment at [may_now_be_proxy]. The - differences are: - - - [p'] *is* an initial promise, so it *can* get canceled. However, if - it does, the [on_cancel] handler installed below will remove this - callback. - - [p'] never gets passed to [make_into_proxy], the only effect of - which is that it cannot be the underlying promise of another - (proxy) promise. So, [p'] can only appear at the head of a chain of - [Proxy _] links, and it's not necessary to worry about whether the - inductive reasoning at [may_now_be_proxy] applies. *) - - let State_may_have_changed p' = - resolve ~allow_deferring:false p' p_result in - ignore p' - in + let p' = new_pending ~how_to_cancel:Cancel_this_promise in + + let callback p_result = + let (State_may_now_be_pending_proxy p') = may_now_be_proxy p' in + let p' = underlying p' in + + (* In this callback, [p'] will either still itself be pending, or it + will have become a proxy for a pending promise. The reasoning for + this is almost the same as in the comment at [may_now_be_proxy]. The + differences are: + + - [p'] *is* an initial promise, so it *can* get canceled. However, if + it does, the [on_cancel] handler installed below will remove this + callback. + - [p'] never gets passed to [make_into_proxy], the only effect of + which is that it cannot be the underlying promise of another + (proxy) promise. So, [p'] can only appear at the head of a chain of + [Proxy _] links, and it's not necessary to worry about whether the + inductive reasoning at [may_now_be_proxy] applies. *) + let (State_may_have_changed p') = + resolve ~allow_deferring:false p' p_result + in + ignore p' + in - let remove_the_callback = - add_explicitly_removable_callback_and_give_remove_function - [p] callback - in + let remove_the_callback = + add_explicitly_removable_callback_and_give_remove_function [ p ] + callback + in - let Pending p'_callbacks = p'.state in - add_cancel_callback p'_callbacks remove_the_callback; + let (Pending p'_callbacks) = p'.state in + add_cancel_callback p'_callbacks remove_the_callback; - to_public_promise p' + to_public_promise p' let no_cancel p = - let Internal p_internal = to_internal_promise p in + let (Internal p_internal) = to_internal_promise p in match (underlying p_internal).state with | Fulfilled _ -> p | Rejected _ -> p - | Pending p_callbacks -> - let p' = new_pending ~how_to_cancel:Not_cancelable in - - let callback p_result = - let State_may_now_be_pending_proxy p' = may_now_be_proxy p' in - let p' = underlying p' in - (* In this callback, [p'] will either still itself be pending, or it - will have become a proxy for a pending promise. The reasoning for - this is as in [protected] and [may_now_be_proxy], but even simpler, - because [p'] is not cancelable. *) - - let State_may_have_changed p' = - resolve ~allow_deferring:false p' p_result in - ignore p' - in - add_implicitly_removed_callback p_callbacks callback; + let p' = new_pending ~how_to_cancel:Not_cancelable in + + let callback p_result = + let (State_may_now_be_pending_proxy p') = may_now_be_proxy p' in + let p' = underlying p' in + + (* In this callback, [p'] will either still itself be pending, or it + will have become a proxy for a pending promise. The reasoning for + this is as in [protected] and [may_now_be_proxy], but even simpler, + because [p'] is not cancelable. *) + let (State_may_have_changed p') = + resolve ~allow_deferring:false p' p_result + in + ignore p' + in + add_implicitly_removed_callback p_callbacks callback; - to_public_promise p' + to_public_promise p' end -include Pending_promises - +include Pending_promises -module Sequential_composition : -sig +module Sequential_composition : sig (* Main interface (public) *) val bind : 'a t -> ('a -> 'b t) -> 'b t val map : ('a -> 'b) -> 'a t -> 'b t @@ -1702,16 +1571,15 @@ sig val on_any : 'a t -> ('a -> unit) -> (exn -> unit) -> unit (* Backtrace support (internal; for use by the PPX) *) - val backtrace_bind : - (exn -> exn) -> 'a t -> ('a -> 'b t) -> 'b t - val backtrace_catch : - (exn -> exn) -> (unit -> 'a t) -> (exn -> 'a t) -> 'a t + val backtrace_bind : (exn -> exn) -> 'a t -> ('a -> 'b t) -> 'b t + val backtrace_catch : (exn -> exn) -> (unit -> 'a t) -> (exn -> 'a t) -> 'a t + val backtrace_finalize : (exn -> exn) -> (unit -> 'a t) -> (unit -> unit t) -> 'a t + val backtrace_try_bind : (exn -> exn) -> (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t -end = -struct +end = struct (* There are five primary sequential composition functions: [bind], [map], [catch], [finalize], and [try_bind]. Of these, [try_bind] is the most general -- all the others can be implemented in terms of it. @@ -1732,8 +1600,6 @@ struct functions. Of these, [on_any] is the most general. If Lwt did not conflate concurrency with error handling, there would only be one: [on_success]. *) - - (* Makes [~user_provided_promise] into a proxy of [~outer_promise]. After [make_into_proxy], these two promise references "behave identically." @@ -1769,77 +1635,70 @@ struct [~user_provided_promise] might see [~user_provided_promise] resolved, but [~outer_promise] still pending, depending on the order in which callbacks are run. *) - let make_into_proxy - (type c) + let make_into_proxy (type c) ~(outer_promise : ('a, underlying, pending) promise) - ~(user_provided_promise : ('a, _, c) promise) - : ('a, underlying, c) state_changed = - + ~(user_provided_promise : ('a, _, c) promise) : + ('a, underlying, c) state_changed = (* Using [p'] as it's the name used inside [bind], etc., for promises with this role -- [p'] is the promise returned by the user's function. *) let p' = underlying user_provided_promise in - if identical p' outer_promise then - State_may_have_changed p' + if identical p' outer_promise then State_may_have_changed p' (* We really want to return [State_may_have_changed outer_promise], but the reference through [p'] has the right type. *) - else match p'.state with - | Fulfilled _ -> - resolve ~allow_deferring:false outer_promise p'.state - | Rejected _ -> - resolve ~allow_deferring:false outer_promise p'.state - + | Fulfilled _ -> resolve ~allow_deferring:false outer_promise p'.state + | Rejected _ -> resolve ~allow_deferring:false outer_promise p'.state | Pending p'_callbacks -> - let Pending outer_callbacks = outer_promise.state in - - merge_callbacks ~from:p'_callbacks ~into:outer_callbacks; - outer_callbacks.how_to_cancel <- p'_callbacks.how_to_cancel; - - let State_may_have_changed p' = - set_promise_state p' (Proxy outer_promise) in - ignore p'; + let (Pending outer_callbacks) = outer_promise.state in - State_may_have_changed outer_promise - (* The state hasn't actually changed, but we still have to wrap - [outer_promise] for type checking. *) + merge_callbacks ~from:p'_callbacks ~into:outer_callbacks; + outer_callbacks.how_to_cancel <- p'_callbacks.how_to_cancel; - (* The state of [p'] may instead have changed -- it may have become a - proxy. However, callers of [make_into_proxy] don't know if - [user_provided_promise] was a proxy or not (that's why we call - underlying on it at the top of this function, to get [p']). We can - therefore take a dangerous shortcut and not bother returning a new - reference to [user_provided_promise] for shadowing. *) + let (State_may_have_changed p') = + set_promise_state p' (Proxy outer_promise) + in + ignore p'; + State_may_have_changed outer_promise + (* The state hasn't actually changed, but we still have to wrap + [outer_promise] for type checking. *) + (* The state of [p'] may instead have changed -- it may have become a + proxy. However, callers of [make_into_proxy] don't know if + [user_provided_promise] was a proxy or not (that's why we call + underlying on it at the top of this function, to get [p']). We can + therefore take a dangerous shortcut and not bother returning a new + reference to [user_provided_promise] for shadowing. *) (* Maintainer's note: a lot of the code below can probably be deduplicated in some way, especially if assuming Flambda. *) let bind p f = - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in let p = underlying p in (* In case [Lwt.bind] needs to defer the call to [f], this function will be - called to create: + called to create: - 1. The promise, [p''], that must be returned to the caller immediately. - 2. The callback that resolves [p'']. + 1. The promise, [p''], that must be returned to the caller immediately. + 2. The callback that resolves [p'']. - [Lwt.bind] defers the call to [f] in two circumstances: + [Lwt.bind] defers the call to [f] in two circumstances: - 1. The promise [p] is pending. - 2. The promise [p] is fulfilled, but the current callback call nesting - depth is such that the call to [f] must go into the callback queue, in - order to avoid stack overflow. + 1. The promise [p] is pending. + 2. The promise [p] is fulfilled, but the current callback call nesting + depth is such that the call to [f] must go into the callback queue, in + order to avoid stack overflow. - Mechanism (2) is currently disabled. It may be used in an alternative Lwt - API. + Mechanism (2) is currently disabled. It may be used in an alternative Lwt + API. - Functions other than [Lwt.bind] have analogous deferral behavior. *) + Functions other than [Lwt.bind] have analogous deferral behavior. *) let create_result_promise_and_callback_if_deferred () = let p'' = new_pending ~how_to_cancel:(Propagate_cancel_to_one p) in + (* The result promise is a fresh pending promise. Initially, trying to cancel this fresh pending promise [p''] will @@ -1849,40 +1708,40 @@ struct [p'] will become a proxy of [p'']. At that point, trying to cancel [p''] will be equivalent to trying to cancel [p'], so the behavior will depend on how the user obtained [p']. *) - let saved_storage = !current_storage in let callback p_result = match p_result with | Fulfilled v -> - current_storage := saved_storage; - - let p' = try f v with exn -> fail exn in - let Internal p' = to_internal_promise p' in - (* Run the user's function [f]. *) - - let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in - (* [p''] was an underlying promise when it was created above, but it - may have become a proxy by the time this code is being executed. - However, it is still either an underlying pending promise, or a - proxy for a pending promise. Therefore, [may_now_be_proxy] produces - a reference with the right type variables. We immediately get - [p'']'s current underlying promise. *) - - let State_may_have_changed p'' = - make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in - ignore p'' - (* Make the outer promise [p''] behaviorally identical to the promise - [p'] returned by [f] by making [p'] into a proxy of [p'']. *) - + current_storage := saved_storage; + + let p' = try f v with exn -> fail exn in + let (Internal p') = to_internal_promise p' in + + (* Run the user's function [f]. *) + let (State_may_now_be_pending_proxy p'') = may_now_be_proxy p'' in + let p'' = underlying p'' in + + (* [p''] was an underlying promise when it was created above, but it + may have become a proxy by the time this code is being executed. + However, it is still either an underlying pending promise, or a + proxy for a pending promise. Therefore, [may_now_be_proxy] produces + a reference with the right type variables. We immediately get + [p'']'s current underlying promise. *) + let (State_may_have_changed p'') = + make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' + in + ignore p'' + (* Make the outer promise [p''] behaviorally identical to the promise + [p'] returned by [f] by making [p'] into a proxy of [p'']. *) | Rejected _ as p_result -> - let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let (State_may_now_be_pending_proxy p'') = may_now_be_proxy p'' in + let p'' = underlying p'' in - let State_may_have_changed p'' = - resolve ~allow_deferring:false p'' p_result in - ignore p'' + let (State_may_have_changed p'') = + resolve ~allow_deferring:false p'' p_result + in + ignore p'' in (to_public_promise p'', callback) @@ -1890,24 +1749,21 @@ struct match p.state with | Fulfilled v -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> f v) - ~if_deferred:(fun () -> - let (p'', callback) = - create_result_promise_and_callback_if_deferred () in - (p'', callback, p.state)) - - | Rejected _ as result -> - to_public_promise {state = result} - + run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true + ~callback:(fun () -> f v) + ~if_deferred:(fun () -> + let p'', callback = + create_result_promise_and_callback_if_deferred () + in + (p'', callback, p.state)) + | Rejected _ as result -> to_public_promise { state = result } | Pending p_callbacks -> - let (p'', callback) = create_result_promise_and_callback_if_deferred () in - add_implicitly_removed_callback p_callbacks callback; - p'' + let p'', callback = create_result_promise_and_callback_if_deferred () in + add_implicitly_removed_callback p_callbacks callback; + p'' let backtrace_bind add_loc p f = - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in let p = underlying p in let create_result_promise_and_callback_if_deferred () = @@ -1918,25 +1774,26 @@ struct let callback p_result = match p_result with | Fulfilled v -> - current_storage := saved_storage; + current_storage := saved_storage; - let p' = try f v with exn -> fail (add_loc exn) in - let Internal p' = to_internal_promise p' in + let p' = try f v with exn -> fail (add_loc exn) in + let (Internal p') = to_internal_promise p' in - let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in - - let State_may_have_changed p'' = - make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in - ignore p'' + let (State_may_now_be_pending_proxy p'') = may_now_be_proxy p'' in + let p'' = underlying p'' in + let (State_may_have_changed p'') = + make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' + in + ignore p'' | Rejected exn -> - let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let (State_may_now_be_pending_proxy p'') = may_now_be_proxy p'' in + let p'' = underlying p'' in - let State_may_have_changed p'' = - resolve ~allow_deferring:false p'' (Rejected (add_loc exn)) in - ignore p'' + let (State_may_have_changed p'') = + resolve ~allow_deferring:false p'' (Rejected (add_loc exn)) + in + ignore p'' in (to_public_promise p'', callback) @@ -1944,24 +1801,21 @@ struct match p.state with | Fulfilled v -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> f v) - ~if_deferred:(fun () -> - let (p'', callback) = - create_result_promise_and_callback_if_deferred () in - (p'', callback, p.state)) - - | Rejected exn -> - to_public_promise {state = Rejected (add_loc exn)} - + run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true + ~callback:(fun () -> f v) + ~if_deferred:(fun () -> + let p'', callback = + create_result_promise_and_callback_if_deferred () + in + (p'', callback, p.state)) + | Rejected exn -> to_public_promise { state = Rejected (add_loc exn) } | Pending p_callbacks -> - let (p'', callback) = create_result_promise_and_callback_if_deferred () in - add_implicitly_removed_callback p_callbacks callback; - p'' + let p'', callback = create_result_promise_and_callback_if_deferred () in + add_implicitly_removed_callback p_callbacks callback; + p'' let map f p = - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in let p = underlying p in let create_result_promise_and_callback_if_deferred () = @@ -1972,24 +1826,25 @@ struct let callback p_result = match p_result with | Fulfilled v -> - current_storage := saved_storage; - - let p''_result = try Fulfilled (f v) with exn -> Rejected exn in + current_storage := saved_storage; - let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let p''_result = try Fulfilled (f v) with exn -> Rejected exn in - let State_may_have_changed p'' = - resolve ~allow_deferring:false p'' p''_result in - ignore p'' + let (State_may_now_be_pending_proxy p'') = may_now_be_proxy p'' in + let p'' = underlying p'' in + let (State_may_have_changed p'') = + resolve ~allow_deferring:false p'' p''_result + in + ignore p'' | Rejected _ as p_result -> - let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let (State_may_now_be_pending_proxy p'') = may_now_be_proxy p'' in + let p'' = underlying p'' in - let State_may_have_changed p'' = - resolve ~allow_deferring:false p'' p_result in - ignore p'' + let (State_may_have_changed p'') = + resolve ~allow_deferring:false p'' p_result + in + ignore p'' in (to_public_promise p'', callback) @@ -1997,27 +1852,24 @@ struct match p.state with | Fulfilled v -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> - to_public_promise - {state = try Fulfilled (f v) with exn -> Rejected exn}) - ~if_deferred:(fun () -> - let (p'', callback) = - create_result_promise_and_callback_if_deferred () in - (p'', callback, p.state)) - - | Rejected _ as result -> - to_public_promise {state = result} - + run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true + ~callback:(fun () -> + to_public_promise + { state = (try Fulfilled (f v) with exn -> Rejected exn) }) + ~if_deferred:(fun () -> + let p'', callback = + create_result_promise_and_callback_if_deferred () + in + (p'', callback, p.state)) + | Rejected _ as result -> to_public_promise { state = result } | Pending p_callbacks -> - let (p'', callback) = create_result_promise_and_callback_if_deferred () in - add_implicitly_removed_callback p_callbacks callback; - p'' + let p'', callback = create_result_promise_and_callback_if_deferred () in + add_implicitly_removed_callback p_callbacks callback; + p'' let catch f h = let p = try f () with exn -> fail exn in - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in let p = underlying p in let create_result_promise_and_callback_if_deferred () = @@ -2028,51 +1880,49 @@ struct let callback p_result = match p_result with | Fulfilled _ as p_result -> - let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in - - let State_may_have_changed p'' = - resolve ~allow_deferring:false p'' p_result in - ignore p'' + let (State_may_now_be_pending_proxy p'') = may_now_be_proxy p'' in + let p'' = underlying p'' in + let (State_may_have_changed p'') = + resolve ~allow_deferring:false p'' p_result + in + ignore p'' | Rejected exn -> - current_storage := saved_storage; + current_storage := saved_storage; - let p' = try h exn with exn -> fail exn in - let Internal p' = to_internal_promise p' in + let p' = try h exn with exn -> fail exn in + let (Internal p') = to_internal_promise p' in - let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let (State_may_now_be_pending_proxy p'') = may_now_be_proxy p'' in + let p'' = underlying p'' in - let State_may_have_changed p'' = - make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in - ignore p'' + let (State_may_have_changed p'') = + make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' + in + ignore p'' in (to_public_promise p'', callback) in match p.state with - | Fulfilled _ -> - to_public_promise p - + | Fulfilled _ -> to_public_promise p | Rejected exn -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> h exn) - ~if_deferred:(fun () -> - let (p'', callback) = - create_result_promise_and_callback_if_deferred () in - (p'', callback, p.state)) - + run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true + ~callback:(fun () -> h exn) + ~if_deferred:(fun () -> + let p'', callback = + create_result_promise_and_callback_if_deferred () + in + (p'', callback, p.state)) | Pending p_callbacks -> - let (p'', callback) = create_result_promise_and_callback_if_deferred () in - add_implicitly_removed_callback p_callbacks callback; - p'' + let p'', callback = create_result_promise_and_callback_if_deferred () in + add_implicitly_removed_callback p_callbacks callback; + p'' let backtrace_catch add_loc f h = let p = try f () with exn -> fail exn in - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in let p = underlying p in let create_result_promise_and_callback_if_deferred () = @@ -2083,51 +1933,49 @@ struct let callback p_result = match p_result with | Fulfilled _ as p_result -> - let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in - - let State_may_have_changed p'' = - resolve ~allow_deferring:false p'' p_result in - ignore p'' + let (State_may_now_be_pending_proxy p'') = may_now_be_proxy p'' in + let p'' = underlying p'' in + let (State_may_have_changed p'') = + resolve ~allow_deferring:false p'' p_result + in + ignore p'' | Rejected exn -> - current_storage := saved_storage; + current_storage := saved_storage; - let p' = try h exn with exn -> fail (add_loc exn) in - let Internal p' = to_internal_promise p' in + let p' = try h exn with exn -> fail (add_loc exn) in + let (Internal p') = to_internal_promise p' in - let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let (State_may_now_be_pending_proxy p'') = may_now_be_proxy p'' in + let p'' = underlying p'' in - let State_may_have_changed p'' = - make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in - ignore p'' + let (State_may_have_changed p'') = + make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' + in + ignore p'' in (to_public_promise p'', callback) in match p.state with - | Fulfilled _ -> - to_public_promise p - + | Fulfilled _ -> to_public_promise p | Rejected exn -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> h (add_loc exn)) - ~if_deferred:(fun () -> - let (p'', callback) = - create_result_promise_and_callback_if_deferred () in - (p'', callback, p.state)) - + run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true + ~callback:(fun () -> h (add_loc exn)) + ~if_deferred:(fun () -> + let p'', callback = + create_result_promise_and_callback_if_deferred () + in + (p'', callback, p.state)) | Pending p_callbacks -> - let (p'', callback) = create_result_promise_and_callback_if_deferred () in - add_implicitly_removed_callback p_callbacks callback; - p'' + let p'', callback = create_result_promise_and_callback_if_deferred () in + add_implicitly_removed_callback p_callbacks callback; + p'' let try_bind f f' h = let p = try f () with exn -> fail exn in - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in let p = underlying p in let create_result_promise_and_callback_if_deferred () = @@ -2138,30 +1986,31 @@ struct let callback p_result = match p_result with | Fulfilled v -> - current_storage := saved_storage; - - let p' = try f' v with exn -> fail exn in - let Internal p' = to_internal_promise p' in + current_storage := saved_storage; - let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let p' = try f' v with exn -> fail exn in + let (Internal p') = to_internal_promise p' in - let State_may_have_changed p'' = - make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in - ignore p'' + let (State_may_now_be_pending_proxy p'') = may_now_be_proxy p'' in + let p'' = underlying p'' in + let (State_may_have_changed p'') = + make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' + in + ignore p'' | Rejected exn -> - current_storage := saved_storage; + current_storage := saved_storage; - let p' = try h exn with exn -> fail exn in - let Internal p' = to_internal_promise p' in + let p' = try h exn with exn -> fail exn in + let (Internal p') = to_internal_promise p' in - let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let (State_may_now_be_pending_proxy p'') = may_now_be_proxy p'' in + let p'' = underlying p'' in - let State_may_have_changed p'' = - make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in - ignore p'' + let (State_may_have_changed p'') = + make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' + in + ignore p'' in (to_public_promise p'', callback) @@ -2169,31 +2018,29 @@ struct match p.state with | Fulfilled v -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> f' v) - ~if_deferred:(fun () -> - let (p'', callback) = - create_result_promise_and_callback_if_deferred () in - (p'', callback, p.state)) - + run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true + ~callback:(fun () -> f' v) + ~if_deferred:(fun () -> + let p'', callback = + create_result_promise_and_callback_if_deferred () + in + (p'', callback, p.state)) | Rejected exn -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> h exn) - ~if_deferred:(fun () -> - let (p'', callback) = - create_result_promise_and_callback_if_deferred () in - (p'', callback, p.state)) - + run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true + ~callback:(fun () -> h exn) + ~if_deferred:(fun () -> + let p'', callback = + create_result_promise_and_callback_if_deferred () + in + (p'', callback, p.state)) | Pending p_callbacks -> - let (p'', callback) = create_result_promise_and_callback_if_deferred () in - add_implicitly_removed_callback p_callbacks callback; - p'' + let p'', callback = create_result_promise_and_callback_if_deferred () in + add_implicitly_removed_callback p_callbacks callback; + p'' let backtrace_try_bind add_loc f f' h = let p = try f () with exn -> fail exn in - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in let p = underlying p in let create_result_promise_and_callback_if_deferred () = @@ -2204,30 +2051,31 @@ struct let callback p_result = match p_result with | Fulfilled v -> - current_storage := saved_storage; - - let p' = try f' v with exn -> fail (add_loc exn) in - let Internal p' = to_internal_promise p' in + current_storage := saved_storage; - let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let p' = try f' v with exn -> fail (add_loc exn) in + let (Internal p') = to_internal_promise p' in - let State_may_have_changed p'' = - make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in - ignore p'' + let (State_may_now_be_pending_proxy p'') = may_now_be_proxy p'' in + let p'' = underlying p'' in + let (State_may_have_changed p'') = + make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' + in + ignore p'' | Rejected exn -> - current_storage := saved_storage; + current_storage := saved_storage; - let p' = try h exn with exn -> fail (add_loc exn) in - let Internal p' = to_internal_promise p' in + let p' = try h exn with exn -> fail (add_loc exn) in + let (Internal p') = to_internal_promise p' in - let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let (State_may_now_be_pending_proxy p'') = may_now_be_proxy p'' in + let p'' = underlying p'' in - let State_may_have_changed p'' = - make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in - ignore p'' + let (State_may_have_changed p'') = + make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' + in + ignore p'' in (to_public_promise p'', callback) @@ -2235,27 +2083,25 @@ struct match p.state with | Fulfilled v -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> f' v) - ~if_deferred:(fun () -> - let (p'', callback) = - create_result_promise_and_callback_if_deferred () in - (p'', callback, p.state)) - + run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true + ~callback:(fun () -> f' v) + ~if_deferred:(fun () -> + let p'', callback = + create_result_promise_and_callback_if_deferred () + in + (p'', callback, p.state)) | Rejected exn -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> h (add_loc exn)) - ~if_deferred:(fun () -> - let (p'', callback) = - create_result_promise_and_callback_if_deferred () in - (p'', callback, p.state)) - + run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true + ~callback:(fun () -> h (add_loc exn)) + ~if_deferred:(fun () -> + let p'', callback = + create_result_promise_and_callback_if_deferred () + in + (p'', callback, p.state)) | Pending p_callbacks -> - let (p'', callback) = create_result_promise_and_callback_if_deferred () in - add_implicitly_removed_callback p_callbacks callback; - p'' + let p'', callback = create_result_promise_and_callback_if_deferred () in + add_implicitly_removed_callback p_callbacks callback; + p'' let finalize f f' = try_bind f @@ -2267,33 +2113,22 @@ struct (fun x -> bind (f' ()) (fun () -> return x)) (fun e -> bind (f' ()) (fun () -> fail (add_loc e))) - - let on_cancel p f = - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in let p = underlying p in match p.state with | Rejected Canceled -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> handle_with_async_exception_hook f ()) - ~if_deferred:(fun () -> - ((), (fun _ -> handle_with_async_exception_hook f ()), Fulfilled ())) - - | Rejected _ -> - () - - | Fulfilled _ -> - () - - | Pending callbacks -> - add_cancel_callback callbacks f - - + run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true + ~callback:(fun () -> handle_with_async_exception_hook f ()) + ~if_deferred:(fun () -> + ((), (fun _ -> handle_with_async_exception_hook f ()), Fulfilled ())) + | Rejected _ -> () + | Fulfilled _ -> () + | Pending callbacks -> add_cancel_callback callbacks f let on_success p f = - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in let p = underlying p in let callback_if_deferred () = @@ -2302,31 +2137,25 @@ struct fun result -> match result with | Fulfilled v -> - current_storage := saved_storage; - handle_with_async_exception_hook f v - - | Rejected _ -> - () + current_storage := saved_storage; + handle_with_async_exception_hook f v + | Rejected _ -> () in match p.state with | Fulfilled v -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> handle_with_async_exception_hook f v) - ~if_deferred:(fun () -> - let callback = callback_if_deferred () in - ((), callback, p.state)) - - | Rejected _ -> - () - + run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true + ~callback:(fun () -> handle_with_async_exception_hook f v) + ~if_deferred:(fun () -> + let callback = callback_if_deferred () in + ((), callback, p.state)) + | Rejected _ -> () | Pending p_callbacks -> - let callback = callback_if_deferred () in - add_implicitly_removed_callback p_callbacks callback + let callback = callback_if_deferred () in + add_implicitly_removed_callback p_callbacks callback let on_failure p f = - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in let p = underlying p in let callback_if_deferred () = @@ -2334,32 +2163,26 @@ struct fun result -> match result with - | Fulfilled _ -> - () - + | Fulfilled _ -> () | Rejected exn -> - current_storage := saved_storage; - handle_with_async_exception_hook f exn + current_storage := saved_storage; + handle_with_async_exception_hook f exn in match p.state with - | Fulfilled _ -> - () - + | Fulfilled _ -> () | Rejected exn -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> handle_with_async_exception_hook f exn) - ~if_deferred:(fun () -> - let callback = callback_if_deferred () in - ((), callback, p.state)) - + run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true + ~callback:(fun () -> handle_with_async_exception_hook f exn) + ~if_deferred:(fun () -> + let callback = callback_if_deferred () in + ((), callback, p.state)) | Pending p_callbacks -> - let callback = callback_if_deferred () in - add_implicitly_removed_callback p_callbacks callback + let callback = callback_if_deferred () in + add_implicitly_removed_callback p_callbacks callback let on_termination p f = - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in let p = underlying p in let callback_if_deferred () = @@ -2372,27 +2195,23 @@ struct match p.state with | Fulfilled _ -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> handle_with_async_exception_hook f ()) - ~if_deferred:(fun () -> - let callback = callback_if_deferred () in - ((), callback, p.state)) - + run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true + ~callback:(fun () -> handle_with_async_exception_hook f ()) + ~if_deferred:(fun () -> + let callback = callback_if_deferred () in + ((), callback, p.state)) | Rejected _ -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> handle_with_async_exception_hook f ()) - ~if_deferred:(fun () -> - let callback = callback_if_deferred () in - ((), callback, p.state)) - + run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true + ~callback:(fun () -> handle_with_async_exception_hook f ()) + ~if_deferred:(fun () -> + let callback = callback_if_deferred () in + ((), callback, p.state)) | Pending p_callbacks -> - let callback = callback_if_deferred () in - add_implicitly_removed_callback p_callbacks callback + let callback = callback_if_deferred () in + add_implicitly_removed_callback p_callbacks callback let on_any p f g = - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in let p = underlying p in let callback_if_deferred () = @@ -2401,134 +2220,103 @@ struct fun result -> match result with | Fulfilled v -> - current_storage := saved_storage; - handle_with_async_exception_hook f v - + current_storage := saved_storage; + handle_with_async_exception_hook f v | Rejected exn -> - current_storage := saved_storage; - handle_with_async_exception_hook g exn + current_storage := saved_storage; + handle_with_async_exception_hook g exn in match p.state with | Fulfilled v -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> handle_with_async_exception_hook f v) - ~if_deferred:(fun () -> - let callback = callback_if_deferred () in - ((), callback, p.state)) - + run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true + ~callback:(fun () -> handle_with_async_exception_hook f v) + ~if_deferred:(fun () -> + let callback = callback_if_deferred () in + ((), callback, p.state)) | Rejected exn -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> handle_with_async_exception_hook g exn) - ~if_deferred:(fun () -> - let callback = callback_if_deferred () in - ((), callback, p.state)) - + run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true + ~callback:(fun () -> handle_with_async_exception_hook g exn) + ~if_deferred:(fun () -> + let callback = callback_if_deferred () in + ((), callback, p.state)) | Pending p_callbacks -> - let callback = callback_if_deferred () in - add_implicitly_removed_callback p_callbacks callback + let callback = callback_if_deferred () in + add_implicitly_removed_callback p_callbacks callback end -include Sequential_composition +include Sequential_composition (* This belongs with the [protected] and such, but it depends on primitives from [Sequential_composition]. *) let wrap_in_cancelable p = - let Internal p_internal = to_internal_promise p in - let p_underlying = underlying p_internal in - match p_underlying.state with - | Fulfilled _ -> p - | Rejected _ -> p - | Pending _ -> - let p', r = task () in - on_cancel p' (fun () -> cancel p); - on_any p (wakeup r) (wakeup_exn r); - p' - - -module Concurrent_composition : -sig + let (Internal p_internal) = to_internal_promise p in + let p_underlying = underlying p_internal in + match p_underlying.state with + | Fulfilled _ -> p + | Rejected _ -> p + | Pending _ -> + let p', r = task () in + on_cancel p' (fun () -> cancel p); + on_any p (wakeup r) (wakeup_exn r); + p' + +module Concurrent_composition : sig val dont_wait : (unit -> _ t) -> (exn -> unit) -> unit 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 all : ('a t) list -> ('a list) t - + val all : 'a t list -> 'a list t val choose : 'a t list -> 'a t val pick : 'a t list -> 'a t - val nchoose : 'a t list -> 'a list t val npick : 'a t list -> 'a list t - val nchoose_split : 'a t list -> ('a list * 'a t list) t -end = -struct +end = struct external reraise : exn -> 'a = "%reraise" let dont_wait f h = let p = try f () with exn -> fail exn in - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in match (underlying p).state with - | Fulfilled _ -> - () - | Rejected exn -> - h exn - + | Fulfilled _ -> () + | Rejected exn -> h exn | Pending p_callbacks -> - let callback result = - match result with - | Fulfilled _ -> - () - | Rejected exn -> - h exn - in - add_implicitly_removed_callback p_callbacks callback + let callback result = + match result with Fulfilled _ -> () | Rejected exn -> h exn + in + add_implicitly_removed_callback p_callbacks callback let async f = let p = try f () with exn -> fail exn in - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in match (underlying p).state with - | Fulfilled _ -> - () - | Rejected exn -> - !async_exception_hook exn - + | Fulfilled _ -> () + | Rejected exn -> !async_exception_hook exn | Pending p_callbacks -> - let callback result = - match result with - | Fulfilled _ -> - () - | Rejected exn -> - !async_exception_hook exn - in - add_implicitly_removed_callback p_callbacks callback + let callback result = + match result with + | Fulfilled _ -> () + | Rejected exn -> !async_exception_hook exn + in + add_implicitly_removed_callback p_callbacks callback let ignore_result p = - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in match (underlying p).state with - | Fulfilled _ -> - () - | Rejected exn -> - reraise exn - + | Fulfilled _ -> () + | Rejected exn -> reraise exn | Pending p_callbacks -> - let callback result = - match result with - | Fulfilled _ -> - () - | Rejected exn -> - !async_exception_hook exn - in - add_implicitly_removed_callback p_callbacks callback - - + let callback result = + match result with + | Fulfilled _ -> () + | Rejected exn -> !async_exception_hook exn + in + add_implicitly_removed_callback p_callbacks callback let join ps = let p' = new_pending ~how_to_cancel:(propagate_cancel_to_several ps) in @@ -2539,27 +2327,26 @@ struct (* Callback attached to each promise in [ps] that is still pending at the time [join] is called. *) let callback new_result = - let State_may_now_be_pending_proxy p' = may_now_be_proxy p' in + let (State_may_now_be_pending_proxy p') = may_now_be_proxy p' in - begin match new_result with + (match new_result with | Fulfilled () -> () - | Rejected _ -> - (* For the first promise in [ps] to be rejected, set the result of the - [join] to rejected with the same exception.. *) - match !join_result with - | Fulfilled () -> join_result := new_result - | Rejected _ -> () - end; + | Rejected _ -> ( + (* For the first promise in [ps] to be rejected, set the result of the + [join] to rejected with the same exception.. *) + match !join_result with + | Fulfilled () -> join_result := new_result + | Rejected _ -> ())); (* In all cases, decrement the number of promises still pending, and resolve the [join] once all promises resolve. *) number_pending_in_ps := !number_pending_in_ps - 1; - if !number_pending_in_ps = 0 then begin + if !number_pending_in_ps = 0 then let p' = underlying p' in - let State_may_have_changed p' = - resolve ~allow_deferring:false (underlying p') !join_result in + let (State_may_have_changed p') = + resolve ~allow_deferring:false (underlying p') !join_result + in ignore p' - end in (* Attach the above callback. Simultaneously count how many pending promises @@ -2568,74 +2355,75 @@ struct let rec attach_callback_or_resolve_immediately ps = match ps with | [] -> - if !number_pending_in_ps = 0 then - to_public_promise {state = !join_result} - else - to_public_promise p' - - | p::ps -> - let Internal p = to_internal_promise p in - - match (underlying p).state with - | Pending p_callbacks -> - number_pending_in_ps := !number_pending_in_ps + 1; - add_implicitly_removed_callback p_callbacks callback; - attach_callback_or_resolve_immediately ps - - | Rejected _ as p_result -> - (* As in the callback above, but for already-resolved promises in - [ps]: reject the [join] with the same exception as in the first - rejected promise found. [join] still waits for any pending promises - before actually resolving, though. *) - begin match !join_result with - | Fulfilled () -> join_result := p_result; - | Rejected _ -> () - end; - attach_callback_or_resolve_immediately ps - - | Fulfilled () -> - attach_callback_or_resolve_immediately ps + if !number_pending_in_ps = 0 then + to_public_promise { state = !join_result } + else to_public_promise p' + | p :: ps -> ( + let (Internal p) = to_internal_promise p in + + match (underlying p).state with + | Pending p_callbacks -> + number_pending_in_ps := !number_pending_in_ps + 1; + add_implicitly_removed_callback p_callbacks callback; + attach_callback_or_resolve_immediately ps + | Rejected _ as p_result -> + (* As in the callback above, but for already-resolved promises in + [ps]: reject the [join] with the same exception as in the first + rejected promise found. [join] still waits for any pending promises + before actually resolving, though. *) + (match !join_result with + | Fulfilled () -> join_result := p_result + | Rejected _ -> ()); + attach_callback_or_resolve_immediately ps + | Fulfilled () -> attach_callback_or_resolve_immediately ps) in attach_callback_or_resolve_immediately ps (* this is 3 words, smaller than the 2 times 2 words a pair of references would take. *) - type ('a,'b) pair = { - mutable x1: 'a option; - mutable x2: 'b option; - } + type ('a, 'b) pair = { mutable x1 : 'a option; mutable x2 : 'b option } let both p1 p2 = - let pair = {x1 = None; x2 = None} in - let p1' = bind p1 (fun v -> pair.x1 <- Some v; return_unit) in - let p2' = bind p2 (fun v -> pair.x2 <- Some v; return_unit) in - join [p1'; p2'] |> map (fun () -> - match pair.x1, pair.x2 with - | Some v1, Some v2 -> v1, v2 - | _ -> assert false) + let pair = { x1 = None; x2 = None } in + let p1' = + bind p1 (fun v -> + pair.x1 <- Some v; + return_unit) + in + let p2' = + bind p2 (fun v -> + pair.x2 <- Some v; + return_unit) + in + join [ p1'; p2' ] + |> map (fun () -> + match (pair.x1, pair.x2) with + | Some v1, Some v2 -> (v1, v2) + | _ -> assert false) let all ps = match ps with | [] -> return_nil - | [x] -> map (fun y -> [y]) x - | [x; y] -> map (fun (x, y) -> [x; y]) (both x y) + | [ x ] -> map (fun y -> [ y ]) x + | [ x; y ] -> map (fun (x, y) -> [ x; y ]) (both x y) | _ -> - let vs = Array.make (List.length ps) None in - ps - |> List.mapi (fun index p -> - bind p (fun v -> vs.(index) <- Some v; return_unit)) - |> join - |> map (fun () -> - let rec to_list_unopt i acc = - if i < 0 then - acc - else - match Array.unsafe_get vs i with - | None -> assert false - | Some x -> to_list_unopt (i - 1) (x::acc) - in - to_list_unopt (Array.length vs - 1) []) + let vs = Array.make (List.length ps) None in + ps + |> List.mapi (fun index p -> + bind p (fun v -> + vs.(index) <- Some v; + return_unit)) + |> join + |> map (fun () -> + let rec to_list_unopt i acc = + if i < 0 then acc + else + match Array.unsafe_get vs i with + | None -> assert false + | Some x -> to_list_unopt (i - 1) (x :: acc) + in + to_list_unopt (Array.length vs - 1) []) (* Maintainer's note: the next few functions are helpers for [choose] and [pick]. Perhaps they should be factored into some kind of generic @@ -2644,7 +2432,7 @@ struct let count_resolved_promises_in (ps : _ t list) = let accumulate total p = - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in match (underlying p).state with | Fulfilled _ -> total + 1 | Rejected _ -> total + 1 @@ -2657,42 +2445,35 @@ struct least [n] resolved promises in [ps]. *) let rec nth_resolved (ps : 'a t list) (n : int) : 'a t = match ps with - | [] -> - assert false - - | p::ps -> - let Internal p' = to_internal_promise p in - match (underlying p').state with - | Pending _ -> - nth_resolved ps n - - | Fulfilled _ -> - if n <= 0 then p - else nth_resolved ps (n - 1) - | Rejected _ -> - if n <= 0 then p - else nth_resolved ps (n - 1) + | [] -> assert false + | p :: ps -> ( + let (Internal p') = to_internal_promise p in + match (underlying p').state with + | Pending _ -> nth_resolved ps n + | Fulfilled _ -> if n <= 0 then p else nth_resolved ps (n - 1) + | Rejected _ -> if n <= 0 then p else nth_resolved ps (n - 1)) (* Like [nth_resolved], but cancels all pending promises found while traversing [ps]. *) let rec nth_resolved_and_cancel_pending (ps : 'a t list) (n : int) : 'a t = match ps with - | [] -> - assert false - - | p::ps -> - let Internal p' = to_internal_promise p in - match (underlying p').state with - | Pending _ -> - cancel p; - nth_resolved_and_cancel_pending ps n - - | Fulfilled _ -> - if n <= 0 then (List.iter cancel ps; p) - else nth_resolved_and_cancel_pending ps (n - 1) - | Rejected _ -> - if n <= 0 then (List.iter cancel ps; p) - else nth_resolved_and_cancel_pending ps (n - 1) + | [] -> assert false + | p :: ps -> ( + let (Internal p') = to_internal_promise p in + match (underlying p').state with + | Pending _ -> + cancel p; + nth_resolved_and_cancel_pending ps n + | Fulfilled _ -> + if n <= 0 then ( + List.iter cancel ps; + p) + else nth_resolved_and_cancel_pending ps (n - 1) + | Rejected _ -> + if n <= 0 then ( + List.iter cancel ps; + p) + else nth_resolved_and_cancel_pending ps (n - 1)) (* The PRNG state is initialized with a constant to make non-IO-based programs deterministic. *) @@ -2701,56 +2482,48 @@ struct let choose ps = if ps = [] then - invalid_arg - "Lwt.choose [] would return a promise that is pending forever"; + invalid_arg "Lwt.choose [] would return a promise that is pending forever"; match count_resolved_promises_in ps with | 0 -> - let p = new_pending ~how_to_cancel:(propagate_cancel_to_several ps) in - - let callback result = - let State_may_now_be_pending_proxy p = may_now_be_proxy p in - let p = underlying p in - let State_may_have_changed p = - resolve ~allow_deferring:false p result in - ignore p - in - add_explicitly_removable_callback_to_each_of ps callback; - - to_public_promise p + let p = new_pending ~how_to_cancel:(propagate_cancel_to_several ps) in - | 1 -> - nth_resolved ps 0 + let callback result = + let (State_may_now_be_pending_proxy p) = may_now_be_proxy p in + let p = underlying p in + let (State_may_have_changed p) = + resolve ~allow_deferring:false p result + in + ignore p + in + add_explicitly_removable_callback_to_each_of ps callback; - | n -> - nth_resolved ps (Random.State.int (Lazy.force prng) n) + to_public_promise p + | 1 -> nth_resolved ps 0 + | n -> nth_resolved ps (Random.State.int (Lazy.force prng) n) let pick ps = if ps = [] then invalid_arg "Lwt.pick [] would return a promise that is pending forever"; match count_resolved_promises_in ps with | 0 -> - let p = new_pending ~how_to_cancel:(propagate_cancel_to_several ps) in - - let callback result = - let State_may_now_be_pending_proxy p = may_now_be_proxy p in - List.iter cancel ps; - let p = underlying p in - let State_may_have_changed p = - resolve ~allow_deferring:false p result in - ignore p - in - add_explicitly_removable_callback_to_each_of ps callback; - - to_public_promise p + let p = new_pending ~how_to_cancel:(propagate_cancel_to_several ps) in - | 1 -> - nth_resolved_and_cancel_pending ps 0 + let callback result = + let (State_may_now_be_pending_proxy p) = may_now_be_proxy p in + List.iter cancel ps; + let p = underlying p in + let (State_may_have_changed p) = + resolve ~allow_deferring:false p result + in + ignore p + in + add_explicitly_removable_callback_to_each_of ps callback; + to_public_promise p + | 1 -> nth_resolved_and_cancel_pending ps 0 | n -> - nth_resolved_and_cancel_pending ps - (Random.State.int (Lazy.force prng) n) - - + nth_resolved_and_cancel_pending ps + (Random.State.int (Lazy.force prng) n) (* If [nchoose ps] or [npick ps] found all promises in [ps] pending, the callback added to each promise in [ps] eventually calls this function. The @@ -2758,27 +2531,18 @@ struct promise in [ps] that has been rejected. It then returns the desired state of the final promise: either the list of results collected, or the exception found. *) - let rec collect_fulfilled_promises_after_pending - (results : 'a list) - (ps : 'a t list) : - ('a list resolved_state) = - + let rec collect_fulfilled_promises_after_pending (results : 'a list) + (ps : 'a t list) : 'a list resolved_state = match ps with - | [] -> - Fulfilled (List.rev results) - - | p::ps -> - let Internal p = to_internal_promise p in - - match (underlying p).state with - | Fulfilled v -> - collect_fulfilled_promises_after_pending (v::results) ps - - | Rejected _ as result -> - result + | [] -> Fulfilled (List.rev results) + | p :: ps -> ( + let (Internal p) = to_internal_promise p in - | Pending _ -> - collect_fulfilled_promises_after_pending results ps + match (underlying p).state with + | Fulfilled v -> + collect_fulfilled_promises_after_pending (v :: results) ps + | Rejected _ as result -> result + | Pending _ -> collect_fulfilled_promises_after_pending results ps) let nchoose ps = (* If at least one promise in [ps] is found fulfilled, this function is @@ -2788,20 +2552,15 @@ struct "Lwt.nchoose [] would return a promise that is pending forever"; let rec collect_already_fulfilled_promises_or_find_rejected acc ps = match ps with - | [] -> - return (List.rev acc) - - | p::ps -> - let Internal p = to_internal_promise p in - match (underlying p).state with - | Fulfilled v -> - collect_already_fulfilled_promises_or_find_rejected (v::acc) ps - - | Rejected _ as result -> - to_public_promise {state = result} - - | Pending _ -> - collect_already_fulfilled_promises_or_find_rejected acc ps + | [] -> return (List.rev acc) + | p :: ps -> ( + let (Internal p) = to_internal_promise p in + match (underlying p).state with + | Fulfilled v -> + collect_already_fulfilled_promises_or_find_rejected (v :: acc) ps + | Rejected _ as result -> to_public_promise { state = result } + | Pending _ -> + collect_already_fulfilled_promises_or_find_rejected acc ps) in (* Looks for already-resolved promises in [ps]. If none are fulfilled or @@ -2810,31 +2569,27 @@ struct let rec check_for_already_resolved_promises ps' = match ps' with | [] -> - let p = new_pending ~how_to_cancel:(propagate_cancel_to_several ps) in - - let callback _result = - let State_may_now_be_pending_proxy p = may_now_be_proxy p in - let p = underlying p in - let result = collect_fulfilled_promises_after_pending [] ps in - let State_may_have_changed p = - resolve ~allow_deferring:false p result in - ignore p - in - add_explicitly_removable_callback_to_each_of ps callback; - - to_public_promise p - - | p::ps -> - let Internal p = to_internal_promise p in - match (underlying p).state with - | Fulfilled v -> - collect_already_fulfilled_promises_or_find_rejected [v] ps - - | Rejected _ as result -> - to_public_promise {state = result} - - | Pending _ -> - check_for_already_resolved_promises ps + let p = new_pending ~how_to_cancel:(propagate_cancel_to_several ps) in + + let callback _result = + let (State_may_now_be_pending_proxy p) = may_now_be_proxy p in + let p = underlying p in + let result = collect_fulfilled_promises_after_pending [] ps in + let (State_may_have_changed p) = + resolve ~allow_deferring:false p result + in + ignore p + in + add_explicitly_removable_callback_to_each_of ps callback; + + to_public_promise p + | p :: ps -> ( + let (Internal p) = to_internal_promise p in + match (underlying p).state with + | Fulfilled v -> + collect_already_fulfilled_promises_or_find_rejected [ v ] ps + | Rejected _ as result -> to_public_promise { state = result } + | Pending _ -> check_for_already_resolved_promises ps) in let p = check_for_already_resolved_promises ps in @@ -2848,60 +2603,52 @@ struct let rec collect_already_fulfilled_promises_or_find_rejected acc ps' = match ps' with | [] -> - List.iter cancel ps; - return (List.rev acc) - - | p::ps' -> - let Internal p = to_internal_promise p in - match (underlying p).state with - | Fulfilled v -> - collect_already_fulfilled_promises_or_find_rejected (v::acc) ps' - - | Rejected _ as result -> List.iter cancel ps; - to_public_promise {state = result} - - | Pending _ -> - collect_already_fulfilled_promises_or_find_rejected acc ps' + return (List.rev acc) + | p :: ps' -> ( + let (Internal p) = to_internal_promise p in + match (underlying p).state with + | Fulfilled v -> + collect_already_fulfilled_promises_or_find_rejected (v :: acc) ps' + | Rejected _ as result -> + List.iter cancel ps; + to_public_promise { state = result } + | Pending _ -> + collect_already_fulfilled_promises_or_find_rejected acc ps') in let rec check_for_already_resolved_promises ps' = match ps' with | [] -> - let p = new_pending ~how_to_cancel:(propagate_cancel_to_several ps) in - - let callback _result = - let State_may_now_be_pending_proxy p = may_now_be_proxy p in - let p = underlying p in - let result = collect_fulfilled_promises_after_pending [] ps in - List.iter cancel ps; - let State_may_have_changed p = - resolve ~allow_deferring:false p result in - ignore p - in - add_explicitly_removable_callback_to_each_of ps callback; - - to_public_promise p - - | p::ps' -> - let Internal p = to_internal_promise p in - match (underlying p).state with - | Fulfilled v -> - collect_already_fulfilled_promises_or_find_rejected [v] ps' - - | Rejected _ as result -> - List.iter cancel ps; - to_public_promise {state = result} - - | Pending _ -> - check_for_already_resolved_promises ps' + let p = new_pending ~how_to_cancel:(propagate_cancel_to_several ps) in + + let callback _result = + let (State_may_now_be_pending_proxy p) = may_now_be_proxy p in + let p = underlying p in + let result = collect_fulfilled_promises_after_pending [] ps in + List.iter cancel ps; + let (State_may_have_changed p) = + resolve ~allow_deferring:false p result + in + ignore p + in + add_explicitly_removable_callback_to_each_of ps callback; + + to_public_promise p + | p :: ps' -> ( + let (Internal p) = to_internal_promise p in + match (underlying p).state with + | Fulfilled v -> + collect_already_fulfilled_promises_or_find_rejected [ v ] ps' + | Rejected _ as result -> + List.iter cancel ps; + to_public_promise { state = result } + | Pending _ -> check_for_already_resolved_promises ps') in let p = check_for_already_resolved_promises ps in p - - (* Same general pattern as [npick] and [nchoose]. *) let nchoose_split ps = if ps = [] then @@ -2909,91 +2656,70 @@ struct "Lwt.nchoose_split [] would return a promise that is pending forever"; let rec finish (to_resolve : ('a list * 'a t list, underlying, pending) promise) - (fulfilled : 'a list) - (pending : 'a t list) - (ps : 'a t list) - : ('a list * 'a t list, underlying, resolved) state_changed = - + (fulfilled : 'a list) (pending : 'a t list) (ps : 'a t list) : + ('a list * 'a t list, underlying, resolved) state_changed = match ps with | [] -> - resolve ~allow_deferring:false to_resolve - (Fulfilled (List.rev fulfilled, List.rev pending)) - - | p::ps -> - let Internal p_internal = to_internal_promise p in - match (underlying p_internal).state with - | Fulfilled v -> - finish to_resolve (v::fulfilled) pending ps - - | Rejected _ as result -> - resolve ~allow_deferring:false to_resolve result - - | Pending _ -> - finish to_resolve fulfilled (p::pending) ps + resolve ~allow_deferring:false to_resolve + (Fulfilled (List.rev fulfilled, List.rev pending)) + | p :: ps -> ( + let (Internal p_internal) = to_internal_promise p in + match (underlying p_internal).state with + | Fulfilled v -> finish to_resolve (v :: fulfilled) pending ps + | Rejected _ as result -> + resolve ~allow_deferring:false to_resolve result + | Pending _ -> finish to_resolve fulfilled (p :: pending) ps) in let rec collect_already_resolved_promises results pending ps = match ps with | [] -> - (* Maintainer's note: should the pending promise list also be - reversed? It is reversed in finish. *) - return (List.rev results, pending) - - | p::ps -> - let Internal p_internal = to_internal_promise p in - match (underlying p_internal).state with - | Fulfilled v -> - collect_already_resolved_promises (v::results) pending ps - - | Rejected _ as result -> - to_public_promise {state = result} - - | Pending _ -> - collect_already_resolved_promises results (p::pending) ps + (* Maintainer's note: should the pending promise list also be + reversed? It is reversed in finish. *) + return (List.rev results, pending) + | p :: ps -> ( + let (Internal p_internal) = to_internal_promise p in + match (underlying p_internal).state with + | Fulfilled v -> + collect_already_resolved_promises (v :: results) pending ps + | Rejected _ as result -> to_public_promise { state = result } + | Pending _ -> + collect_already_resolved_promises results (p :: pending) ps) in let rec check_for_already_resolved_promises pending_acc ps' = match ps' with | [] -> - let p = new_pending ~how_to_cancel:(propagate_cancel_to_several ps) in + let p = new_pending ~how_to_cancel:(propagate_cancel_to_several ps) in - let callback _result = - let State_may_now_be_pending_proxy p = may_now_be_proxy p in - let p = underlying p in - let State_may_have_changed p = finish p [] [] ps in - ignore p - in - add_explicitly_removable_callback_to_each_of ps callback; - - to_public_promise p - - | p::ps' -> - let Internal p_internal = to_internal_promise p in - match (underlying p_internal).state with - | Fulfilled v -> - collect_already_resolved_promises [v] pending_acc ps' - - | Rejected _ as result -> - to_public_promise {state = result} - - | Pending _ -> - check_for_already_resolved_promises (p::pending_acc) ps' + let callback _result = + let (State_may_now_be_pending_proxy p) = may_now_be_proxy p in + let p = underlying p in + let (State_may_have_changed p) = finish p [] [] ps in + ignore p + in + add_explicitly_removable_callback_to_each_of ps callback; + + to_public_promise p + | p :: ps' -> ( + let (Internal p_internal) = to_internal_promise p in + match (underlying p_internal).state with + | Fulfilled v -> + collect_already_resolved_promises [ v ] pending_acc ps' + | Rejected _ as result -> to_public_promise { state = result } + | Pending _ -> + check_for_already_resolved_promises (p :: pending_acc) ps') in let p = check_for_already_resolved_promises [] ps in p end -include Concurrent_composition - +include Concurrent_composition -module Miscellaneous : -sig +module Miscellaneous : sig (* Promise state query *) - type 'a state = - | Return of 'a - | Fail of exn - | Sleep + type 'a state = Return of 'a | Fail of exn | Sleep val state : 'a t -> 'a state val is_sleeping : 'a t -> bool @@ -3001,31 +2727,43 @@ sig (* Function lifters *) val apply : ('a -> 'b t) -> 'a -> 'b t + val wrap : (unit -> 'b) -> 'b t + val wrap1 : ('a1 -> 'b) -> 'a1 -> 'b t + val wrap2 : ('a1 -> 'a2 -> 'b) -> 'a1 -> 'a2 -> 'b t + val wrap3 : ('a1 -> 'a2 -> 'a3 -> 'b) -> 'a1 -> 'a2 -> 'a3 -> 'b t - val wrap : - (unit -> 'b) -> - 'b t - val wrap1 : - ('a1 -> 'b) -> - ('a1 -> 'b t) - val wrap2 : - ('a1 -> 'a2 -> 'b) -> - ('a1 -> 'a2 -> 'b t) - val wrap3 : - ('a1 -> 'a2 -> 'a3 -> 'b) -> - ('a1 -> 'a2 -> 'a3 -> 'b t) val wrap4 : - ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'b) -> - ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'b t) + ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'b) -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'b t + val wrap5 : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'b) -> - ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'b t) + 'a1 -> + 'a2 -> + 'a3 -> + 'a4 -> + 'a5 -> + 'b t + val wrap6 : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'b) -> - ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'b t) + 'a1 -> + 'a2 -> + 'a3 -> + 'a4 -> + 'a5 -> + 'a6 -> + 'b t + val wrap7 : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'b) -> - ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'b t) + 'a1 -> + 'a2 -> + 'a3 -> + 'a4 -> + 'a5 -> + 'a6 -> + 'a7 -> + 'b t (* Paused promises *) val pause : unit -> unit t @@ -3036,77 +2774,51 @@ sig (* Internal interface for other modules in Lwt *) val poll : 'a t -> 'a option -end = -struct - type 'a state = - | Return of 'a - | Fail of exn - | Sleep +end = struct + type 'a state = Return of 'a | Fail of exn | Sleep external reraise : exn -> 'a = "%reraise" let state p = - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in match (underlying p).state with | Fulfilled v -> Return v | Rejected exn -> Fail exn | Pending _ -> Sleep - let debug_state_is expected_state p = - return (state p = expected_state) + let debug_state_is expected_state p = return (state p = expected_state) let is_sleeping p = - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in match (underlying p).state with | Fulfilled _ -> false | Rejected _ -> false | Pending _ -> true let poll p = - let Internal p = to_internal_promise p in + let (Internal p) = to_internal_promise p in match (underlying p).state with | Rejected e -> reraise e | Fulfilled v -> Some v | Pending _ -> None - - let apply f x = try f x with exn -> fail exn - let wrap f = try return (f ()) with exn -> fail exn - - let wrap1 f x1 = - try return (f x1) - with exn -> fail exn - - let wrap2 f x1 x2 = - try return (f x1 x2) - with exn -> fail exn - - let wrap3 f x1 x2 x3 = - try return (f x1 x2 x3) - with exn -> fail exn - - let wrap4 f x1 x2 x3 x4 = - try return (f x1 x2 x3 x4) - with exn -> fail exn + let wrap1 f x1 = try return (f x1) with exn -> fail exn + let wrap2 f x1 x2 = try return (f x1 x2) with exn -> fail exn + let wrap3 f x1 x2 x3 = try return (f x1 x2 x3) with exn -> fail exn + let wrap4 f x1 x2 x3 x4 = try return (f x1 x2 x3 x4) with exn -> fail exn let wrap5 f x1 x2 x3 x4 x5 = - try return (f x1 x2 x3 x4 x5) - with exn -> fail exn + try return (f x1 x2 x3 x4 x5) with exn -> fail exn let wrap6 f x1 x2 x3 x4 x5 x6 = - try return (f x1 x2 x3 x4 x5 x6) - with exn -> fail exn + try return (f x1 x2 x3 x4 x5 x6) with exn -> fail exn let wrap7 f x1 x2 x3 x4 x5 x6 x7 = - try return (f x1 x2 x3 x4 x5 x6 x7) - with exn -> fail exn - - + try return (f x1 x2 x3 x4 x5 x6 x7) with exn -> fail exn let pause_hook = ref ignore - let paused = Lwt_sequence.create () let paused_count = ref 0 @@ -3117,14 +2829,12 @@ struct p let wakeup_paused () = - if Lwt_sequence.is_empty paused then - paused_count := 0 - else begin + if Lwt_sequence.is_empty paused then paused_count := 0 + else let tmp = Lwt_sequence.create () in Lwt_sequence.transfer_r paused tmp; paused_count := 0; Lwt_sequence.iter_l (fun r -> wakeup r ()) tmp - end let register_pause_notifier f = pause_hook := f @@ -3134,52 +2844,47 @@ struct let paused_count () = !paused_count end + include Miscellaneous -module Let_syntax = -struct - module Let_syntax = - struct +module Let_syntax = struct + 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 + module Open_on_rhs = struct end end end -module Infix = -struct - let (>>=) = bind - let (=<<) f p = bind p f - let (>|=) p f = map f p - let (=|<) = map - let (<&>) p p' = join [p; p'] - let () p p' = choose [p; p'] +module Infix = struct + let ( >>= ) = bind + let ( =<< ) f p = bind p f + let ( >|= ) p f = map f p + let ( =|< ) = map + let ( <&> ) p p' = join [ p; p' ] + let ( ) p p' = choose [ p; p' ] include Let_syntax end -include ( Infix : module type of Infix with module Let_syntax := Let_syntax.Let_syntax ) -module Syntax = -struct - let (let*) = bind - let (and*) = both +include ( + Infix : module type of Infix with module Let_syntax := Let_syntax.Let_syntax) - let (let+) x f = map f x - let (and+) = both +module Syntax = struct + let ( let* ) = bind + let ( and* ) = both + let ( let+ ) x f = map f x + let ( and+ ) = both end - -module Lwt_result_type = -struct +module Lwt_result_type = struct type +'a result = 'a lwt_result (* Deprecated. *) let make_value v = Result.Ok v let make_error exn = Result.Error exn end + include Lwt_result_type diff --git a/src/core/lwt.mli b/src/core/lwt.mli index 5c8bc43f8d..fd48bfefc6 100644 --- a/src/core/lwt.mli +++ b/src/core/lwt.mli @@ -1,8 +1,6 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Asynchronous programming with promises. A {b promise} is a placeholder for a single value which might take a long @@ -41,36 +39,33 @@ Lwt has a small amount of syntactic sugar to make this look as natural as possible: -{[ -let () = - Lwt_main.run begin - let%lwt data = Lwt_io.(read_line stdin) in - let%lwt () = Lwt_io.printl data in - Lwt.return () - end + {[ + let () = + Lwt_main.run + (let%lwt data = Lwt_io.(read_line stdin) in + let%lwt () = Lwt_io.printl data in + Lwt.return ()) -(* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix echo.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix echo.ml && ./a.out *) + ]} This is all explained in the next sections: - - {{: #3_Quickstart} Quick start} links these concepts to actual functions - in Lwt – the most fundamental ones. - - {{: #3_Tutorial} Tutorial} shows how to write examples like the above, and + - {{:#3_Quickstart} Quick start} links these concepts to actual functions in + Lwt – the most fundamental ones. + - {{:#3_Tutorial} Tutorial} shows how to write examples like the above, and how concurrency happens. - - {{: #3_Executionmodel} Execution model} clarifies control flow when using + - {{:#3_Executionmodel} Execution model} clarifies control flow when using Lwt. - - {{: #3_GuidetotherestofLwt} Guide to the rest of Lwt} shows how + - {{:#3_GuidetotherestofLwt} Guide to the rest of Lwt} shows how {e everything} else in Lwt fits into this framework. - After that is the {{: #2_Fundamentals} reference proper}, which goes into + After that is the {{:#2_Fundamentals} reference proper}, which goes into {e painful} levels of detail on every single type and value in this module, [Lwt]. Please be safe, and read only what you need from it :) Happy asynchronous programming! - - {3 Quick start} {e All} of Lwt is variations on: @@ -86,91 +81,83 @@ let () = - {!Lwt_main.run} is used to wait on one “top-level” promise. When that promise gets a value, the program terminates. - - {3 Tutorial} - Let's read from STDIN. The first version is written using ordinary values + Let's read from STDIN. The first version is written using ordinary values from the OCaml standard library. This makes the program block until the user enters a line: -{[ -let () = - let line : string = read_line () in - print_endline "Now unblocked!"; - ignore line + {[ + let () = + let line : string = read_line () in + print_endline "Now unblocked!"; + ignore line -(* ocamlfind opt -linkpkg code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg code.ml && ./a.out *) + ]} If we use a promise instead, execution continues immediately: -{[ -let () = - let line_promise : string Lwt.t = - Lwt_io.(read_line stdin) in - print_endline "Execution just continues..."; - ignore line_promise + {[ + let () = + let line_promise : string Lwt.t = Lwt_io.(read_line stdin) in + print_endline "Execution just continues..."; + ignore line_promise -(* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) + ]} Indeed, this program is a little {e too} asynchronous – it exits right away! Let's force it to wait for [line_promise] at the end by calling {!Lwt_main.run}: -{[ -let () = - let line_promise : string Lwt.t = - Lwt_io.(read_line stdin) in - print_endline "Execution just continues..."; + {[ + let () = + let line_promise : string Lwt.t = Lwt_io.(read_line stdin) in + print_endline "Execution just continues..."; - let line : string = - Lwt_main.run line_promise in - ignore line + let line : string = Lwt_main.run line_promise in + ignore line -(* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) + ]} {!Lwt_main.run} should only be called once, on one promise, at the top level of your program. Most of the time, waiting for promises is done using [let%lwt]. That is the recommended syntactic sugar for {!Lwt.bind}, and is pronounced “bind”: -{[ -let () = - let p : unit Lwt.t = - let%lwt line_1 = Lwt_io.(read_line stdin) in - let%lwt line_2 = Lwt_io.(read_line stdin) in - Lwt_io.printf "%s and %s\n" line_1 line_2 - in - - Lwt_main.run p - -(* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) -]} + {[ + let () = + let p : unit Lwt.t = + let%lwt line_1 = Lwt_io.(read_line stdin) in + let%lwt line_2 = Lwt_io.(read_line stdin) in + Lwt_io.printf "%s and %s\n" line_1 line_2 + in - The way that works is everything in scope after the “[in]” in - “[let%lwt x =] ... [in] ...” goes into a callback, and “[x]” is that - callback's argument. So, we could have been very explicit, and written the - code like this: + Lwt_main.run p -{[ -let () = - let p : unit Lwt.t = - let line_1_promise : string Lwt.t = Lwt_io.(read_line stdin) in - Lwt.bind line_1_promise (fun (line_1 : string) -> + (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) + ]} - let line_2_promise : string Lwt.t = Lwt_io.(read_line stdin) in - Lwt.bind line_2_promise (fun (line_2 : string) -> + The way that works is everything in scope after the “[in]” in “[let%lwt x =] + ... [in] ...” goes into a callback, and “[x]” is that callback's argument. + So, we could have been very explicit, and written the code like this: - Lwt_io.printf "%s and %s\n" line_1 line_2)) - in + {[ + let () = + let p : unit Lwt.t = + let line_1_promise : string Lwt.t = Lwt_io.(read_line stdin) in + Lwt.bind line_1_promise (fun (line_1 : string) -> + let line_2_promise : string Lwt.t = Lwt_io.(read_line stdin) in + Lwt.bind line_2_promise (fun (line_2 : string) -> + Lwt_io.printf "%s and %s\n" line_1 line_2)) + in - Lwt_main.run p + Lwt_main.run p -(* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) + ]} But, as you can see, this is verbose, and the indentation gets a bit crazy. So, we will always use [let%lwt]. @@ -183,48 +170,43 @@ let () = second I/O in a callback of the first. Because it doesn't make sense to read two lines from STDIN concurrently, let's start two waits instead: -{[ -let () = - Lwt_main.run begin - let three_seconds : unit Lwt.t = Lwt_unix.sleep 3. in - let five_seconds : unit Lwt.t = Lwt_unix.sleep 5. in - let%lwt () = three_seconds in - let%lwt () = Lwt_io.printl "3 seconds passed" in - let%lwt () = five_seconds in - Lwt_io.printl "Only 2 more seconds passed" - end + {[ + let () = + Lwt_main.run + (let three_seconds : unit Lwt.t = Lwt_unix.sleep 3. in + let five_seconds : unit Lwt.t = Lwt_unix.sleep 5. in + let%lwt () = three_seconds in + let%lwt () = Lwt_io.printl "3 seconds passed" in + let%lwt () = five_seconds in + Lwt_io.printl "Only 2 more seconds passed") -(* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) + ]} This program takes about five seconds to run. We are still new to [let%lwt], so let's desugar it: -{[ -let () = - Lwt_main.run begin - let three_seconds : unit Lwt.t = Lwt_unix.sleep 3. in - let five_seconds : unit Lwt.t = Lwt_unix.sleep 5. in - - (* Both waits have already been started at this point! *) - - Lwt.bind three_seconds (fun () -> - (* This is 3 seconds later. *) - Lwt.bind (Lwt_io.printl "3 seconds passed") (fun () -> - Lwt.bind five_seconds (fun () -> - (* Only 2 seconds were left in the 5-second wait, so - this callback runs 2 seconds after the first callback. *) - Lwt_io.printl "Only 2 more seconds passed"))) - end + {[ + let () = + Lwt_main.run + (let three_seconds : unit Lwt.t = Lwt_unix.sleep 3. in + let five_seconds : unit Lwt.t = Lwt_unix.sleep 5. in + + (* Both waits have already been started at this point! *) + Lwt.bind three_seconds (fun () -> + (* This is 3 seconds later. *) + Lwt.bind (Lwt_io.printl "3 seconds passed") (fun () -> + Lwt.bind five_seconds (fun () -> + (* Only 2 seconds were left in the 5-second wait, so + this callback runs 2 seconds after the first callback. *) + Lwt_io.printl "Only 2 more seconds passed")))) -(* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) + ]} And that's it! Concurrency in Lwt is simply a matter of whether you start an operation in the callback of another one or not. As a convenience, Lwt - provides a few {{: #2_Concurrency} helpers} for common concurrency patterns. - - + provides a few {{:#2_Concurrency} helpers} for common concurrency patterns. {3 Execution model} @@ -233,13 +215,13 @@ let () = pending), or containers for one value (if resolved). The interesting function is {!Lwt_main.run}. It's a wrapper around - {{: http://man7.org/linux/man-pages/man2/select.2.html} [select(2)]}, - {{: http://man7.org/linux/man-pages/man7/epoll.7.html} [epoll(7)]}, - {{: https://www.freebsd.org/cgi/man.cgi?query=kqueue&sektion=2} - [kqueue(2)]}, or whatever asynchronous I/O API your system provides. On - browsers, the work of {!Lwt_main.run} is done by the surrounding JavaScript - engine, so you don't call {!Lwt_main.run} from inside your program. But the - execution model is still the same, and the description below applies! + {{:http://man7.org/linux/man-pages/man2/select.2.html} [select(2)]}, + {{:http://man7.org/linux/man-pages/man7/epoll.7.html} [epoll(7)]}, + {{:https://www.freebsd.org/cgi/man.cgi?query=kqueue&sektion=2} [kqueue(2)]}, + or whatever asynchronous I/O API your system provides. On browsers, the work + of {!Lwt_main.run} is done by the surrounding JavaScript engine, so you + don't call {!Lwt_main.run} from inside your program. But the execution model + is still the same, and the description below applies! To avoid writing out “underlying asynchronous I/O API,” we'll assume, in this section, that the API is [select(2)]. That's just for the sake of @@ -249,22 +231,20 @@ let () = Let's use the program from the tutorial that reads two lines as an example. Here it is, again, in its desugared form: -{[ -let () = - let p : unit Lwt.t = - let line_1_promise : string Lwt.t = Lwt_io.(read_line stdin) in - Lwt.bind line_1_promise (fun (line_1 : string) -> - - let line_2_promise : string Lwt.t = Lwt_io.(read_line stdin) in - Lwt.bind line_2_promise (fun (line_2 : string) -> + {[ + let () = + let p : unit Lwt.t = + let line_1_promise : string Lwt.t = Lwt_io.(read_line stdin) in + Lwt.bind line_1_promise (fun (line_1 : string) -> + let line_2_promise : string Lwt.t = Lwt_io.(read_line stdin) in + Lwt.bind line_2_promise (fun (line_2 : string) -> + Lwt_io.printf "%s and %s\n" line_1 line_2)) + in - Lwt_io.printf "%s and %s\n" line_1 line_2)) - in + Lwt_main.run p - Lwt_main.run p - -(* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) + ]} {!Lwt_main.run} is your program's main I/O loop. You pass it a single promise, and it: @@ -298,11 +278,10 @@ let () = underlying I/O operations complete. In case your callback is just using the CPU for a really long time, you can - insert a few calls to {!Lwt.pause} into it, and resume your computation - in callbacks of [pause]. This is basically the same as - {!Lwt_unix.sleep}[ 0.] – it's a promise that will be resolved by - {!Lwt_main.run} {e after} any other I/O resolutions that are already in its - queue. + insert a few calls to {!Lwt.pause} into it, and resume your computation in + callbacks of [pause]. This is basically the same as {!Lwt_unix.sleep}[ 0.] – + it's a promise that will be resolved by {!Lwt_main.run} {e after} any other + I/O resolutions that are already in its queue. {b (2)} The good implication is that all your callbacks run in a single thread. This means that in most situations, you don't have to worry about @@ -311,25 +290,23 @@ let () = easier to write and refactor, than equivalent programs written with threads – but both are concurrent! - - {3 Guide to the rest of Lwt} This module [Lwt] is the pure-OCaml definition of promises and callback-calling. It has a few extras on top of what's described above: - - {{: #2_Rejection} Rejection}. Lwt promises can actually be resolved in two + - {{:#2_Rejection} Rejection}. Lwt promises can actually be resolved in two ways: {e fulfilled} with a value, or {e rejected} with an exception. There is nothing conceptually special about rejection – it's just that you can ask for callbacks to run only on fulfillment, only on rejection, etc. - - {{: #2_Cancelation} Cancellation}. This is a special case of rejection, + - {{:#2_Cancelation} Cancellation}. This is a special case of rejection, specifically with exception {!Lwt.Canceled}. It has extra helpers in the Lwt API. - - {{: #2_Concurrency} Concurrency helpers}. All of these could be - implemented on top of {!Lwt.bind}. As we saw, Lwt concurrency requires - only deciding whether to run something inside a callback, or outside it. - These functions just implement common patterns, and make intent explicit. - - Miscellaneous {{: #2_Convenience} helpers}, and {{: #2_Deprecated} + - {{:#2_Concurrency} Concurrency helpers}. All of these could be implemented + on top of {!Lwt.bind}. As we saw, Lwt concurrency requires only deciding + whether to run something inside a callback, or outside it. These functions + just implement common patterns, and make intent explicit. + - Miscellaneous {{:#2_Convenience} helpers}, and {{:#2_Deprecated} deprecated} APIs. The next layer above module [Lwt] is the pure-OCaml Lwt “core” library, @@ -358,8 +335,6 @@ let () = Warning! Introductory material ends and detailed reference begins! *) - - (** {2 Fundamentals} *) (** {3 Promises} *) @@ -395,8 +370,8 @@ type -'a u be passed to {!Lwt.wakeup_later}, {!Lwt.wakeup_later_exn}, or {!Lwt.wakeup_later_result} to resolve that promise. *) -val wait : unit -> ('a t * 'a u) -(** Creates a new pending {{: #TYPEt} promise}, paired with its {{: #TYPEu} +val wait : unit -> 'a t * 'a u +(** Creates a new pending {{:#TYPEt} promise}, paired with its {{:#TYPEu} resolver}. It is rare to use this function directly. Many helpers in Lwt, and Lwt-aware @@ -407,57 +382,56 @@ val wait : unit -> ('a t * 'a u) “constructor.” All other functions that evaluate to a promise can be, or are, eventually implemented in terms of it. *) - - (** {3 Resolving} *) val wakeup_later : 'a u -> 'a -> unit (** [Lwt.wakeup_later r v] {e fulfills}, with value [v], the {e pending} - {{: #TYPEt} promise} associated with {{: #TYPEu} resolver} [r]. This - triggers callbacks attached to the promise. + {{:#TYPEt} promise} associated with {{:#TYPEu} resolver} [r]. This triggers + callbacks attached to the promise. If the promise is not pending, [Lwt.wakeup_later] raises - {{: https://ocaml.org/api/Stdlib.html#VALinvalid_arg} - [Invalid_argument]}, unless the promise is {{: #VALcancel} canceled}. If the - promise is canceled, [Lwt.wakeup_later] has no effect. + {{:https://ocaml.org/api/Stdlib.html#VALinvalid_arg} [Invalid_argument]}, + unless the promise is {{:#VALcancel} canceled}. If the promise is canceled, + [Lwt.wakeup_later] has no effect. If your program has multiple threads, it is important to make sure that [Lwt.wakeup_later] (and any similar function) is only called from the main - thread. [Lwt.wakeup_later] can trigger callbacks attached to promises - by the program, and these assume they are running in the main thread. If you - need to communicate from a worker thread to the main thread running Lwt, see + thread. [Lwt.wakeup_later] can trigger callbacks attached to promises by the + program, and these assume they are running in the main thread. If you need + to communicate from a worker thread to the main thread running Lwt, see {!Lwt_preemptive} or {!Lwt_unix.send_notification}. *) val wakeup_later_exn : _ u -> exn -> unit (** [Lwt.wakeup_later_exn r exn] is like {!Lwt.wakeup_later}, except, if the - associated {{: #TYPEt} promise} is {e pending}, it is {e rejected} with + associated {{:#TYPEt} promise} is {e pending}, it is {e rejected} with [exn]. *) val return : 'a -> 'a t -(** [Lwt.return v] creates a new {{: #TYPEt} promise} that is {e already - fulfilled} with value [v]. +(** [Lwt.return v] creates a new {{:#TYPEt} promise} that is + {e already fulfilled} with value [v]. This is needed to satisfy the type system in some cases. For example, in a [match] expression where one case evaluates to a promise, the other cases have to evaluate to promises as well: -{[ -match need_input with -| true -> Lwt_io.(read_line stdin) (* Has type string Lwt.t... *) -| false -> Lwt.return "" (* ...so wrap empty string in a promise. *) -]} + {[ + match need_input with + | true -> Lwt_io.(read_line stdin) (* Has type string Lwt.t... *) + | false -> Lwt.return "" + (* ...so wrap empty string in a promise. *) + ]} - Another typical usage is in {{: #VALbind} [let%lwt]}. The expression after + Another typical usage is in {{:#VALbind} [let%lwt]}. The expression after the “[in]” has to evaluate to a promise. So, if you compute an ordinary value instead, you have to wrap it: -{[ -let%lwt line = Lwt_io.(read_line stdin) in -Lwt.return (line ^ ".") -]} *) + {[ + let%lwt line = Lwt_io.(read_line stdin) in + Lwt.return (line ^ ".") + ]} *) val fail : exn -> _ t -(** [Lwt.fail exn] is like {!Lwt.return}, except the new {{: #TYPEt} promise} +(** [Lwt.fail exn] is like {!Lwt.return}, except the new {{:#TYPEt} promise} that is {e already rejected} with [exn]. Whenever possible, it is recommended to use [raise exn] instead, as [raise] @@ -468,12 +442,10 @@ val fail : exn -> _ t specifically want to create a rejected promise, to pass to another function, or store in a data structure. *) - - (** {3 Callbacks} *) val bind : 'a t -> ('a -> 'b t) -> 'b t -(** [Lwt.bind p_1 f] makes it so that [f] will run when [p_1] is {{: #TYPEt} +(** [Lwt.bind p_1 f] makes it so that [f] will run when [p_1] is {{:#TYPEt} {e fulfilled}}. When [p_1] is fulfilled with value [v_1], the callback [f] is called with @@ -487,17 +459,15 @@ val bind : 'a t -> ('a -> 'b t) -> 'b t A minimal example of this is an echo program: -{[ -let () = - let p_3 = - Lwt.bind - Lwt_io.(read_line stdin) - (fun line -> Lwt_io.printl line) - in - Lwt_main.run p_3 + {[ + let () = + let p_3 = + Lwt.bind Lwt_io.(read_line stdin) (fun line -> Lwt_io.printl line) + in + Lwt_main.run p_3 -(* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) + ]} Rejection of [p_1] and [p_2], and raising an exception in [f], are all forwarded to rejection of [p_3]. @@ -526,91 +496,84 @@ let () = [Lwt.bind] is almost never written directly, because sequences of [Lwt.bind] result in growing indentation and many parentheses: -{[ -let () = - Lwt_main.run begin - Lwt.bind Lwt_io.(read_line stdin) (fun line -> - Lwt.bind (Lwt_unix.sleep 1.) (fun () -> - Lwt_io.printf "One second ago, you entered %s\n" line)) - end + {[ + let () = + Lwt_main.run + (Lwt.bind + Lwt_io.(read_line stdin) + (fun line -> + Lwt.bind (Lwt_unix.sleep 1.) (fun () -> + Lwt_io.printf "One second ago, you entered %s\n" line))) -(* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) + ]} The recommended way to write [Lwt.bind] is using the [let%lwt] syntactic sugar: -{[ -let () = - Lwt_main.run begin - let%lwt line = Lwt_io.(read_line stdin) in - let%lwt () = Lwt_unix.sleep 1. in - Lwt_io.printf "One second ago, you entered %s\n" line - end + {[ + let () = + Lwt_main.run + (let%lwt line = Lwt_io.(read_line stdin) in + let%lwt () = Lwt_unix.sleep 1. in + Lwt_io.printf "One second ago, you entered %s\n" line) -(* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) + ]} - This uses the Lwt {{: Ppx_lwt.html} PPX} (preprocessor). Note that we had to + This uses the Lwt {{:Ppx_lwt.html} PPX} (preprocessor). Note that we had to add package [lwt_ppx] to the command line for building this program. We will do that throughout this manual. Another way to write [Lwt.bind], that you may encounter while reading code, is with the [>>=] operator: -{[ -open Lwt.Infix + {[ + open Lwt.Infix -let () = - Lwt_main.run begin - Lwt_io.(read_line stdin) >>= fun line -> - Lwt_unix.sleep 1. >>= fun () -> - Lwt_io.printf "One second ago, you entered %s\n" line - end + let () = + Lwt_main.run + ( Lwt_io.(read_line stdin) >>= fun line -> + Lwt_unix.sleep 1. >>= fun () -> + Lwt_io.printf "One second ago, you entered %s\n" line ) -(* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) + ]} The [>>=] operator comes from the module {!Lwt.Infix}, which is why we opened it at the beginning of the program. See also {!Lwt.map}. *) - - (** {2 Rejection} *) val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t (** [Lwt.catch f h] applies [f ()], which returns a promise, and then makes it - so that [h] (“handler”) will run when that promise is {{: #TYPEt} + so that [h] (“handler”) will run when that promise is {{:#TYPEt} {e rejected}}. -{[ -let () = - Lwt_main.run begin - Lwt.catch - (fun () -> Lwt.fail Exit) - (function - | Exit -> Lwt_io.printl "Got Stdlib.Exit" - | exn -> Lwt.fail exn) - end + {[ + let () = + Lwt_main.run + (Lwt.catch + (fun () -> Lwt.fail Exit) + (function + | Exit -> Lwt_io.printl "Got Stdlib.Exit" | exn -> Lwt.fail exn)) -(* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) + ]} Despite the above code, the recommended way to write [Lwt.catch] is using - the [try%lwt] syntactic sugar from the {{: Ppx_lwt.html} PPX}. Here is an + the [try%lwt] syntactic sugar from the {{:Ppx_lwt.html} PPX}. Here is an equivalent example: -{[ -let () = - Lwt_main.run begin - try%lwt Lwt.fail Exit - with Exit -> Lwt_io.printl "Got Stdlb.Exit" - end + {[ + let () = + Lwt_main.run + (try%lwt Lwt.fail Exit with Exit -> Lwt_io.printl "Got Stdlb.Exit") -(* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) + ]} A particular advantage of the PPX syntax is that it is not necessary to artificially insert a catch-all [exn -> Lwt.fail exn] case. Like in the core @@ -625,9 +588,9 @@ let () = - [p_2], the promise returned from applying [h exn]. - [p_3], the promise returned by [Lwt.catch] itself. - The remainder is (1) a precise description of how [p_3] is resolved, and - (2) a warning about accidentally using ordinary [try] for exception handling - in asynchronous code. + The remainder is (1) a precise description of how [p_3] is resolved, and (2) + a warning about accidentally using ordinary [try] for exception handling in + asynchronous code. {b (1)} [Lwt.catch] first applies [f ()]. It then returns [p_3] immediately. [p_3] starts out pending. It is resolved as follows: @@ -653,15 +616,13 @@ let () = from the second example above only in that [try] is used instead of [try%lwt]: -{[ -let () = - Lwt_main.run begin - try Lwt.fail Exit - with Exit -> Lwt_io.printl "Got Stdlib.Exit" - end + {[ + let () = + Lwt_main.run + (try Lwt.fail Exit with Exit -> Lwt_io.printl "Got Stdlib.Exit") -(* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) + ]} This does {e not} handle the exception and does not print the message. Instead, it terminates the program with an unhandled [Stdlib.Exit]. @@ -669,15 +630,15 @@ let () = This is because the call to {!Lwt.fail} creates a rejected promise. The promise is still an ordinary OCaml value, though, and not a {e raised} exception. So, [try] considers that code to have succeeded, and doesn't run - the handler. When that rejected promise reaches {!Lwt_main.run}, - it is {!Lwt_main.run} that raises the exception. + the handler. When that rejected promise reaches {!Lwt_main.run}, it is + {!Lwt_main.run} that raises the exception. - Basically, the rule is: if the code inside [try] evaluates to a promise - (has type [_ Lwt.t]), replace [try] by [try%lwt]. *) + Basically, the rule is: if the code inside [try] evaluates to a promise (has + type [_ Lwt.t]), replace [try] by [try%lwt]. *) val finalize : (unit -> 'a t) -> (unit -> unit t) -> 'a t (** [Lwt.finalize f c] applies [f ()], which returns a promise, and then makes - it so [c] (“cleanup”) will run when that promise is {{: #TYPEt} + it so [c] (“cleanup”) will run when that promise is {{:#TYPEt} {e resolved}}. In other words, [c] runs no matter whether promise [f ()] is fulfilled or @@ -685,38 +646,32 @@ val finalize : (unit -> 'a t) -> (unit -> unit t) -> 'a t construct found in many programming languages, and [c] is typically used for cleaning up resources: -{[ -let () = - Lwt_main.run begin - let%lwt file = Lwt_io.(open_file ~mode:Input "code.ml") in - Lwt.finalize - (fun () -> - let%lwt content = Lwt_io.read file in - Lwt_io.print content) - (fun () -> - Lwt_io.close file) - end + {[ + let () = + Lwt_main.run + (let%lwt file = Lwt_io.(open_file ~mode:Input "code.ml") in + Lwt.finalize + (fun () -> + let%lwt content = Lwt_io.read file in + Lwt_io.print content) + (fun () -> Lwt_io.close file)) -(* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) + ]} As with {!Lwt.bind} and {!Lwt.catch}, there is a syntactic sugar for [Lwt.finalize], though it is not as often used: -{[ -let () = - Lwt_main.run begin - let%lwt file = Lwt_io.(open_file ~mode:Input "code.ml") in - begin - let%lwt content = Lwt_io.read file in - Lwt_io.print content - end - [%lwt.finally - Lwt_io.close file] - end + {[ + let () = + Lwt_main.run + (let%lwt file = Lwt_io.(open_file ~mode:Input "code.ml") in + (let%lwt content = Lwt_io.read file in + Lwt_io.print content) + [%lwt.finally Lwt_io.close file]) -(* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) + ]} Also as with {!Lwt.bind} and {!Lwt.catch}, three promises are involved: @@ -750,8 +705,8 @@ let () = val try_bind : (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t (** [Lwt.try_bind f g h] applies [f ()], and then makes it so that: - - [g] will run when promise [f ()] is {{: #TYPEt} {e fulfilled}}, - - [h] will run when promise [f ()] is {{: #TYPEt} {e rejected}}. + - [g] will run when promise [f ()] is {{:#TYPEt} {e fulfilled}}, + - [h] will run when promise [f ()] is {{:#TYPEt} {e rejected}}. [Lwt.try_bind] is a generalized {!Lwt.finalize}. The difference is that [Lwt.try_bind] runs different callbacks depending on {e how} [f ()] is @@ -760,8 +715,7 @@ val try_bind : (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t - The cleanup functions [g] and [h] each “know” whether [f ()] was fulfilled or rejected. - The cleanup functions [g] and [h] are passed the value [f ()] was - fulfilled with, and, respectively, the exception [f ()] was rejected - with. + fulfilled with, and, respectively, the exception [f ()] was rejected with. The rest is a detailed description of the promises involved. @@ -798,7 +752,7 @@ val try_bind : (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t val dont_wait : (unit -> unit t) -> (exn -> unit) -> unit (** [Lwt.dont_wait f handler] applies [f ()], which returns a promise, and then - makes it so that if the promise is {{: #TYPEt} {e rejected}}, the exception + makes it so that if the promise is {{:#TYPEt} {e rejected}}, the exception is passed to [handler]. In addition, if [f ()] raises an exception, it is also passed to [handler]. @@ -817,7 +771,7 @@ val dont_wait : (unit -> unit t) -> (exn -> unit) -> unit val async : (unit -> unit t) -> unit (** [Lwt.async f] applies [f ()], which returns a promise, and then makes it so - that if the promise is {{: #TYPEt} {e rejected}}, the exception is passed to + that if the promise is {{:#TYPEt} {e rejected}}, the exception is passed to [!]{!Lwt.async_exception_hook}. In addition, if [f ()] raises an exception, it is also passed to @@ -834,22 +788,22 @@ val async : (unit -> unit t) -> unit For example, take this program, which prints messages in a loop, while waiting for one line of user input: -{[ -let () = - let rec show_nag () : _ Lwt.t = - let%lwt () = Lwt_io.printl "Please enter a line" in - let%lwt () = Lwt_unix.sleep 1. in - show_nag () - in - ignore (show_nag ()); (* Bad – see note for (1)! *) - - Lwt_main.run begin - let%lwt line = Lwt_io.(read_line stdin) in - Lwt_io.printl line - end + {[ + let () = + let rec show_nag () : _ Lwt.t = + let%lwt () = Lwt_io.printl "Please enter a line" in + let%lwt () = Lwt_unix.sleep 1. in + show_nag () + in + ignore (show_nag ()); -(* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) -]} + (* Bad – see note for (1)! *) + Lwt_main.run + (let%lwt line = Lwt_io.(read_line stdin) in + Lwt_io.printl line) + + (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) + ]} If one of the I/O operations in [show_nag] were to fail, the promise representing the whole loop would get rejected. However, since we are @@ -860,22 +814,21 @@ let () = A safer version differs only in using [Lwt.async] instead of [Stdlib.ignore]: -{[ -let () = - let rec show_nag () : _ Lwt.t = - let%lwt () = Lwt_io.printl "Please enter a line" in - let%lwt () = Lwt_unix.sleep 1. in - show_nag () - in - Lwt.async (fun () -> show_nag ()); - - Lwt_main.run begin - let%lwt line = Lwt_io.(read_line stdin) in - Lwt_io.printl line - end + {[ + let () = + let rec show_nag () : _ Lwt.t = + let%lwt () = Lwt_io.printl "Please enter a line" in + let%lwt () = Lwt_unix.sleep 1. in + show_nag () + in + Lwt.async (fun () -> show_nag ()); + + Lwt_main.run + (let%lwt line = Lwt_io.(read_line stdin) in + Lwt_io.printl line) -(* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) + ]} In this version, if I/O in [show_nag] fails with an exception, the exception is printed by [Lwt.async], and then the program exits. @@ -899,17 +852,15 @@ val async_exception_hook : (exn -> unit) ref the process with non-zero exit status, as if the exception had reached the top level of the program: -{[ -let () = Lwt.async (fun () -> Lwt.fail Exit) + {[ + let () = Lwt.async (fun () -> Lwt.fail Exit) -(* ocamlfind opt -linkpkg -package lwt code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -package lwt code.ml && ./a.out *) + ]} produces in the output: -{v -Fatal error: exception Stdlib.Exit -v} + {v Fatal error: exception Stdlib.Exit v} If you are writing an application, you are welcome to reassign the reference, and replace the function with something more appropriate for your @@ -918,33 +869,31 @@ v} If you are writing a library, you should leave this reference alone. Its behavior should be determined by the application. *) - - (** {2 Concurrency} *) (** {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}}. + [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 () = + 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_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 + let p_3 = Lwt.both p_1 p_2 in + Lwt_main.run p_3 -(* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -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 @@ -955,27 +904,27 @@ let () = @since 4.2.0 *) -val join : (unit t) list -> unit t +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}}. + the list [ps] become {{:#TYPEt} {e resolved}}. -{[ -let () = - let p_1 = - let%lwt () = Lwt_unix.sleep 3. in - Lwt_io.printl "Three seconds elapsed" - in + {[ + 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_2 = + let%lwt () = Lwt_unix.sleep 5. in + Lwt_io.printl "Five seconds elapsed" + in - let p_3 = Lwt.join [p_1; p_2] in - Lwt_main.run p_3 + let p_3 = Lwt.join [ p_1; p_2 ] in + Lwt_main.run p_3 -(* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) + ]} If all of the promises in [ps] become fulfilled, [Lwt.join ps] is also fulfilled. Otherwise, if at least one promise in [ps] becomes rejected, @@ -983,9 +932,9 @@ let () = chosen arbitrarily. Note that this occurs only after all the promises are resolved, not immediately when the first promise is rejected. *) -val all : ('a t) list -> ('a list) t +val all : 'a t list -> 'a list t (** [Lwt.all ps] is like {!Lwt.join}[ ps]: it waits for all promises in the list - [ps] to become {{: #TYPEt} {e resolved}}. + [ps] to become {{:#TYPEt} {e resolved}}. It then resolves the returned promise with the list of all resulting values. @@ -998,30 +947,28 @@ val all : ('a t) list -> ('a list) t @since 5.1.0 *) - - (** {3 Racing} *) -val pick : ('a t) list -> 'a t -(** [Lwt.pick ps] returns a promise that is pending until {e one} promise in - the list [ps] becomes {{: #TYPEt} {e resolved}}. +val pick : 'a t list -> 'a t +(** [Lwt.pick ps] returns a promise that is pending until {e one} promise in the + list [ps] becomes {{:#TYPEt} {e resolved}}. When at least one promise in [ps] is resolved, [Lwt.pick] tries to cancel all other promises that are still pending, using {!Lwt.cancel}. -{[ -let () = - let echo = - let%lwt line = Lwt_io.(read_line stdin) in - Lwt_io.printl line - in + {[ + let () = + let echo = + let%lwt line = Lwt_io.(read_line stdin) in + Lwt_io.printl line + in - let timeout = Lwt_unix.sleep 5. in + let timeout = Lwt_unix.sleep 5. in - Lwt_main.run (Lwt.pick [echo; timeout]) + Lwt_main.run (Lwt.pick [ echo; timeout ]) -(* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) + ]} If the first promise in [ps] to become resolved is fulfilled, the result promise [p] is also fulfilled, with the same value. Likewise, if the first @@ -1042,11 +989,11 @@ let () = The remaining functions in this section are variations on [Lwt.pick]. *) -val choose : ('a t) list -> 'a t +val choose : 'a t list -> 'a t (** [Lwt.choose ps] is the same as {!Lwt.pick}[ ps], except that it does not try to cancel pending promises in [ps]. *) -val npick : ('a t) list -> ('a list) t +val npick : 'a t list -> 'a list t (** [Lwt.npick ps] is similar to {!Lwt.pick}[ ps], the difference being that when multiple promises in [ps] are fulfilled simultaneously (and none are rejected), the result promise is fulfilled with the {e list} of values the @@ -1055,18 +1002,15 @@ val npick : ('a t) list -> ('a list) t When at least one promise is rejected, [Lwt.npick] still rejects the result promise with the same exception. *) -val nchoose : ('a t) list -> ('a list) t +val nchoose : 'a t list -> 'a list t (** [Lwt.nchoose ps] is the same as {!Lwt.npick}[ ps], except that it does not try to cancel pending promises in [ps]. *) -val nchoose_split : ('a t) list -> ('a list * ('a t) list) t +val nchoose_split : 'a t list -> ('a list * 'a t list) t (** [Lwt.nchoose_split ps] is the same as {!Lwt.nchoose}[ ps], except that when multiple promises in [ps] are fulfilled simultaneously (and none are rejected), the result promise is fulfilled with {e both} the list of values - of the fulfilled promises, and the list of promises that are still - pending. *) - - + of the fulfilled promises, and the list of promises that are still pending. *) (** {2 Cancellation} @@ -1079,9 +1023,9 @@ exception Canceled (** Canceled promises are those rejected with this exception, [Lwt.Canceled]. See {!Lwt.cancel}. *) -val task : unit -> ('a t * 'a u) +val task : unit -> 'a t * 'a u (** [Lwt.task] is the same as {!Lwt.wait}, except the resulting promise [p] is - {{: #VALcancel} cancelable}. + {{:#VALcancel} cancelable}. This is significant, because it means promises created by [Lwt.task] can be resolved (specifically, rejected) by canceling them directly, in addition to @@ -1120,19 +1064,19 @@ val cancel : _ t -> unit All of this will be made precise, but first let's have an example: -{[ -let () = - let p = - let%lwt () = Lwt_unix.sleep 5. in - Lwt_io.printl "Slept five seconds" - in + {[ + let () = + let p = + let%lwt () = Lwt_unix.sleep 5. in + Lwt_io.printl "Slept five seconds" + in - Lwt.cancel p; + Lwt.cancel p; - Lwt_main.run p + Lwt_main.run p -(* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) + ]} At the time [Lwt.cancel] is called, [p] “depends” on the [sleep] promise (the [printl] is not yet called, so its promise hasn't been created). @@ -1179,7 +1123,7 @@ let () = val on_cancel : _ t -> (unit -> unit) -> unit (** [Lwt.on_cancel p f] makes it so that [f] will run when [p] becomes - {{: #EXCEPTIONCanceled} {e canceled}}. + {{:#EXCEPTIONCanceled} {e canceled}}. Callbacks scheduled with [on_cancel] are guaranteed to run before any other callbacks that are triggered by rejection, such as those added by @@ -1194,83 +1138,79 @@ val on_cancel : _ t -> (unit -> unit) -> unit [!]{!Lwt.async_exception_hook}, which terminates the process by default. *) val protected : 'a t -> 'a t -(** [Lwt.protected p] creates a {{: #VALcancel} cancelable} promise [p']. The +(** [Lwt.protected p] creates a {{:#VALcancel} cancelable} promise [p']. The original state of [p'] is the same as the state of [p] at the time of the call. - The state of [p'] can change in one of two ways: - a. if [p] changes state (i.e., is resolved), then [p'] eventually changes - state to match [p]'s, and + The state of [p'] can change in one of two ways: a. if [p] changes state + (i.e., is resolved), then [p'] eventually changes state to match [p]'s, and b. during cancellation, if the backwards search described in {!Lwt.cancel} - reaches [p'] then it changes state to {!Rejected} [Canceled] and the - search stops. + reaches [p'] then it changes state to {!Rejected} [Canceled] and the search + stops. As a consequence of the b. case, [Lwt.cancel (protected p)] does not cancel [p]. - The promise [p] can still be canceled either directly (through [Lwt.cancel p]) - or being reached by the backwards cancellation search via another path. - [Lwt.protected] only prevents cancellation of [p] through [p']. *) + The promise [p] can still be canceled either directly (through + [Lwt.cancel p]) or being reached by the backwards cancellation search via + another path. [Lwt.protected] only prevents cancellation of [p] through + [p']. *) val no_cancel : 'a t -> 'a t -(** [Lwt.no_cancel p] creates a non-{{: #VALcancel}cancelable} promise [p']. The +(** [Lwt.no_cancel p] creates a non-{{:#VALcancel} cancelable} promise [p']. The original state of [p'] is the same as [p] at the time of the call. If the state of [p] changes, then the state of [p'] eventually changes too to match [p]'s. - Note that even though [p'] is non-{{: #VALcancel}cancelable}, it can still + Note that even though [p'] is non-{{:#VALcancel} cancelable}, it can still become canceled if [p] is canceled. [Lwt.no_cancel] only prevents cancellation of [p] and [p'] through [p']. *) val wrap_in_cancelable : 'a t -> 'a t -(** [Lwt.wrap_in_cancelable p] creates a {{: #VALcancel} cancelable} promise +(** [Lwt.wrap_in_cancelable p] creates a {{:#VALcancel} cancelable} promise [p']. The original state of [p'] is the same as [p]. - The state of [p'] can change in one of two ways: - a. if [p] changes state (i.e., is resolved), then [p'] eventually changes - state to match [p]'s, and + The state of [p'] can change in one of two ways: a. if [p] changes state + (i.e., is resolved), then [p'] eventually changes state to match [p]'s, and b. during cancellation, if the backwards search described in {!Lwt.cancel} - reaches [p'] then it changes state to {!Rejected} [Canceled] and the - search continues to [p]. -*) + reaches [p'] then it changes state to {!Rejected} [Canceled] and the search + continues to [p]. *) (** {3 Cancellation tweaks} - The primitives [protected], [no_cancel], and [wrap_in_cancelable] give you - some level of control over the cancellation mechanism of Lwt. Note that - promises passed as arguments to either of these three functions are unchanged. - The functions return new promises with a specific cancellation behaviour. - - The three behaviour of all three functions are summarised in the following - table. - -{[ - +----------------------------+--------------------+--------------------+ - | setup - action | cancel p | cancel p' | - +----------------------------+--------------------+--------------------+ - | p is cancelable | p is canceled | p is not canceled | - | p' = protected p | p' is canceled | p' is canceled | - +----------------------------+--------------------+--------------------+ - | p is not cancelable | p is not canceled | p is not canceled | - | p' = protected p | p' is not canceled | p' is canceled | - +----------------------------+--------------------+--------------------+ - | p is cancelable | p is canceled | p is not canceled | - | p' = no_cancel p | p' is canceled | p' is not canceled | - +----------------------------+--------------------+--------------------+ - | p is not cancelable | p is not canceled | p is not canceled | - | p' = no_cancel p | p' is not canceled | p' is not canceled | - +----------------------------+--------------------+--------------------+ - | p is cancelable | p is canceled | p is canceled | - | p' = wrap_in_cancelable p | p' is canceled | p' is canceled | - +----------------------------+--------------------+--------------------+ - | p is not cancelable | p is not canceled | p is not canceled | - | p' = wrap_in_cancelable p | p' is not canceled | p' is canceled | - +----------------------------+--------------------+--------------------+ -]} - -*) - + The primitives [protected], [no_cancel], and [wrap_in_cancelable] give you + some level of control over the cancellation mechanism of Lwt. Note that + promises passed as arguments to either of these three functions are + unchanged. The functions return new promises with a specific cancellation + behaviour. + + The three behaviour of all three functions are summarised in the following + table. + + {[ + +----------------------------+--------------------+--------------------+ + | setup - action | cancel p | cancel p' | + +----------------------------+--------------------+--------------------+ + | p is cancelable | p is canceled | p is not canceled | + | p' = protected p | p' is canceled | p' is canceled | + +----------------------------+--------------------+--------------------+ + | p is not cancelable | p is not canceled | p is not canceled | + | p' = protected p | p' is not canceled | p' is canceled | + +----------------------------+--------------------+--------------------+ + | p is cancelable | p is canceled | p is not canceled | + | p' = no_cancel p | p' is canceled | p' is not canceled | + +----------------------------+--------------------+--------------------+ + | p is not cancelable | p is not canceled | p is not canceled | + | p' = no_cancel p | p' is not canceled | p' is not canceled | + +----------------------------+--------------------+--------------------+ + | p is cancelable | p is canceled | p is canceled | + | p' = wrap_in_cancelable p | p' is canceled | p' is canceled | + +----------------------------+--------------------+--------------------+ + | p is not cancelable | p is not canceled | p is not canceled | + | p' = wrap_in_cancelable p | p' is not canceled | p' is canceled | + +----------------------------+--------------------+--------------------+ + ]} *) (** {2 Convenience} *) @@ -1283,41 +1223,39 @@ val map : ('a -> 'b) -> 'a t -> 'b t This function is more convenient that {!Lwt.bind} when [f] inherently does not return a promise. An example is [Stdlib.int_of_string]: -{[ -let read_int : unit -> int Lwt.t = fun () -> - Lwt.map - int_of_string - Lwt_io.(read_line stdin) + {[ + let read_int : unit -> int Lwt.t = + fun () -> Lwt.map int_of_string Lwt_io.(read_line stdin) -let () = - Lwt_main.run begin - let%lwt number = read_int () in - Lwt_io.printf "%i\n" number - end + let () = + Lwt_main.run + (let%lwt number = read_int () in + Lwt_io.printf "%i\n" number) -(* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) + ]} By comparison, the {!Lwt.bind} version is more awkward: -{[ -let read_int : unit -> int Lwt.t = fun () -> - Lwt.bind - Lwt_io.(read_line stdin) - (fun line -> Lwt.return (int_of_string line)) -]} + {[ + let read_int : unit -> int Lwt.t = + fun () -> + Lwt.bind + Lwt_io.(read_line stdin) + (fun line -> Lwt.return (int_of_string line)) + ]} As with {!Lwt.bind}, sequences of calls to [Lwt.map] result in excessive indentation and parentheses. The recommended syntactic sugar for avoiding - this is the {{: #VAL(>|=)} [>|=]} operator, which comes from module + this is the {{:#VAL(>|=)} [>|=]} operator, which comes from module [Lwt.Infix]: -{[ -open Lwt.Infix + {[ + open Lwt.Infix -let read_int : unit -> int Lwt.t = fun () -> - Lwt_io.(read_line stdin) >|= int_of_string -]} + let read_int : unit -> int Lwt.t = + fun () -> Lwt_io.(read_line stdin) >|= int_of_string + ]} The detailed operation follows. For consistency with the promises in {!Lwt.bind}, the {e two} promises involved are named [p_1] and [p_3]: @@ -1340,7 +1278,7 @@ let read_int : unit -> int Lwt.t = fun () -> - If [f v] raises exception [exn], [p_3] is rejected with [exn]. *) val on_success : 'a t -> ('a -> unit) -> unit -(** [Lwt.on_success p f] makes it so that [f] will run when [p] is {{: #TYPEt} +(** [Lwt.on_success p f] makes it so that [f] will run when [p] is {{:#TYPEt} {e fulfilled}}. It is similar to {!Lwt.bind}, except no new promises are created. [f] is a @@ -1350,7 +1288,7 @@ val on_success : 'a t -> ('a -> unit) -> unit By default, this will terminate the process. *) val on_failure : _ t -> (exn -> unit) -> unit -(** [Lwt.on_failure p f] makes it so that [f] will run when [p] is {{: #TYPEt} +(** [Lwt.on_failure p f] makes it so that [f] will run when [p] is {{:#TYPEt} {e rejected}}. It is similar to {!Lwt.catch}, except no new promises are created. @@ -1360,7 +1298,7 @@ val on_failure : _ t -> (exn -> unit) -> unit val on_termination : _ t -> (unit -> unit) -> unit (** [Lwt.on_termination p f] makes it so that [f] will run when [p] is - {{: #TYPEt} {e resolved}} – that is, fulfilled {e or} rejected. + {{:#TYPEt} {e resolved}} – that is, fulfilled {e or} rejected. It is similar to {!Lwt.finalize}, except no new promises are created. @@ -1370,86 +1308,77 @@ val on_termination : _ t -> (unit -> unit) -> unit val on_any : 'a t -> ('a -> unit) -> (exn -> unit) -> unit (** [Lwt.on_any p f g] makes it so that: - - [f] will run when [p] is {{: #TYPEt} {e fulfilled}}, - - [g] will run when [p] is, alternatively, {{: #TYPEt} {e rejected}}. + - [f] will run when [p] is {{:#TYPEt} {e fulfilled}}, + - [g] will run when [p] is, alternatively, {{:#TYPEt} {e rejected}}. It is similar to {!Lwt.try_bind}, except no new promises are created. If [f] or [g] raise an exception, the exception is passed to - [!]{!Lwt.async_exception_hook}. By default, this will terminate the - process. *) - - + [!]{!Lwt.async_exception_hook}. By default, this will terminate the process. *) (** {3 Infix operators} *) -(** This module provides several infix operators for making programming with - Lwt more convenient. +(** This module provides several infix operators for making programming with Lwt + more convenient. To use it, open [Lwt.Infix]. Of the operators declared in this module, only [>|=] is recommended for new code. The only other commonly-used operator is [>>=]. *) -module Infix : -sig - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t +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: -{[ -open Lwt.Infix + {[ + open Lwt.Infix -let () = - Lwt_main.run - (Lwt_io.(read_line stdin) >>= Lwt_io.printl) + let () = Lwt_main.run (Lwt_io.(read_line stdin) >>= Lwt_io.printl) -(* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) + ]} It is recommended to use the PPX [let%lwt] syntax instead. This operator - is the next-best choice. It is frequently found while reading existing - Lwt code. *) + is the next-best choice. It is frequently found while reading existing Lwt + code. *) - val (>|=) : 'a t -> ('a -> 'b) -> 'b t + val ( >|= ) : 'a t -> ('a -> 'b) -> 'b t (** [p >|= f] is the same as {!Lwt.map}[ f p]. It requires [Lwt.Infix] to be opened in scope. -{[ -open Lwt.Infix + {[ + open Lwt.Infix -let () = - Lwt_main.run - (Lwt_io.(read_line stdin) >|= ignore) + let () = Lwt_main.run (Lwt_io.(read_line stdin) >|= ignore) -(* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) -]} *) + (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) + ]} *) - val (<&>) : unit t -> unit t -> unit t - (** [p1 <&> p2] is the same as {!Lwt.join}[ [p1; p2]]. It requires [Lwt.Infix] - to be opened in scope. + val ( <&> ) : unit t -> unit t -> unit t + (** [p1 <&> p2] is the same as {!Lwt.join}[ \[p1; p2\]]. It requires + [Lwt.Infix] to be opened in scope. Unlike with {!Lwt.bind} and {!Lwt.map}, there are no problems with explicit {!Lwt.join} syntax, so using this operator is not recommended. *) - val () : 'a t -> 'a t -> 'a t - (** [p1 p2] is the same as {!Lwt.choose}[ [p1; p2]]. It requires + val ( ) : 'a t -> 'a t -> 'a t + (** [p1 p2] is the same as {!Lwt.choose}[ \[p1; p2\]]. It requires [Lwt.Infix] to be opened in scope. Unlike with {!Lwt.bind} and {!Lwt.join}, there are no problems with - explicit {!Lwt.choose} syntax, so using this operator is not - recommended. + explicit {!Lwt.choose} syntax, so using this operator is not recommended. Furthermore, most users actually need {!Lwt.pick} instead of {!Lwt.choose}. *) - val (=<<) : ('a -> 'b t) -> 'a t -> 'b t + val ( =<< ) : ('a -> 'b t) -> 'a t -> 'b t (** [f =<< p] is the same as {!Lwt.bind}[ p f]. It requires [Lwt.Infix] to be opened in scope. This operator is obscure and its use is discouraged. It is the same as [p >>= f]. *) - val (=|<) : ('a -> 'b) -> 'a t -> 'b t + val ( =|< ) : ('a -> 'b) -> 'a t -> 'b t (** [f =|< p] is the same as {!Lwt.map}[ f p]. It requires [Lwt.Infix] to be opened in scope. @@ -1460,8 +1389,7 @@ let () = ppx_let}. @since 4.2.0 *) - module Let_syntax : - sig + module Let_syntax : sig val return : 'a -> 'a t (** See {!Lwt.return}. *) @@ -1474,16 +1402,12 @@ let () = val both : 'a t -> 'b t -> ('a * 'b) t (** See {!Lwt.both}. *) - module Open_on_rhs : - sig - end + module Open_on_rhs : sig end end end -module Let_syntax : -sig - module Let_syntax : - sig +module Let_syntax : sig + module Let_syntax : sig val return : 'a -> 'a t (** See {!Lwt.return}. *) @@ -1496,35 +1420,29 @@ sig val both : 'a t -> 'b t -> ('a * 'b) t (** See {!Lwt.both}. *) - module Open_on_rhs : - sig - end + module Open_on_rhs : sig end end end (** {3 Let syntax} *) -module Syntax : -sig - +module Syntax : sig (** {1 Monadic syntax} *) - val (let*) : 'a t -> ('a -> 'b t) -> 'b t + val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t (** Syntax for {!bind}. *) - val (and*) : 'a t -> 'b t -> ('a * 'b) t + val ( and* ) : 'a t -> 'b t -> ('a * 'b) t (** Syntax for {!both}. *) (** {1 Applicative syntax} *) - val (let+) : 'a t -> ('a -> 'b) -> 'b t + val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t (** Syntax for {!map}. *) - val (and+) : 'a t -> 'b t -> ('a * 'b) t + val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t (** Syntax for {!both}. *) end - - (** {3 Pre-allocated promises} *) val return_unit : unit t @@ -1544,52 +1462,47 @@ val return_unit : unit t pre-allocated promise, automatically, wherever {!Lwt.return}[ ()] is written. *) -val return_none : (_ option) t -(** [Lwt.return_none] is like {!Lwt.return_unit}, but for - {!Lwt.return}[ None]. *) +val return_none : _ option t +(** [Lwt.return_none] is like {!Lwt.return_unit}, but for {!Lwt.return}[ None]. *) -val return_nil : (_ list) t -(** [Lwt.return_nil] is like {!Lwt.return_unit}, but for {!Lwt.return}[ []]. *) +val return_nil : _ list t +(** [Lwt.return_nil] is like {!Lwt.return_unit}, but for {!Lwt.return}[ \[\]]. *) val return_true : bool t -(** [Lwt.return_true] is like {!Lwt.return_unit}, but for - {!Lwt.return}[ true]. *) +(** [Lwt.return_true] is like {!Lwt.return_unit}, but for {!Lwt.return}[ true]. *) val return_false : bool t (** [Lwt.return_false] is like {!Lwt.return_unit}, but for {!Lwt.return}[ false]. *) - - (** {3 Result type} *) type +'a result = ('a, exn) Result.result -(** Representation of the content of a resolved promise of type - ['a ]{!Lwt.t}. +(** Representation of the content of a resolved promise of type ['a ]{!Lwt.t}. This type is effectively -{[ -type +'a Lwt.result = - | Ok of 'a - | Error of exn -]} + {[ + type +'a Lwt.result = + | Ok of 'a + | Error of exn + ]} or, on OCaml 4.02: -{[ -type +'a Lwt.result = - | Result.Ok of 'a - | Result.Error of exn -]} + {[ + type +'a Lwt.result = + | Result.Ok of 'a + | Result.Error of exn + ]} A resolved promise of type ['a ]{!Lwt.t} is either fulfilled with a value of type ['a], or rejected with an exception. This corresponds to the cases of a - [('a, exn)]{{: https://ocaml.org/api/Stdlib.html#TYPEresult}[Stdlib.result]}: - fulfilled corresponds to [Ok of 'a], and rejected corresponds to - [Error of exn]. + [('a, exn)]{{:https://ocaml.org/api/Stdlib.html#TYPEresult} + [Stdlib.result]}: fulfilled corresponds to [Ok of 'a], and rejected + corresponds to [Error of exn]. It's important to note that this type constructor, [Lwt.result], is different from [Stdlib.result]. It is a specialization of [Stdlib.result] so @@ -1623,31 +1536,24 @@ val wakeup_later_result : 'a u -> 'a result -> unit - If [result] is [Error exn], [p] is rejected with [exn]. If [p] is not pending, [Lwt.wakeup_later_result] raises - [Stdlib.Invalid_argument _], except if [p] is {{: #VALcancel} canceled}. If + [Stdlib.Invalid_argument _], except if [p] is {{:#VALcancel} canceled}. If [p] is canceled, [Lwt.wakeup_later_result] has no effect. *) - - (** {3 State query} *) -type 'a state = - | Return of 'a - | Fail of exn - | Sleep +type 'a state = Return of 'a | Fail of exn | Sleep val state : 'a t -> 'a state (** [Lwt.state p] evaluates to the current state of promise [p]: - - If [p] is {{: #TYPEt} fulfilled} with value [v], the result is + - If [p] is {{:#TYPEt} fulfilled} with value [v], the result is [Lwt.Return v]. - - If [p] is {{: #TYPEt} rejected} with exception [exn], the result is + - If [p] is {{:#TYPEt} rejected} with exception [exn], the result is [Lwt.Fail exn]. - - If [p] is {{: #TYPEt} pending}, the result is [Lwt.Sleep]. + - If [p] is {{:#TYPEt} pending}, the result is [Lwt.Sleep]. The constructor names are historical holdovers. *) - - (** {2 Deprecated} *) (** {3 Implicit callback arguments} @@ -1688,26 +1594,22 @@ val with_value : 'a key -> 'a option -> (unit -> 'b) -> 'b Lwt maintains a single, global map, that can be used to “pass” extra arguments to callbacks: -{[ -let () = - let k : string Lwt.key = Lwt.new_key () in - - let say_hello () = - match Lwt.get k with - | None -> assert false - | Some s -> Lwt_io.printl s - in - - Lwt_main.run begin - Lwt.with_value k (Some "Hello world!") begin fun () -> - Lwt.bind - (Lwt_unix.sleep 1.) - (fun () -> say_hello ()) - end - end + {[ + let () = + let k : string Lwt.key = Lwt.new_key () in + + let say_hello () = + match Lwt.get k with + | None -> assert false + | Some s -> Lwt_io.printl s + in + + Lwt_main.run + (Lwt.with_value k (Some "Hello world!") (fun () -> + Lwt.bind (Lwt_unix.sleep 1.) (fun () -> say_hello ()))) -(* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) -]} + (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) + ]} Note that the string [Hello world!] was passed to [say_hello] through the key [k]. Meanwhile, the only {e explicit} argument of the callback @@ -1754,8 +1656,6 @@ let () = [Lwt.with_value] should only be called in the main thread, i.e. do not call it inside {!Lwt_preemptive.detach}. *) - - (** {3 Immediate resolving} *) val wakeup : 'a u -> 'a -> unit @@ -1777,25 +1677,22 @@ val wakeup : 'a u -> 'a -> unit {!Lwt_condition}, and/or {!Lwt_mvar}. *) val wakeup_exn : _ u -> exn -> unit -(** [Lwt.wakeup_exn r exn] is like {!Lwt.wakeup_later_exn}[ r exn], but has - the same problems as {!Lwt.wakeup}. *) +(** [Lwt.wakeup_exn r exn] is like {!Lwt.wakeup_later_exn}[ r exn], but has the + same problems as {!Lwt.wakeup}. *) val wakeup_result : 'a u -> 'a result -> unit (** [Lwt.wakeup_result r result] is like {!Lwt.wakeup_later_result}[ r result], but has the same problems as {!Lwt.wakeup}. *) - - (** {3 Helpers for resolving} *) val make_value : 'a -> 'a result [@@ocaml.deprecated " Use Result.Ok, which is the same as Ok since OCaml 4.03."] (** [Lwt.make_value v] is equivalent to - {{: https://ocaml.org/api/Stdlib.html#TYPEresult} - [Ok v]} since OCaml 4.03. If you need compatibility with OCaml 4.02, use - [Result.Ok] and depend on opam package - {{: https://opam.ocaml.org/packages/result/} [result]}. + {{:https://ocaml.org/api/Stdlib.html#TYPEresult} [Ok v]} since OCaml 4.03. + If you need compatibility with OCaml 4.02, use [Result.Ok] and depend on + opam package {{:https://opam.ocaml.org/packages/result/} [result]}. @deprecated Use [Result.Ok] instead *) @@ -1803,52 +1700,51 @@ val make_error : exn -> _ result [@@ocaml.deprecated " Use Result.Error, which is the same as Error since OCaml 4.03."] (** [Lwt.make_error exn] is equivalent to - {{: https://ocaml.org/api/Stdlib.html#TYPEresult} - [Error exn]} since OCaml 4.03. If you need compatibility with OCaml 4.02, - use [Result.Error] and depend on opam package - {{: https://opam.ocaml.org/packages/result/} [result]}. + {{:https://ocaml.org/api/Stdlib.html#TYPEresult} [Error exn]} since OCaml + 4.03. If you need compatibility with OCaml 4.02, use [Result.Error] and + depend on opam package {{:https://opam.ocaml.org/packages/result/} + [result]}. @deprecated Use [Result.Error] instead. *) val waiter_of_wakener : 'a u -> 'a t [@@ocaml.deprecated -" This function should be avoided, because it makes subtyping of resolvers - unsound. See - https://github.com/ocsigen/lwt/issues/458"] + " This function should be avoided, because it makes subtyping of resolvers\n\ + \ unsound. See\n\ + \ https://github.com/ocsigen/lwt/issues/458"] (** [Lwt.waiter_of_wakener r] evaluates to the promise associated with resolver [r]. @deprecated Keep the reference to the promise instead. *) - - (** {3 Linked lists of promises} *) [@@@ocaml.warning "-3"] -val add_task_r : ('a u) Lwt_sequence.t -> 'a t +val add_task_r : 'a u Lwt_sequence.t -> 'a t [@@ocaml.deprecated -" Deprecated because Lwt_sequence is an implementation detail of Lwt. See - https://github.com/ocsigen/lwt/issues/361"] + " Deprecated because Lwt_sequence is an implementation detail of Lwt. See\n\ + \ https://github.com/ocsigen/lwt/issues/361"] (** [Lwt.add_task_r sequence] is equivalent to -{[ -let p, r = Lwt.task () in -let node = Lwt_sequence.add_r r sequence in -Lwt.on_cancel p (fun () -> Lwt_sequence.remove node); -p -]} - - @deprecated Use of this function is discouraged for two reasons: - - - {!Lwt_sequence} should not be used outside Lwt. - - This function only exists because it performs a minor internal - optimization, which may be removed. *) - -val add_task_l : ('a u) Lwt_sequence.t -> 'a t + {[ + let p, r = Lwt.task () in + let node = Lwt_sequence.add_r r sequence in + Lwt.on_cancel p (fun () -> Lwt_sequence.remove node); + p + ]} + @deprecated + Use of this function is discouraged for two + reasons: + + - {!Lwt_sequence} should not be used outside Lwt. + - This function only exists because it performs a minor internal + optimization, which may be removed. *) + +val add_task_l : 'a u Lwt_sequence.t -> 'a t [@@ocaml.deprecated -" Deprecated because Lwt_sequence is an implementation detail of Lwt. See - https://github.com/ocsigen/lwt/issues/361"] + " Deprecated because Lwt_sequence is an implementation detail of Lwt. See\n\ + \ https://github.com/ocsigen/lwt/issues/361"] (** Like {!Lwt.add_task_r}, but the equivalent code calls {!Lwt_sequence.add_l} instead. @@ -1856,8 +1752,6 @@ val add_task_l : ('a u) Lwt_sequence.t -> 'a t [@@@ocaml.warning "+3"] - - (** {3 Yielding} *) val pause : unit -> unit t @@ -1871,39 +1765,35 @@ val pause : unit -> unit t For example, to break up a long-running computation, allowing I/O to be handled between chunks: -{[ -let () = - let rec handle_io () = - let%lwt () = Lwt_io.printl "Handling I/O" in - let%lwt () = Lwt_unix.sleep 0.1 in - handle_io () - in - - let rec compute n = - if n = 0 then - Lwt.return () - else - let%lwt () = - if n mod 1_000_000 = 0 then - Lwt.pause () - else - Lwt.return () - in - compute (n - 1) - in - - Lwt.async handle_io; - Lwt_main.run (compute 100_000_000) - -(* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) -]} - - If you replace the call to [Lwt.pause] by [Lwt.return] in the program above, - ["Handling I/O"] is printed only once. With [Lwt.pause], it is printed several - times, depending on the speed of your machine. - - An alternative way to handle long-running computations is to detach them to - preemptive threads using {!Lwt_preemptive}. *) + {[ + let () = + let rec handle_io () = + let%lwt () = Lwt_io.printl "Handling I/O" in + let%lwt () = Lwt_unix.sleep 0.1 in + handle_io () + in + + let rec compute n = + if n = 0 then Lwt.return () + else + let%lwt () = + if n mod 1_000_000 = 0 then Lwt.pause () else Lwt.return () + in + compute (n - 1) + in + + Lwt.async handle_io; + Lwt_main.run (compute 100_000_000) + + (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) + ]} + + If you replace the call to [Lwt.pause] by [Lwt.return] in the program above, + ["Handling I/O"] is printed only once. With [Lwt.pause], it is printed + several times, depending on the speed of your machine. + + An alternative way to handle long-running computations is to detach them to + preemptive threads using {!Lwt_preemptive}. *) (**/**) @@ -1932,14 +1822,13 @@ val register_pause_notifier : (int -> unit) -> unit val abandon_paused : unit -> unit (** Causes promises created with {!Lwt.pause} to remain forever pending. See - {!Lwt_main.abandon_yielded_and_paused} before {!Lwt_main.yield} is phased out. + {!Lwt_main.abandon_yielded_and_paused} before {!Lwt_main.yield} is phased + out. This function is intended for internal use by Lwt. *) (**/**) - - (** {3 Function lifters} *) val wrap : (unit -> 'a) -> 'a t @@ -1947,37 +1836,43 @@ val wrap : (unit -> 'a) -> 'a t returns {!Lwt.return}[ v]. If [f ()] raises an exception exn, [Lwt.wrap] returns {!Lwt.fail}[ exn]. *) -val wrap1 : - ('a -> 'b) -> - ('a -> 'b t) -val wrap2 : - ('a -> 'b -> 'c) -> - ('a -> 'b -> 'c t) -val wrap3 : - ('a -> 'b -> 'c -> 'd) -> - ('a -> 'b -> 'c -> 'd t) -val wrap4 : - ('a -> 'b -> 'c -> 'd -> 'e) -> - ('a -> 'b -> 'c -> 'd -> 'e t) +val wrap1 : ('a -> 'b) -> 'a -> 'b t +val wrap2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c t +val wrap3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd t +val wrap4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e t + val wrap5 : - ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> - ('a -> 'b -> 'c -> 'd -> 'e -> 'f t) + ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f t + val wrap6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> - ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g t) + 'a -> + 'b -> + 'c -> + 'd -> + 'e -> + 'f -> + 'g t + val wrap7 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> - ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h t) + 'a -> + 'b -> + 'c -> + 'd -> + 'e -> + 'f -> + 'g -> + 'h t (** As a “prototype,” [Lwt_wrap1 f] creates a promise-valued function [g]: -{[ -let g v = - try - let v' = f v in - Lwt.return v' - with exn -> - Lwt.fail exn -]} + {[ + let g v = + try + let v' = f v in + Lwt.return v' + with exn -> Lwt.fail exn + ]} The remainder of the functions work analogously – they just work on [f] with larger numbers of arguments. @@ -1989,22 +1884,20 @@ let g v = To get a suspended function instead of the eager execution of {!Lwt.wrap}, use [Lwt.wrap1]. *) - - (** {3 Trivial promises} *) -val return_some : 'a -> ('a option) t +val return_some : 'a -> 'a option t (** Counterpart to {!Lwt.return_none}. However, unlike {!Lwt.return_none}, this - function performs no {{: #VALreturn_unit} optimization}. This is because it + function performs no {{:#VALreturn_unit} optimization}. This is because it takes an argument, so it cannot be evaluated at initialization time, at which time the argument is not yet available. *) -val return_ok : 'a -> (('a, _) Result.result) t +val return_ok : 'a -> ('a, _) Result.result t (** Like {!Lwt.return_some}, this function performs no optimization. @since Lwt 2.6.0 *) -val return_error : 'e -> ((_, 'e) Result.result) t +val return_error : 'e -> (_, 'e) Result.result t (** Like {!Lwt.return_some}, this function performs no optimization. @since Lwt 2.6.0 *) @@ -2012,9 +1905,7 @@ val return_error : 'e -> ((_, 'e) Result.result) t val fail_with : string -> _ t (** [Lwt.fail_with s] is an abbreviation for -{[ -Lwt.fail (Stdlib.Failure s) -]} + {[ Lwt.fail (Stdlib.Failure s) ]} In most cases, it is better to use [failwith s] from the standard library. See {!Lwt.fail} for an explanation. *) @@ -2022,29 +1913,24 @@ Lwt.fail (Stdlib.Failure s) val fail_invalid_arg : string -> _ t (** [Lwt.invalid_arg s] is an abbreviation for -{[ -Lwt.fail (Stdlib.Invalid_argument s) -]} + {[ Lwt.fail (Stdlib.Invalid_argument s) ]} In most cases, it is better to use [invalid_arg s] from the standard library. See {!Lwt.fail} for an explanation. *) - - (** {3 Unscoped infix operators} *) -val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -val (>|=) : 'a t -> ('a -> 'b) -> 'b t -val () : 'a t -> 'a t -> 'a t -val (<&>) : unit t -> unit t -> unit t -val (=<<) : ('a -> 'b t) -> 'a t -> 'b t -val (=|<) : ('a -> 'b) -> 'a t -> 'b t -(** Use the operators in module {{: #MODULEInfix} [Lwt.Infix]} instead. Using +val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t +val ( >|= ) : 'a t -> ('a -> 'b) -> 'b t +val ( ) : 'a t -> 'a t -> 'a t +val ( <&> ) : unit t -> unit t -> unit t +val ( =<< ) : ('a -> 'b t) -> 'a t -> 'b t + +val ( =|< ) : ('a -> 'b) -> 'a t -> 'b t +(** Use the operators in module {{:#MODULEInfix} [Lwt.Infix]} instead. Using these instances of the operators directly requires opening module [Lwt], which brings an excessive number of other names into scope. *) - - (** {3 Miscellaneous} *) val is_sleeping : _ t -> bool @@ -2070,22 +1956,18 @@ val ignore_result : _ t -> unit resolved, completing any associated side effects along the way. In fact, the function that does {e that} is ordinary {!Lwt.bind}. *) - - (**/**) val poll : 'a t -> 'a option val apply : ('a -> 'b t) -> 'a -> 'b t +val backtrace_bind : (exn -> exn) -> 'a t -> ('a -> 'b t) -> 'b t +val backtrace_catch : (exn -> exn) -> (unit -> 'a t) -> (exn -> 'a t) -> 'a t -val backtrace_bind : - (exn -> exn) -> 'a t -> ('a -> 'b t) -> 'b t -val backtrace_catch : - (exn -> exn) -> (unit -> 'a t) -> (exn -> 'a t) -> 'a t val backtrace_finalize : (exn -> exn) -> (unit -> 'a t) -> (unit -> unit t) -> 'a t + val backtrace_try_bind : (exn -> exn) -> (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t val abandon_wakeups : unit -> unit - val debug_state_is : 'a state -> 'a t -> bool t diff --git a/src/core/lwt_condition.ml b/src/core/lwt_condition.ml index 0ff854d327..64a8025bfa 100644 --- a/src/core/lwt_condition.ml +++ b/src/core/lwt_condition.ml @@ -32,7 +32,9 @@ [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] + module Lwt_sequence = Lwt_sequence + [@@@ocaml.warning "+3"] type 'a t = 'a Lwt.u Lwt_sequence.t @@ -41,23 +43,15 @@ let create = Lwt_sequence.create let wait ?mutex cvar = let waiter = (Lwt.add_task_r [@ocaml.warning "-3"]) cvar in - let () = - match mutex with - | Some m -> Lwt_mutex.unlock m - | None -> () - in + let () = match mutex with Some m -> Lwt_mutex.unlock m | None -> () in Lwt.finalize (fun () -> waiter) (fun () -> - match mutex with - | Some m -> Lwt_mutex.lock m - | None -> Lwt.return_unit) + match mutex with Some m -> Lwt_mutex.lock m | None -> Lwt.return_unit) let signal cvar arg = - try - Lwt.wakeup_later (Lwt_sequence.take_l cvar) arg - with Lwt_sequence.Empty -> - () + try Lwt.wakeup_later (Lwt_sequence.take_l cvar) arg + with Lwt_sequence.Empty -> () let broadcast cvar arg = let wakeners = Lwt_sequence.fold_r (fun x l -> x :: l) cvar [] in diff --git a/src/core/lwt_condition.mli b/src/core/lwt_condition.mli index 009004611b..7984e6b6d4 100644 --- a/src/core/lwt_condition.mli +++ b/src/core/lwt_condition.mli @@ -31,38 +31,33 @@ (** Condition variables to synchronize between threads. *) type 'a t - (** Condition variable type. The type parameter denotes the type of - value propagated from notifier to waiter. *) +(** Condition variable type. The type parameter denotes the type of value + propagated from notifier to waiter. *) val create : unit -> 'a t - (** [create ()] creates a new condition variable. *) +(** [create ()] creates a new condition variable. *) val wait : ?mutex:Lwt_mutex.t -> 'a t -> 'a Lwt.t - (** [wait mutex condvar] will cause the current thread to block, - awaiting notification for a condition variable, [condvar]. If - provided, the [mutex] must have been previously locked (within - the scope of [Lwt_mutex.with_lock], for example) and is - temporarily unlocked until the condition is notified. Upon - notification, [mutex] is re-locked before [wait] returns and - the thread's activity is resumed. When the awaited condition - is notified, the value parameter passed to [signal] is - returned. *) +(** [wait mutex condvar] will cause the current thread to block, awaiting + notification for a condition variable, [condvar]. If provided, the [mutex] + must have been previously locked (within the scope of [Lwt_mutex.with_lock], + for example) and is temporarily unlocked until the condition is notified. + Upon notification, [mutex] is re-locked before [wait] returns and the + thread's activity is resumed. When the awaited condition is notified, the + value parameter passed to [signal] is returned. *) val signal : 'a t -> 'a -> unit - (** [signal condvar value] notifies that a condition is ready. A - single waiting thread will be awoken and will receive the - notification value which will be returned from [wait]. Note - that condition notification is not "sticky", i.e. if there is - no waiter when [signal] is called, the notification will be - missed and the value discarded. *) +(** [signal condvar value] notifies that a condition is ready. A single waiting + thread will be awoken and will receive the notification value which will be + returned from [wait]. Note that condition notification is not "sticky", i.e. + if there is no waiter when [signal] is called, the notification will be + missed and the value discarded. *) val broadcast : 'a t -> 'a -> unit - (** [broadcast condvar value] notifies all waiting threads. Each - will be awoken in turn and will receive the same notification - value. *) +(** [broadcast condvar value] notifies all waiting threads. Each will be awoken + in turn and will receive the same notification value. *) val broadcast_exn : 'a t -> exn -> unit - (** [broadcast_exn condvar exn] fails all waiting threads with exception - [exn]. +(** [broadcast_exn condvar exn] fails all waiting threads with exception [exn]. - @since 2.6.0 *) + @since 2.6.0 *) diff --git a/src/core/lwt_list.ml b/src/core/lwt_list.ml index 957f692e08..0cd1a8cd90 100644 --- a/src/core/lwt_list.ml +++ b/src/core/lwt_list.ml @@ -1,20 +1,17 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (* A survey and measurements of more optimized implementations can be found at: https://jsthomas.github.io/map-comparison.html See discussion in https://github.com/ocsigen/lwt/pull/347. *) -let tail_recursive_map f l = - List.rev (List.rev_map f l) +let tail_recursive_map f l = List.rev (List.rev_map f l) let tail_recursive_mapi_rev f l = let rec inner acc i = function | [] -> acc - | hd::tl -> (inner [@ocaml.tailcall]) ((f i hd)::acc) (i + 1) tl + | hd :: tl -> (inner [@ocaml.tailcall]) (f i hd :: acc) (i + 1) tl in inner [] 0 l @@ -22,11 +19,8 @@ open Lwt.Infix let rec iter_s f l = match l with - | [] -> - Lwt.return_unit - | x :: l -> - Lwt.apply f x >>= fun () -> - iter_s f l + | [] -> Lwt.return_unit + | x :: l -> Lwt.apply f x >>= fun () -> iter_s f l let iter_p f l = let ts = List.rev_map (Lwt.apply f) l in @@ -34,11 +28,8 @@ let iter_p f l = let rec iteri_s i f l = match l with - | [] -> - Lwt.return_unit - | x :: l -> - Lwt.apply (f i) x >>= fun () -> - iteri_s (i + 1) f l + | [] -> Lwt.return_unit + | x :: l -> Lwt.apply (f i) x >>= fun () -> iteri_s (i + 1) f l let iteri_s f l = iteri_s 0 f l @@ -50,18 +41,14 @@ let iteri_p f l = let map_s f l = let rec inner acc = function | [] -> List.rev acc |> Lwt.return - | hd::tl -> - Lwt.apply f hd >>= fun r -> - (inner [@ocaml.tailcall]) (r::acc) tl + | hd :: tl -> + Lwt.apply f hd >>= fun r -> (inner [@ocaml.tailcall]) (r :: acc) tl in inner [] l let rec _collect_rev acc = function - | [] -> - Lwt.return acc - | t::ts -> - t >>= fun i -> - (_collect_rev [@ocaml.tailcall]) (i::acc) ts + | [] -> Lwt.return acc + | t :: ts -> t >>= fun i -> (_collect_rev [@ocaml.tailcall]) (i :: acc) ts let map_p f l = let ts = List.rev_map (Lwt.apply f) l in @@ -69,31 +56,31 @@ let map_p f l = let filter_map_s f l = let rec inner acc = function - | [] -> List.rev acc |> Lwt.return - | hd::tl -> - Lwt.apply f hd >>= function - | Some v -> (inner [@ocaml.tailcall]) (v::acc) tl - | None -> (inner [@ocaml.tailcall]) acc tl + | [] -> List.rev acc |> Lwt.return + | hd :: tl -> ( + Lwt.apply f hd >>= function + | Some v -> (inner [@ocaml.tailcall]) (v :: acc) tl + | None -> (inner [@ocaml.tailcall]) acc tl) in inner [] l let filter_map_p f l = let rec _collect_optional_rev acc = function - | [] -> Lwt.return acc - | t::ts -> - t >>= function - | Some v -> (_collect_optional_rev [@ocaml.tailcall]) (v::acc) ts - | None -> (_collect_optional_rev [@ocaml.tailcall]) acc ts + | [] -> Lwt.return acc + | t :: ts -> ( + t >>= function + | Some v -> (_collect_optional_rev [@ocaml.tailcall]) (v :: acc) ts + | None -> (_collect_optional_rev [@ocaml.tailcall]) acc ts) in let ts = List.rev_map (Lwt.apply f) l in _collect_optional_rev [] ts let mapi_s f l = let rec inner acc i = function - | [] -> List.rev acc |> Lwt.return - | hd::tl -> - Lwt.apply (f i) hd >>= fun v -> - (inner [@ocaml.tailcall]) (v::acc) (i+1) tl + | [] -> List.rev acc |> Lwt.return + | hd :: tl -> + Lwt.apply (f i) hd >>= fun v -> + (inner [@ocaml.tailcall]) (v :: acc) (i + 1) tl in inner [] 0 l @@ -104,100 +91,78 @@ let mapi_p f l = let rec rev_map_append_s acc f l = match l with - | [] -> - Lwt.return acc - | x :: l -> - Lwt.apply f x >>= fun x -> - rev_map_append_s (x :: acc) f l + | [] -> Lwt.return acc + | x :: l -> Lwt.apply f x >>= fun x -> rev_map_append_s (x :: acc) f l -let rev_map_s f l = - rev_map_append_s [] f l +let rev_map_s f l = rev_map_append_s [] f l let rec rev_map_append_p acc f l = match l with - | [] -> - acc + | [] -> acc | x :: l -> - rev_map_append_p - (Lwt.apply f x >>= fun x -> - acc >|= fun l -> - x :: l) f l + rev_map_append_p + ( Lwt.apply f x >>= fun x -> + acc >|= fun l -> x :: l ) + f l -let rev_map_p f l = - rev_map_append_p Lwt.return_nil f l +let rev_map_p f l = rev_map_append_p Lwt.return_nil f l let rec fold_left_s f acc l = match l with - | [] -> - Lwt.return acc + | [] -> Lwt.return acc | x :: l -> - Lwt.apply (f acc) x >>= fun acc -> - (fold_left_s [@ocaml.tailcall]) f acc l + Lwt.apply (f acc) x >>= fun acc -> (fold_left_s [@ocaml.tailcall]) f acc l let fold_right_s f l acc = let rec inner f a = function - | [] -> Lwt.return a - | hd::tl -> (Lwt.apply (f hd) a) >>= fun a' -> - (inner [@ocaml.tailcall]) f a' tl + | [] -> Lwt.return a + | hd :: tl -> + Lwt.apply (f hd) a >>= fun a' -> (inner [@ocaml.tailcall]) f a' tl in inner f acc (List.rev l) let rec for_all_s f l = match l with - | [] -> - Lwt.return_true - | x :: l -> - Lwt.apply f x >>= function - | true -> - (for_all_s [@ocaml.tailcall]) f l - | false -> - Lwt.return_false + | [] -> Lwt.return_true + | x :: l -> ( + Lwt.apply f x >>= function + | true -> (for_all_s [@ocaml.tailcall]) f l + | false -> Lwt.return_false) let for_all_p f l = map_p f l >>= fun bl -> List.for_all (fun x -> x) bl |> Lwt.return let rec exists_s f l = match l with - | [] -> - Lwt.return_false - | x :: l -> - Lwt.apply f x >>= function - | true -> - Lwt.return_true - | false -> - (exists_s [@ocaml.tailcall]) f l + | [] -> Lwt.return_false + | x :: l -> ( + Lwt.apply f x >>= function + | true -> Lwt.return_true + | false -> (exists_s [@ocaml.tailcall]) f l) let exists_p f l = map_p f l >>= fun bl -> List.exists (fun x -> x) bl |> Lwt.return let rec find_s f l = match l with - | [] -> - Lwt.fail Not_found - | x :: l -> - Lwt.apply f x >>= function - | true -> - Lwt.return x - | false -> - (find_s [@ocaml.tailcall]) f l + | [] -> Lwt.fail Not_found + | x :: l -> ( + Lwt.apply f x >>= function + | true -> Lwt.return x + | false -> (find_s [@ocaml.tailcall]) f l) let _optionalize f x = f x >>= fun b -> if b then Lwt.return (Some x) else Lwt.return None -let filter_s f l = - filter_map_s (_optionalize f) l - -let filter_p f l = - filter_map_p (_optionalize f) l +let filter_s f l = filter_map_s (_optionalize f) l +let filter_p f l = filter_map_p (_optionalize f) l let partition_s f l = let rec inner acc1 acc2 = function - | [] -> Lwt.return (List.rev acc1, List.rev acc2) - | hd::tl -> Lwt.apply f hd >>= fun b -> - if b then - inner (hd::acc1) acc2 tl - else - inner acc1 (hd::acc2) tl + | [] -> Lwt.return (List.rev acc1, List.rev acc2) + | hd :: tl -> + Lwt.apply f hd >>= fun b -> + if b then inner (hd :: acc1) acc2 tl else inner acc1 (hd :: acc2) tl in inner [] [] l @@ -206,5 +171,6 @@ let partition_p f l = map_p g l >>= fun tl -> let group1 = tail_recursive_map snd @@ List.filter fst tl in let group2 = - tail_recursive_map snd @@ List.filter (fun x -> not @@ fst x) tl in + tail_recursive_map snd @@ List.filter (fun x -> not @@ fst x) tl + in Lwt.return (group1, group2) diff --git a/src/core/lwt_list.mli b/src/core/lwt_list.mli index 457083b3af..48b81943d5 100644 --- a/src/core/lwt_list.mli +++ b/src/core/lwt_list.mli @@ -1,51 +1,38 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** List helpers *) -(** Note: this module use the same naming convention as - {!Lwt_stream}. *) +(** Note: this module use the same naming convention as {!Lwt_stream}. *) (** {2 List iterators} *) val iter_s : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t - val iteri_s : (int -> 'a -> unit Lwt.t) -> 'a list -> unit Lwt.t val iteri_p : (int -> 'a -> unit Lwt.t) -> 'a list -> unit Lwt.t - val map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t - val mapi_s : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t val mapi_p : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t - val rev_map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t val rev_map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t - val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b list -> 'a Lwt.t - val fold_right_s : ('a -> 'b -> 'b Lwt.t) -> 'a list -> 'b -> 'b Lwt.t (** {2 List scanning} *) val for_all_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t val for_all_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t - val exists_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t val exists_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t (** {2 List searching} *) val find_s : ('a -> bool Lwt.t) -> 'a list -> 'a Lwt.t - val filter_s : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t val filter_p : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t - val filter_map_s : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t val filter_map_p : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t - val partition_s : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t val partition_p : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t diff --git a/src/core/lwt_mutex.ml b/src/core/lwt_mutex.ml index 93bd12ab0c..962eecc06a 100644 --- a/src/core/lwt_mutex.ml +++ b/src/core/lwt_mutex.ml @@ -1,44 +1,42 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] + module Lwt_sequence = Lwt_sequence + [@@@ocaml.warning "+3"] open Lwt.Infix -type t = { mutable locked : bool; waiters : unit Lwt.u Lwt_sequence.t } +type t = { mutable locked : bool; waiters : unit Lwt.u Lwt_sequence.t } let create () = { locked = false; waiters = Lwt_sequence.create () } let lock m = - if m.locked then - (Lwt.add_task_r [@ocaml.warning "-3"]) m.waiters - else begin + if m.locked then (Lwt.add_task_r [@ocaml.warning "-3"]) m.waiters + else ( m.locked <- true; - Lwt.return_unit - end + Lwt.return_unit) let unlock m = - if m.locked then begin - if Lwt_sequence.is_empty m.waiters then - m.locked <- false + if m.locked then + if Lwt_sequence.is_empty m.waiters then m.locked <- false else (* We do not use [Lwt.wakeup] here to avoid a stack overflow when unlocking a lot of threads. *) Lwt.wakeup_later (Lwt_sequence.take_l m.waiters) () - end let with_lock m f = lock m >>= fun () -> - Lwt.finalize f (fun () -> unlock m; Lwt.return_unit) + Lwt.finalize f (fun () -> + unlock m; + Lwt.return_unit) let is_locked m = m.locked let is_empty m = Lwt_sequence.is_empty m.waiters diff --git a/src/core/lwt_mutex.mli b/src/core/lwt_mutex.mli index b82c237140..4320c2b1c1 100644 --- a/src/core/lwt_mutex.mli +++ b/src/core/lwt_mutex.mli @@ -1,44 +1,38 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Cooperative locks for mutual exclusion *) type t - (** Type of Lwt mutexes *) +(** Type of Lwt mutexes *) val create : unit -> t - (** [create ()] creates a new mutex, which is initially unlocked *) +(** [create ()] creates a new mutex, which is initially unlocked *) val lock : t -> unit Lwt.t - (** [lock mutex] lockcs the mutex, that is: +(** [lock mutex] lockcs the mutex, that is: - - if the mutex is unlocked, then it is marked as locked and - {!lock} returns immediately + - if the mutex is unlocked, then it is marked as locked and {!lock} returns + immediately - - if it is locked, then {!lock} waits for all threads waiting on - the mutex to terminate, then it resumes when the last one - unlocks the mutex + - if it is locked, then {!lock} waits for all threads waiting on the mutex + to terminate, then it resumes when the last one unlocks the mutex - Note: threads are woken up in the same order they try to lock the - mutex *) + Note: threads are woken up in the same order they try to lock the mutex *) val unlock : t -> unit - (** [unlock mutex] unlock the mutex if no threads is waiting on - it. Otherwise it will eventually removes the first one and - resumes it. *) +(** [unlock mutex] unlock the mutex if no threads is waiting on it. Otherwise it + will eventually removes the first one and resumes it. *) val is_locked : t -> bool - (** [locked mutex] returns whether [mutex] is currently locked *) +(** [locked mutex] returns whether [mutex] is currently locked *) val is_empty : t -> bool - (** [is_empty mutex] returns [true] if they are no thread waiting on - the mutex, and [false] otherwise *) +(** [is_empty mutex] returns [true] if they are no thread waiting on the mutex, + and [false] otherwise *) val with_lock : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t - (** [with_lock lock f] is used to lock a mutex within a block scope. - The function [f ()] is called with the mutex locked, and its - result is returned from the call to [with_lock]. If an exception - is raised from f, the mutex is also unlocked before the scope of - [with_lock] is exited. *) +(** [with_lock lock f] is used to lock a mutex within a block scope. The + function [f ()] is called with the mutex locked, and its result is returned + from the call to [with_lock]. If an exception is raised from f, the mutex is + also unlocked before the scope of [with_lock] is exited. *) diff --git a/src/core/lwt_mvar.ml b/src/core/lwt_mvar.ml index d7a949150a..1e26a8c5bc 100644 --- a/src/core/lwt_mvar.ml +++ b/src/core/lwt_mvar.ml @@ -35,61 +35,58 @@ [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] + module Lwt_sequence = Lwt_sequence + [@@@ocaml.warning "+3"] type 'a t = { - mutable mvar_contents : 'a option; - (* Current contents *) - + mutable mvar_contents : 'a option; (* Current contents *) writers : ('a * unit Lwt.u) Lwt_sequence.t; (* Threads waiting to put a value *) - - readers : 'a Lwt.u Lwt_sequence.t; - (* Threads waiting for a value *) + readers : 'a Lwt.u Lwt_sequence.t; (* Threads waiting for a value *) } let create_empty () = - { mvar_contents = None; + { + mvar_contents = None; writers = Lwt_sequence.create (); - readers = Lwt_sequence.create () } + readers = Lwt_sequence.create (); + } let create v = - { mvar_contents = Some v; + { + mvar_contents = Some v; writers = Lwt_sequence.create (); - readers = Lwt_sequence.create () } + readers = Lwt_sequence.create (); + } let put mvar v = match mvar.mvar_contents with | None -> - begin match Lwt_sequence.take_opt_l mvar.readers with - | None -> - mvar.mvar_contents <- Some v - | Some w -> - Lwt.wakeup_later w v - end; - Lwt.return_unit + (match Lwt_sequence.take_opt_l mvar.readers with + | None -> mvar.mvar_contents <- Some v + | Some w -> Lwt.wakeup_later w v); + Lwt.return_unit | Some _ -> - let (res, w) = Lwt.task () in - let node = Lwt_sequence.add_r (v, w) mvar.writers in - Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); - res + let res, w = Lwt.task () in + let node = Lwt_sequence.add_r (v, w) mvar.writers in + Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); + res let next_writer mvar = match Lwt_sequence.take_opt_l mvar.writers with - | Some(v', w) -> - mvar.mvar_contents <- Some v'; - Lwt.wakeup_later w () - | None -> - mvar.mvar_contents <- None + | Some (v', w) -> + mvar.mvar_contents <- Some v'; + Lwt.wakeup_later w () + | None -> mvar.mvar_contents <- None let take_available mvar = match mvar.mvar_contents with | Some v -> - next_writer mvar; - Some v - | None -> - None + next_writer mvar; + Some v + | None -> None let take mvar = match take_available mvar with @@ -97,6 +94,4 @@ let take mvar = | None -> (Lwt.add_task_r [@ocaml.warning "-3"]) mvar.readers let is_empty mvar = - match mvar.mvar_contents with - | Some _ -> false - | None -> true + match mvar.mvar_contents with Some _ -> false | None -> true diff --git a/src/core/lwt_mvar.mli b/src/core/lwt_mvar.mli index 0678d7dda1..9ef0883ff5 100644 --- a/src/core/lwt_mvar.mli +++ b/src/core/lwt_mvar.mli @@ -32,28 +32,25 @@ communication between concurrent threads. *) type 'a t - (** The type of a mailbox variable. Mailbox variables are used to - communicate values between threads in a synchronous way. The - type parameter specifies the type of the value propagated from - [put] to [take]. *) +(** The type of a mailbox variable. Mailbox variables are used to communicate + values between threads in a synchronous way. The type parameter specifies + the type of the value propagated from [put] to [take]. *) val create : 'a -> 'a t - (** [create v] creates a new mailbox variable containing value [v]. *) +(** [create v] creates a new mailbox variable containing value [v]. *) val create_empty : unit -> 'a t - (** [create ()] creates a new empty mailbox variable. *) +(** [create ()] creates a new empty mailbox variable. *) val put : 'a t -> 'a -> unit Lwt.t - (** [put mvar value] puts a value into a mailbox variable. This - value will remain in the mailbox until [take] is called to - remove it. If the mailbox is not empty, the current thread will - block until it is emptied. *) +(** [put mvar value] puts a value into a mailbox variable. This value will + remain in the mailbox until [take] is called to remove it. If the mailbox is + not empty, the current thread will block until it is emptied. *) val take : 'a t -> 'a Lwt.t - (** [take mvar] will take any currently available value from the - mailbox variable. If no value is currently available, the - current thread will block, awaiting a value to be [put] by - another thread. *) +(** [take mvar] will take any currently available value from the mailbox + variable. If no value is currently available, the current thread will block, + awaiting a value to be [put] by another thread. *) val take_available : 'a t -> 'a option (** [take_available mvar] immediately takes the value from [mvar] without diff --git a/src/core/lwt_pool.ml b/src/core/lwt_pool.ml index 1605bc89fa..92662c08ab 100644 --- a/src/core/lwt_pool.ml +++ b/src/core/lwt_pool.ml @@ -1,15 +1,15 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] + module Lwt_sequence = Lwt_sequence + [@@@ocaml.warning "+3"] open Lwt.Infix @@ -32,42 +32,45 @@ type 'a t = { list : 'a Queue.t; (* Available pool members. *) waiters : 'a Lwt.u Lwt_sequence.t; - (* Promise resolvers waiting for a free member. *) + (* Promise resolvers waiting for a free member. *) } -let create m ?(validate = fun _ -> Lwt.return_true) ?(check = fun _ f -> f true) ?(dispose = fun _ -> Lwt.return_unit) create = - { max = m; - create = create; - validate = validate; - check = check; - dispose = dispose; +let create m ?(validate = fun _ -> Lwt.return_true) ?(check = fun _ f -> f true) + ?(dispose = fun _ -> Lwt.return_unit) create = + { + max = m; + create; + validate; + check; + dispose; cleared = ref (ref false); count = 0; list = Queue.create (); - waiters = Lwt_sequence.create () } + waiters = Lwt_sequence.create (); + } (* Create a pool member. *) let create_member p = Lwt.catch (fun () -> - (* Must be done before p.create to prevent other resolvers from - creating new members if the limit is reached. *) - p.count <- p.count + 1; - p.create ()) + (* Must be done before p.create to prevent other resolvers from + creating new members if the limit is reached. *) + p.count <- p.count + 1; + p.create ()) (fun exn -> - (* Creation failed, so don't increment count. *) - p.count <- p.count - 1; - Lwt.fail exn) + (* Creation failed, so don't increment count. *) + p.count <- p.count - 1; + Lwt.fail exn) (* Release a pool member. *) let release p c = match Lwt_sequence.take_opt_l p.waiters with | Some wakener -> - (* A promise resolver is waiting, give it the pool member. *) - Lwt.wakeup_later wakener c + (* A promise resolver is waiting, give it the pool member. *) + Lwt.wakeup_later wakener c | None -> - (* No one is waiting, queue it. *) - Queue.push c p.list + (* No one is waiting, queue it. *) + Queue.push c p.list (* Dispose of a pool member. *) let dispose p c = @@ -79,36 +82,31 @@ let dispose p c = let replace_disposed p = match Lwt_sequence.take_opt_l p.waiters with | None -> - (* No one is waiting, do not create a new member to avoid - losing an error if creation fails. *) - () + (* No one is waiting, do not create a new member to avoid + losing an error if creation fails. *) + () | Some wakener -> - Lwt.on_any - (Lwt.apply p.create ()) - (fun c -> - Lwt.wakeup_later wakener c) - (fun exn -> - (* Creation failed, notify the waiter of the failure. *) - Lwt.wakeup_later_exn wakener exn) + Lwt.on_any (Lwt.apply p.create ()) + (fun c -> Lwt.wakeup_later wakener c) + (fun exn -> + (* Creation failed, notify the waiter of the failure. *) + Lwt.wakeup_later_exn wakener exn) (* Verify a member is still valid before using it. *) let validate_and_return p c = Lwt.try_bind - (fun () -> - p.validate c) - (function - | true -> - Lwt.return c - | false -> + (fun () -> p.validate c) + (function + | true -> Lwt.return c + | false -> (* Remove this member and create a new one. *) - dispose p c >>= fun () -> - create_member p) - (fun e -> - (* Validation failed: create a new member if at least one - resolver is waiting. *) - dispose p c >>= fun () -> - replace_disposed p; - Lwt.fail e) + dispose p c >>= fun () -> create_member p) + (fun e -> + (* Validation failed: create a new member if at least one + resolver is waiting. *) + dispose p c >>= fun () -> + replace_disposed p; + Lwt.fail e) (* Acquire a pool member. *) let acquire p = @@ -130,15 +128,13 @@ let acquire p = let check_and_release p c cleared = let ok = ref false in p.check c (fun result -> ok := result); - if cleared || not !ok then ( + if cleared || not !ok then (* Element is not ok or the pool was cleared - dispose of it *) dispose p c - ) else ( (* Element is ok - release it back to the pool *) release p c; - Lwt.return_unit - ) + Lwt.return_unit) let use p f = acquire p >>= fun c -> @@ -148,20 +144,15 @@ let use p f = let promise = Lwt.catch (fun () -> f c) - (fun e -> - check_and_release p c !cleared >>= fun () -> - Lwt.fail e) + (fun e -> check_and_release p c !cleared >>= fun () -> Lwt.fail e) in promise >>= fun _ -> - if !cleared then ( + if !cleared then (* p was cleared while promise was resolving - dispose of this element *) - dispose p c >>= fun () -> - promise - ) + dispose p c >>= fun () -> promise else ( release p c; - promise - ) + promise) let clear p = let elements = Queue.fold (fun l element -> element :: l) [] p.list in diff --git a/src/core/lwt_pool.mli b/src/core/lwt_pool.mli index 2e2676c8be..d39776ead3 100644 --- a/src/core/lwt_pool.mli +++ b/src/core/lwt_pool.mli @@ -1,8 +1,6 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** External resource pools. This module provides an abstraction for managing collections of resources. @@ -12,79 +10,78 @@ are free. It also provides the capability of: + - specifying the maximum number of resources that the pool can manage simultaneously, - checking whether a resource is still valid before/after use, and - performing cleanup logic before dropping a resource. - The following example illustrates how it is used with an imaginary - [Db] module: + The following example illustrates how it is used with an imaginary [Db] + module: {[ -let uri = "postgresql://localhost:5432" - -(* Create a database connection pool with max size of 10. *) -let pool = - Lwt_pool.create 10 - ~dispose:(fun connection -> Db.close connection |> Lwt.return) - (fun () -> Db.connect uri |> Lwt.return) - -(* Use the pool in queries. *) -let create_user name = - Lwt_pool.use pool (fun connection -> - connection - |> Db.insert "users" [("name", name)] - |> Lwt.return - ) -]} - - Note that this is {e not} intended to keep a pool of system threads. - If you want to have such pool, consider using {!Lwt_preemptive}. *) + let uri = "postgresql://localhost:5432" + + (* Create a database connection pool with max size of 10. *) + let pool = + Lwt_pool.create 10 + ~dispose:(fun connection -> Db.close connection |> Lwt.return) + (fun () -> Db.connect uri |> Lwt.return) + + (* Use the pool in queries. *) + let create_user name = + Lwt_pool.use pool (fun connection -> + connection |> Db.insert "users" [ ("name", name) ] |> Lwt.return) + ]} + + Note that this is {e not} intended to keep a pool of system threads. If you + want to have such pool, consider using {!Lwt_preemptive}. *) type 'a t - (** A pool containing elements of type ['a]. *) +(** A pool containing elements of type ['a]. *) val create : int -> - ?validate : ('a -> bool Lwt.t) -> - ?check : ('a -> (bool -> unit) -> unit) -> - ?dispose : ('a -> unit Lwt.t) -> - (unit -> 'a Lwt.t) -> 'a t - (** [create n ?check ?validate ?dispose f] creates a new pool with at most - [n] elements. [f] is used to create a new pool element. Elements are - created on demand and re-used until disposed of. - - @param validate is called each time a pool element is accessed by {!use}, - before the element is provided to {!use}'s callback. If - [validate element] resolves to [true] the element is considered valid and - is passed to the callback for use as-is. If [validate element] resolves - to [false] the tested pool element is passed to [dispose] then dropped, - with a new one is created to take [element]'s place in the pool. - [validate] is available since Lwt 3.2.0. - - @param check is called after the resolution of {!use}'s callback when the - resolution is a failed promise. [check element is_ok] must call [is_ok] - exactly once with [true] if [element] is still valid and [false] - otherwise. If [check] calls [is_ok false] then [dispose] will be run - on [element] and the element will not be returned to the pool. - - @param dispose is used as described above and by {!clear} to dispose of - all elements in a pool. [dispose] is {b not} guaranteed to be called on - the elements in a pool when the pool is garbage collected. {!clear} - should be used if the elements of the pool need to be explicitly disposed - of. *) + ?validate:('a -> bool Lwt.t) -> + ?check:('a -> (bool -> unit) -> unit) -> + ?dispose:('a -> unit Lwt.t) -> + (unit -> 'a Lwt.t) -> + 'a t +(** [create n ?check ?validate ?dispose f] creates a new pool with at most [n] + elements. [f] is used to create a new pool element. Elements are created on + demand and re-used until disposed of. + + @param validate + is called each time a pool element is accessed by {!use}, before the + element is provided to {!use}'s callback. If [validate element] resolves + to [true] the element is considered valid and is passed to the callback + for use as-is. If [validate element] resolves to [false] the tested pool + element is passed to [dispose] then dropped, with a new one is created to + take [element]'s place in the pool. [validate] is available since Lwt + 3.2.0. + @param check + is called after the resolution of {!use}'s callback when the resolution is + a failed promise. [check element is_ok] must call [is_ok] exactly once + with [true] if [element] is still valid and [false] otherwise. If [check] + calls [is_ok false] then [dispose] will be run on [element] and the + element will not be returned to the pool. + @param dispose + is used as described above and by {!clear} to dispose of all elements in a + pool. [dispose] is {b not} guaranteed to be called on the elements in a + pool when the pool is garbage collected. {!clear} should be used if the + elements of the pool need to be explicitly disposed of. *) val use : 'a t -> ('a -> 'b Lwt.t) -> 'b Lwt.t - (** [use p f] requests one free element of the pool [p] and gives it to - the function [f]. The element is put back into the pool after the - promise created by [f] completes. +(** [use p f] requests one free element of the pool [p] and gives it to the + function [f]. The element is put back into the pool after the promise + created by [f] completes. - In the case that [p] is exhausted and the maximum number of elements - is reached, [use] will wait until one becomes free. *) + In the case that [p] is exhausted and the maximum number of elements is + reached, [use] will wait until one becomes free. *) val clear : 'a t -> unit Lwt.t (** [clear p] will clear all elements in [p], calling the [dispose] function - associated with [p] on each of the cleared elements. Any elements from [p] + associated with [p] on each of the cleared elements. Any elements from [p] which are currently in use will be disposed of once they are released. The next call to [use p] after [clear p] guarantees a freshly created pool diff --git a/src/core/lwt_pqueue.ml b/src/core/lwt_pqueue.ml index 91fa8c5f2c..8f72024f19 100644 --- a/src/core/lwt_pqueue.ml +++ b/src/core/lwt_pqueue.ml @@ -1,30 +1,27 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - -module type OrderedType = -sig +module type OrderedType = sig type t - val compare: t -> t -> int + + val compare : t -> t -> int end -module type S = -sig +module type S = sig type elt type t - val empty: t - val is_empty: t -> bool - val add: elt -> t -> t - val union: t -> t -> t - val find_min: t -> elt - val lookup_min: t -> elt option - val remove_min: t -> t - val size: t -> int + + val empty : t + val is_empty : t -> bool + val add : elt -> t -> t + val union : t -> t -> t + val find_min : t -> elt + val lookup_min : t -> elt option + val remove_min : t -> t + val size : t -> int end -module Make(Ord: OrderedType) : (S with type elt = Ord.t) = -struct +module Make (Ord : OrderedType) : S with type elt = Ord.t = struct type elt = Ord.t type t = tree list @@ -32,67 +29,62 @@ struct let root (Node (x, _, _)) = x let rank (Node (_, r, _)) = r + let link (Node (x1, r1, c1) as t1) (Node (x2, r2, c2) as t2) = let c = Ord.compare x1 x2 in - if c <= 0 then Node (x1, r1 + 1, t2::c1) else Node(x2, r2 + 1, t1::c2) - let rec ins t = - function - [] -> - [t] - | (t'::_) as ts when rank t < rank t' -> - t::ts - | t'::ts -> - ins (link t t') ts + if c <= 0 then Node (x1, r1 + 1, t2 :: c1) else Node (x2, r2 + 1, t1 :: c2) + + let rec ins t = function + | [] -> [ t ] + | t' :: _ as ts when rank t < rank t' -> t :: ts + | t' :: ts -> ins (link t t') ts let empty = [] let is_empty ts = ts = [] let add x ts = ins (Node (x, 0, [])) ts + let rec union ts ts' = - match ts, ts' with - ([], _) -> ts' - | (_, []) -> ts - | (t1::ts1, t2::ts2) -> - if rank t1 < rank t2 then t1 :: union ts1 (t2::ts2) - else if rank t2 < rank t1 then t2 :: union (t1::ts1) ts2 - else ins (link t1 t2) (union ts1 ts2) - - let rec find_min = - function - [] -> raise Not_found - | [t] -> root t - | t::ts -> - let x = find_min ts in - let c = Ord.compare (root t) x in - if c < 0 then root t else x - - let rec lookup_min = - function - | [] -> None - | [t] -> Some (root t) - | t::ts -> - match lookup_min ts with - | None -> None - | Some x as result -> + match (ts, ts') with + | [], _ -> ts' + | _, [] -> ts + | t1 :: ts1, t2 :: ts2 -> + if rank t1 < rank t2 then t1 :: union ts1 (t2 :: ts2) + else if rank t2 < rank t1 then t2 :: union (t1 :: ts1) ts2 + else ins (link t1 t2) (union ts1 ts2) + + let rec find_min = function + | [] -> raise Not_found + | [ t ] -> root t + | t :: ts -> + let x = find_min ts in let c = Ord.compare (root t) x in - if c < 0 then Some (root t) else result - - let rec get_min = - function - [] -> assert false - | [t] -> (t, []) - | t::ts -> - let (t', ts') = get_min ts in - let c = Ord.compare (root t) (root t') in - if c < 0 then (t, ts) else (t', t::ts') - - let remove_min = - function - [] -> raise Not_found + if c < 0 then root t else x + + let rec lookup_min = function + | [] -> None + | [ t ] -> Some (root t) + | t :: ts -> ( + match lookup_min ts with + | None -> None + | Some x as result -> + let c = Ord.compare (root t) x in + if c < 0 then Some (root t) else result) + + let rec get_min = function + | [] -> assert false + | [ t ] -> (t, []) + | t :: ts -> + let t', ts' = get_min ts in + let c = Ord.compare (root t) (root t') in + if c < 0 then (t, ts) else (t', t :: ts') + + let remove_min = function + | [] -> raise Not_found | ts -> - let (Node (_, _, c), ts) = get_min ts in - union (List.rev c) ts + let Node (_, _, c), ts = get_min ts in + union (List.rev c) ts let rec size l = - let sizetree (Node (_,_,tl)) = 1 + size tl in + let sizetree (Node (_, _, tl)) = 1 + size tl in List.fold_left (fun s t -> s + sizetree t) 0 l end diff --git a/src/core/lwt_pqueue.mli b/src/core/lwt_pqueue.mli index f14a11cca2..0b3be602c5 100644 --- a/src/core/lwt_pqueue.mli +++ b/src/core/lwt_pqueue.mli @@ -1,8 +1,6 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Functional priority queues (deprecated). A priority queue maintains, in the abstract sense, a set of elements in @@ -13,64 +11,64 @@ The priority queues in this module preserve "duplicates": elements that compare equal in their order. - @deprecated This module is an internal implementation detail of Lwt, and may - be removed from the API at some point in the future. For alternatives, see, - for example: {{: https://www.lri.fr/~filliatr/software.en.html#heap} Heaps} - by Jean-Cristophe Filliatre, - {{: http://cedeela.fr/~simon/software/containers/CCHeap.html} containers}, - {{: http://ocaml-batteries-team.github.io/batteries-included/hdoc2/BatHeap.html} - Batteries}, or {{:https://github.com/pqwy/psq} psq}. *) + @deprecated + This module is an internal implementation detail of Lwt, and may be + removed from the API at some point in the future. For alternatives, see, + for example: {{:https://www.lri.fr/~filliatr/software.en.html#heap} Heaps} + by Jean-Cristophe Filliatre, + {{:http://cedeela.fr/~simon/software/containers/CCHeap.html} containers}, + {{:http://ocaml-batteries-team.github.io/batteries-included/hdoc2/BatHeap.html} + Batteries}, or {{:https://github.com/pqwy/psq} psq}. *) [@@@ocaml.deprecated -" This module is an implementation detail of Lwt. See - http://ocsigen.org/lwt/dev/api/Lwt_pqueue"] +" This module is an implementation detail of Lwt. See\n\ +\ http://ocsigen.org/lwt/dev/api/Lwt_pqueue"] (** Signature pairing an element type with an ordering function. *) -module type OrderedType = - sig - type t - val compare: t -> t -> int - end +module type OrderedType = sig + type t + + val compare : t -> t -> int +end (** Signature of priority queues. *) -module type S = - sig - type elt - (** Type of elements contained in the priority queue. *) +module type S = sig + type elt + (** Type of elements contained in the priority queue. *) - type t - (** Type of priority queues. *) + type t + (** Type of priority queues. *) - val empty: t - (** The empty priority queue. Contains no elements. *) + val empty : t + (** The empty priority queue. Contains no elements. *) - val is_empty: t -> bool - (** [is_empty q] evaluates to [true] iff [q] is empty. *) + val is_empty : t -> bool + (** [is_empty q] evaluates to [true] iff [q] is empty. *) - val add: elt -> t -> t - (** [add e q] evaluates to a new priority queue, which contains all the - elements of [q], and the additional element [e]. *) + val add : elt -> t -> t + (** [add e q] evaluates to a new priority queue, which contains all the + elements of [q], and the additional element [e]. *) - val union: t -> t -> t - (** [union q q'] evaluates to a new priority queue, which contains all the - elements of both [q] and [q']. *) + val union : t -> t -> t + (** [union q q'] evaluates to a new priority queue, which contains all the + elements of both [q] and [q']. *) - val find_min: t -> elt - (** [find_min q] evaluates to the minimum element of [q] if it is not empty, - and raises [Not_found] otherwise. *) + val find_min : t -> elt + (** [find_min q] evaluates to the minimum element of [q] if it is not empty, + and raises [Not_found] otherwise. *) - val lookup_min: t -> elt option - (** [lookup_min q] evaluates to [Some e], where [e] is the minimum element - of [q], if [q] is not empty, and evaluates to [None] otherwise. *) + val lookup_min : t -> elt option + (** [lookup_min q] evaluates to [Some e], where [e] is the minimum element of + [q], if [q] is not empty, and evaluates to [None] otherwise. *) - val remove_min: t -> t - (** [remove_min q] evaluates to a new priority queue, which contains all the - elements of [q] except for its minimum element. Raises [Not_found] if - [q] is empty. *) + val remove_min : t -> t + (** [remove_min q] evaluates to a new priority queue, which contains all the + elements of [q] except for its minimum element. Raises [Not_found] if [q] + is empty. *) - val size: t -> int - (** [size q] evaluates to the number of elements in [q]. *) - end + val size : t -> int + (** [size q] evaluates to the number of elements in [q]. *) +end (** Generates priority queue types from ordered types. *) -module Make(Ord: OrderedType) : S with type elt = Ord.t +module Make (Ord : OrderedType) : S with type elt = Ord.t diff --git a/src/core/lwt_result.ml b/src/core/lwt_result.ml index 7d14a07730..1307ecfa3c 100644 --- a/src/core/lwt_result.ml +++ b/src/core/lwt_result.ml @@ -1,8 +1,6 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Module [Lwt_result]: explicit error handling *) open Result @@ -11,83 +9,38 @@ type (+'a, +'b) t = ('a, 'b) Result.result Lwt.t let return x = Lwt.return (Ok x) let fail e = Lwt.return (Error e) - let lift = Lwt.return let ok x = Lwt.map (fun y -> Ok y) x - -let map f e = - Lwt.map - (function - | Error e -> Error e - | Ok x -> Ok (f x)) - e - -let map_err f e = - Lwt.map - (function - | Error e -> Error (f e) - | Ok x -> Ok x) - e - -let catch e = - Lwt.catch - (fun () -> ok e) - fail +let map f e = Lwt.map (function Error e -> Error e | Ok x -> Ok (f x)) e +let map_err f e = Lwt.map (function Error e -> Error (f e) | Ok x -> Ok x) e +let catch e = Lwt.catch (fun () -> ok e) fail let get_exn e = - Lwt.bind e - (function - | Ok x -> Lwt.return x - | Error e -> Lwt.fail e) + Lwt.bind e (function Ok x -> Lwt.return x | Error e -> Lwt.fail e) let bind e f = - Lwt.bind e - (function - | Error e -> Lwt.return (Error e) - | Ok x -> f x) + Lwt.bind e (function Error e -> Lwt.return (Error e) | Ok x -> f x) -let bind_lwt e f = - Lwt.bind e - (function - | Ok x -> ok (f x) - | Error e -> fail e) - -let bind_result e f = - Lwt.map - (function - | Error e -> Error e - | Ok x -> f x) - e +let bind_lwt e f = Lwt.bind e (function Ok x -> ok (f x) | Error e -> fail e) +let bind_result e f = Lwt.map (function Error e -> Error e | Ok x -> f x) e let bind_lwt_err e f = - Lwt.bind e - (function - | Error e -> Lwt.bind (f e) fail - | Ok x -> return x) + Lwt.bind e (function 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 + 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) + | 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 + let ( >>= ) = bind + let ( >|= ) e f = map f e end module Let_syntax = struct @@ -96,17 +49,16 @@ module Let_syntax = struct let map t ~f = map f t let bind t ~f = bind t f let both = both - module Open_on_rhs = struct - end + + module Open_on_rhs = struct end end end module Syntax = struct - let (let*) = bind - let (and*) = both - - let (let+) x f = map f x - let (and+) = both + let ( let* ) = bind + let ( and* ) = both + let ( let+ ) x f = map f x + let ( and+ ) = both end include Infix diff --git a/src/core/lwt_result.mli b/src/core/lwt_result.mli index bb891b9e95..cab1d65e31 100644 --- a/src/core/lwt_result.mli +++ b/src/core/lwt_result.mli @@ -1,58 +1,45 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Explicit error handling @since 2.6.0 *) -(** This module provides helpers for values of type [('a, 'b) result Lwt.t]. - The module is experimental and may change in the future. *) +(** This module provides helpers for values of type [('a, 'b) result Lwt.t]. The + module is experimental and may change in the future. *) type (+'a, +'b) t = ('a, 'b) Result.result Lwt.t val return : 'a -> ('a, _) t - val fail : 'b -> (_, 'b) t - val lift : ('a, 'b) Result.result -> ('a, 'b) t - val ok : 'a Lwt.t -> ('a, _) t val catch : 'a Lwt.t -> ('a, exn) t -(** [catch x] behaves like [return y] if [x] evaluates to [y], - and like [fail e] if [x] raises [e] *) +(** [catch x] behaves like [return y] if [x] evaluates to [y], and like [fail e] + if [x] raises [e] *) val get_exn : ('a, exn) t -> 'a Lwt.t -(** [get_exn] is the opposite of {!catch}: it unwraps the result type, - returning the value in case of success, calls {!Lwt.fail} in - case of error. *) - -val map : ('a -> 'b) -> ('a,'e) t -> ('b,'e) t +(** [get_exn] is the opposite of {!catch}: it unwraps the result type, returning + the value in case of success, calls {!Lwt.fail} in case of error. *) -val map_err : ('e1 -> 'e2) -> ('a,'e1) t -> ('a,'e2) t +val map : ('a -> 'b) -> ('a, 'e) t -> ('b, 'e) t +val map_err : ('e1 -> 'e2) -> ('a, 'e1) t -> ('a, 'e2) t +val bind : ('a, 'e) t -> ('a -> ('b, 'e) t) -> ('b, 'e) t +val bind_lwt : ('a, 'e) t -> ('a -> 'b Lwt.t) -> ('b, 'e) t +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 bind : ('a,'e) t -> ('a -> ('b,'e) t) -> ('b,'e) t - -val bind_lwt : ('a,'e) t -> ('a -> 'b Lwt.t) -> ('b,'e) t - -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 +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 {e resolved}. - If only [p_1] is [Error e], the promise is resolved with [Error e], - If only [p_2] is [Error e], the promise is resolved with [Error e], - If both [p_1] and [p_2] resolve with [Error _], the promise is resolved with - the error that occurred first. *) - + [p_1] and [p_2] become {e resolved}. If only [p_1] is [Error e], the promise + is resolved with [Error e], If only [p_2] is [Error e], the promise is + resolved with [Error e], If both [p_1] and [p_2] resolve with [Error _], the + promise is resolved with the error that occurred first. *) module Infix : sig - val (>|=) : ('a,'e) t -> ('a -> 'b) -> ('b,'e) t - val (>>=) : ('a,'e) t -> ('a -> ('b,'e) t) -> ('b,'e) t + val ( >|= ) : ('a, 'e) t -> ('a -> 'b) -> ('b, 'e) t + val ( >>= ) : ('a, 'e) t -> ('a -> ('b, 'e) t) -> ('b, 'e) t end module Let_syntax : sig @@ -69,28 +56,26 @@ module Let_syntax : sig val both : ('a, 'e) t -> ('b, 'e) t -> ('a * 'b, 'e) t (** See {!Lwt_result.both}. *) - module Open_on_rhs : sig - end + module Open_on_rhs : sig end end end (** {3 Let syntax} *) module Syntax : sig - (** {1 Monadic syntax} *) - val (let*) : ('a,'e) t -> ('a -> ('b,'e) t) -> ('b,'e) t + val ( let* ) : ('a, 'e) t -> ('a -> ('b, 'e) t) -> ('b, 'e) t (** Syntax for {!bind}. *) - val (and*) : ('a,'e) t -> ('b,'e) t -> ('a * 'b,'e) t + val ( and* ) : ('a, 'e) t -> ('b, 'e) t -> ('a * 'b, 'e) t (** Syntax for {!both}. *) (** {1 Applicative syntax} *) - val (let+) : ('a,'e) t -> ('a -> 'b) -> ('b, 'e) t + val ( let+ ) : ('a, 'e) t -> ('a -> 'b) -> ('b, 'e) t (** Syntax for {!map}. *) - val (and+) : ('a,'e) t -> ('b,'e) t -> ('a * 'b,'e) t + val ( and+ ) : ('a, 'e) t -> ('b, 'e) t -> ('a * 'b, 'e) t (** Syntax for {!both}. *) end diff --git a/src/core/lwt_seq.ml b/src/core/lwt_seq.ml index 5c9fe3ade6..48431bb052 100644 --- a/src/core/lwt_seq.ml +++ b/src/core/lwt_seq.ml @@ -1,30 +1,26 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Lwt.Syntax open Lwt.Infix type +'a node = Nil | Cons of 'a * 'a t - and 'a t = unit -> 'a node Lwt.t let return_nil = Lwt.return Nil - let empty : 'a t = fun () -> return_nil - let return (x : 'a) : 'a t = fun () -> Lwt.return (Cons (x, empty)) -let return_lwt (x : 'a Lwt.t) : 'a t = fun () -> - let+ x = x in - Cons (x, empty) +let return_lwt (x : 'a Lwt.t) : 'a t = + fun () -> + let+ x in + Cons (x, empty) let cons x t () = Lwt.return (Cons (x, t)) let cons_lwt x t () = - let+ x = x in - Cons (x, t) + let+ x in + Cons (x, t) (* A note on recursing through the seqs: When traversing a seq, the first time we evaluate a suspended node we are @@ -42,6 +38,7 @@ let rec append seq1 seq2 () = seq1 () >>= function | Nil -> seq2 () | Cons (x, next) -> Lwt.return (Cons (x, append next seq2)) + let append seq1 seq2 () = Lwt.apply seq1 () >>= function | Nil -> seq2 () @@ -53,6 +50,7 @@ let rec map f seq () = | Cons (x, next) -> let x = f x in Cons (x, map f next) + let map f seq () = Lwt.apply seq () >|= function | Nil -> Nil @@ -66,6 +64,7 @@ let rec map_s f seq () = | Cons (x, next) -> let+ x = f x in Cons (x, map_s f next) + let map_s f seq () = Lwt.apply seq () >>= function | Nil -> return_nil @@ -80,7 +79,8 @@ let rec filter_map f seq () = let x = f x in match x with | None -> filter_map f next () - | Some y -> Lwt.return (Cons (y, filter_map f next) )) + | Some y -> Lwt.return (Cons (y, filter_map f next))) + let filter_map f seq () = Lwt.apply seq () >>= function | Nil -> return_nil @@ -88,7 +88,7 @@ let filter_map f seq () = let x = f x in match x with | None -> filter_map f next () - | Some y -> Lwt.return (Cons (y, filter_map f next) )) + | Some y -> Lwt.return (Cons (y, filter_map f next))) let rec filter_map_s f seq () = seq () >>= function @@ -97,7 +97,8 @@ let rec filter_map_s f seq () = let* x = f x in match x with | None -> filter_map_s f next () - | Some y -> Lwt.return (Cons (y, filter_map_s f next) )) + | Some y -> Lwt.return (Cons (y, filter_map_s f next))) + let filter_map_s f seq () = Lwt.apply seq () >>= function | Nil -> return_nil @@ -105,7 +106,7 @@ let filter_map_s f seq () = let* x = f x in match x with | None -> filter_map_s f next () - | Some y -> Lwt.return (Cons (y, filter_map_s f next) )) + | Some y -> Lwt.return (Cons (y, filter_map_s f next))) let rec filter f seq () = seq () >>= function @@ -113,6 +114,7 @@ let rec filter f seq () = | Cons (x, next) -> let ok = f x in if ok then Lwt.return (Cons (x, filter f next)) else filter f next () + let filter f seq () = Lwt.apply seq () >>= function | Nil -> return_nil @@ -126,6 +128,7 @@ let rec filter_s f seq () = | Cons (x, next) -> let* ok = f x in if ok then Lwt.return (Cons (x, filter_s f next)) else filter_s f next () + let filter_s f seq () = Lwt.apply seq () >>= function | Nil -> return_nil @@ -136,8 +139,7 @@ let filter_s f seq () = let rec flat_map f seq () = seq () >>= function | Nil -> return_nil - | Cons (x, next) -> - flat_map_app f (f x) next () + | Cons (x, next) -> flat_map_app f (f x) next () (* this is [append seq (flat_map f tail)] *) and flat_map_app f seq tail () = @@ -148,8 +150,7 @@ and flat_map_app f seq tail () = let flat_map f seq () = Lwt.apply seq () >>= function | Nil -> return_nil - | Cons (x, next) -> - flat_map_app f (f x) next () + | Cons (x, next) -> flat_map_app f (f x) next () let fold_left f acc seq = let rec aux f acc seq = @@ -225,42 +226,33 @@ let iter_p f seq = | Nil -> Lwt.join acc | Cons (x, next) -> let p = f x in - aux (p::acc) next + aux (p :: acc) next in let aux acc seq = Lwt.apply seq () >>= function | Nil -> Lwt.join acc | Cons (x, next) -> let p = f x in - aux (p::acc) next + aux (p :: acc) next in aux [] seq let iter_n ?(max_concurrency = 1) f seq = - begin - if max_concurrency <= 0 then - let message = - Printf.sprintf - "Lwt_seq.iter_n: max_concurrency must be > 0, %d given" - max_concurrency - in - invalid_arg message - end; + (if max_concurrency <= 0 then + let message = + Printf.sprintf "Lwt_seq.iter_n: max_concurrency must be > 0, %d given" + max_concurrency + in + invalid_arg message); let rec loop running available seq = - begin - if available > 0 then ( - Lwt.return (running, available) - ) - else ( - Lwt.nchoose_split running >>= fun (complete, running) -> - Lwt.return (running, available + List.length complete) - ) - end >>= fun (running, available) -> + (if available > 0 then Lwt.return (running, available) + else + Lwt.nchoose_split running >>= fun (complete, running) -> + Lwt.return (running, available + List.length complete)) + >>= fun (running, available) -> seq () >>= function - | Nil -> - Lwt.join running - | Cons (elt, seq) -> - loop (f elt :: running) (pred available) seq + | Nil -> Lwt.join running + | Cons (elt, seq) -> loop (f elt :: running) (pred available) seq in (* because the recursion is more complicated here, we apply the seq directly at the call-site instead *) @@ -277,48 +269,50 @@ let rec unfold_lwt f u () = match x with | None -> return_nil | Some (x, u') -> Lwt.return (Cons (x, unfold_lwt f u')) + let unfold_lwt f u () = let* x = Lwt.apply f u in match x with | None -> return_nil | Some (x, u') -> Lwt.return (Cons (x, unfold_lwt f u')) -let rec of_list = function - | [] -> empty - | h :: t -> cons h (of_list t) +let rec of_list = function [] -> empty | h :: t -> cons h (of_list t) let rec to_list seq = seq () >>= function | Nil -> Lwt.return_nil | Cons (x, next) -> - let+ l = to_list next in - x :: l + let+ l = to_list next in + x :: l + let to_list seq = Lwt.apply seq () >>= function | Nil -> Lwt.return_nil | Cons (x, next) -> - let+ l = to_list next in - x :: l + let+ l = to_list next in + x :: l let rec of_seq seq () = match seq () with | Seq.Nil -> return_nil - | Seq.Cons (x, next) -> - Lwt.return (Cons (x, (of_seq next))) + | Seq.Cons (x, next) -> Lwt.return (Cons (x, of_seq next)) | exception exn -> Lwt.fail exn -let rec of_seq_lwt (seq: 'a Lwt.t Seq.t): 'a t = fun () -> - match seq () with - | Seq.Nil -> return_nil - | Seq.Cons (x, next) -> - let+ x = x in - let next = of_seq_lwt next in - Cons (x, next) -let of_seq_lwt (seq: 'a Lwt.t Seq.t): 'a t = fun () -> - match seq () with - | Seq.Nil -> return_nil - | Seq.Cons (x, next) -> - let+ x = x in - let next = of_seq_lwt next in - Cons (x, next) - | exception exc -> Lwt.fail exc +let rec of_seq_lwt (seq : 'a Lwt.t Seq.t) : 'a t = + fun () -> + match seq () with + | Seq.Nil -> return_nil + | Seq.Cons (x, next) -> + let+ x in + let next = of_seq_lwt next in + Cons (x, next) + +let of_seq_lwt (seq : 'a Lwt.t Seq.t) : 'a t = + fun () -> + match seq () with + | Seq.Nil -> return_nil + | Seq.Cons (x, next) -> + let+ x in + let next = of_seq_lwt next in + Cons (x, next) + | exception exc -> Lwt.fail exc diff --git a/src/core/lwt_seq.mli b/src/core/lwt_seq.mli index 2b7756f383..abcb87c678 100644 --- a/src/core/lwt_seq.mli +++ b/src/core/lwt_seq.mli @@ -1,19 +1,18 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** @since 5.5.0 *) type 'a t = unit -> 'a node Lwt.t -(** The type of delayed lists containing elements of type ['a]. - Note that the concrete list node ['a node] is delayed under a closure, - not a [lazy] block, which means it might be recomputed every time - we access it. *) +(** The type of delayed lists containing elements of type ['a]. Note that the + concrete list node ['a node] is delayed under a closure, not a [lazy] block, + which means it might be recomputed every time we access it. *) -and +'a node = Nil | Cons of 'a * 'a t -(** A fully-evaluated list node, either empty or containing an element - and a delayed tail. *) +and +'a node = + | Nil + | Cons of 'a * 'a t + (** A fully-evaluated list node, either empty or containing an element and + a delayed tail. *) val empty : 'a t (** The empty sequence, containing no elements. *) @@ -25,137 +24,133 @@ val return_lwt : 'a Lwt.t -> 'a t (** The singleton sequence containing only the given promised element. *) val cons : 'a -> 'a t -> 'a t -(** [cons x xs] is the sequence containing the element [x] followed by - the sequence [xs] *) +(** [cons x xs] is the sequence containing the element [x] followed by the + sequence [xs] *) val cons_lwt : 'a Lwt.t -> 'a t -> 'a t (** [cons x xs] is the sequence containing the element promised by [x] followed - by the sequence [xs] *) + by the sequence [xs] *) val append : 'a t -> 'a t -> 'a t (** [append xs ys] is the sequence [xs] followed by the sequence [ys] *) val map : ('a -> 'b) -> 'a t -> 'b t -(** [map f seq] returns a new sequence whose elements are the elements of - [seq], transformed by [f]. - This transformation is lazy, it only applies when the result is traversed. *) +(** [map f seq] returns a new sequence whose elements are the elements of [seq], + transformed by [f]. This transformation is lazy, it only applies when the + result is traversed. *) val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t (** [map_s f seq] is like [map f seq] but [f] is a function that returns a - promise. + promise. - Note that there is no concurrency between the promises from the underlying - sequence [seq] and the promises from applying the function [f]. In other - words, the next promise-element of the underlying sequence ([seq]) is only - created when the current promise-element of the returned sequence (as mapped - by [f]) has resolved. This scheduling is true for all the [_s] functions of - this module. *) + Note that there is no concurrency between the promises from the underlying + sequence [seq] and the promises from applying the function [f]. In other + words, the next promise-element of the underlying sequence ([seq]) is only + created when the current promise-element of the returned sequence (as mapped + by [f]) has resolved. This scheduling is true for all the [_s] functions of + this module. *) val filter : ('a -> bool) -> 'a t -> 'a t -(** Remove from the sequence the elements that do not satisfy the - given predicate. - This transformation is lazy, it only applies when the result is - traversed. *) +(** Remove from the sequence the elements that do not satisfy the given + predicate. This transformation is lazy, it only applies when the result is + traversed. *) val filter_s : ('a -> bool Lwt.t) -> 'a t -> 'a t (** [filter_s] is like [filter] but the predicate returns a promise. - See {!map_s} for additional details about scheduling. *) + See {!map_s} for additional details about scheduling. *) val filter_map : ('a -> 'b option) -> 'a t -> 'b t -(** Apply the function to every element; if [f x = None] then [x] is dropped; - if [f x = Some y] then [y] is returned. - This transformation is lazy, it only applies when the result is - traversed. *) +(** Apply the function to every element; if [f x = None] then [x] is dropped; if + [f x = Some y] then [y] is returned. This transformation is lazy, it only + applies when the result is traversed. *) val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t (** [filter_map_s] is like [filter] but the predicate returns a promise. - See {!map_s} for additional details about scheduling. *) + See {!map_s} for additional details about scheduling. *) val flat_map : ('a -> 'b t) -> 'a t -> 'b t (** Map each element to a subsequence, then return each element of this - sub-sequence in turn. - This transformation is lazy, it only applies when the result is - traversed. *) + sub-sequence in turn. This transformation is lazy, it only applies when the + result is traversed. *) val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a Lwt.t (** Traverse the sequence from left to right, combining each element with the - accumulator using the given function. - The traversal happens immediately and will not terminate (i.e., the promise - will not resolve) on infinite sequences. *) + accumulator using the given function. The traversal happens immediately and + will not terminate (i.e., the promise will not resolve) on infinite + sequences. *) val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b t -> 'a Lwt.t (** [fold_left_s] is like [fold_left] but the function returns a promise. - See {!map_s} for additional details about scheduling. *) + See {!map_s} for additional details about scheduling. *) val iter : ('a -> unit) -> 'a t -> unit Lwt.t (** Iterate on the sequence, calling the (imperative) function on every element. - The sequence's next node is evaluated only once the function has finished - processing the current element. More formally: the promise for the [n+1]th - node of the sequence is created only once the promise returned by [f] on the - [n]th element of the sequence has resolved. + The sequence's next node is evaluated only once the function has finished + processing the current element. More formally: the promise for the [n+1]th + node of the sequence is created only once the promise returned by [f] on the + [n]th element of the sequence has resolved. - The traversal happens immediately and will not terminate (i.e., the promise - will not resolve) on infinite sequences. *) + The traversal happens immediately and will not terminate (i.e., the promise + will not resolve) on infinite sequences. *) val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t (** [iter_s] is like [iter] but the function returns a promise. - See {!map_s} for additional details about scheduling. *) + See {!map_s} for additional details about scheduling. *) val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t (** Iterate on the sequence, calling the (imperative) function on every element. - The sequence's next node is evaluated as soon as the previous node is - resolved. + The sequence's next node is evaluated as soon as the previous node is + resolved. - The traversal happens immediately and will not terminate (i.e., the promise - will not resolve) on infinite sequences. *) + The traversal happens immediately and will not terminate (i.e., the promise + will not resolve) on infinite sequences. *) val iter_n : ?max_concurrency:int -> ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t (** [iter_n ~max_concurrency f s] - Iterates on the sequence [s], calling the (imperative) function [f] on every - element. + Iterates on the sequence [s], calling the (imperative) function [f] on every + element. - The sum total of unresolved promises returned by [f] never exceeds - [max_concurrency]. Node suspensions are evaluated only when there is capacity - for [f]-promises to be evaluated. Consequently, there might be significantly - fewer than [max_concurrency] promises being evaluated concurrently; especially - if the node suspensions take longer to evaluate than the [f]-promises. + The sum total of unresolved promises returned by [f] never exceeds + [max_concurrency]. Node suspensions are evaluated only when there is + capacity for [f]-promises to be evaluated. Consequently, there might be + significantly fewer than [max_concurrency] promises being evaluated + concurrently; especially if the node suspensions take longer to evaluate + than the [f]-promises. - The traversal happens immediately and will not terminate (i.e., the promise - will not resolve) on infinite sequences. + The traversal happens immediately and will not terminate (i.e., the promise + will not resolve) on infinite sequences. - @param max_concurrency defaults to [1]. - @raise Invalid_argument if [max_concurrency < 1]. *) + @param max_concurrency defaults to [1]. + @raise Invalid_argument if [max_concurrency < 1]. *) val unfold : ('b -> ('a * 'b) option) -> 'b -> 'a t -(** Build a sequence from a step function and an initial value. - [unfold f u] returns [empty] if the promise [f u] resolves to [None], - or [fun () -> Lwt.return (Cons (x, unfold f y))] if the promise [f u] resolves - to [Some (x, y)]. *) +(** Build a sequence from a step function and an initial value. [unfold f u] + returns [empty] if the promise [f u] resolves to [None], or + [fun () -> Lwt.return (Cons (x, unfold f y))] if the promise [f u] resolves + to [Some (x, y)]. *) val unfold_lwt : ('b -> ('a * 'b) option Lwt.t) -> 'b -> 'a t (** [unfold_lwt] is like [unfold] but the step function returns a promise. *) val to_list : 'a t -> 'a list Lwt.t -(** Convert a sequence to a list, preserving order. - The traversal happens immediately and will not terminate (i.e., the promise - will not resolve) on infinite sequences. *) +(** Convert a sequence to a list, preserving order. The traversal happens + immediately and will not terminate (i.e., the promise will not resolve) on + infinite sequences. *) val of_list : 'a list -> 'a t (** Convert a list to a sequence, preserving order. *) val of_seq : 'a Seq.t -> 'a t -(** Convert from ['a Stdlib.Seq.t] to ['a Lwt_seq.t]. - This transformation is lazy, it only applies when the result is - traversed. *) +(** Convert from ['a Stdlib.Seq.t] to ['a Lwt_seq.t]. This transformation is + lazy, it only applies when the result is traversed. *) val of_seq_lwt : 'a Lwt.t Seq.t -> 'a t -(** Convert from ['a Lwt.t Stdlib.Seq.t] to ['a Lwt_seq.t]. - This transformation is lazy, it only applies when the result is - traversed. *) +(** Convert from ['a Lwt.t Stdlib.Seq.t] to ['a Lwt_seq.t]. This transformation + is lazy, it only applies when the result is traversed. *) diff --git a/src/core/lwt_sequence.ml b/src/core/lwt_sequence.ml index 8e8a8d46a2..1f21048b4a 100644 --- a/src/core/lwt_sequence.ml +++ b/src/core/lwt_sequence.ml @@ -1,14 +1,9 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - exception Empty -type 'a t = { - mutable prev : 'a t; - mutable next : 'a t; -} +type 'a t = { mutable prev : 'a t; mutable next : 'a t } type 'a node = { node_prev : 'a t; @@ -24,19 +19,15 @@ external node_of_seq : 'a t -> 'a node = "%identity" | Operations on nodes | +-----------------------------------------------------------------+ *) -let get node = - node.node_data - -let set node data = - node.node_data <- data +let get node = node.node_data +let set node data = node.node_data <- data let remove node = - if node.node_active then begin + if node.node_active then ( node.node_active <- false; let seq = seq_of_node node in seq.prev.next <- seq.next; - seq.next.prev <- seq.prev - end + seq.next.prev <- seq.prev) (* +-----------------------------------------------------------------+ | Operations on sequences | @@ -54,60 +45,66 @@ let is_empty seq = seq.next == seq let length seq = let rec loop curr len = - if curr == seq then - len + if curr == seq then len else - let node = node_of_seq curr in loop node.node_next (len + 1) + let node = node_of_seq curr in + loop node.node_next (len + 1) in loop seq.next 0 let add_l data seq = - let node = { node_prev = seq; node_next = seq.next; node_data = data; node_active = true } in + let node = + { + node_prev = seq; + node_next = seq.next; + node_data = data; + node_active = true; + } + in seq.next.prev <- seq_of_node node; seq.next <- seq_of_node node; node let add_r data seq = - let node = { node_prev = seq.prev; node_next = seq; node_data = data; node_active = true } in + let node = + { + node_prev = seq.prev; + node_next = seq; + node_data = data; + node_active = true; + } + in seq.prev.next <- seq_of_node node; seq.prev <- seq_of_node node; node let take_l seq = - if is_empty seq then - raise Empty - else begin + if is_empty seq then raise Empty + else let node = node_of_seq seq.next in remove node; node.node_data - end let take_r seq = - if is_empty seq then - raise Empty - else begin + if is_empty seq then raise Empty + else let node = node_of_seq seq.prev in remove node; node.node_data - end let take_opt_l seq = - if is_empty seq then - None - else begin + if is_empty seq then None + else let node = node_of_seq seq.next in remove node; Some node.node_data - end let take_opt_r seq = - if is_empty seq then - None - else begin + if is_empty seq then None + else let node = node_of_seq seq.prev in remove node; Some node.node_data - end let transfer_l s1 s2 = s2.next.prev <- s1.prev; @@ -127,67 +124,57 @@ let transfer_r s1 s2 = let iter_l f seq = let rec loop curr = - if curr != seq then begin + if curr != seq then ( let node = node_of_seq curr in if node.node_active then f node.node_data; - loop node.node_next - end + loop node.node_next) in loop seq.next let iter_r f seq = let rec loop curr = - if curr != seq then begin + if curr != seq then ( let node = node_of_seq curr in if node.node_active then f node.node_data; - loop node.node_prev - end + loop node.node_prev) in loop seq.prev let iter_node_l f seq = let rec loop curr = - if curr != seq then begin + if curr != seq then ( let node = node_of_seq curr in if node.node_active then f node; - loop node.node_next - end + loop node.node_next) in loop seq.next let iter_node_r f seq = let rec loop curr = - if curr != seq then begin + if curr != seq then ( let node = node_of_seq curr in if node.node_active then f node; - loop node.node_prev - end + loop node.node_prev) in loop seq.prev let fold_l f seq acc = let rec loop curr acc = - if curr == seq then - acc + if curr == seq then acc else let node = node_of_seq curr in - if node.node_active then - loop node.node_next (f node.node_data acc) - else - loop node.node_next acc + if node.node_active then loop node.node_next (f node.node_data acc) + else loop node.node_next acc in loop seq.next acc let fold_r f seq acc = let rec loop curr acc = - if curr == seq then - acc + if curr == seq then acc else let node = node_of_seq curr in - if node.node_active then - loop node.node_prev (f node.node_data acc) - else - loop node.node_prev acc + if node.node_active then loop node.node_prev (f node.node_data acc) + else loop node.node_prev acc in loop seq.prev acc @@ -196,14 +183,9 @@ let find_node_l f seq = if curr != seq then let node = node_of_seq curr in if node.node_active then - if f node.node_data then - node - else - loop node.node_next - else - loop node.node_next - else - raise Not_found + if f node.node_data then node else loop node.node_next + else loop node.node_next + else raise Not_found in loop seq.next @@ -212,14 +194,9 @@ let find_node_r f seq = if curr != seq then let node = node_of_seq curr in if node.node_active then - if f node.node_data then - node - else - loop node.node_prev - else - loop node.node_prev - else - raise Not_found + if f node.node_data then node else loop node.node_prev + else loop node.node_prev + else raise Not_found in loop seq.prev diff --git a/src/core/lwt_sequence.mli b/src/core/lwt_sequence.mli index a2691725ef..b235f9bcb6 100644 --- a/src/core/lwt_sequence.mli +++ b/src/core/lwt_sequence.mli @@ -1,150 +1,135 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Mutable sequence of elements (deprecated) *) -(** A sequence is an object holding a list of elements which support - the following operations: +(** A sequence is an object holding a list of elements which support the + following operations: - adding an element to the left or the right in time and space O(1) - taking an element from the left or the right in time and space O(1) - removing a previously added element from a sequence in time and space O(1) - removing an element while the sequence is being transversed. - @deprecated This module should be an internal implementation detail of Lwt, - and may be removed from the API at some point in the future. Use package - {{:https://github.com/mirage/lwt-dllist} [lwt-dllist]} instead. -*) + @deprecated + This module should be an internal implementation detail of Lwt, and may be + removed from the API at some point in the future. Use package + {{:https://github.com/mirage/lwt-dllist} [lwt-dllist]} instead. *) [@@@ocaml.deprecated -" Use package lwt-dllist. See - https://github.com/mirage/lwt-dllist"] +" Use package lwt-dllist. See\n https://github.com/mirage/lwt-dllist"] type 'a t - (** Type of a sequence holding values of type ['a] *) +(** Type of a sequence holding values of type ['a] *) type 'a node - (** Type of a node holding one value of type ['a] in a sequence *) +(** Type of a node holding one value of type ['a] in a sequence *) (** {2 Operation on nodes} *) val get : 'a node -> 'a - (** Returns the contents of a node *) +(** Returns the contents of a node *) val set : 'a node -> 'a -> unit - (** Change the contents of a node *) +(** Change the contents of a node *) val remove : 'a node -> unit - (** Removes a node from the sequence it is part of. It does nothing - if the node has already been removed. *) +(** Removes a node from the sequence it is part of. It does nothing if the node + has already been removed. *) (** {2 Operations on sequence} *) val create : unit -> 'a t - (** [create ()] creates a new empty sequence *) +(** [create ()] creates a new empty sequence *) val clear : 'a t -> unit (** Removes all nodes from the given sequence. The nodes are not actually mutated to note their removal. Only the sequence's pointers are updated. *) val is_empty : 'a t -> bool - (** Returns [true] iff the given sequence is empty *) +(** Returns [true] iff the given sequence is empty *) val length : 'a t -> int - (** Returns the number of elements in the given sequence. This is a - O(n) operation where [n] is the number of elements in the - sequence. *) +(** Returns the number of elements in the given sequence. This is a O(n) + operation where [n] is the number of elements in the sequence. *) val add_l : 'a -> 'a t -> 'a node - (** [add_l x s] adds [x] to the left of the sequence [s] *) +(** [add_l x s] adds [x] to the left of the sequence [s] *) val add_r : 'a -> 'a t -> 'a node - (** [add_r x s] adds [x] to the right of the sequence [s] *) +(** [add_r x s] adds [x] to the right of the sequence [s] *) exception Empty - (** Exception raised by [take_l] and [take_r] and when the sequence - is empty *) +(** Exception raised by [take_l] and [take_r] and when the sequence is empty *) val take_l : 'a t -> 'a - (** [take_l x s] remove and returns the leftmost element of [s] +(** [take_l x s] remove and returns the leftmost element of [s] - @raise Empty if the sequence is empty *) + @raise Empty if the sequence is empty *) val take_r : 'a t -> 'a - (** [take_r x s] remove and returns the rightmost element of [s] +(** [take_r x s] remove and returns the rightmost element of [s] - @raise Empty if the sequence is empty *) + @raise Empty if the sequence is empty *) val take_opt_l : 'a t -> 'a option - (** [take_opt_l x s] remove and returns [Some x] where [x] is the - leftmost element of [s] or [None] if [s] is empty *) +(** [take_opt_l x s] remove and returns [Some x] where [x] is the leftmost + element of [s] or [None] if [s] is empty *) val take_opt_r : 'a t -> 'a option - (** [take_opt_r x s] remove and returns [Some x] where [x] is the - rightmost element of [s] or [None] if [s] is empty *) +(** [take_opt_r x s] remove and returns [Some x] where [x] is the rightmost + element of [s] or [None] if [s] is empty *) val transfer_l : 'a t -> 'a t -> unit - (** [transfer_l s1 s2] removes all elements of [s1] and add them at - the left of [s2]. This operation runs in constant time and - space. *) +(** [transfer_l s1 s2] removes all elements of [s1] and add them at the left of + [s2]. This operation runs in constant time and space. *) val transfer_r : 'a t -> 'a t -> unit - (** [transfer_r s1 s2] removes all elements of [s1] and add them at - the right of [s2]. This operation runs in constant time and - space. *) +(** [transfer_r s1 s2] removes all elements of [s1] and add them at the right of + [s2]. This operation runs in constant time and space. *) (** {2 Sequence iterators} *) (** Note: it is OK to remove a node while traversing a sequence *) val iter_l : ('a -> unit) -> 'a t -> unit - (** [iter_l f s] applies [f] on all elements of [s] starting from - the left *) +(** [iter_l f s] applies [f] on all elements of [s] starting from the left *) val iter_r : ('a -> unit) -> 'a t -> unit - (** [iter_r f s] applies [f] on all elements of [s] starting from - the right *) +(** [iter_r f s] applies [f] on all elements of [s] starting from the right *) val iter_node_l : ('a node -> unit) -> 'a t -> unit - (** [iter_node_l f s] applies [f] on all nodes of [s] starting from - the left *) +(** [iter_node_l f s] applies [f] on all nodes of [s] starting from the left *) val iter_node_r : ('a node -> unit) -> 'a t -> unit - (** [iter_node_r f s] applies [f] on all nodes of [s] starting from - the right *) +(** [iter_node_r f s] applies [f] on all nodes of [s] starting from the right *) val fold_l : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b - (** [fold_l f s] is: - {[ - fold_l f s x = f en (... (f e2 (f e1 x))) - ]} - where [e1], [e2], ..., [en] are the elements of [s] - *) +(** [fold_l f s] is: + + {[ fold_l f s x = f en (... (f e2 (f e1 x))) ]} + + where [e1], [e2], ..., [en] are the elements of [s] *) val fold_r : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b - (** [fold_r f s] is: - {[ - fold_r f s x = f e1 (f e2 (... (f en x))) - ]} - where [e1], [e2], ..., [en] are the elements of [s] - *) +(** [fold_r f s] is: + + {[ fold_r f s x = f e1 (f e2 (... (f en x))) ]} + + where [e1], [e2], ..., [en] are the elements of [s] *) val find_node_opt_l : ('a -> bool) -> 'a t -> 'a node option - (** [find_node_opt_l f s] returns [Some x], where [x] is the first node of - [s] starting from the left that satisfies [f] or [None] if none - exists. *) +(** [find_node_opt_l f s] returns [Some x], where [x] is the first node of [s] + starting from the left that satisfies [f] or [None] if none exists. *) val find_node_opt_r : ('a -> bool) -> 'a t -> 'a node option - (** [find_node_opt_r f s] returns [Some x], where [x] is the first node of - [s] starting from the right that satisfies [f] or [None] if none - exists. *) +(** [find_node_opt_r f s] returns [Some x], where [x] is the first node of [s] + starting from the right that satisfies [f] or [None] if none exists. *) val find_node_l : ('a -> bool) -> 'a t -> 'a node - (** [find_node_l f s] returns the first node of [s] starting from the left - that satisfies [f] or raises [Not_found] if none exists. *) +(** [find_node_l f s] returns the first node of [s] starting from the left that + satisfies [f] or raises [Not_found] if none exists. *) val find_node_r : ('a -> bool) -> 'a t -> 'a node - (** [find_node_r f s] returns the first node of [s] starting from the right - that satisfies [f] or raises [Not_found] if none exists. *) +(** [find_node_r f s] returns the first node of [s] starting from the right that + satisfies [f] or raises [Not_found] if none exists. *) diff --git a/src/core/lwt_stream.ml b/src/core/lwt_stream.ml index 011a45b717..979ce0578e 100644 --- a/src/core/lwt_stream.ml +++ b/src/core/lwt_stream.ml @@ -1,8 +1,6 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Lwt.Infix exception Closed @@ -14,7 +12,7 @@ type 'a node = { mutable next : 'a node; (* Next node in the queue. For the last node it points to itself. *) mutable data : 'a option; - (* Data of this node. For the last node it is always [None]. *) + (* Data of this node. For the last node it is always [None]. *) } (* Note: a queue for an exhausted stream is represented by a node @@ -30,13 +28,13 @@ type 'a from = { from_create : unit -> 'a option Lwt.t; (* Function used to create new elements. *) mutable from_thread : unit Lwt.t; - (* Thread which: + (* Thread which: - - wait for the thread returned by the last call to [from_next], - - add the next element to the end of the queue. + - wait for the thread returned by the last call to [from_next], + - add the next element to the end of the queue. - If it is a sleeping thread, then it must be used instead of creating a - new one with [from_create]. *) + If it is a sleeping thread, then it must be used instead of creating a + new one with [from_create]. *) } (* Type of a stream source for push streams. *) @@ -45,8 +43,8 @@ type push = { (* Thread signaled when a new element is added to the stream. *) mutable push_waiting : bool; (* Is a thread waiting on [push_signal] ? *) - mutable push_external : Obj.t [@ocaml.warning "-69"]; - (* Reference to an external source. *) + mutable push_external : Obj.t; [@ocaml.warning "-69"] + (* Reference to an external source. *) } (* Type of a stream source for bounded-push streams. *) @@ -66,8 +64,8 @@ type 'a push_bounded = { mutable pushb_push_waiter : unit Lwt.t; mutable pushb_push_wakener : unit Lwt.u; (* Thread blocked on push. *) - mutable pushb_external : Obj.t [@ocaml.warning "-69"]; - (* Reference to an external source. *) + mutable pushb_external : Obj.t; [@ocaml.warning "-69"] + (* Reference to an external source. *) } (* Source of a stream. *) @@ -86,77 +84,57 @@ type 'a t = { (* Pointer to first pending element, or to [last] if there is no pending element. *) last : 'a node ref; - (* Node marking the end of the queue of pending elements. *) + (* Node marking the end of the queue of pending elements. *) } -class type ['a] bounded_push = object - method size : int - method resize : int -> unit - method push : 'a -> unit Lwt.t - method close : unit - method count : int - method blocked : bool - method closed : bool - method set_reference : 'a. 'a -> unit -end +class type ['a] bounded_push = + object + method size : int + method resize : int -> unit + method push : 'a -> unit Lwt.t + method close : unit + method count : int + method blocked : bool + method closed : bool + method set_reference : 'a. 'a -> unit + end (* The only difference between two clones is the pointer to the first pending element. *) let clone s = (match s.source with - | Push_bounded _ -> invalid_arg "Lwt_stream.clone" - | From _ | From_direct _ | Push _ -> ()); - { - source = s.source; - close = s.close; - node = s.node; - last = s.last; - } + | Push_bounded _ -> invalid_arg "Lwt_stream.clone" + | From _ | From_direct _ | Push _ -> ()); + { source = s.source; close = s.close; node = s.node; last = s.last } let from_source source = let last = new_node () in let _, close = Lwt.wait () in - { source = source - ; close = close - ; node = last - ; last = ref last - } + { source; close; node = last; last = ref last } let from f = from_source (From { from_create = f; from_thread = Lwt.return_unit }) -let from_direct f = - from_source (From_direct f) - -let closed s = - (Lwt.waiter_of_wakener [@ocaml.warning "-3"]) s.close - -let is_closed s = - not (Lwt.is_sleeping (closed s)) - -let on_termination s f = - Lwt.async (fun () -> closed s >|= f) - +let from_direct f = from_source (From_direct f) +let closed s = (Lwt.waiter_of_wakener [@ocaml.warning "-3"]) s.close +let is_closed s = not (Lwt.is_sleeping (closed s)) +let on_termination s f = Lwt.async (fun () -> closed s >|= f) let on_terminate = on_termination let enqueue' e last = - let node = !last - and new_last = new_node () in + let node = !last and new_last = new_node () in node.data <- e; node.next <- new_last; last := new_last -let enqueue e s = - enqueue' e s.last +let enqueue e s = enqueue' e s.last let create_with_reference () = (* Create the source for notifications of new elements. *) let source, push_signal_resolver = let push_signal, push_signal_resolver = Lwt.wait () in - ({ push_signal; - push_waiting = false; - push_external = Obj.repr () }, - ref push_signal_resolver) + ( { push_signal; push_waiting = false; push_external = Obj.repr () }, + ref push_signal_resolver ) in let t = from_source (Push source) in (* [push] should not close over [t] so that it can be garbage collected even @@ -165,13 +143,13 @@ let create_with_reference () = let close = t.close and last = t.last in (* The push function. It does not keep a reference to the stream. *) let push x = - let waiter_of_wakener = Lwt.waiter_of_wakener [@ocaml.warning "-3"] in + let waiter_of_wakener = (Lwt.waiter_of_wakener [@ocaml.warning "-3"]) in if not (Lwt.is_sleeping (waiter_of_wakener close)) then raise Closed; (* Push the element at the end of the queue. *) enqueue' x last; (* Send a signal if at least one thread is waiting for a new element. *) - if source.push_waiting then begin + if source.push_waiting then ( source.push_waiting <- false; (* Update threads. *) let old_push_signal_resolver = !push_signal_resolver in @@ -179,8 +157,7 @@ let create_with_reference () = source.push_signal <- new_waiter; push_signal_resolver := new_push_signal_resolver; (* Signal that a new value has been received. *) - Lwt.wakeup_later old_push_signal_resolver () - end; + Lwt.wakeup_later old_push_signal_resolver ()); (* Do this at the end in case one of the function raise an exception. *) if x = None then Lwt.wakeup close () @@ -198,9 +175,9 @@ let return_lwt a = Lwt.dont_wait (fun () -> Lwt.bind a (fun x -> - push (Some x); - push None; - Lwt.return_unit)) + push (Some x); + push None; + Lwt.return_unit)) (fun _exc -> push None); source @@ -209,7 +186,9 @@ let of_seq s = let get () = match !s () with | Seq.Nil -> None - | Seq.Cons (elt, s') -> s := s'; Some elt + | Seq.Cons (elt, s') -> + s := s'; + Some elt in from_direct get @@ -218,11 +197,12 @@ let of_lwt_seq s = let get () = !s () >|= function | Lwt_seq.Nil -> None - | Lwt_seq.Cons (elt, s') -> s := s'; Some elt + | Lwt_seq.Cons (elt, s') -> + s := s'; + Some elt in from get - let create () = let source, push, _ = create_with_reference () in (source, push) @@ -233,14 +213,9 @@ let of_iter iter i = push None; stream -let of_list l = - of_iter List.iter l - -let of_array a = - of_iter Array.iter a - -let of_string s = - of_iter String.iter s +let of_list l = of_iter List.iter l +let of_array a = of_iter Array.iter a +let of_string s = of_iter String.iter s (* Add the pending element to the queue and notify the blocked pushed. @@ -259,92 +234,77 @@ let notify_pusher info last = info.pushb_push_wakener <- wakener; Lwt.wakeup_later old_wakener () -class ['a] bounded_push_impl (info : 'a push_bounded) wakener_cell last close = object - val mutable closed = false - - method size = - info.pushb_size - - method resize size = - if size < 0 then invalid_arg "Lwt_stream.bounded_push#resize"; - info.pushb_size <- size; - if info.pushb_count < info.pushb_size && info.pushb_pending <> None then begin - info.pushb_count <- info.pushb_count + 1; - notify_pusher info last - end - - method push x = - if closed then - Lwt.fail Closed - else if info.pushb_pending <> None then - Lwt.fail Full - else if info.pushb_count >= info.pushb_size then begin - info.pushb_pending <- Some x; - Lwt.catch - (fun () -> info.pushb_push_waiter) - (fun exn -> - match exn with - | Lwt.Canceled -> - info.pushb_pending <- None; - let waiter, wakener = Lwt.task () in - info.pushb_push_waiter <- waiter; - info.pushb_push_wakener <- wakener; - Lwt.fail exn - | _ -> - Lwt.fail exn) - end else begin - (* Push the element at the end of the queue. *) - enqueue' (Some x) last; - info.pushb_count <- info.pushb_count + 1; - (* Send a signal if at least one thread is waiting for a new - element. *) - if info.pushb_waiting then begin - info.pushb_waiting <- false; - (* Update threads. *) - let old_wakener = !wakener_cell in - let new_waiter, new_wakener = Lwt.wait () in - info.pushb_signal <- new_waiter; - wakener_cell := new_wakener; - (* Signal that a new value has been received. *) - Lwt.wakeup_later old_wakener () - end; - Lwt.return_unit - end - - method close = - if not closed then begin - closed <- true; - let node = !last and new_last = new_node () in - node.data <- None; - node.next <- new_last; - last := new_last; - if info.pushb_pending <> None then begin - info.pushb_pending <- None; - Lwt.wakeup_later_exn info.pushb_push_wakener Closed - end; - (* Send a signal if at least one thread is waiting for a new - element. *) - if info.pushb_waiting then begin - info.pushb_waiting <- false; - let old_wakener = !wakener_cell in - (* Signal that a new value has been received. *) - Lwt.wakeup_later old_wakener () - end; - Lwt.wakeup close (); - end - - method count = - info.pushb_count - - method blocked = - info.pushb_pending <> None - - method closed = - closed - - method set_reference : 'a. 'a -> unit = - fun x -> info.pushb_external <- Obj.repr x -end +class ['a] bounded_push_impl (info : 'a push_bounded) wakener_cell last close = + object + val mutable closed = false + method size = info.pushb_size + + method resize size = + if size < 0 then invalid_arg "Lwt_stream.bounded_push#resize"; + info.pushb_size <- size; + if info.pushb_count < info.pushb_size && info.pushb_pending <> None then ( + info.pushb_count <- info.pushb_count + 1; + notify_pusher info last) + + method push x = + if closed then Lwt.fail Closed + else if info.pushb_pending <> None then Lwt.fail Full + else if info.pushb_count >= info.pushb_size then ( + info.pushb_pending <- Some x; + Lwt.catch + (fun () -> info.pushb_push_waiter) + (fun exn -> + match exn with + | Lwt.Canceled -> + info.pushb_pending <- None; + let waiter, wakener = Lwt.task () in + info.pushb_push_waiter <- waiter; + info.pushb_push_wakener <- wakener; + Lwt.fail exn + | _ -> Lwt.fail exn)) + else ( + (* Push the element at the end of the queue. *) + enqueue' (Some x) last; + info.pushb_count <- info.pushb_count + 1; + (* Send a signal if at least one thread is waiting for a new + element. *) + if info.pushb_waiting then ( + info.pushb_waiting <- false; + (* Update threads. *) + let old_wakener = !wakener_cell in + let new_waiter, new_wakener = Lwt.wait () in + info.pushb_signal <- new_waiter; + wakener_cell := new_wakener; + (* Signal that a new value has been received. *) + Lwt.wakeup_later old_wakener ()); + Lwt.return_unit) + + method close = + if not closed then ( + closed <- true; + let node = !last and new_last = new_node () in + node.data <- None; + node.next <- new_last; + last := new_last; + if info.pushb_pending <> None then ( + info.pushb_pending <- None; + Lwt.wakeup_later_exn info.pushb_push_wakener Closed); + (* Send a signal if at least one thread is waiting for a new + element. *) + if info.pushb_waiting then ( + info.pushb_waiting <- false; + let old_wakener = !wakener_cell in + (* Signal that a new value has been received. *) + Lwt.wakeup_later old_wakener ()); + Lwt.wakeup close ()) + + method count = info.pushb_count + method blocked = info.pushb_pending <> None + method closed = closed + + method set_reference : 'a. 'a -> unit = + fun x -> info.pushb_external <- Obj.repr x + end let create_bounded size = if size < 0 then invalid_arg "Lwt_stream.create_bounded"; @@ -352,15 +312,17 @@ let create_bounded size = let info, wakener_cell = let waiter, wakener = Lwt.wait () in let push_waiter, push_wakener = Lwt.task () in - ({ pushb_signal = waiter; - pushb_waiting = false; - pushb_size = size; - pushb_count = 0; - pushb_pending = None; - pushb_push_waiter = push_waiter; - pushb_push_wakener = push_wakener; - pushb_external = Obj.repr () }, - ref wakener) + ( { + pushb_signal = waiter; + pushb_waiting = false; + pushb_size = size; + pushb_count = 0; + pushb_pending = None; + pushb_push_waiter = push_waiter; + pushb_push_wakener = push_wakener; + pushb_external = Obj.repr (); + }, + ref wakener ) in let t = from_source (Push_bounded info) in (t, new bounded_push_impl info wakener_cell t.last t.close) @@ -370,35 +332,33 @@ let create_bounded size = let feed s = match s.source with | From from -> - (* There is already a thread started to create a new element, - wait for this one to terminate. *) - if Lwt.is_sleeping from.from_thread then - Lwt.protected from.from_thread - else begin - (* Otherwise request a new element. *) - let thread = - from.from_create () >>= fun x -> - (* Push the element to the end of the queue. *) - enqueue x s; - if x = None then Lwt.wakeup s.close (); - Lwt.return_unit - in - (* Allow other threads to access this thread. *) - from.from_thread <- thread; - Lwt.protected thread - end + (* There is already a thread started to create a new element, + wait for this one to terminate. *) + if Lwt.is_sleeping from.from_thread then Lwt.protected from.from_thread + else + (* Otherwise request a new element. *) + let thread = + from.from_create () >>= fun x -> + (* Push the element to the end of the queue. *) + enqueue x s; + if x = None then Lwt.wakeup s.close (); + Lwt.return_unit + in + (* Allow other threads to access this thread. *) + from.from_thread <- thread; + Lwt.protected thread | From_direct f -> - let x = f () in - (* Push the element to the end of the queue. *) - enqueue x s; - if x = None then Lwt.wakeup s.close (); - Lwt.return_unit + let x = f () in + (* Push the element to the end of the queue. *) + enqueue x s; + if x = None then Lwt.wakeup s.close (); + Lwt.return_unit | Push push -> - push.push_waiting <- true; - Lwt.protected push.push_signal + push.push_waiting <- true; + Lwt.protected push.push_signal | Push_bounded push -> - push.pushb_waiting <- true; - Lwt.protected push.pushb_signal + push.pushb_waiting <- true; + Lwt.protected push.pushb_signal (* Remove [node] from the top of the queue, or do nothing if it was already consumed. @@ -406,53 +366,40 @@ let feed s = Precondition: node.data <> None *) let consume s node = - if node == s.node then begin + if node == s.node then ( s.node <- node.next; match s.source with | Push_bounded info -> - if info.pushb_pending = None then - info.pushb_count <- info.pushb_count - 1 - else - notify_pusher info s.last - | From _ | From_direct _ | Push _ -> - () - end + if info.pushb_pending = None then + info.pushb_count <- info.pushb_count - 1 + else notify_pusher info s.last + | From _ | From_direct _ | Push _ -> ()) let rec peek_rec s node = - if node == !(s.last) then - feed s >>= fun () -> peek_rec s node - else - Lwt.return node.data + if node == !(s.last) then feed s >>= fun () -> peek_rec s node + else Lwt.return node.data let peek s = peek_rec s s.node let rec npeek_rec node acc n s = - if n <= 0 then - Lwt.return (List.rev acc) - else if node == !(s.last) then - feed s >>= fun () -> npeek_rec node acc n s + if n <= 0 then Lwt.return (List.rev acc) + else if node == !(s.last) then feed s >>= fun () -> npeek_rec node acc n s else match node.data with - | Some x -> - npeek_rec node.next (x :: acc) (n - 1) s - | None -> - Lwt.return (List.rev acc) + | Some x -> npeek_rec node.next (x :: acc) (n - 1) s + | None -> Lwt.return (List.rev acc) let npeek n s = npeek_rec s.node [] n s let rec get_rec s node = - if node == !(s.last) then - feed s >>= fun () -> get_rec s node - else begin + if node == !(s.last) then feed s >>= fun () -> get_rec s node + else ( if node.data <> None then consume s node; - Lwt.return node.data - end + Lwt.return node.data) let get s = get_rec s s.node -type 'a result = - | Value of 'a - | Error of exn +type 'a result = Value of 'a | Error of exn let rec get_exn_rec s node = if node == !(s.last) then @@ -460,19 +407,18 @@ let rec get_exn_rec s node = (fun () -> feed s) (fun () -> get_exn_rec s node) (fun exn -> Lwt.return (Some (Error exn : _ result))) - (* Note: the [Error] constructor above is from [Lwt_stream.result], not - [Pervasives.result], nor its alias [Lwt.result]. [Lwt_stream.result] is - a deprecated type, defined right above this function. + (* Note: the [Error] constructor above is from [Lwt_stream.result], not + [Pervasives.result], nor its alias [Lwt.result]. [Lwt_stream.result] is + a deprecated type, defined right above this function. - The type constraint is necessary to avoid a warning about an ambiguous - constructor. *) + The type constraint is necessary to avoid a warning about an ambiguous + constructor. *) else match node.data with | Some value -> - consume s node; - Lwt.return (Some (Value value)) - | None -> - Lwt.return_none + consume s node; + Lwt.return (Some (Value value)) + | None -> Lwt.return_none let map_exn s = from (fun () -> get_exn_rec s s.node) @@ -485,73 +431,60 @@ let rec get_exn_rec' s node = else match node.data with | Some value -> - consume s node; - Lwt.return (Some (Result.Ok value)) - | None -> - Lwt.return_none + consume s node; + Lwt.return (Some (Result.Ok value)) + | None -> Lwt.return_none let wrap_exn s = from (fun () -> get_exn_rec' s s.node) let rec nget_rec node acc n s = - if n <= 0 then - Lwt.return (List.rev acc) - else if node == !(s.last) then - feed s >>= fun () -> nget_rec node acc n s + if n <= 0 then Lwt.return (List.rev acc) + else if node == !(s.last) then feed s >>= fun () -> nget_rec node acc n s else match s.node.data with | Some x -> - consume s node; - nget_rec node.next (x :: acc) (n - 1) s - | None -> - Lwt.return (List.rev acc) + consume s node; + nget_rec node.next (x :: acc) (n - 1) s + | None -> Lwt.return (List.rev acc) let nget n s = nget_rec s.node [] n s let rec get_while_rec node acc f s = - if node == !(s.last) then - feed s >>= fun () -> get_while_rec node acc f s + if node == !(s.last) then feed s >>= fun () -> get_while_rec node acc f s else match node.data with | Some x -> - let test = f x in - if test then begin - consume s node; - get_while_rec node.next (x :: acc) f s - end else - Lwt.return (List.rev acc) - | None -> - Lwt.return (List.rev acc) + let test = f x in + if test then ( + consume s node; + get_while_rec node.next (x :: acc) f s) + else Lwt.return (List.rev acc) + | None -> Lwt.return (List.rev acc) let get_while f s = get_while_rec s.node [] f s let rec get_while_s_rec node acc f s = - if node == !(s.last) then - feed s >>= fun () -> get_while_s_rec node acc f s + if node == !(s.last) then feed s >>= fun () -> get_while_s_rec node acc f s else match node.data with - | Some x -> begin + | Some x -> ( f x >>= function | true -> - consume s node; - get_while_s_rec node.next (x :: acc) f s - | false -> - Lwt.return (List.rev acc) - end - | None -> - Lwt.return (List.rev acc) + consume s node; + get_while_s_rec node.next (x :: acc) f s + | false -> Lwt.return (List.rev acc)) + | None -> Lwt.return (List.rev acc) let get_while_s f s = get_while_s_rec s.node [] f s let rec next_rec s node = - if node == !(s.last) then - feed s >>= fun () -> next_rec s node + if node == !(s.last) then feed s >>= fun () -> next_rec s node else match node.data with | Some x -> - consume s node; - Lwt.return x - | None -> - Lwt.fail Empty + consume s node; + Lwt.return x + | None -> Lwt.fail Empty let next s = next_rec s s.node @@ -559,122 +492,100 @@ let rec last_new_rec node x s = if node == !(s.last) then let thread = feed s in match Lwt.state thread with - | Lwt.Return _ -> - last_new_rec node x s - | Lwt.Fail exn -> - Lwt.fail exn - | Lwt.Sleep -> - Lwt.return x + | Lwt.Return _ -> last_new_rec node x s + | Lwt.Fail exn -> Lwt.fail exn + | Lwt.Sleep -> Lwt.return x else match node.data with | Some x -> - consume s node; - last_new_rec node.next x s - | None -> - Lwt.return x + consume s node; + last_new_rec node.next x s + | None -> Lwt.return x let last_new s = let node = s.node in if node == !(s.last) then let thread = next s in match Lwt.state thread with - | Lwt.Return x -> - last_new_rec node x s - | Lwt.Fail _ | Lwt.Sleep -> - thread + | Lwt.Return x -> last_new_rec node x s + | Lwt.Fail _ | Lwt.Sleep -> thread else match node.data with | Some x -> - consume s node; - last_new_rec node.next x s - | None -> - Lwt.fail Empty + consume s node; + last_new_rec node.next x s + | None -> Lwt.fail Empty let rec to_list_rec node acc s = - if node == !(s.last) then - feed s >>= fun () -> to_list_rec node acc s + if node == !(s.last) then feed s >>= fun () -> to_list_rec node acc s else match node.data with | Some x -> - consume s node; - to_list_rec node.next (x :: acc) s - | None -> - Lwt.return (List.rev acc) + consume s node; + to_list_rec node.next (x :: acc) s + | None -> Lwt.return (List.rev acc) let to_list s = to_list_rec s.node [] s let rec to_string_rec node buf s = - if node == !(s.last) then - feed s >>= fun () -> to_string_rec node buf s + if node == !(s.last) then feed s >>= fun () -> to_string_rec node buf s else match node.data with | Some x -> - consume s node; - Buffer.add_char buf x; - to_string_rec node.next buf s - | None -> - Lwt.return (Buffer.contents buf) + consume s node; + Buffer.add_char buf x; + to_string_rec node.next buf s + | None -> Lwt.return (Buffer.contents buf) let to_string s = to_string_rec s.node (Buffer.create 128) s let junk s = let node = s.node in - if node == !(s.last) then begin + if node == !(s.last) then ( feed s >>= fun () -> if node.data <> None then consume s node; - Lwt.return_unit - end else begin + Lwt.return_unit) + else ( if node.data <> None then consume s node; - Lwt.return_unit - end + Lwt.return_unit) let rec njunk_rec node n s = - if n <= 0 then - Lwt.return_unit - else if node == !(s.last) then - feed s >>= fun () -> njunk_rec node n s + if n <= 0 then Lwt.return_unit + else if node == !(s.last) then feed s >>= fun () -> njunk_rec node n s else match node.data with | Some _ -> - consume s node; - njunk_rec node.next (n - 1) s - | None -> - Lwt.return_unit + consume s node; + njunk_rec node.next (n - 1) s + | None -> Lwt.return_unit let njunk n s = njunk_rec s.node n s let rec junk_while_rec node f s = - if node == !(s.last) then - feed s >>= fun () -> junk_while_rec node f s + if node == !(s.last) then feed s >>= fun () -> junk_while_rec node f s else match node.data with | Some x -> - let test = f x in - if test then begin - consume s node; - junk_while_rec node.next f s - end else - Lwt.return_unit - | None -> - Lwt.return_unit + let test = f x in + if test then ( + consume s node; + junk_while_rec node.next f s) + else Lwt.return_unit + | None -> Lwt.return_unit let junk_while f s = junk_while_rec s.node f s let rec junk_while_s_rec node f s = - if node == !(s.last) then - feed s >>= fun () -> junk_while_s_rec node f s + if node == !(s.last) then feed s >>= fun () -> junk_while_s_rec node f s else match node.data with - | Some x -> begin + | Some x -> ( f x >>= function | true -> - consume s node; - junk_while_s_rec node.next f s - | false -> - Lwt.return_unit - end - | None -> - Lwt.return_unit + consume s node; + junk_while_s_rec node.next f s + | false -> Lwt.return_unit) + | None -> Lwt.return_unit let junk_while_s f s = junk_while_s_rec s.node f s @@ -682,19 +593,15 @@ let rec junk_old_rec node s = if node == !(s.last) then let thread = feed s in match Lwt.state thread with - | Lwt.Return _ -> - junk_old_rec node s - | Lwt.Fail exn -> - Lwt.fail exn - | Lwt.Sleep -> - Lwt.return_unit + | Lwt.Return _ -> junk_old_rec node s + | Lwt.Fail exn -> Lwt.fail exn + | Lwt.Sleep -> Lwt.return_unit else match node.data with | Some _ -> - consume s node; - junk_old_rec node.next s - | None -> - Lwt.return_unit + consume s node; + junk_old_rec node.next s + | None -> Lwt.return_unit let junk_old s = junk_old_rec s.node s @@ -702,77 +609,61 @@ let rec get_available_rec node acc s = if node == !(s.last) then let thread = feed s in match Lwt.state thread with - | Lwt.Return _ -> - get_available_rec node acc s - | Lwt.Fail exn -> - raise exn - | Lwt.Sleep -> - List.rev acc + | Lwt.Return _ -> get_available_rec node acc s + | Lwt.Fail exn -> raise exn + | Lwt.Sleep -> List.rev acc else match node.data with | Some x -> - consume s node; - get_available_rec node.next (x :: acc) s - | None -> - List.rev acc + consume s node; + get_available_rec node.next (x :: acc) s + | None -> List.rev acc let get_available s = get_available_rec s.node [] s let rec get_available_up_to_rec node acc n s = - if n <= 0 then - List.rev acc + if n <= 0 then List.rev acc else if node == !(s.last) then let thread = feed s in match Lwt.state thread with - | Lwt.Return _ -> - get_available_up_to_rec node acc n s - | Lwt.Fail exn -> - raise exn - | Lwt.Sleep -> - List.rev acc + | Lwt.Return _ -> get_available_up_to_rec node acc n s + | Lwt.Fail exn -> raise exn + | Lwt.Sleep -> List.rev acc else match s.node.data with | Some x -> - consume s node; - get_available_up_to_rec node.next (x :: acc) (n - 1) s - | None -> - List.rev acc + consume s node; + get_available_up_to_rec node.next (x :: acc) (n - 1) s + | None -> List.rev acc let get_available_up_to n s = get_available_up_to_rec s.node [] n s let rec is_empty s = - if s.node == !(s.last) then - feed s >>= fun () -> is_empty s - else - Lwt.return (s.node.data = None) + if s.node == !(s.last) then feed s >>= fun () -> is_empty s + else Lwt.return (s.node.data = None) let map f s = - from (fun () -> get s >|= function - | Some x -> - let x = f x in - Some x - | None -> - None) + from (fun () -> + get s >|= function + | Some x -> + let x = f x in + Some x + | None -> None) let map_s f s = - from (fun () -> get s >>= function - | Some x -> - f x >|= (fun x -> Some x) - | None -> - Lwt.return_none) + from (fun () -> + get s >>= function + | Some x -> f x >|= fun x -> Some x + | None -> Lwt.return_none) let filter f s = let rec next () = let t = get s in t >>= function | Some x -> - let test = f x in - if test then - t - else - next () - | None -> - Lwt.return_none + let test = f x in + if test then t else next () + | None -> Lwt.return_none in from next @@ -780,45 +671,28 @@ let filter_s f s = let rec next () = let t = get s in t >>= function - | Some x -> begin - f x >>= function - | true -> - t - | false -> - next () - end - | None -> - t + | Some x -> ( f x >>= function true -> t | false -> next ()) + | None -> t in from next let filter_map f s = let rec next () = get s >>= function - | Some x -> - let x = f x in - (match x with - | Some _ -> - Lwt.return x - | None -> - next ()) - | None -> - Lwt.return_none + | Some x -> ( + let x = f x in + match x with Some _ -> Lwt.return x | None -> next ()) + | None -> Lwt.return_none in from next let filter_map_s f s = let rec next () = get s >>= function - | Some x -> - let t = f x in - (t >>= function - | Some _ -> - t - | None -> - next ()) - | None -> - Lwt.return_none + | Some x -> ( + let t = f x in + t >>= function Some _ -> t | None -> next ()) + | None -> Lwt.return_none in from next @@ -826,17 +700,16 @@ let map_list f s = let pendings = ref [] in let rec next () = match !pendings with - | [] -> - (get s >>= function - | Some x -> - let l = f x in - pendings := l; - next () - | None -> - Lwt.return_none) + | [] -> ( + get s >>= function + | Some x -> + let l = f x in + pendings := l; + next () + | None -> Lwt.return_none) | x :: l -> - pendings := l; - Lwt.return (Some x) + pendings := l; + Lwt.return (Some x) in from next @@ -844,189 +717,145 @@ let map_list_s f s = let pendings = ref [] in let rec next () = match !pendings with - | [] -> - (get s >>= function - | Some x -> - f x >>= fun l -> - pendings := l; - next () - | None -> - Lwt.return_none) + | [] -> ( + get s >>= function + | Some x -> + f x >>= fun l -> + pendings := l; + next () + | None -> Lwt.return_none) | x :: l -> - pendings := l; - Lwt.return (Some x) + pendings := l; + Lwt.return (Some x) in from next -let flatten s = - map_list (fun l -> l) s +let flatten s = map_list (fun l -> l) s let rec fold_rec node f s acc = - if node == !(s.last) then - feed s >>= fun () -> fold_rec node f s acc + if node == !(s.last) then feed s >>= fun () -> fold_rec node f s acc else match node.data with | Some x -> - consume s node; - let acc = f x acc in - fold_rec node.next f s acc - | None -> - Lwt.return acc + consume s node; + let acc = f x acc in + fold_rec node.next f s acc + | None -> Lwt.return acc let fold f s acc = fold_rec s.node f s acc let rec fold_s_rec node f s acc = - if node == !(s.last) then - feed s >>= fun () -> fold_s_rec node f s acc + if node == !(s.last) then feed s >>= fun () -> fold_s_rec node f s acc else match node.data with | Some x -> - consume s node; - f x acc >>= fun acc -> - fold_s_rec node.next f s acc - | None -> - Lwt.return acc + consume s node; + f x acc >>= fun acc -> fold_s_rec node.next f s acc + | None -> Lwt.return acc let fold_s f s acc = fold_s_rec s.node f s acc let rec iter_rec node f s = - if node == !(s.last) then - feed s >>= fun () -> iter_rec node f s + if node == !(s.last) then feed s >>= fun () -> iter_rec node f s else match node.data with | Some x -> - consume s node; - let () = f x in - iter_rec node.next f s - | None -> - Lwt.return_unit + consume s node; + let () = f x in + iter_rec node.next f s + | None -> Lwt.return_unit let iter f s = iter_rec s.node f s let rec iter_s_rec node f s = - if node == !(s.last) then - feed s >>= fun () -> iter_s_rec node f s + if node == !(s.last) then feed s >>= fun () -> iter_s_rec node f s else match node.data with | Some x -> - consume s node; - f x >>= fun () -> - iter_s_rec node.next f s - | None -> - Lwt.return_unit + consume s node; + f x >>= fun () -> iter_s_rec node.next f s + | None -> Lwt.return_unit let iter_s f s = iter_s_rec s.node f s let rec iter_p_rec node f s = - if node == !(s.last) then - feed s >>= fun () -> iter_p_rec node f s + if node == !(s.last) then feed s >>= fun () -> iter_p_rec node f s else match node.data with | Some x -> - consume s node; - let res = f x in - let rest = iter_p_rec node.next f s in - res >>= fun () -> rest - | None -> - Lwt.return_unit + consume s node; + let res = f x in + let rest = iter_p_rec node.next f s in + res >>= fun () -> rest + | None -> Lwt.return_unit let iter_p f s = iter_p_rec s.node f s let iter_n ?(max_concurrency = 1) f stream = - begin - if max_concurrency <= 0 then - let message = - Printf.sprintf - "Lwt_stream.iter_n: max_concurrency must be > 0, %d given" - max_concurrency - in - invalid_arg message - end; + (if max_concurrency <= 0 then + let message = + Printf.sprintf "Lwt_stream.iter_n: max_concurrency must be > 0, %d given" + max_concurrency + in + invalid_arg message); let rec loop running available = - begin - if available > 0 then ( - Lwt.return (running, available) - ) - else ( - Lwt.nchoose_split running >>= fun (complete, running) -> - Lwt.return (running, available + List.length complete) - ) - end >>= fun (running, available) -> + (if available > 0 then Lwt.return (running, available) + else + Lwt.nchoose_split running >>= fun (complete, running) -> + Lwt.return (running, available + List.length complete)) + >>= fun (running, available) -> get stream >>= function - | None -> - Lwt.join running - | Some elt -> - loop (f elt :: running) (pred available) + | None -> Lwt.join running + | Some elt -> loop (f elt :: running) (pred available) in loop [] max_concurrency let rec find_rec node f s = - if node == !(s.last) then - feed s >>= fun () -> find_rec node f s + if node == !(s.last) then feed s >>= fun () -> find_rec node f s else match node.data with | Some x as opt -> - consume s node; - let test = f x in - if test then - Lwt.return opt - else - find_rec node.next f s - | None -> - Lwt.return_none + consume s node; + let test = f x in + if test then Lwt.return opt else find_rec node.next f s + | None -> Lwt.return_none let find f s = find_rec s.node f s let rec find_s_rec node f s = - if node == !(s.last) then - feed s >>= fun () -> find_s_rec node f s + if node == !(s.last) then feed s >>= fun () -> find_s_rec node f s else match node.data with - | Some x as opt -> begin + | Some x as opt -> ( consume s node; f x >>= function - | true -> - Lwt.return opt - | false -> - find_s_rec node.next f s - end - | None -> - Lwt.return_none + | true -> Lwt.return opt + | false -> find_s_rec node.next f s) + | None -> Lwt.return_none let find_s f s = find_s_rec s.node f s let rec find_map_rec node f s = - if node == !(s.last) then - feed s >>= fun () -> find_map_rec node f s + if node == !(s.last) then feed s >>= fun () -> find_map_rec node f s else match node.data with | Some x -> - consume s node; - let x = f x in - if x = None then - find_map_rec node.next f s - else - Lwt.return x - | None -> - Lwt.return_none + consume s node; + let x = f x in + if x = None then find_map_rec node.next f s else Lwt.return x + | None -> Lwt.return_none let find_map f s = find_map_rec s.node f s let rec find_map_s_rec node f s = - if node == !(s.last) then - feed s >>= fun () -> find_map_s_rec node f s + if node == !(s.last) then feed s >>= fun () -> find_map_s_rec node f s else match node.data with - | Some x -> - consume s node; - let t = f x in - (t >>= function - | None -> - find_map_s_rec node.next f s - | Some _ -> - t) - | None -> - Lwt.return_none + | Some x -> ( + consume s node; + let t = f x in + t >>= function None -> find_map_s_rec node.next f s | Some _ -> t) + | None -> Lwt.return_none let find_map_s f s = find_map_s_rec s.node f s @@ -1035,11 +864,9 @@ let combine s1 s2 = let t1 = get s1 and t2 = get s2 in t1 >>= fun n1 -> t2 >>= fun n2 -> - match n1, n2 with - | Some x1, Some x2 -> - Lwt.return (Some(x1, x2)) - | _ -> - Lwt.return_none + match (n1, n2) with + | Some x1, Some x2 -> Lwt.return (Some (x1, x2)) + | _ -> Lwt.return_none in from next @@ -1048,15 +875,12 @@ let append s1 s2 = let rec next () = let t = get !current_s in t >>= function - | Some _ -> - t + | Some _ -> t | None -> - if !current_s == s2 then - Lwt.return_none - else begin - current_s := s2; - next () - end + if !current_s == s2 then Lwt.return_none + else ( + current_s := s2; + next ()) in from next @@ -1065,15 +889,13 @@ let concat s_top = let rec next () = let t = get !current_s in t >>= function - | Some _ -> - t - | None -> - get s_top >>= function - | Some s -> - current_s := s; - next () - | None -> - Lwt.return_none + | Some _ -> t + | None -> ( + get s_top >>= function + | Some s -> + current_s := s; + next () + | None -> Lwt.return_none) in from next @@ -1082,61 +904,58 @@ let choose streams = let streams = ref (List.map source streams) in let rec next () = match !streams with - | [] -> - Lwt.return_none - | l -> - Lwt.choose (List.map snd l) >>= fun (s, x) -> - let l = List.remove_assq s l in - match x with - | Some _ -> - streams := source s :: l; - Lwt.return x - | None -> - streams := l; - next () + | [] -> Lwt.return_none + | l -> ( + Lwt.choose (List.map snd l) >>= fun (s, x) -> + let l = List.remove_assq s l in + match x with + | Some _ -> + streams := source s :: l; + Lwt.return x + | None -> + streams := l; + next ()) in from next let parse s f = (match s.source with - | Push_bounded _ -> invalid_arg "Lwt_stream.parse" - | From _ | From_direct _ | Push _ -> ()); + | Push_bounded _ -> invalid_arg "Lwt_stream.parse" + | From _ | From_direct _ | Push _ -> ()); let node = s.node in Lwt.catch (fun () -> f s) (fun exn -> - s.node <- node; - Lwt.fail exn) + s.node <- node; + Lwt.fail exn) let hexdump stream = let buf = Buffer.create 80 and num = ref 0 in - from begin fun _ -> - nget 16 stream >>= function - | [] -> - Lwt.return_none - | l -> - Buffer.clear buf; - Printf.bprintf buf "%08x| " !num; - num := !num + 16; - let rec bytes pos = function - | [] -> - blanks pos - | x :: l -> - if pos = 8 then Buffer.add_char buf ' '; - Printf.bprintf buf "%02x " (Char.code x); - bytes (pos + 1) l - and blanks pos = - if pos < 16 then begin - if pos = 8 then - Buffer.add_string buf " " - else - Buffer.add_string buf " "; - blanks (pos + 1) - end - in - bytes 0 l; - Buffer.add_string buf " |"; - List.iter (fun ch -> Buffer.add_char buf (if ch >= '\x20' && ch <= '\x7e' then ch else '.')) l; - Buffer.add_char buf '|'; - Lwt.return (Some(Buffer.contents buf)) - end + from (fun _ -> + nget 16 stream >>= function + | [] -> Lwt.return_none + | l -> + Buffer.clear buf; + Printf.bprintf buf "%08x| " !num; + num := !num + 16; + let rec bytes pos = function + | [] -> blanks pos + | x :: l -> + if pos = 8 then Buffer.add_char buf ' '; + Printf.bprintf buf "%02x " (Char.code x); + bytes (pos + 1) l + and blanks pos = + if pos < 16 then ( + if pos = 8 then Buffer.add_string buf " " + else Buffer.add_string buf " "; + blanks (pos + 1)) + in + bytes 0 l; + Buffer.add_string buf " |"; + List.iter + (fun ch -> + Buffer.add_char buf + (if ch >= '\x20' && ch <= '\x7e' then ch else '.')) + l; + Buffer.add_char buf '|'; + Lwt.return (Some (Buffer.contents buf))) diff --git a/src/core/lwt_stream.mli b/src/core/lwt_stream.mli index 360eb8ca29..f48b708757 100644 --- a/src/core/lwt_stream.mli +++ b/src/core/lwt_stream.mli @@ -1,15 +1,13 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Data streams *) type 'a t (** A stream holding values of type ['a]. - Naming convention: in this module, all functions applying a function - to each element of a stream are suffixed by: + Naming convention: in this module, all functions applying a function to each + element of a stream are suffixed by: - [_s] when the function returns a thread and calls are serialised - [_p] when the function returns a thread and calls are parallelised *) @@ -17,100 +15,92 @@ type 'a t (** {2 Construction} *) val from : (unit -> 'a option Lwt.t) -> 'a t -(** [from f] creates a stream from the given input function. [f] is - called each time more input is needed, and the stream ends when - [f] returns [None]. +(** [from f] creates a stream from the given input function. [f] is called each + time more input is needed, and the stream ends when [f] returns [None]. If [f], or the thread produced by [f], raises an exception, that exception is forwarded to the consumer of the stream (for example, a caller of {!get}). Note that this does not end the stream. A subsequent attempt to - read from the stream will cause another call to [f], which may succeed - with a value. *) + read from the stream will cause another call to [f], which may succeed with + a value. *) val from_direct : (unit -> 'a option) -> 'a t -(** [from_direct f] does the same as {!from} but with a function - that does not return a thread. It is preferred that this - function be used rather than wrapping [f] into a function which - returns a thread. +(** [from_direct f] does the same as {!from} but with a function that does not + return a thread. It is preferred that this function be used rather than + wrapping [f] into a function which returns a thread. - The behavior when [f] raises an exception is the same as for {!from}, - except that [f] does not produce a thread. *) + The behavior when [f] raises an exception is the same as for {!from}, except + that [f] does not produce a thread. *) exception Closed -(** Exception raised by the push function of a push-stream when - pushing an element after the end of stream ([= None]) has been - pushed. *) +(** Exception raised by the push function of a push-stream when pushing an + element after the end of stream ([= None]) has been pushed. *) val create : unit -> 'a t * ('a option -> unit) (** [create ()] returns a new stream and a push function. To notify the stream's consumer of errors, either use a separate communication channel, or use a - {{:https://ocaml.org/api/Stdlib.html#TYPEresult} - [result]} stream. There is no way to push an exception into a - push-stream. *) + {{:https://ocaml.org/api/Stdlib.html#TYPEresult} [result]} stream. There is + no way to push an exception into a push-stream. *) val create_with_reference : unit -> 'a t * ('a option -> unit) * ('b -> unit) -(** [create_with_reference ()] returns a new stream and a push - function. The last function allows a reference to be set to an - external source. This prevents the external source from being - garbage collected. +(** [create_with_reference ()] returns a new stream and a push function. The + last function allows a reference to be set to an external source. This + prevents the external source from being garbage collected. For example, to convert a reactive event to a stream: {[ let stream, push, set_ref = Lwt_stream.create_with_reference () in set_ref (map_event push event) - ]} -*) + ]} *) exception Full -(** Exception raised by the push function of a bounded push-stream - when the stream queue is full and a thread is already waiting to - push an element. *) +(** Exception raised by the push function of a bounded push-stream when the + stream queue is full and a thread is already waiting to push an element. *) (** Type of sources for bounded push-streams. *) -class type ['a] bounded_push = object - method size : int - (** Size of the stream. *) +class type ['a] bounded_push = + object + method size : int + (** Size of the stream. *) - method resize : int -> unit - (** Change the size of the stream queue. Note that the new size - can smaller than the current stream queue size. + method resize : int -> unit + (** Change the size of the stream queue. Note that the new size can smaller + than the current stream queue size. - It raises [Invalid_argument] if [size < 0]. *) + It raises [Invalid_argument] if [size < 0]. *) - method push : 'a -> unit Lwt.t - (** Pushes a new element to the stream. If the stream is full then - it will block until one element is consumed. If another thread - is already blocked on {!push}, it raises {!Full}. *) + method push : 'a -> unit Lwt.t + (** Pushes a new element to the stream. If the stream is full then it will + block until one element is consumed. If another thread is already + blocked on {!push}, it raises {!Full}. *) - method close : unit - (** Closes the stream. Any thread currently blocked on {!push} - fails with {!Closed}. *) + method close : unit + (** Closes the stream. Any thread currently blocked on {!push} fails with + {!Closed}. *) - method count : int - (** Number of elements in the stream queue. *) + method count : int + (** Number of elements in the stream queue. *) - method blocked : bool - (** Is a thread is blocked on {!push} ? *) + method blocked : bool + (** Is a thread is blocked on {!push} ? *) - method closed : bool - (** Is the stream closed ? *) + method closed : bool + (** Is the stream closed ? *) - method set_reference : 'a. 'a -> unit - (** Set the reference to an external source. *) -end + method set_reference : 'a. 'a -> unit + (** Set the reference to an external source. *) + end val create_bounded : int -> 'a t * 'a bounded_push -(** [create_bounded size] returns a new stream and a bounded push - source. The stream can hold a maximum of [size] elements. When - this limit is reached, pushing a new element will block until - one is consumed. +(** [create_bounded size] returns a new stream and a bounded push source. The + stream can hold a maximum of [size] elements. When this limit is reached, + pushing a new element will block until one is consumed. - Note that you cannot clone or parse (with {!parse}) a bounded - stream. These functions will raise [Invalid_argument] if you try - to do so. + Note that you cannot clone or parse (with {!parse}) a bounded stream. These + functions will raise [Invalid_argument] if you try to do so. It raises [Invalid_argument] if [size < 0]. *) @@ -159,8 +149,8 @@ val of_string : string -> char t stream (in the sense of {!is_closed}). *) val clone : 'a t -> 'a t -(** [clone st] clone the given stream. Operations on each stream - will not affect the other. +(** [clone st] clone the given stream. Operations on each stream will not affect + the other. For example: @@ -175,8 +165,7 @@ val clone : 'a t -> 'a t val y : int = 1 ]} - It raises [Invalid_argument] if [st] is a bounded - push-stream. *) + It raises [Invalid_argument] if [st] is a bounded push-stream. *) (** {2 Destruction} *) @@ -184,43 +173,40 @@ val to_list : 'a t -> 'a list Lwt.t (** Returns the list of elements of the given stream *) val to_string : char t -> string Lwt.t -(** Returns the word composed of all characters of the given - stream *) +(** Returns the word composed of all characters of the given stream *) (** {2 Data retrieval} *) exception Empty -(** Exception raised when trying to retrieve data from an empty - stream. *) +(** Exception raised when trying to retrieve data from an empty stream. *) val peek : 'a t -> 'a option Lwt.t -(** [peek st] returns the first element of the stream, if any, - without removing it. *) +(** [peek st] returns the first element of the stream, if any, without removing + it. *) val npeek : int -> 'a t -> 'a list Lwt.t -(** [npeek n st] returns at most the first [n] elements of [st], - without removing them. *) +(** [npeek n st] returns at most the first [n] elements of [st], without + removing them. *) val get : 'a t -> 'a option Lwt.t -(** [get st] removes and returns the first element of the stream, if - any. *) +(** [get st] removes and returns the first element of the stream, if any. *) val nget : int -> 'a t -> 'a list Lwt.t -(** [nget n st] removes and returns at most the first [n] elements of - [st]. *) +(** [nget n st] removes and returns at most the first [n] elements of [st]. *) val get_while : ('a -> bool) -> 'a t -> 'a list Lwt.t + val get_while_s : ('a -> bool Lwt.t) -> 'a t -> 'a list Lwt.t -(** [get_while f st] returns the longest prefix of [st] where all - elements satisfy [f]. *) +(** [get_while f st] returns the longest prefix of [st] where all elements + satisfy [f]. *) val next : 'a t -> 'a Lwt.t -(** [next st] removes and returns the next element of the stream or - fails with {!Empty}, if the stream is empty. *) +(** [next st] removes and returns the next element of the stream or fails with + {!Empty}, if the stream is empty. *) val last_new : 'a t -> 'a Lwt.t -(** [last_new st] returns the last element that can be obtained - without sleeping, or wait for one if none is available. +(** [last_new st] returns the last element that can be obtained without + sleeping, or wait for one if none is available. It fails with {!Empty} if the stream has no more elements. *) @@ -228,29 +214,27 @@ val junk : 'a t -> unit Lwt.t (** [junk st] removes the first element of [st]. *) val njunk : int -> 'a t -> unit Lwt.t -(** [njunk n st] removes at most the first [n] elements of the - stream. *) +(** [njunk n st] removes at most the first [n] elements of the stream. *) val junk_while : ('a -> bool) -> 'a t -> unit Lwt.t + val junk_while_s : ('a -> bool Lwt.t) -> 'a t -> unit Lwt.t -(** [junk_while f st] removes all elements at the beginning of the - streams which satisfy [f]. *) +(** [junk_while f st] removes all elements at the beginning of the streams which + satisfy [f]. *) val junk_old : 'a t -> unit Lwt.t -(** [junk_old st] removes all elements that are ready to be read - without yielding from [st]. +(** [junk_old st] removes all elements that are ready to be read without + yielding from [st]. - For example, the [read_password] function of [Lwt_read_line] - uses it to flush keys previously typed by the user. -*) + For example, the [read_password] function of [Lwt_read_line] uses it to + flush keys previously typed by the user. *) val get_available : 'a t -> 'a list -(** [get_available st] returns all available elements of [l] without - blocking. *) +(** [get_available st] returns all available elements of [l] without blocking. *) val get_available_up_to : int -> 'a t -> 'a list -(** [get_available_up_to n st] returns up to [n] elements of [l] - without blocking. *) +(** [get_available_up_to n st] returns up to [n] elements of [l] without + blocking. *) val is_empty : 'a t -> bool Lwt.t (** [is_empty st] returns whether the given stream is empty. *) @@ -258,8 +242,8 @@ val is_empty : 'a t -> bool Lwt.t val is_closed : 'a t -> bool (** [is_closed st] returns whether the given stream has been closed. A closed stream is not necessarily empty. It may still contain unread elements. If - [is_closed s = true], then all subsequent reads until the end of the - stream are guaranteed not to block. + [is_closed s = true], then all subsequent reads until the end of the stream + are guaranteed not to block. @since 2.6.0 *) @@ -270,15 +254,15 @@ val closed : 'a t -> unit Lwt.t @since 2.6.0 *) val on_termination : 'a t -> (unit -> unit) -> unit -[@@ocaml.deprecated " Bind on Lwt_stream.closed."] -(** [on_termination st f] executes [f] when the end of the stream [st] - is reached. Note that the stream may still contain elements if - {!peek} or similar was used. + [@@ocaml.deprecated " Bind on Lwt_stream.closed."] +(** [on_termination st f] executes [f] when the end of the stream [st] is + reached. Note that the stream may still contain elements if {!peek} or + similar was used. @deprecated Use {!closed}. *) val on_terminate : 'a t -> (unit -> unit) -> unit -[@@ocaml.deprecated " Bind on Lwt_stream.closed."] + [@@ocaml.deprecated " Bind on Lwt_stream.closed."] (** Same as {!on_termination}. @deprecated Use {!closed}. *) @@ -298,37 +282,41 @@ val on_terminate : 'a t -> (unit -> unit) -> unit val x : int = 1 # lwt y = Lwt_stream.next st2;; val y : string = "2" - ]} -*) + ]} *) val choose : 'a t list -> 'a t -(** [choose l] creates an stream from a list of streams. The - resulting stream will return elements returned by any stream of - [l] in an unspecified order. *) +(** [choose l] creates an stream from a list of streams. The resulting stream + will return elements returned by any stream of [l] in an unspecified order. *) val map : ('a -> 'b) -> 'a t -> 'b t + val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t (** [map f st] maps the value returned by [st] with [f] *) val filter : ('a -> bool) -> 'a t -> 'a t + val filter_s : ('a -> bool Lwt.t) -> 'a t -> 'a t (** [filter f st] keeps only values, [x], such that [f x] is [true] *) val filter_map : ('a -> 'b option) -> 'a t -> 'b t + val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t (** [filter_map f st] filter and map [st] at the same time *) val map_list : ('a -> 'b list) -> 'a t -> 'b t + val map_list_s : ('a -> 'b list Lwt.t) -> 'a t -> 'b t -(** [map_list f st] applies [f] on each element of [st] and flattens - the lists returned *) +(** [map_list f st] applies [f] on each element of [st] and flattens the lists + returned *) val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b Lwt.t + val fold_s : ('a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t (** [fold f s x] fold_like function for streams. *) val iter : ('a -> unit) -> 'a t -> unit Lwt.t val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t + val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t (** [iter f s] iterates over all elements of the stream. *) @@ -337,28 +325,30 @@ val iter_n : ?max_concurrency:int -> ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t Iteration is performed concurrently with up to [max_threads] concurrent instances of [f]. - Iteration is {b not} guaranteed to be in order as this function will - attempt to always process [max_concurrency] elements from [s] at once. + Iteration is {b not} guaranteed to be in order as this function will attempt + to always process [max_concurrency] elements from [s] at once. @param max_concurrency defaults to [1]. @raise Invalid_argument if [max_concurrency < 1]. @since 3.3.0 *) val find : ('a -> bool) -> 'a t -> 'a option Lwt.t + val find_s : ('a -> bool Lwt.t) -> 'a t -> 'a option Lwt.t (** [find f s] find an element in a stream. *) val find_map : ('a -> 'b option) -> 'a t -> 'b option Lwt.t + val find_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b option Lwt.t (** [find_map f s] find and map at the same time. *) val combine : 'a t -> 'b t -> ('a * 'b) t -(** [combine s1 s2] combines two streams. The stream will end when - either stream ends. *) +(** [combine s1 s2] combines two streams. The stream will end when either stream + ends. *) val append : 'a t -> 'a t -> 'a t -(** [append s1 s2] returns a stream which returns all elements of - [s1], then all elements of [s2] *) +(** [append s1 s2] returns a stream which returns all elements of [s1], then all + elements of [s2] *) val concat : 'a t t -> 'a t (** [concat st] returns the concatenation of all streams of [st]. *) @@ -382,45 +372,45 @@ val wrap_exn : 'a t -> 'a Lwt.result t (** {2 Parsing} *) val parse : 'a t -> ('a t -> 'b Lwt.t) -> 'b Lwt.t -(** [parse st f] parses [st] with [f]. If [f] raise an exception, - [st] is restored to its previous state. +(** [parse st f] parses [st] with [f]. If [f] raise an exception, [st] is + restored to its previous state. - It raises [Invalid_argument] if [st] is a bounded - push-stream. *) + It raises [Invalid_argument] if [st] is a bounded push-stream. *) (** {2 Misc} *) val hexdump : char t -> string t -(** [hexdump byte_stream] returns a stream which is the same as the - output of [hexdump -C]. +(** [hexdump byte_stream] returns a stream which is the same as the output of + [hexdump -C]. Basically, here is a simple implementation of [hexdump -C]: {[ - let () = Lwt_main.run (Lwt_io.write_lines Lwt_io.stdout (Lwt_stream.hexdump (Lwt_io.read_lines Lwt_io.stdin))) - ]} -*) + let () = + Lwt_main.run + (Lwt_io.write_lines Lwt_io.stdout + (Lwt_stream.hexdump (Lwt_io.read_lines Lwt_io.stdin))) + ]} *) (** {2 Deprecated} *) -type 'a result = - | Value of 'a - | Error of exn -[@@ocaml.deprecated - " This type is being replaced by Lwt.result and the corresponding function - Lwt_stream.wrap_exn."] (** A value or an error. @deprecated Replaced by {!wrap_exn}, which uses {!Lwt.result}. *) +type 'a result = Value of 'a | Error of exn +[@@ocaml.deprecated + " This type is being replaced by Lwt.result and the corresponding function\n\ + \ Lwt_stream.wrap_exn."] [@@@ocaml.warning "-3"] + val map_exn : 'a t -> 'a result t -[@@ocaml.deprecated " Use Lwt_stream.wrap_exn"] -(** [map_exn s] returns a stream that captures all exceptions raised - by the source of the stream (the function passed to {!from}). + [@@ocaml.deprecated " Use Lwt_stream.wrap_exn"] +(** [map_exn s] returns a stream that captures all exceptions raised by the + source of the stream (the function passed to {!from}). - Note that for push-streams (as returned by {!create}) all - elements of the mapped streams are values. + Note that for push-streams (as returned by {!create}) all elements of the + mapped streams are values. If the stream source keeps raising the same exception [e] each time the stream is read, the stream produced by [map_exn] is unbounded. Reading it diff --git a/src/core/lwt_switch.ml b/src/core/lwt_switch.ml index 84aa8bc222..a978bd2c7f 100644 --- a/src/core/lwt_switch.ml +++ b/src/core/lwt_switch.ml @@ -1,60 +1,40 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - exception Off -type on_switch = { - mutable hooks : (unit -> unit Lwt.t) list; -} - -type state = - | St_on of on_switch - | St_off - +type on_switch = { mutable hooks : (unit -> unit Lwt.t) list } +type state = St_on of on_switch | St_off type t = { mutable state : state } let create () = { state = St_on { hooks = [] } } - -let is_on switch = - match switch.state with - | St_on _ -> true - | St_off -> false +let is_on switch = match switch.state with St_on _ -> true | St_off -> false let check = function - | Some{ state = St_off } -> raise Off - | Some {state = St_on _} | None -> () + | Some { state = St_off } -> raise Off + | Some { state = St_on _ } | None -> () let add_hook switch hook = match switch with - | Some { state = St_on os } -> - os.hooks <- hook :: os.hooks - | Some { state = St_off } -> - raise Off - | None -> - () + | Some { state = St_on os } -> os.hooks <- hook :: os.hooks + | Some { state = St_off } -> raise Off + | None -> () let add_hook_or_exec switch hook = match switch with | Some { state = St_on os } -> - os.hooks <- hook :: os.hooks; - Lwt.return_unit - | Some { state = St_off } -> - hook () - | None -> - Lwt.return_unit + os.hooks <- hook :: os.hooks; + Lwt.return_unit + | Some { state = St_off } -> hook () + | None -> Lwt.return_unit let turn_off switch = match switch.state with - | St_on { hooks = hooks } -> - switch.state <- St_off; - Lwt.join (List.map (fun hook -> Lwt.apply hook ()) hooks) - | St_off -> - Lwt.return_unit + | St_on { hooks } -> + switch.state <- St_off; + Lwt.join (List.map (fun hook -> Lwt.apply hook ()) hooks) + | St_off -> Lwt.return_unit let with_switch fn = let switch = create () in - Lwt.finalize - (fun () -> fn switch) - (fun () -> turn_off switch) + Lwt.finalize (fun () -> fn switch) (fun () -> turn_off switch) diff --git a/src/core/lwt_switch.mli b/src/core/lwt_switch.mli index e2d2f6ffa2..c67e8664c4 100644 --- a/src/core/lwt_switch.mli +++ b/src/core/lwt_switch.mli @@ -1,15 +1,13 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Lwt switches *) (** Switch has two goals: - being able to free multiple resources at the same time, - - offer a better alternative than always returning an id to free - some resource. + - offer a better alternative than always returning an id to free some + resource. For example, consider the following interface: @@ -17,31 +15,29 @@ type id val free : id -> unit Lwt.t - val f : unit -> id Lwt.t val g : unit -> id Lwt.t val h : unit -> id Lwt.t ]} - Now you want to call [f], [g] and [h] in parallel. You can - simply do: + Now you want to call [f], [g] and [h] in parallel. You can simply do: {[ lwt idf = f () and idg = g () and idh = h () in ... ]} - However, one may want to handle possible failures of [f ()], [g ()] - and [h ()], and disable all allocated resources if one of - these three threads fails. This may be hard since you have to - remember which one failed and which one returned correctly. + However, one may want to handle possible failures of [f ()], [g ()] and + [h ()], and disable all allocated resources if one of these three threads + fails. This may be hard since you have to remember which one failed and + which one returned correctly. Now if we change the interface a little bit: {[ - val f : ?switch : Lwt_switch.t -> unit -> id Lwt.t - val g : ?switch : Lwt_switch.t -> unit -> id Lwt.t - val h : ?switch : Lwt_switch.t -> unit -> id Lwt.t + val f : ?switch:Lwt_switch.t -> unit -> id Lwt.t + val g : ?switch:Lwt_switch.t -> unit -> id Lwt.t + val h : ?switch:Lwt_switch.t -> unit -> id Lwt.t ]} the code becomes: @@ -53,46 +49,42 @@ and idh = h ~switch () in ... ) - ]} -*) + ]} *) type t - (** Type of switches. *) +(** Type of switches. *) val create : unit -> t - (** [create ()] creates a new switch. *) +(** [create ()] creates a new switch. *) val with_switch : (t -> 'a Lwt.t) -> 'a Lwt.t - (** [with_switch fn] is [fn switch], where [switch] is a fresh switch - that is turned off when the callback thread finishes (whether it - succeeds or fails). +(** [with_switch fn] is [fn switch], where [switch] is a fresh switch that is + turned off when the callback thread finishes (whether it succeeds or fails). - @since 2.6.0 *) + @since 2.6.0 *) val is_on : t -> bool - (** [is_on switch] returns [true] if the switch is currently on, and - [false] otherwise. *) +(** [is_on switch] returns [true] if the switch is currently on, and [false] + otherwise. *) val turn_off : t -> unit Lwt.t - (** [turn_off switch] turns off the switch. It calls all registered - hooks, waits for all of them to terminate, then returns. If - one of the hooks failed, it will fail with the exception raised - by the hook. If the switch is already off, it does nothing. *) +(** [turn_off switch] turns off the switch. It calls all registered hooks, waits + for all of them to terminate, then returns. If one of the hooks failed, it + will fail with the exception raised by the hook. If the switch is already + off, it does nothing. *) exception Off - (** Exception raised when trying to add a hook to a switch that is - already off. *) +(** Exception raised when trying to add a hook to a switch that is already off. *) val check : t option -> unit - (** [check switch] does nothing if [switch] is [None] or contains an - switch that is currently on, and raises {!Off} otherwise. *) +(** [check switch] does nothing if [switch] is [None] or contains an switch that + is currently on, and raises {!Off} otherwise. *) val add_hook : t option -> (unit -> unit Lwt.t) -> unit - (** [add_hook switch f] registers [f] so it will be called when - {!turn_off} is invoked. It does nothing if [switch] is - [None]. If [switch] contains an switch that is already off then - {!Off} is raised. *) +(** [add_hook switch f] registers [f] so it will be called when {!turn_off} is + invoked. It does nothing if [switch] is [None]. If [switch] contains an + switch that is already off then {!Off} is raised. *) val add_hook_or_exec : t option -> (unit -> unit Lwt.t) -> unit Lwt.t - (** [add_hook_or_exec switch f] is the same as {!add_hook} except - that if the switch is already off, [f] is called immediately. *) +(** [add_hook_or_exec switch f] is the same as {!add_hook} except that if the + switch is already off, [f] is called immediately. *) diff --git a/src/domain/lwt_domain.ml b/src/domain/lwt_domain.ml index 00e1243693..f4bf2c1399 100644 --- a/src/domain/lwt_domain.ml +++ b/src/domain/lwt_domain.ml @@ -1,38 +1,33 @@ open Lwt.Infix - module C = Domainslib.Chan module T = Domainslib.Task type pool = Domainslib.Task.pool let setup_pool ?name num_additional_domains = - T.setup_pool ?name ~num_additional_domains () + T.setup_pool ?name ~num_additional_domains () let teardown_pool = T.teardown_pool - let lookup_pool = T.lookup_pool - let get_num_domains = T.get_num_domains - let init_result = Error (Failure "Lwt_domain.detach") let detach pool f args = - if (get_num_domains pool = 1) then - Lwt.wrap1 f args - else begin + if get_num_domains pool = 1 then Lwt.wrap1 f args + else let result = ref init_result in - let task () = - result := try Ok (f args) with exn -> Error exn - in + let task () = result := try Ok (f args) with exn -> Error exn in let waiter, wakener = Lwt.wait () in let id = - Lwt_unix.make_notification ~once:true - (fun () -> Lwt.wakeup_result wakener !result) + Lwt_unix.make_notification ~once:true (fun () -> + Lwt.wakeup_result wakener !result) + in + let _ = + T.async pool (fun _ -> + task (); + Lwt_unix.send_notification id) in - let _ = T.async pool (fun _ -> task (); - Lwt_unix.send_notification id) in waiter - end (* +-----------------------------------------------------------------+ | Running Lwt threads in the main domain | @@ -41,9 +36,9 @@ let detach pool f args = (* Jobs to be run in the main domain *) let jobs = C.make_unbounded () let job_done = C.make_bounded 0 + let job_notification = - Lwt_unix.make_notification - (fun () -> + Lwt_unix.make_notification (fun () -> let thunk = C.recv jobs in ignore (thunk ())) @@ -52,7 +47,8 @@ let run_in_main f = let job () = Lwt.try_bind f (fun ret -> Lwt.return (Result.Ok ret)) - (fun exn -> Lwt.return (Result.Error exn)) >>= fun result -> + (fun exn -> Lwt.return (Result.Error exn)) + >>= fun result -> res := result; C.send job_done (); Lwt.return_unit @@ -61,6 +57,4 @@ let run_in_main f = Lwt_unix.send_notification job_notification; (* blocks calling domain until the job is executed *) C.recv job_done; - match !res with - | Result.Ok ret -> ret - | Result.Error exn -> raise exn + match !res with Result.Ok ret -> ret | Result.Error exn -> raise exn diff --git a/src/domain/lwt_domain.mli b/src/domain/lwt_domain.mli index eb543ec5db..4d9cf1431b 100644 --- a/src/domain/lwt_domain.mli +++ b/src/domain/lwt_domain.mli @@ -1,98 +1,92 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** This module provides the necessary function ({!detach}) to schedule some computations to be ran in parallel in a separate domain. The result of such a computation is exposed to the caller of {!detach} as a promise. Thus, this module allows to mix multicore parallelism with the concurrent-only scheduling of the rest of Lwt. *) - type pool - (** Domainslib Task pool *) +type pool +(** Domainslib Task pool *) - val detach : pool-> ('a -> 'b) -> 'a -> 'b Lwt.t - (** [detach pool f x] runs the computation [f x] in a separate domain in - parallel. +val detach : pool -> ('a -> 'b) -> 'a -> 'b Lwt.t +(** [detach pool f x] runs the computation [f x] in a separate domain in + parallel. - [detach pool f x] evaluates to an Lwt promise which is pending until the - domain completes the execution of [f x] at which point it becomes - resolved. If [f x] raises an exception, then the promise is rejected. + [detach pool f x] evaluates to an Lwt promise which is pending until the + domain completes the execution of [f x] at which point it becomes resolved. + If [f x] raises an exception, then the promise is rejected. - It is recommended you initialise the task pool using - {!setup_pool} with a number of domains equal to the number of - physical cores. + It is recommended you initialise the task pool using {!setup_pool} with a + number of domains equal to the number of physical cores. - Note that the function [f] passed to [detach] cannot safely use {!Lwt}. - This is true even for implicit callback arguments (i.e., - {!Lwt.with_value}). If you need to use {!Lwt} or interact with promises, - you must use {!run_in_main}. + Note that the function [f] passed to [detach] cannot safely use {!Lwt}. This + is true even for implicit callback arguments (i.e., {!Lwt.with_value}). If + you need to use {!Lwt} or interact with promises, you must use + {!run_in_main}. - In the special case where the task pool has size one (i.e., when there - is no additional domain to detach the computation to), the computation - runs immediately on the main domain. In other words, when the number of - domains is one (1), then [detach f x] is identical to - [Lwt.return (f x)]. + In the special case where the task pool has size one (i.e., when there is no + additional domain to detach the computation to), the computation runs + immediately on the main domain. In other words, when the number of domains + is one (1), then [detach f x] is identical to [Lwt.return (f x)]. - @raise [Invalid_argument] if pool is already torn down. *) + @raise [Invalid_argument] if pool is already torn down. *) - val run_in_main : (unit -> 'a Lwt.t) -> 'a - (** [run_in_main f] can be called from a detached computation to execute [f +val run_in_main : (unit -> 'a Lwt.t) -> 'a +(** [run_in_main f] can be called from a detached computation to execute + [f ()] in the parent domain, i.e. the one executing {!Lwt_main.run}. - [run_in_main f] blocks until [f ()] completes, then it returns its - result. If [f ()] raises an exception, [run_in_main f] raises the same - exception. The whole of {!Lwt} can be safely used from within [f]. - However, note that implicit callback arguments are local to [f]. I.e., - {!Lwt.get} can only retrieve values set inside of [f], and not those set - inside the promise that called [detach] that called [run_in_main]. - - Note that the calling domain will be idle until [f ()] completes - execution and returns the result. Thus, heavy use of [run_in_main] may - lead to most or all domains being frozen. It's also possible to create a - dead-lock when [run_in_main] is called (thus freezing a domain) with a - function that calls [detach] (thus needing a domain). Consequently, it - is recommended to use this function sparingly. *) - - val setup_pool : ?name:string -> int -> pool - (** [setup_pool name num_additional_domains] returns a task pool with - [num_additional_domains] domains including the current domain. + [run_in_main f] blocks until [f ()] completes, then it returns its result. + If [f ()] raises an exception, [run_in_main f] raises the same exception. + The whole of {!Lwt} can be safely used from within [f]. However, note that + implicit callback arguments are local to [f]. I.e., {!Lwt.get} can only + retrieve values set inside of [f], and not those set inside the promise that + called [detach] that called [run_in_main]. - It is recommended to use this function to create a pool once before - calling [Lwt_main.run] and to not call it again afterwards. To resize the - pool, call [teardown_pool ()] first before creating a new pool again. - Multiple calls to resize the domain pool are safe but costly. + Note that the calling domain will be idle until [f ()] completes execution + and returns the result. Thus, heavy use of [run_in_main] may lead to most or + all domains being frozen. It's also possible to create a dead-lock when + [run_in_main] is called (thus freezing a domain) with a function that calls + [detach] (thus needing a domain). Consequently, it is recommended to use + this function sparingly. *) - If [name] is provided, the pool is mapped to name. It can be obtained - later with [lookup_pool name]. +val setup_pool : ?name:string -> int -> pool +(** [setup_pool name num_additional_domains] returns a task pool with + [num_additional_domains] domains including the current domain. - For more details about task pool, please refer: - https://github.com/ocaml-multicore/domainslib/blob/master/lib/task.mli + It is recommended to use this function to create a pool once before calling + [Lwt_main.run] and to not call it again afterwards. To resize the pool, call + [teardown_pool ()] first before creating a new pool again. Multiple calls to + resize the domain pool are safe but costly. - @raise [Invalid_argument] if given number of domains [n] is smaller than - [1]. + If [name] is provided, the pool is mapped to name. It can be obtained later + with [lookup_pool name]. - @raise [Failure] if the pool is already initialised when the function is - called. - *) + For more details about task pool, please refer: + https://github.com/ocaml-multicore/domainslib/blob/master/lib/task.mli - val teardown_pool : pool -> unit - (** [teardown_pool ()] shuts down the task pool. It is safe to call - [setup_pool] again after [teardown_pool] returns. + @raise [Invalid_argument] + if given number of domains [n] is smaller than [1]. + @raise [Failure] + if the pool is already initialised when the function is called. *) - This function is useful if different portions of your program have benefit - from different degree of parallelism. +val teardown_pool : pool -> unit +(** [teardown_pool ()] shuts down the task pool. It is safe to call [setup_pool] + again after [teardown_pool] returns. - @raise [TasksActive] if any tasks in the pool are currently active. + This function is useful if different portions of your program have benefit + from different degree of parallelism. - @raise [Invalid_argument] if pool is already torn down. *) + @raise [TasksActive] if any tasks in the pool are currently active. + @raise [Invalid_argument] if pool is already torn down. *) - val lookup_pool : string -> pool option - (** [lookup_pool name] returns [Some pool] if [pool] is associated to [name] - or returns [None] if no value is associated to it. *) +val lookup_pool : string -> pool option +(** [lookup_pool name] returns [Some pool] if [pool] is associated to [name] or + returns [None] if no value is associated to it. *) - val get_num_domains : pool -> int - (** [get_num_domains pool] returns the number of domains in [pool]. *) +val get_num_domains : pool -> int +(** [get_num_domains pool] returns the number of domains in [pool]. *) - (**/**) +(**/**) diff --git a/src/ppx/ppx_lwt.ml b/src/ppx/ppx_lwt.ml index 1a3a9d8920..b1a09ccbf1 100644 --- a/src/ppx/ppx_lwt.ml +++ b/src/ppx/ppx_lwt.ml @@ -3,27 +3,26 @@ open Ast_builder.Default (** {2 Convenient stuff} *) -let with_loc f {txt ; loc } = - f ~loc txt +let with_loc f { txt; loc } = f ~loc txt (** Test if a case is a catchall. *) let is_catchall case = - let rec is_catchall_pat p = match p.ppat_desc with + let rec is_catchall_pat p = + match p.ppat_desc with | Ppat_any | Ppat_var _ -> true - | Ppat_alias (p, _) | Ppat_constraint (p,_) -> is_catchall_pat p + | Ppat_alias (p, _) | Ppat_constraint (p, _) -> is_catchall_pat p | _ -> false in case.pc_guard = None && is_catchall_pat case.pc_lhs (** Add a wildcard case in there is none. Useful for exception handlers. *) let add_wildcard_case cases = - let has_wildcard = - List.exists is_catchall cases - in - if not has_wildcard - then cases - @ (let loc = Location.none in - [case ~lhs:[%pat? exn] ~guard:None ~rhs:[%expr Lwt.fail exn]]) + let has_wildcard = List.exists is_catchall cases in + if not has_wildcard then + cases + @ + let loc = Location.none in + [ case ~lhs:[%pat? exn] ~guard:None ~rhs:[%expr Lwt.fail exn] ] else cases (** {3 Internal names} *) @@ -33,10 +32,8 @@ let lwt_prefix = "__ppx_lwt_" (** {2 Here we go!} *) let default_loc = ref Location.none - -let sequence = ref true +let sequence = ref true let strict_seq = ref true - let used_no_sequence_option = ref false let used_no_strict_sequence_option = ref false @@ -55,9 +52,7 @@ let gen_name i = lwt_prefix ^ string_of_int i (** [p = x] ≡ [__ppx_lwt_$i = x] *) let gen_bindings l = let aux i binding = - { binding with - pvb_pat = pvar ~loc:binding.pvb_expr.pexp_loc (gen_name i) - } + { binding with pvb_pat = pvar ~loc:binding.pvb_expr.pexp_loc (gen_name i) } in List.mapi aux l @@ -67,103 +62,104 @@ let gen_binds e_loc l e = match bindings with | [] -> e | binding :: t -> - let name = (* __ppx_lwt_$i, at the position of $x$ *) - evar ~loc:binding.pvb_expr.pexp_loc (gen_name i) - in - let fun_ = - let loc = e_loc in - [%expr (fun [%p binding.pvb_pat] -> [%e aux (i+1) t])] - in - let new_exp = + let name = + (* __ppx_lwt_$i, at the position of $x$ *) + evar ~loc:binding.pvb_expr.pexp_loc (gen_name i) + in + let fun_ = + let loc = e_loc in + [%expr fun [%p binding.pvb_pat] -> [%e aux (i + 1) t]] + in + let new_exp = let loc = e_loc in [%expr - let module Reraise = struct external reraise : exn -> 'a = "%reraise" end in + let module Reraise = struct + external reraise : exn -> 'a = "%reraise" + end in Lwt.backtrace_bind (fun exn -> try Reraise.reraise exn with exn -> exn) - [%e name] - [%e fun_] - ] - in - { new_exp with pexp_attributes = binding.pvb_attributes } - in aux 0 l + [%e name] [%e fun_]] + in + { new_exp with pexp_attributes = binding.pvb_attributes } + in + aux 0 l let lwt_sequence mapper ~exp ~lhs ~rhs ~ext_loc = - let pat= let loc = ext_loc in [%pat? ()] in - let lhs, rhs = mapper#expression lhs, mapper#expression rhs in + let pat = + let loc = ext_loc in + [%pat? ()] + in + let lhs, rhs = (mapper#expression lhs, mapper#expression rhs) in let loc = exp.pexp_loc in - [%expr - let module Reraise = struct external reraise : exn -> 'a = "%reraise" end in - Lwt.backtrace_bind - (fun exn -> try Reraise.reraise exn with exn -> exn) - [%e lhs] - (fun [%p pat] -> [%e rhs]) - ] + [%expr + let module Reraise = struct + external reraise : exn -> 'a = "%reraise" + end in + Lwt.backtrace_bind + (fun exn -> try Reraise.reraise exn with exn -> exn) + [%e lhs] + (fun [%p pat] -> [%e rhs])] -(** For expressions only *) (* We only expand the first level after a %lwt. After that, we call the mapper to expand sub-expressions. *) + +(** For expressions only *) let lwt_expression mapper exp attributes ext_loc = default_loc := exp.pexp_loc; let pexp_attributes = attributes @ exp.pexp_attributes in match exp.pexp_desc with - (* $e$;%lwt $e'$ ≡ [Lwt.bind $e$ (fun $p$ -> $e'$)] *) | Pexp_sequence (lhs, rhs) -> - Some (lwt_sequence mapper ~exp ~lhs ~rhs ~ext_loc) + Some (lwt_sequence mapper ~exp ~lhs ~rhs ~ext_loc) (* [let%lwt $p$ = $e$ in $e'$] ≡ [Lwt.bind $e$ (fun $p$ -> $e'$)] *) - | Pexp_let (Nonrecursive, vbl , e) -> - let new_exp = - pexp_let - ~loc:!default_loc - Nonrecursive - (gen_bindings vbl) - (gen_binds exp.pexp_loc vbl e) - in - Some (mapper#expression { new_exp with pexp_attributes }) - + | Pexp_let (Nonrecursive, vbl, e) -> + let new_exp = + pexp_let ~loc:!default_loc Nonrecursive (gen_bindings vbl) + (gen_binds exp.pexp_loc vbl e) + in + Some (mapper#expression { new_exp with pexp_attributes }) (* [match%lwt $e$ with $c$] ≡ [Lwt.bind $e$ (function $c$)] [match%lwt $e$ with exception $x$ | $c$] ≡ [Lwt.try_bind (fun () -> $e$) (function $c$) (function $x$)] *) | Pexp_match (e, cases) -> - let exns, cases = - cases |> List.partition ( - function - | {pc_lhs = [%pat? exception [%p? _]]; _} -> true - | _ -> false) - in - if cases = [] then - Location.raise_errorf ~loc:exp.pexp_loc - "match%%lwt must contain at least one non-exception pattern." ; - let exns = - exns |> List.map ( - function - | {pc_lhs = [%pat? exception [%p? pat]]; _} as case -> - { case with pc_lhs = pat } - | _ -> assert false) - in - let exns = add_wildcard_case exns in - let new_exp = - match exns with - | [] -> - let loc = !default_loc in - [%expr Lwt.bind [%e e] [%e pexp_function ~loc cases]] - | _ -> - let loc = !default_loc in - [%expr Lwt.try_bind (fun () -> [%e e]) - [%e pexp_function ~loc cases] - [%e pexp_function ~loc exns]] - in - Some (mapper#expression { new_exp with pexp_attributes }) - + let exns, cases = + cases + |> List.partition (function + | { pc_lhs = [%pat? exception [%p? _]]; _ } -> true + | _ -> false) + in + if cases = [] then + Location.raise_errorf ~loc:exp.pexp_loc + "match%%lwt must contain at least one non-exception pattern."; + let exns = + exns + |> List.map (function + | { pc_lhs = [%pat? exception [%p? pat]]; _ } as case -> + { case with pc_lhs = pat } + | _ -> assert false) + in + let exns = add_wildcard_case exns in + let new_exp = + match exns with + | [] -> + let loc = !default_loc in + [%expr Lwt.bind [%e e] [%e pexp_function ~loc cases]] + | _ -> + let loc = !default_loc in + [%expr + Lwt.try_bind + (fun () -> [%e e]) + [%e pexp_function ~loc cases] [%e pexp_function ~loc exns]] + in + Some (mapper#expression { new_exp with pexp_attributes }) (* [assert%lwt $e$] ≡ [try Lwt.return (assert $e$) with exn -> Lwt.fail exn] *) | Pexp_assert e -> - let new_exp = - let loc = !default_loc in - [%expr try Lwt.return (assert [%e e]) with exn -> Lwt.fail exn] - in - Some (mapper#expression { new_exp with pexp_attributes }) - + let new_exp = + let loc = !default_loc in + [%expr try Lwt.return (assert [%e e]) with exn -> Lwt.fail exn] + in + Some (mapper#expression { new_exp with pexp_attributes }) (* [while%lwt $cond$ do $body$ done] ≡ [let rec __ppx_lwt_loop () = if $cond$ then Lwt.bind $body$ __ppx_lwt_loop @@ -171,17 +167,16 @@ let lwt_expression mapper exp attributes ext_loc = in __ppx_lwt_loop] *) | Pexp_while (cond, body) -> - let new_exp = - let loc = !default_loc in - [%expr - let rec __ppx_lwt_loop () = - if [%e cond] then Lwt.bind [%e body] __ppx_lwt_loop - else Lwt.return_unit - in __ppx_lwt_loop () - ] - in - Some (mapper#expression { new_exp with pexp_attributes }) - + let new_exp = + let loc = !default_loc in + [%expr + let rec __ppx_lwt_loop () = + if [%e cond] then Lwt.bind [%e body] __ppx_lwt_loop + else Lwt.return_unit + in + __ppx_lwt_loop ()] + in + Some (mapper#expression { new_exp with pexp_attributes }) (* [for%lwt $p$ = $start$ (to|downto) $end$ do $body$ done] ≡ [let __ppx_lwt_bound = $end$ in let rec __ppx_lwt_loop $p$ = @@ -189,178 +184,174 @@ let lwt_expression mapper exp attributes ext_loc = else Lwt.bind $body$ (fun () -> __ppx_lwt_loop ($p$ OP 1)) in __ppx_lwt_loop $start$] *) - | Pexp_for ({ppat_desc = Ppat_var p_var; _} as p, start, bound, dir, body) -> - let comp, op = - let loc = !default_loc in - match dir with - | Upto -> evar ~loc ">", evar ~loc "+" - | Downto -> evar ~loc "<", evar ~loc "-" - in - let p' = with_loc evar p_var in - - let exp_bound = let loc = bound.pexp_loc in [%expr __ppx_lwt_bound] in - let pat_bound = let loc = bound.pexp_loc in [%pat? __ppx_lwt_bound] in - - let new_exp = - let loc = !default_loc in - [%expr - let [%p pat_bound] : int = [%e bound] in - let rec __ppx_lwt_loop [%p p] = - if [%e comp] [%e p'] [%e exp_bound] then Lwt.return_unit - else Lwt.bind [%e body] (fun () -> __ppx_lwt_loop ([%e op] [%e p'] 1)) - in __ppx_lwt_loop [%e start] - ] - in - Some (mapper#expression { new_exp with pexp_attributes }) + | Pexp_for (({ ppat_desc = Ppat_var p_var; _ } as p), start, bound, dir, body) + -> + let comp, op = + let loc = !default_loc in + match dir with + | Upto -> (evar ~loc ">", evar ~loc "+") + | Downto -> (evar ~loc "<", evar ~loc "-") + in + let p' = with_loc evar p_var in + let exp_bound = + let loc = bound.pexp_loc in + [%expr __ppx_lwt_bound] + in + let pat_bound = + let loc = bound.pexp_loc in + [%pat? __ppx_lwt_bound] + in + let new_exp = + let loc = !default_loc in + [%expr + let ([%p pat_bound] : int) = [%e bound] in + let rec __ppx_lwt_loop [%p p] = + if [%e comp] [%e p'] [%e exp_bound] then Lwt.return_unit + else + Lwt.bind [%e body] (fun () -> __ppx_lwt_loop ([%e op] [%e p'] 1)) + in + __ppx_lwt_loop [%e start]] + in + Some (mapper#expression { new_exp with pexp_attributes }) (* [try%lwt $e$ with $c$] ≡ [Lwt.catch (fun () -> $e$) (function $c$)] *) | Pexp_try (expr, cases) -> - let cases = add_wildcard_case cases in - let new_exp = - let loc = !default_loc in + let cases = add_wildcard_case cases in + let new_exp = + let loc = !default_loc in [%expr - let module Reraise = struct external reraise : exn -> 'a = "%reraise" end in + let module Reraise = struct + external reraise : exn -> 'a = "%reraise" + end in Lwt.backtrace_catch (fun exn -> try Reraise.reraise exn with exn -> exn) (fun () -> [%e expr]) - [%e pexp_function ~loc cases] - ] - in - Some (mapper#expression { new_exp with pexp_attributes }) - + [%e pexp_function ~loc cases]] + in + Some (mapper#expression { new_exp with pexp_attributes }) (* [if%lwt $c$ then $e1$ else $e2$] ≡ [match%lwt $c$ with true -> $e1$ | false -> $e2$] [if%lwt $c$ then $e1$] ≡ [match%lwt $c$ with true -> $e1$ | false -> Lwt.return_unit] *) | Pexp_ifthenelse (cond, e1, e2) -> - let e2 = - match e2 with - | None -> let loc = !default_loc in [%expr Lwt.return_unit] - | Some e -> e - in - let cases = - let loc = !default_loc in - [ - case ~lhs:[%pat? true] ~guard:None ~rhs:e1 ; - case ~lhs:[%pat? false] ~guard:None ~rhs:e2 ; - ] - in - let new_exp = - let loc = !default_loc in - [%expr Lwt.bind [%e cond] [%e pexp_function ~loc cases]] - in - Some (mapper#expression { new_exp with pexp_attributes }) - - | _ -> - None + let e2 = + match e2 with + | None -> + let loc = !default_loc in + [%expr Lwt.return_unit] + | Some e -> e + in + let cases = + let loc = !default_loc in + [ + case ~lhs:[%pat? true] ~guard:None ~rhs:e1; + case ~lhs:[%pat? false] ~guard:None ~rhs:e2; + ] + in + let new_exp = + let loc = !default_loc in + [%expr Lwt.bind [%e cond] [%e pexp_function ~loc cases]] + in + Some (mapper#expression { new_exp with pexp_attributes }) + | _ -> None let warned = ref false -class mapper = object (self) - inherit Ast_traverse.map as super - - method! structure = begin fun structure -> - if !warned then - super#structure structure +class mapper = + object (self) + inherit Ast_traverse.map as super - else begin + method! structure structure = + if !warned then super#structure structure + else ( warned := true; let structure = super#structure structure in let loc = Location.in_file !Ocaml_common.Location.input_name in let warn_if condition message structure = if condition then - (pstr_attribute ~loc (attribute_of_warning loc message))::structure - else - structure + pstr_attribute ~loc (attribute_of_warning loc message) :: structure + else structure in structure - |> warn_if (!used_no_strict_sequence_option) - ("-no-strict-sequence is a deprecated Lwt PPX option\n" ^ - " See https://github.com/ocsigen/lwt/issues/495") - |> warn_if (!used_no_sequence_option) - ("-no-sequence is a deprecated Lwt PPX option\n" ^ - " See https://github.com/ocsigen/lwt/issues/495") - end - end - - method! expression = (fun expr -> + |> warn_if + !used_no_strict_sequence_option + ("-no-strict-sequence is a deprecated Lwt PPX option\n" + ^ " See https://github.com/ocsigen/lwt/issues/495") + |> warn_if !used_no_sequence_option + ("-no-sequence is a deprecated Lwt PPX option\n" + ^ " See https://github.com/ocsigen/lwt/issues/495")) + + method! expression expr = match expr with - | { pexp_desc= - Pexp_extension ( - {txt="lwt"; loc= ext_loc}, - PStr[{pstr_desc= Pstr_eval (exp, _);_}]); - _ - }-> - begin match lwt_expression self exp expr.pexp_attributes ext_loc with - | Some expr' -> expr' - | None -> expr - end + | { + pexp_desc = + Pexp_extension + ( { txt = "lwt"; loc = ext_loc }, + PStr [ { pstr_desc = Pstr_eval (exp, _); _ } ] ); + _; + } -> ( + match lwt_expression self exp expr.pexp_attributes ext_loc with + | Some expr' -> expr' + | None -> expr) (* [($e$)[%finally $f$]] ≡ [Lwt.finalize (fun () -> $e$) (fun () -> $f$)] *) - | [%expr [%e? exp ] [%finally [%e? finally]] ] - | [%expr [%e? exp ] [%lwt.finally [%e? finally]] ] -> - let new_exp = - let loc = !default_loc in + | [%expr [%e? exp] [%finally [%e? finally]]] + | [%expr [%e? exp] [%lwt.finally [%e? finally]]] -> + let new_exp = + let loc = !default_loc in [%expr - let module Reraise = struct external reraise : exn -> 'a = "%reraise" end in + let module Reraise = struct + external reraise : exn -> 'a = "%reraise" + end in Lwt.backtrace_finalize (fun exn -> try Reraise.reraise exn with exn -> exn) (fun () -> [%e exp]) - (fun () -> [%e finally]) - ] - in - super#expression - { new_exp with - pexp_attributes = expr.pexp_attributes @ exp.pexp_attributes - } - - | [%expr [%finally [%e? _ ]]] - | [%expr [%lwt.finally [%e? _ ]]] -> - Location.raise_errorf ~loc:expr.pexp_loc - "Lwt's finally should be used only with the syntax: \"()[%%finally ...]\"." - - | _ -> - super#expression expr) - - method! structure_item = (fun stri -> + (fun () -> [%e finally])] + in + super#expression + { + new_exp with + pexp_attributes = expr.pexp_attributes @ exp.pexp_attributes; + } + | [%expr [%finally [%e? _]]] | [%expr [%lwt.finally [%e? _]]] -> + Location.raise_errorf ~loc:expr.pexp_loc + "Lwt's finally should be used only with the syntax: \ + \"()[%%finally ...]\"." + | _ -> super#expression expr + + method! structure_item stri = default_loc := stri.pstr_loc; match stri with | [%stri let%lwt [%p? var] = [%e? exp]] -> - let warning = - estring ~loc:!default_loc - ("let%lwt should not be used at the module item level.\n" ^ - "Replace let%lwt x = e by let x = Lwt_main.run (e)") - in - let loc = !default_loc in - [%stri - let [%p var] = - (Lwt_main.run [@ocaml.ppwarning [%e warning]]) - [%e super#expression exp]] - - | x -> super#structure_item x); -end - + let warning = + estring ~loc:!default_loc + ("let%lwt should not be used at the module item level.\n" + ^ "Replace let%lwt x = e by let x = Lwt_main.run (e)") + in + let loc = !default_loc in + [%stri + let [%p var] = + (Lwt_main.run [@ocaml.ppwarning [%e warning]]) + [%e super#expression exp]] + | x -> super#structure_item x + end let args = [ - "-no-sequence", - Arg.Unit no_sequence_option, - " has no effect (deprecated)"; - - "-no-strict-sequence", + ("-no-sequence", Arg.Unit no_sequence_option, " has no effect (deprecated)"); + ( "-no-strict-sequence", Arg.Unit no_strict_sequence_option, - " has no effect (deprecated)"; + " has no effect (deprecated)" ); ] let () = let mapper = new mapper in - Driver.register_transformation "ppx_lwt" - ~impl:mapper#structure - ~intf:mapper#signature ; + Driver.register_transformation "ppx_lwt" ~impl:mapper#structure + ~intf:mapper#signature; List.iter (fun (key, spec, doc) -> Driver.add_arg key spec ~doc) args diff --git a/src/ppx/ppx_lwt.mli b/src/ppx/ppx_lwt.mli index 8591da2d19..e21591cdbd 100644 --- a/src/ppx/ppx_lwt.mli +++ b/src/ppx/ppx_lwt.mli @@ -1,164 +1,145 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Ppx syntax extension for Lwt *) - (** {2 Ppx extensions} - This Ppx extension adds various syntactic shortcut for lwt programming. - It needs OCaml >= 4.02 and {{:https://github.com/alainfrisch/ppx_tools}ppx_tools}. + This Ppx extension adds various syntactic shortcut for lwt programming. It + needs OCaml >= 4.02 and {{:https://github.com/alainfrisch/ppx_tools} + ppx_tools}. To use it, simply use the ocamlfind package [lwt_ppx]. - This extension adds the following syntax: - - - lwt-binding: + This extension adds the following syntax: - {[ -let%lwt ch = get_char stdin in -code - ]} + - lwt-binding: - is the same as [bind (get_char stdin) (fun ch -> code)]. + {[ + let%lwt ch = get_char stdin in + code + ]} - Moreover, it supports parallel binding: + is the same as [bind (get_char stdin) (fun ch -> code)]. - {[ -let%lwt x = do_something1 () -and y = do_something2 in -code - ]} + Moreover, it supports parallel binding: - will run [do_something1 ()] and [do_something2 ()], then - bind their results to [x] and [y]. It is the same as: + {[ + let%lwt x = do_something1 () and y = do_something2 in + code + ]} - {[ -let t1 = do_something1 -and t2 = do_something2 in -bind t1 (fun x -> bind t2 (fun y -> code)) - ]} + will run [do_something1 ()] and [do_something2 ()], then bind their results + to [x] and [y]. It is the same as: - Due to a {{:https://github.com/ocaml/ocaml/issues/7758} bug} in the OCaml - parser, if you'd like to put a type constraint on the variable, please write + {[ + let t1 = do_something1 and t2 = do_something2 in + bind t1 (fun x -> bind t2 (fun y -> code)) + ]} - {[ -let (foo : int) = do_something in -code - ]} + Due to a {{:https://github.com/ocaml/ocaml/issues/7758} bug} in the OCaml + parser, if you'd like to put a type constraint on the variable, please write - Not using parentheses will confuse the OCaml parser. + {[ + let (foo : int) = do_something in + code + ]} - - exception catching: + Not using parentheses will confuse the OCaml parser. - {[ -try%lwt - -with - - ]} + - exception catching: - For example: + {[ + try%lwt + + with + + ]} - {[ -try%lwt - f x -with - | Failure msg -> - prerr_endline msg; - return () - ]} + For example: - is expanded to: - - {[ -catch (fun () -> f x) - (function - | Failure msg -> + {[ + try%lwt f x + with Failure msg -> prerr_endline msg; return () - | exn -> - Lwt.fail exn) - ]} - - Note that the [exn -> Lwt.fail exn] branch is automatically added - when needed. - - - finalizer: - - {[ - () [%finally ] - ]} - - You can use [[%lwt.finally ...]] instead of [[%finally ...]]. - - - - assertion: - - {[ - assert%lwt - ]} - - - for loop: - - {[ -for%lwt i = to do - -done - ]} - - and: - - {[ -for%lwt i = downto do - -done - ]} - - - while loop: - - {[ -while%lwt do - -done - ]} - - - pattern matching: - - {[ -match%lwt with - | -> - ... - | -> - ]} - - Exception cases are also supported: - - {[ -match%lwt with - | exception -> - | -> - ... - | -> - ]} - - - conditional: - - {[ -if%lwt then - -else - - ]} - - and - - {[ - if%lwt then - ]} -*) - + ]} + + is expanded to: + + {[ + catch + (fun () -> f x) + (function + | Failure msg -> + prerr_endline msg; + return () + | exn -> Lwt.fail exn) + ]} + + Note that the [exn -> Lwt.fail exn] branch is automatically added when + needed. + + - finalizer: + + {[ () [%finally ] ]} + + You can use [\[%lwt.finally ...\]] instead of [\[%finally ...\]]. + + - assertion: + + {[ assert%lwt ]} + - for loop: + + {[ + for%lwt i = to do + + done + ]} + + and: + + {[ + for%lwt i = downto do + + done + ]} + - while loop: + + {[ + while%lwt do + + done + ]} + - pattern matching: + + {[ + match%lwt with + | -> + ... + | -> + ]} + + Exception cases are also supported: + + {[ + match%lwt with + | exception -> + | -> + ... + | -> + ]} + - conditional: + + {[ + if%lwt then + + else + + ]} + + and + + {[ if%lwt then ]} *) class mapper : Ppxlib.Ast_traverse.map diff --git a/src/react/lwt_react.mli b/src/react/lwt_react.mli index c148784fb5..bf85d94ff0 100644 --- a/src/react/lwt_react.mli +++ b/src/react/lwt_react.mli @@ -1,22 +1,19 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** React utilities *) -(** This module is an overlay for the [React] module. You can open it - instead of the [React] module in order to get all of [React]'s functions - plus Lwt ones. +(** This module is an overlay for the [React] module. You can open it instead of + the [React] module in order to get all of [React]'s functions plus Lwt ones. This module is provided by OPAM package [lwt_react]. Link with ocamlfind package [lwt_react]. *) type 'a event = 'a React.event - (** Type of events. *) +(** Type of events. *) type 'a signal = 'a React.signal - (** Type of signals. *) +(** Type of signals. *) module E : sig include module type of React.E @@ -24,9 +21,8 @@ module E : sig (** {2 Lwt-specific utilities} *) val with_finaliser : (unit -> unit) -> 'a event -> 'a event - (** [with_finaliser f e] returns an event [e'] which behave as - [e], except that [f] is called when [e'] is garbage - collected. *) + (** [with_finaliser f e] returns an event [e'] which behave as [e], except + that [f] is called when [e'] is garbage collected. *) val next : 'a event -> 'a Lwt.t (** [next e] returns the next occurrence of [e]. @@ -47,67 +43,55 @@ module E : sig stream. *) val limit : (unit -> unit Lwt.t) -> 'a event -> 'a event - (** [limit f e] limits the rate of [e] with [f]. + (** [limit f e] limits the rate of [e] with [f]. - For example, to limit the rate of an event to 1 per second you - can use: [limit (fun () -> Lwt_unix.sleep 1.0) event]. *) + For example, to limit the rate of an event to 1 per second you can use: + [limit (fun () -> Lwt_unix.sleep 1.0) event]. *) val from : (unit -> 'a Lwt.t) -> 'a event - (** [from f] creates an event which occurs each time [f ()] - returns a value. If [f] raises an exception, the event is just - stopped. *) + (** [from f] creates an event which occurs each time [f ()] returns a value. + If [f] raises an exception, the event is just stopped. *) val to_stream : 'a event -> 'a Lwt_stream.t - (** Creates a stream holding all values occurring on the given - event *) + (** Creates a stream holding all values occurring on the given event *) val of_stream : 'a Lwt_stream.t -> 'a event - (** [of_stream stream] creates an event which occurs each time a - value is available on the stream. + (** [of_stream stream] creates an event which occurs each time a value is + available on the stream. - If updating the event causes an exception at any point during the update - step, the excpetion is passed to [!]{!Lwt.async_exception_hook}, which - terminates the process by default. *) + If updating the event causes an exception at any point during the update + step, the excpetion is passed to [!]{!Lwt.async_exception_hook}, which + terminates the process by default. *) val delay : 'a event Lwt.t -> 'a event - (** [delay promise] is an event which does not occur until - [promise] resolves. Then it behaves as the event returned by - [promise]. *) + (** [delay promise] is an event which does not occur until [promise] resolves. + Then it behaves as the event returned by [promise]. *) val keep : 'a event -> unit - (** [keep e] keeps a reference to [e] so it will never be garbage - collected. *) + (** [keep e] keeps a reference to [e] so it will never be garbage collected. *) (** {2 Threaded versions of React transformation functions} *) - (** The following functions behave as their [React] counterpart, - except that they take functions that may yield. + (** The following functions behave as their [React] counterpart, except that + they take functions that may yield. - As usual the [_s] suffix is used when calls are serialized, and - the [_p] suffix is used when they are not. + As usual the [_s] suffix is used when calls are serialized, and the [_p] + suffix is used when they are not. Note that [*_p] functions may not preserve event order. *) val app_s : ('a -> 'b Lwt.t) event -> 'a event -> 'b event val app_p : ('a -> 'b Lwt.t) event -> 'a event -> 'b event - val map_s : ('a -> 'b Lwt.t) -> 'a event -> 'b event - val map_p: ('a -> 'b Lwt.t) -> 'a event -> 'b event - + val map_p : ('a -> 'b Lwt.t) -> 'a event -> 'b event val filter_s : ('a -> bool Lwt.t) -> 'a event -> 'a event val filter_p : ('a -> bool Lwt.t) -> 'a event -> 'a event - val fmap_s : ('a -> 'b option Lwt.t) -> 'a event -> 'b event val fmap_p : ('a -> 'b option Lwt.t) -> 'a event -> 'b event - val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a event -> 'b event - val accum_s : ('a -> 'a Lwt.t) event -> 'a -> 'a event - val fold_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a event - val merge_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event list -> 'a event - val run_s : 'a Lwt.t event -> 'a event val run_p : 'a Lwt.t event -> 'a event end @@ -118,69 +102,139 @@ module S : sig (** {2 Monadic interface} *) val return : 'a -> 'a signal - (** Same as [const]. *) - - val bind : ?eq : ('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal) -> 'b signal - (** [bind ?eq s f] is initially [f x] where [x] is the current - value of [s]. Each time [s] changes to a new value [y], [bind - signal f] is set to [f y], until the next change of - [signal]. *) - - val bind_s : ?eq : ('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal Lwt.t) -> 'b signal Lwt.t - (** Same as {!bind} except that [f] returns a promise. Calls to [f] - are serialized. *) + (** Same as [const]. *) + + val bind : + ?eq:('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal) -> 'b signal + (** [bind ?eq s f] is initially [f x] where [x] is the current value of [s]. + Each time [s] changes to a new value [y], [bind + signal f] is set + to [f y], until the next change of [signal]. *) + + val bind_s : + ?eq:('b -> 'b -> bool) -> + 'a signal -> + ('a -> 'b signal Lwt.t) -> + 'b signal Lwt.t + (** Same as {!bind} except that [f] returns a promise. Calls to [f] are + serialized. *) (** {2 Lwt-specific utilities} *) val with_finaliser : (unit -> unit) -> 'a signal -> 'a signal - (** [with_finaliser f s] returns a signal [s'] which behaves as - [s], except that [f] is called when [s'] is garbage - collected. *) + (** [with_finaliser f s] returns a signal [s'] which behaves as [s], except + that [f] is called when [s'] is garbage collected. *) - val limit : ?eq : ('a -> 'a -> bool) -> (unit -> unit Lwt.t) -> 'a signal -> 'a signal - (** [limit f s] limits the rate of [s] update with [f]. + val limit : + ?eq:('a -> 'a -> bool) -> (unit -> unit Lwt.t) -> 'a signal -> 'a signal + (** [limit f s] limits the rate of [s] update with [f]. - For example, to limit it to 1 per second, you can use: [limit + For example, to limit it to 1 per second, you can use: + [limit (fun () -> Lwt_unix.sleep 1.0) s]. *) val keep : 'a signal -> unit - (** [keep s] keeps a reference to [s] so it will never be garbage - collected. *) + (** [keep s] keeps a reference to [s] so it will never be garbage collected. *) (** {2 Threaded versions of React transformation functions} *) - (** The following functions behave as their [React] counterpart, - except that they take functions that may yield. + (** The following functions behave as their [React] counterpart, except that + they take functions that may yield. - The [_s] suffix means that calls are serialized. - *) + The [_s] suffix means that calls are serialized. *) - val app_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) signal -> 'a signal -> 'b signal Lwt.t + val app_s : + ?eq:('b -> 'b -> bool) -> + ('a -> 'b Lwt.t) signal -> + 'a signal -> + 'b signal Lwt.t - val map_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'a signal -> 'b signal Lwt.t + val map_s : + ?eq:('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'a signal -> 'b signal Lwt.t - val filter_s : ?eq : ('a -> 'a -> bool) -> ('a -> bool Lwt.t) -> 'a -> 'a signal -> 'a signal Lwt.t + val filter_s : + ?eq:('a -> 'a -> bool) -> + ('a -> bool Lwt.t) -> + 'a -> + 'a signal -> + 'a signal Lwt.t - val fmap_s : ?eq:('b -> 'b -> bool) -> ('a -> 'b option Lwt.t) -> 'b -> 'a signal -> 'b signal Lwt.t + val fmap_s : + ?eq:('b -> 'b -> bool) -> + ('a -> 'b option Lwt.t) -> + 'b -> + 'a signal -> + 'b signal Lwt.t val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a signal -> 'b event - val sample_s : ('b -> 'a -> 'c Lwt.t) -> 'b event -> 'a signal -> 'c event - val accum_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'a Lwt.t) event -> 'a -> 'a signal - - val fold_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a signal - - val merge_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b signal list -> 'a signal Lwt.t - - val l1_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'a signal -> 'b signal Lwt.t - val l2_s : ?eq : ('c -> 'c -> bool) -> ('a -> 'b -> 'c Lwt.t) -> 'a signal -> 'b signal -> 'c signal Lwt.t - val l3_s : ?eq : ('d -> 'd -> bool) -> ('a -> 'b -> 'c -> 'd Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal Lwt.t - val l4_s : ?eq : ('e -> 'e -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal Lwt.t - val l5_s : ?eq : ('f -> 'f -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal Lwt.t - val l6_s : ?eq : ('g -> 'g -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal -> 'g signal Lwt.t - - val run_s : ?eq : ('a -> 'a -> bool) -> 'a Lwt.t signal -> 'a signal Lwt.t + val accum_s : + ?eq:('a -> 'a -> bool) -> ('a -> 'a Lwt.t) event -> 'a -> 'a signal + + val fold_s : + ?eq:('a -> 'a -> bool) -> + ('a -> 'b -> 'a Lwt.t) -> + 'a -> + 'b event -> + 'a signal + + val merge_s : + ?eq:('a -> 'a -> bool) -> + ('a -> 'b -> 'a Lwt.t) -> + 'a -> + 'b signal list -> + 'a signal Lwt.t + + val l1_s : + ?eq:('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'a signal -> 'b signal Lwt.t + + val l2_s : + ?eq:('c -> 'c -> bool) -> + ('a -> 'b -> 'c Lwt.t) -> + 'a signal -> + 'b signal -> + 'c signal Lwt.t + + val l3_s : + ?eq:('d -> 'd -> bool) -> + ('a -> 'b -> 'c -> 'd Lwt.t) -> + 'a signal -> + 'b signal -> + 'c signal -> + 'd signal Lwt.t + + val l4_s : + ?eq:('e -> 'e -> bool) -> + ('a -> 'b -> 'c -> 'd -> 'e Lwt.t) -> + 'a signal -> + 'b signal -> + 'c signal -> + 'd signal -> + 'e signal Lwt.t + + val l5_s : + ?eq:('f -> 'f -> bool) -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'f Lwt.t) -> + 'a signal -> + 'b signal -> + 'c signal -> + 'd signal -> + 'e signal -> + 'f signal Lwt.t + + val l6_s : + ?eq:('g -> 'g -> bool) -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g Lwt.t) -> + 'a signal -> + 'b signal -> + 'c signal -> + 'd signal -> + 'e signal -> + 'f signal -> + 'g signal Lwt.t + + val run_s : ?eq:('a -> 'a -> bool) -> 'a Lwt.t signal -> 'a signal Lwt.t end (**/**) diff --git a/src/unix/config/discover.ml b/src/unix/config/discover.ml index 28af2b0302..7a0c10a369 100644 --- a/src/unix/config/discover.ml +++ b/src/unix/config/discover.ml @@ -1,8 +1,6 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Lwt_unix feature discovery script. This program tests system features, and outputs four files: @@ -40,9 +38,7 @@ The possible arguments can be found by running - {v - dune exec src/unix/config/discover.exe -- --help - v} + {v dune exec src/unix/config/discover.exe -- --help v} In addition, the environment variables [LIBEV_CFLAGS], [LIBEV_LIBS], [PTHREAD_CFLAGS], and [PTHREAD_LIBS] can be used to override the flags used @@ -51,120 +47,98 @@ This [discover.ml] was added in Lwt 4.3.0, so if you pass arguments to [discover.ml], 4.3.0 is the minimal required version of Lwt. - The code is broken up into sections, each of which is an OCaml module. If your text editor supports code folding, it will make reading this file much easier if you fold the structures. Add feature tests at the end of module [Features]. For most cases, what to - do should be clear from the feature tests that are already in that - module. *) - - + do should be clear from the feature tests that are already in that module. *) module Configurator = Configurator.V1 -let split = Configurator.Flags.extract_blank_separated_words -let uppercase = String.uppercase [@ocaml.warning "-3"] - +let split = Configurator.Flags.extract_blank_separated_words +let uppercase = (String.uppercase [@ocaml.warning "-3"]) (* Command-line arguments and environment variables. *) -module Arguments : -sig +module Arguments : sig val use_libev : bool option ref val use_pthread : bool option ref val android_target : bool option ref val libev_default : bool option ref val verbose : bool ref - val args : (Arg.key * Arg.spec * Arg.doc) list - val parse_environment_variable : unit -> unit val parse_arguments_file : unit -> unit -end = -struct +end = struct let use_libev = ref None let use_pthread = ref None let android_target = ref None let libev_default = ref None let verbose = ref false - - let set reference = - Arg.Bool (fun value -> reference := Some value) - - let args = [ - "--use-libev", set use_libev, - "BOOLEAN whether to check for libev"; - - "--use-pthread", set use_pthread, - "BOOLEAN whether to check for libpthread"; - - "--android-target", set android_target, - "BOOLEAN whether to compile for Android"; - - "--libev-default", set libev_default, - "BOOLEAN whether to use the libev backend by default"; - - "--verbose", Arg.Set verbose, - "BOOLEAN show results of feature detection"; - ] + let set reference = Arg.Bool (fun value -> reference := Some value) + + let args = + [ + ("--use-libev", set use_libev, "BOOLEAN whether to check for libev"); + ( "--use-pthread", + set use_pthread, + "BOOLEAN whether to check for libpthread" ); + ( "--android-target", + set android_target, + "BOOLEAN whether to compile for Android" ); + ( "--libev-default", + set libev_default, + "BOOLEAN whether to use the libev backend by default" ); + ("--verbose", Arg.Set verbose, "BOOLEAN show results of feature detection"); + ] let environment_variable = "LWT_DISCOVER_ARGUMENTS" let arguments_file = "discover_arguments" let parse arguments = try - Arg.parse_argv - ~current:(ref 0) - (Array.of_list ((Filename.basename Sys.argv.(0))::(split arguments))) + Arg.parse_argv ~current:(ref 0) + (Array.of_list (Filename.basename Sys.argv.(0) :: split arguments)) (Arg.align args) (fun s -> raise (Arg.Bad (Printf.sprintf "Unrecognized argument '%s'" s))) - (Printf.sprintf - "Environment variable usage: %s=[OPTIONS]" environment_variable) + (Printf.sprintf "Environment variable usage: %s=[OPTIONS]" + environment_variable) with | Arg.Bad s -> - prerr_string s; - exit 2 + prerr_string s; + exit 2 | Arg.Help s -> - print_string s; - exit 0 + print_string s; + exit 0 let parse_environment_variable () = match Sys.getenv environment_variable with - | exception Not_found -> - () - | arguments -> - parse arguments + | exception Not_found -> () + | arguments -> parse arguments let parse_arguments_file () = try let channel = open_in arguments_file in parse (input_line channel); close_in channel - with _ -> - () + with _ -> () end - - -module C_library_flags : -sig +module C_library_flags : sig val detect : ?env_var:string -> ?package:string -> ?header:string -> Configurator.t -> library:string -> - unit + unit val ws2_32_lib : Configurator.t -> unit - val c_flags : unit -> string list val link_flags : unit -> string list val add_link_flags : string list -> unit -end = -struct +end = struct let c_flags = ref [] let link_flags = ref [] @@ -172,46 +146,30 @@ struct c_flags := !c_flags @ c_flags'; link_flags := !link_flags @ link_flags' - let add_link_flags flags = - extend [] flags - - let (//) = Filename.concat + let add_link_flags flags = extend [] flags + let ( // ) = Filename.concat - let default_search_paths = [ - "/usr"; - "/usr/local"; - "/usr/pkg"; - "/opt"; - "/opt/local"; - "/sw"; - "/mingw"; - ] + let default_search_paths = + [ "/usr"; "/usr/local"; "/usr/pkg"; "/opt"; "/opt/local"; "/sw"; "/mingw" ] - let path_separator = - if Sys.win32 then - ';' - else - ':' + let path_separator = if Sys.win32 then ';' else ':' let paths_from_environment_variable variable = match Sys.getenv variable with - | exception Not_found -> - [] + | exception Not_found -> [] | paths -> - Configurator.Flags.extract_words paths ~is_word_char:((<>) path_separator) - |> List.map Filename.dirname + Configurator.Flags.extract_words paths + ~is_word_char:(( <> ) path_separator) + |> List.map Filename.dirname let search_paths = - lazy begin - paths_from_environment_variable "C_INCLUDE_PATH" @ - paths_from_environment_variable "LIBRARY_PATH" @ - default_search_paths - end + lazy + (paths_from_environment_variable "C_INCLUDE_PATH" + @ paths_from_environment_variable "LIBRARY_PATH" + @ default_search_paths) let default argument fallback = - match argument with - | Some value -> value - | None -> fallback + match argument with Some value -> value | None -> fallback let detect ?env_var ?package ?header context ~library = let env_var = default env_var ("LIB" ^ uppercase library) in @@ -221,78 +179,55 @@ struct let flags_from_env_var = let c_flags_var = env_var ^ "_CFLAGS" in let link_flags_var = env_var ^ "_LIBS" in - match Sys.getenv c_flags_var, Sys.getenv link_flags_var with - | exception Not_found -> - None - | "", "" -> - None - | values -> - Some values + match (Sys.getenv c_flags_var, Sys.getenv link_flags_var) with + | exception Not_found -> None + | "", "" -> None + | values -> Some values in match flags_from_env_var with | Some (c_flags', link_flags') -> - extend (split c_flags') (split link_flags') - - | None -> - let flags_from_pkg_config = - match Configurator.Pkg_config.get context with - | None -> - None - | Some pkg_config -> - Configurator.Pkg_config.query pkg_config ~package - in + extend (split c_flags') (split link_flags') + | None -> ( + let flags_from_pkg_config = + match Configurator.Pkg_config.get context with + | None -> None + | Some pkg_config -> Configurator.Pkg_config.query pkg_config ~package + in - match flags_from_pkg_config with - | Some flags -> - extend flags.cflags flags.libs - - | None -> - try - let path = - List.find - (fun path -> Sys.file_exists (path // "include" // header)) - (Lazy.force search_paths) - in - extend - ["-I" ^ (path // "include")] - ["-L" ^ (path // "lib"); "-l" ^ library] - with Not_found -> - () + match flags_from_pkg_config with + | Some flags -> extend flags.cflags flags.libs + | None -> ( + try + let path = + List.find + (fun path -> Sys.file_exists (path // "include" // header)) + (Lazy.force search_paths) + in + extend + [ "-I" ^ (path // "include") ] + [ "-L" ^ (path // "lib"); "-l" ^ library ] + with Not_found -> ())) let ws2_32_lib context = if Configurator.ocaml_config_var_exn context "os_type" = "Win32" then - let unicode = ["-DUNICODE"; "-D_UNICODE"] in + let unicode = [ "-DUNICODE"; "-D_UNICODE" ] in if Configurator.ocaml_config_var_exn context "ccomp_type" = "msvc" then - extend unicode ["ws2_32.lib"] - else - extend unicode ["-lws2_32"] + extend unicode [ "ws2_32.lib" ] + else extend unicode [ "-lws2_32" ] - let c_flags () = - !c_flags - - let link_flags () = - !link_flags + let c_flags () = !c_flags + let link_flags () = !link_flags end - - -module Output : -sig - type t = { - name : string; - found : bool; - } +module Output : sig + type t = { name : string; found : bool } val write_c_header : ?extra:string list -> Configurator.t -> t list -> unit val write_ml_file : ?extra:t list -> t list -> unit val write_flags_files : unit -> unit -end = -struct - type t = { - name : string; - found : bool; - } +end = struct + type t = { name : string; found : bool } module C_define = Configurator.C_define @@ -303,32 +238,30 @@ struct let write_c_header ?(extra = []) context macros = macros - |> List.filter (fun {found; _} -> found) - |> List.map (fun {name; _} -> name, C_define.Value.Switch true) - |> (@) (List.map (fun s -> s, C_define.Value.Switch true) extra) + |> List.filter (fun { found; _ } -> found) + |> List.map (fun { name; _ } -> (name, C_define.Value.Switch true)) + |> ( @ ) (List.map (fun s -> (s, C_define.Value.Switch true)) extra) |> C_define.gen_header_file context ~fname:c_header let write_ml_file ?(extra = []) macros = macros - |> List.map (fun {name; found} -> Printf.sprintf "let _%s = %b" name found) - |> (@) (List.map - (fun {name; found} -> Printf.sprintf "let %s = %b" name found) extra) + |> List.map (fun { name; found } -> + Printf.sprintf "let _%s = %b" name found) + |> ( @ ) + (List.map + (fun { name; found } -> Printf.sprintf "let %s = %b" name found) + extra) |> Configurator.Flags.write_lines ml_file let write_flags_files () = - Configurator.Flags.write_sexp - c_flags_file (C_library_flags.c_flags ()); - Configurator.Flags.write_sexp - link_flags_file (C_library_flags.link_flags ()); + Configurator.Flags.write_sexp c_flags_file (C_library_flags.c_flags ()); + Configurator.Flags.write_sexp link_flags_file + (C_library_flags.link_flags ()) end - - -module Features : -sig +module Features : sig val detect : Configurator.t -> Output.t list -end = -struct +end = struct type t = { pretty_name : string; macro_name : string; @@ -336,14 +269,10 @@ struct } let features = ref [] - - let feature the_feature = - features := !features @ [the_feature] + let feature the_feature = features := !features @ [ the_feature ] let verbose = - Printf.ksprintf (fun s -> - if !Arguments.verbose then - print_string s) + Printf.ksprintf (fun s -> if !Arguments.verbose then print_string s) let dots feature to_column = String.make (to_column - String.length feature.pretty_name) '.' @@ -352,33 +281,24 @@ struct let detect context = !features - |> List.map begin fun feature -> - verbose "%s " feature.pretty_name; - match feature.detect context with - | None -> - verbose "%s skipped\n" (dots feature right_column); - Output.{name = feature.macro_name; found = false} - | Some found -> - begin - if found then - verbose "%s available\n" (dots feature (right_column - 2)) - else - verbose "%s unavailable\n" (dots feature (right_column - 4)) - end; - Output.{name = feature.macro_name; found} - end + |> List.map (fun feature -> + verbose "%s " feature.pretty_name; + match feature.detect context with + | None -> + verbose "%s skipped\n" (dots feature right_column); + Output.{ name = feature.macro_name; found = false } + | Some found -> + if found then + verbose "%s available\n" (dots feature (right_column - 2)) + else verbose "%s unavailable\n" (dots feature (right_column - 4)); + Output.{ name = feature.macro_name; found }) let compiles ?(werror = false) ?(link_flags = []) context code = let c_flags = C_library_flags.c_flags () in - let c_flags = - if werror then - "-Werror"::c_flags - else - c_flags - in - let link_flags = link_flags @ (C_library_flags.link_flags ()) in - Configurator.c_test context ~c_flags ~link_flags code - |> fun result -> Some result + let c_flags = if werror then "-Werror" :: c_flags else c_flags in + let link_flags = link_flags @ C_library_flags.link_flags () in + Configurator.c_test context ~c_flags ~link_flags code |> fun result -> + Some result let skip_if_windows context k = match Configurator.ocaml_config_var_exn context "os_type" with @@ -386,42 +306,45 @@ struct | _ -> k () let skip_if_android _context k = - match !Arguments.android_target with - | Some true -> None - | _ -> k () - - let () = feature { - pretty_name = "libev"; - macro_name = "HAVE_LIBEV"; - detect = fun context -> - let detect_esy_wants_libev () = - match Sys.getenv "cur__target_dir" with - | exception Not_found -> None - | _ -> - match Sys.getenv "LIBEV_CFLAGS", Sys.getenv "LIBEV_LIBS" with - | exception Not_found -> Some false - | "", "" -> Some false - | _ -> Some true - in - - let should_look_for_libev = - match !Arguments.use_libev with - | Some argument -> - argument - | None -> - match detect_esy_wants_libev () with - | Some result -> - result - | None -> - (* we're not under esy *) - let os = Configurator.ocaml_config_var_exn context "os_type" in - os <> "Win32" && !Arguments.android_target <> Some true - in - - if not should_look_for_libev then - None - else begin - let code = {| + match !Arguments.android_target with Some true -> None | _ -> k () + + let () = + feature + { + pretty_name = "libev"; + macro_name = "HAVE_LIBEV"; + detect = + (fun context -> + let detect_esy_wants_libev () = + match Sys.getenv "cur__target_dir" with + | exception Not_found -> None + | _ -> ( + match + (Sys.getenv "LIBEV_CFLAGS", Sys.getenv "LIBEV_LIBS") + with + | exception Not_found -> Some false + | "", "" -> Some false + | _ -> Some true) + in + + let should_look_for_libev = + match !Arguments.use_libev with + | Some argument -> argument + | None -> ( + match detect_esy_wants_libev () with + | Some result -> result + | None -> + (* we're not under esy *) + let os = + Configurator.ocaml_config_var_exn context "os_type" + in + os <> "Win32" && !Arguments.android_target <> Some true) + in + + if not should_look_for_libev then None + else + let code = + {| #include int main() @@ -430,26 +353,28 @@ struct return 0; } |} - in - match compiles context code ~link_flags:["-lev"] with - | Some true -> - C_library_flags.add_link_flags ["-lev"]; - Some true - | _ -> - C_library_flags.detect context ~library:"ev"; - compiles context code - end - } - - let () = feature { - pretty_name = "pthread"; - macro_name = "HAVE_PTHREAD"; - detect = fun context -> - if !Arguments.use_pthread = Some false then - None - else begin - skip_if_windows context @@ fun () -> - let code = {| + in + match compiles context code ~link_flags:[ "-lev" ] with + | Some true -> + C_library_flags.add_link_flags [ "-lev" ]; + Some true + | _ -> + C_library_flags.detect context ~library:"ev"; + compiles context code); + } + + let () = + feature + { + pretty_name = "pthread"; + macro_name = "HAVE_PTHREAD"; + detect = + (fun context -> + if !Arguments.use_pthread = Some false then None + else + skip_if_windows context @@ fun () -> + let code = + {| #include int main() @@ -458,40 +383,41 @@ struct return 0; } |} - in - (* On some platforms, pthread is included in the standard library, but - linking with -lpthread fails. So, try to link the test code without - any flags first. - - If that fails and we are not targetting Android, try to link with - -lpthread. If *that* fails, search for libpthread in the filesystem. - - When targetting Android, compiling without -lpthread is the only way - to link with pthread, and we don't to search for libpthread, because - if we find it, it is likely the host's libpthread. *) - match compiles context code with - | Some true -> Some true - | no -> - if !Arguments.android_target = Some true then - no - else begin - match compiles context code ~link_flags:["-lpthread"] with - | Some true -> - C_library_flags.add_link_flags ["-lpthread"]; - Some true - | _ -> - C_library_flags.detect context ~library:"pthread"; - compiles context code - end - end - } - - let () = feature { - pretty_name = "eventfd"; - macro_name = "HAVE_EVENTFD"; - detect = fun context -> - skip_if_windows context @@ fun () -> - compiles context {| + in + (* On some platforms, pthread is included in the standard library, but + linking with -lpthread fails. So, try to link the test code without + any flags first. + + If that fails and we are not targetting Android, try to link with + -lpthread. If *that* fails, search for libpthread in the filesystem. + + When targetting Android, compiling without -lpthread is the only way + to link with pthread, and we don't to search for libpthread, because + if we find it, it is likely the host's libpthread. *) + match compiles context code with + | Some true -> Some true + | no -> ( + if !Arguments.android_target = Some true then no + else + match compiles context code ~link_flags:[ "-lpthread" ] with + | Some true -> + C_library_flags.add_link_flags [ "-lpthread" ]; + Some true + | _ -> + C_library_flags.detect context ~library:"pthread"; + compiles context code)); + } + + let () = + feature + { + pretty_name = "eventfd"; + macro_name = "HAVE_EVENTFD"; + detect = + (fun context -> + skip_if_windows context @@ fun () -> + compiles context + {| #include int main() @@ -499,15 +425,19 @@ struct eventfd(0, 0); return 0; } - |} - } - - let () = feature { - pretty_name = "fd passing"; - macro_name = "HAVE_FD_PASSING"; - detect = fun context -> - skip_if_windows context @@ fun () -> - compiles context {| + |}); + } + + let () = + feature + { + pretty_name = "fd passing"; + macro_name = "HAVE_FD_PASSING"; + detect = + (fun context -> + skip_if_windows context @@ fun () -> + compiles context + {| #include #include @@ -518,16 +448,20 @@ struct msg.msg_control = 0; return 0; } - |} - } - - let () = feature { - pretty_name = "sched_getcpu"; - macro_name = "HAVE_GETCPU"; - detect = fun context -> - skip_if_windows context @@ fun () -> - skip_if_android context @@ fun () -> - compiles context {| + |}); + } + + let () = + feature + { + pretty_name = "sched_getcpu"; + macro_name = "HAVE_GETCPU"; + detect = + (fun context -> + skip_if_windows context @@ fun () -> + skip_if_android context @@ fun () -> + compiles context + {| #define _GNU_SOURCE #include @@ -536,16 +470,20 @@ struct sched_getcpu(); return 0; } - |} - } - - let () = feature { - pretty_name = "affinity getting/setting"; - macro_name = "HAVE_AFFINITY"; - detect = fun context -> - skip_if_windows context @@ fun () -> - skip_if_android context @@ fun () -> - compiles context {| + |}); + } + + let () = + feature + { + pretty_name = "affinity getting/setting"; + macro_name = "HAVE_AFFINITY"; + detect = + (fun context -> + skip_if_windows context @@ fun () -> + skip_if_android context @@ fun () -> + compiles context + {| #define _GNU_SOURCE #include @@ -554,61 +492,80 @@ struct sched_getaffinity(0, 0, 0); return 0; } - |} - } + |}); + } - let get_credentials struct_name = {| + let get_credentials struct_name = + {| #define _GNU_SOURCE #include #include int main() { - struct |} ^ struct_name ^ {| cred; + struct |} + ^ struct_name + ^ {| cred; socklen_t cred_len = sizeof(cred); getsockopt(0, SOL_SOCKET, SO_PEERCRED, &cred, &cred_len); return 0; } |} - let () = feature { - pretty_name = "credentials getting (Linux)"; - macro_name = "HAVE_GET_CREDENTIALS_LINUX"; - detect = fun context -> - skip_if_windows context @@ fun () -> - compiles context (get_credentials "ucred") - } - - let () = feature { - pretty_name = "credentials getting (NetBSD)"; - macro_name = "HAVE_GET_CREDENTIALS_NETBSD"; - detect = fun context -> - skip_if_windows context @@ fun () -> - compiles context (get_credentials "sockcred") - } - - let () = feature { - pretty_name = "credentials getting (OpenBSD)"; - macro_name = "HAVE_GET_CREDENTIALS_OPENBSD"; - detect = fun context -> - skip_if_windows context @@ fun () -> - compiles context (get_credentials "sockpeercred") - } - - let () = feature { - pretty_name = "credentials getting (FreeBSD)"; - macro_name = "HAVE_GET_CREDENTIALS_FREEBSD"; - detect = fun context -> - skip_if_windows context @@ fun () -> - compiles context (get_credentials "cmsgcred") - } - - let () = feature { - pretty_name = "getpeereid"; - macro_name = "HAVE_GETPEEREID"; - detect = fun context -> - skip_if_windows context @@ fun () -> - compiles context {| + let () = + feature + { + pretty_name = "credentials getting (Linux)"; + macro_name = "HAVE_GET_CREDENTIALS_LINUX"; + detect = + (fun context -> + skip_if_windows context @@ fun () -> + compiles context (get_credentials "ucred")); + } + + let () = + feature + { + pretty_name = "credentials getting (NetBSD)"; + macro_name = "HAVE_GET_CREDENTIALS_NETBSD"; + detect = + (fun context -> + skip_if_windows context @@ fun () -> + compiles context (get_credentials "sockcred")); + } + + let () = + feature + { + pretty_name = "credentials getting (OpenBSD)"; + macro_name = "HAVE_GET_CREDENTIALS_OPENBSD"; + detect = + (fun context -> + skip_if_windows context @@ fun () -> + compiles context (get_credentials "sockpeercred")); + } + + let () = + feature + { + pretty_name = "credentials getting (FreeBSD)"; + macro_name = "HAVE_GET_CREDENTIALS_FREEBSD"; + detect = + (fun context -> + skip_if_windows context @@ fun () -> + compiles context (get_credentials "cmsgcred")); + } + + let () = + feature + { + pretty_name = "getpeereid"; + macro_name = "HAVE_GETPEEREID"; + detect = + (fun context -> + skip_if_windows context @@ fun () -> + compiles context + {| #include #include @@ -619,15 +576,19 @@ struct getpeereid(0, &euid, &egid); return 0; } - |} - } - - let () = feature { - pretty_name = "fdatasync"; - macro_name = "HAVE_FDATASYNC"; - detect = fun context -> - skip_if_windows context @@ fun () -> - compiles context {| + |}); + } + + let () = + feature + { + pretty_name = "fdatasync"; + macro_name = "HAVE_FDATASYNC"; + detect = + (fun context -> + skip_if_windows context @@ fun () -> + compiles context + {| #include int main() @@ -636,16 +597,20 @@ struct fdatasyncp(0); return 0; } - |} - } - - let () = feature { - pretty_name = "netdb_reentrant"; - macro_name = "HAVE_NETDB_REENTRANT"; - detect = fun context -> - skip_if_windows context @@ fun () -> - skip_if_android context @@ fun () -> - compiles context {| + |}); + } + + let () = + feature + { + pretty_name = "netdb_reentrant"; + macro_name = "HAVE_NETDB_REENTRANT"; + detect = + (fun context -> + skip_if_windows context @@ fun () -> + skip_if_android context @@ fun () -> + compiles context + {| #define _POSIX_PTHREAD_SEMANTICS #include #include @@ -711,15 +676,19 @@ struct return 0; } - |} - } - - let () = feature { - pretty_name = "reentrant gethost*"; - macro_name = "HAVE_REENTRANT_HOSTENT"; - detect = fun context -> - skip_if_windows context @@ fun () -> - compiles context {| + |}); + } + + let () = + feature + { + pretty_name = "reentrant gethost*"; + macro_name = "HAVE_REENTRANT_HOSTENT"; + detect = + (fun context -> + skip_if_windows context @@ fun () -> + compiles context + {| #define _GNU_SOURCE #include #include @@ -742,10 +711,11 @@ struct return 0; #endif } - |} - } + |}); + } - let nanosecond_stat projection = {| + let nanosecond_stat projection = + {| #define _GNU_SOURCE #include #include @@ -754,40 +724,55 @@ struct int main() { struct stat *buf; double a, m, c; - a = (double)buf->st_a|} ^ projection ^ {|; - m = (double)buf->st_m|} ^ projection ^ {|; - c = (double)buf->st_c|} ^ projection ^ {|; + a = (double)buf->st_a|} + ^ projection + ^ {|; + m = (double)buf->st_m|} + ^ projection + ^ {|; + c = (double)buf->st_c|} + ^ projection + ^ {|; return 0; } |} - let () = feature { - pretty_name = "st_mtim.tv_nsec"; - macro_name = "HAVE_ST_MTIM_TV_NSEC"; - detect = fun context -> - compiles context (nanosecond_stat "tim.tv_nsec") - } - - let () = feature { - pretty_name = "st_mtimespec.tv_nsec"; - macro_name = "HAVE_ST_MTIMESPEC_TV_NSEC"; - detect = fun context -> - compiles context (nanosecond_stat "timespec.tv_nsec") - } - - let () = feature { - pretty_name = "st_mtimensec"; - macro_name = "HAVE_ST_MTIMENSEC"; - detect = fun context -> - compiles context (nanosecond_stat "timensec") - } - - let () = feature { - pretty_name = "BSD mincore"; - macro_name = "HAVE_BSD_MINCORE"; - detect = fun context -> - skip_if_windows context @@ fun () -> - compiles ~werror:true context {| + let () = + feature + { + pretty_name = "st_mtim.tv_nsec"; + macro_name = "HAVE_ST_MTIM_TV_NSEC"; + detect = + (fun context -> compiles context (nanosecond_stat "tim.tv_nsec")); + } + + let () = + feature + { + pretty_name = "st_mtimespec.tv_nsec"; + macro_name = "HAVE_ST_MTIMESPEC_TV_NSEC"; + detect = + (fun context -> compiles context (nanosecond_stat "timespec.tv_nsec")); + } + + let () = + feature + { + pretty_name = "st_mtimensec"; + macro_name = "HAVE_ST_MTIMENSEC"; + detect = (fun context -> compiles context (nanosecond_stat "timensec")); + } + + let () = + feature + { + pretty_name = "BSD mincore"; + macro_name = "HAVE_BSD_MINCORE"; + detect = + (fun context -> + skip_if_windows context @@ fun () -> + compiles ~werror:true context + {| #include #include @@ -796,15 +781,19 @@ struct int (*mincore_ptr)(const void*, size_t, char*) = mincore; return (int)(mincore_ptr == NULL); } - |} - } - - let () = feature { - pretty_name = "accept4"; - macro_name = "HAVE_ACCEPT4"; - detect = fun context -> - skip_if_windows context @@ fun () -> - compiles context {| + |}); + } + + let () = + feature + { + pretty_name = "accept4"; + macro_name = "HAVE_ACCEPT4"; + detect = + (fun context -> + skip_if_windows context @@ fun () -> + compiles context + {| #define _GNU_SOURCE #include #include @@ -814,61 +803,50 @@ struct accept4(0, NULL, 0, 0); return 0; } - |} - } + |}); + } end +let () = + (match List.partition (( = ) "--save") (Array.to_list Sys.argv) with + | [ "--save" ], rest -> + Configurator.Flags.write_lines "src/unix/discover_arguments" + [ String.concat " " (List.tl rest) ]; + exit 0 + | _ -> ()); + + Configurator.main ~args:Arguments.args ~name:"lwt" (fun context -> + (* Parse arguments from additional sources. *) + Arguments.parse_environment_variable (); + Arguments.parse_arguments_file (); + (* Detect features. *) + let macros = Features.detect context in -let () = - begin match List.partition ((=) "--save") (Array.to_list Sys.argv) with - | ["--save"], rest -> - Configurator.Flags.write_lines - "src/unix/discover_arguments" [String.concat " " (List.tl rest)]; - exit 0 - | _ -> - () - end; - - Configurator.main ~args:Arguments.args ~name:"lwt" begin fun context -> - (* Parse arguments from additional sources. *) - Arguments.parse_environment_variable (); - Arguments.parse_arguments_file (); - - (* Detect features. *) - let macros = Features.detect context in - - (* Link with ws2_32.lib on Windows. *) - C_library_flags.ws2_32_lib context; - - (* Write lwt_features.h. *) - let extra = - match Configurator.ocaml_config_var_exn context "os_type" with - | "Win32" -> ["LWT_ON_WINDOWS"] - | _ -> [] - in - Output.write_c_header ~extra context macros; - - (* Write lwt_features.ml. *) - let libev_default = - match !Arguments.libev_default with - | Some argument -> - argument - | None -> - true - in - Output.write_ml_file - ~extra:[ - { - name = "android"; - found = !Arguments.android_target = Some true; - }; - { - name = "libev_default"; - found = libev_default; - }; - ] macros; - - (* Write unix_c_flags.sexp and unix_c_library_flags.sexp. *) - Output.write_flags_files () - end + (* Link with ws2_32.lib on Windows. *) + C_library_flags.ws2_32_lib context; + + (* Write lwt_features.h. *) + let extra = + match Configurator.ocaml_config_var_exn context "os_type" with + | "Win32" -> [ "LWT_ON_WINDOWS" ] + | _ -> [] + in + Output.write_c_header ~extra context macros; + + (* Write lwt_features.ml. *) + let libev_default = + match !Arguments.libev_default with + | Some argument -> argument + | None -> true + in + Output.write_ml_file + ~extra: + [ + { name = "android"; found = !Arguments.android_target = Some true }; + { name = "libev_default"; found = libev_default }; + ] + macros; + + (* Write unix_c_flags.sexp and unix_c_library_flags.sexp. *) + Output.write_flags_files ()) diff --git a/src/unix/luv/lwt_luv.ml b/src/unix/luv/lwt_luv.ml index ae1f7ff656..1a6363e480 100644 --- a/src/unix/luv/lwt_luv.ml +++ b/src/unix/luv/lwt_luv.ml @@ -1,57 +1,91 @@ let from_unix : Unix.file_descr -> int = Obj.magic -class engine = object - inherit Lwt_engine.abstract +class engine = + object + inherit Lwt_engine.abstract + val loop = ref (Luv.Loop.default ()) - val loop = ref (Luv.Loop.default ()) + method! fork = + Luv.Loop.fork !loop |> function + | Ok () -> () + | Error e -> + failwith + (Printf.sprintf + "Could not handle the fork, this is probably a error in Lwt, \ + please open a issue on the repo. \n\ + Error message: %s" (Luv.Error.err_name e)) - method! fork = - Luv.Loop.fork !loop |> function - | Ok () -> () - | Error e -> failwith (Printf.sprintf "Could not handle the fork, this is probably a error in Lwt, please open a issue on the repo. \nError message: %s" (Luv.Error.err_name e)) + method private cleanup = Luv.Loop.stop !loop - method private cleanup = Luv.Loop.stop !loop - - method iter block = - match (block) with + method iter block = + match block with | true -> Luv.Loop.run ~loop:!loop ~mode:`ONCE () |> ignore | false -> Luv.Loop.run ~loop:!loop ~mode:`NOWAIT () |> ignore - method private register_readable fd f = - let p = Luv.Poll.init ~loop:!loop (from_unix fd) in - match p with - | Ok poll -> - let () = Luv.Poll.start poll [`READABLE;] (fun _ -> f ()) in - lazy( - Luv.Poll.stop poll |> function - | Ok () -> () - | Error e -> failwith (Printf.sprintf "Could not stop read polling, this is probably a error in Lwt, please open a issue on the repo. \nError message: %s" (Luv.Error.err_name e)) - ) - | Result.Error e -> failwith (Printf.sprintf "Could not register fd for read polling, this is probably a error in Lwt, please open a issue on the repo. \nError message: %s" (Luv.Error.err_name e)) + method private register_readable fd f = + let p = Luv.Poll.init ~loop:!loop (from_unix fd) in + match p with + | Ok poll -> + let () = Luv.Poll.start poll [ `READABLE ] (fun _ -> f ()) in + lazy + (Luv.Poll.stop poll |> function + | Ok () -> () + | Error e -> + failwith + (Printf.sprintf + "Could not stop read polling, this is probably a error \ + in Lwt, please open a issue on the repo. \n\ + Error message: %s" (Luv.Error.err_name e))) + | Result.Error e -> + failwith + (Printf.sprintf + "Could not register fd for read polling, this is probably a \ + error in Lwt, please open a issue on the repo. \n\ + Error message: %s" (Luv.Error.err_name e)) - method private register_writable fd f = - let p = Luv.Poll.init ~loop:!loop (from_unix fd) in - match p with - | Ok poll -> - let () = Luv.Poll.start poll [`WRITABLE;] (fun _ -> f ()) in - lazy( - Luv.Poll.stop poll |> function - | Ok () -> () - | Error e -> failwith (Printf.sprintf "Could not stop write polling, this is probably a error in Lwt, please open a issue on the repo. \nError message: %s" (Luv.Error.err_name e)) - ) - | Result.Error e -> failwith (Printf.sprintf "Could not register fd for write polling, this is probably a error in Lwt, please open a issue on the repo. \nError message: %s" (Luv.Error.err_name e)) + method private register_writable fd f = + let p = Luv.Poll.init ~loop:!loop (from_unix fd) in + match p with + | Ok poll -> + let () = Luv.Poll.start poll [ `WRITABLE ] (fun _ -> f ()) in + lazy + (Luv.Poll.stop poll |> function + | Ok () -> () + | Error e -> + failwith + (Printf.sprintf + "Could not stop write polling, this is probably a error \ + in Lwt, please open a issue on the repo. \n\ + Error message: %s" (Luv.Error.err_name e))) + | Result.Error e -> + failwith + (Printf.sprintf + "Could not register fd for write polling, this is probably a \ + error in Lwt, please open a issue on the repo. \n\ + Error message: %s" (Luv.Error.err_name e)) - method private register_timer delay repeat f = - let delay_ms = (int_of_float (delay *. 1000.)) in - let t = Luv.Timer.init ~loop:!loop () in - match t with - | Result.Error e -> failwith (Printf.sprintf "Could not initialize a timer, this is probably a error in Lwt, please open a issue on the repo. \nError message: %s" (Luv.Error.err_name e)) - | Ok timer -> - let timer_fn = match repeat with - | true -> Luv.Timer.start ~repeat:delay_ms timer - | false -> Luv.Timer.start timer - in - match timer_fn delay_ms f with - | Ok () -> lazy(Luv.Timer.stop timer |> ignore) - | Result.Error e -> failwith (Printf.sprintf "Could not start a timer, this is probably a error in Lwt, please open a issue on the repo. \nError message: %s" (Luv.Error.err_name e)) -end + method private register_timer delay repeat f = + let delay_ms = int_of_float (delay *. 1000.) in + let t = Luv.Timer.init ~loop:!loop () in + match t with + | Result.Error e -> + failwith + (Printf.sprintf + "Could not initialize a timer, this is probably a error in Lwt, \ + please open a issue on the repo. \n\ + Error message: %s" (Luv.Error.err_name e)) + | Ok timer -> ( + let timer_fn = + match repeat with + | true -> Luv.Timer.start ~repeat:delay_ms timer + | false -> Luv.Timer.start timer + in + match timer_fn delay_ms f with + | Ok () -> lazy (Luv.Timer.stop timer |> ignore) + | Result.Error e -> + failwith + (Printf.sprintf + "Could not start a timer, this is probably a error in Lwt, \ + please open a issue on the repo. \n\ + Error message: %s" (Luv.Error.err_name e))) + end diff --git a/src/unix/luv/lwt_luv.mli b/src/unix/luv/lwt_luv.mli index fccd982b9a..2c66bb37e8 100644 --- a/src/unix/luv/lwt_luv.mli +++ b/src/unix/luv/lwt_luv.mli @@ -1,2 +1,2 @@ -(** Engine based on libuv. *) class engine : Lwt_engine.t +(** Engine based on libuv. *) diff --git a/src/unix/lwt_bytes.ml b/src/unix/lwt_bytes.ml index e9c7b9466f..ee1f6a6d5a 100644 --- a/src/unix/lwt_bytes.ml +++ b/src/unix/lwt_bytes.ml @@ -1,8 +1,6 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Bigarray type t = (char, int8_unsigned_elt, c_layout) Array1.t @@ -12,62 +10,80 @@ let length bytes = Array1.dim bytes external get : t -> int -> char = "%caml_ba_ref_1" external set : t -> int -> char -> unit = "%caml_ba_set_1" - external unsafe_get : t -> int -> char = "%caml_ba_unsafe_ref_1" external unsafe_set : t -> int -> char -> unit = "%caml_ba_unsafe_set_1" [@@@ocaml.warning "-3"] -external unsafe_fill : t -> int -> int -> char -> unit = "lwt_unix_fill_bytes" "noalloc" + +external unsafe_fill : t -> int -> int -> char -> unit + = "lwt_unix_fill_bytes" "noalloc" + [@@@ocaml.warning "+3"] let fill bytes ofs len ch = if ofs < 0 || len < 0 || ofs > length bytes - len then invalid_arg "Lwt_bytes.fill" - else - unsafe_fill bytes ofs len ch + else unsafe_fill bytes ofs len ch (* +-----------------------------------------------------------------+ | Blitting | +-----------------------------------------------------------------+ *) [@@@ocaml.warning "-3"] -external unsafe_blit_from_bytes : Bytes.t -> int -> t -> int -> int -> unit = "lwt_unix_blit_from_bytes" "noalloc" -external unsafe_blit_from_string : string -> int -> t -> int -> int -> unit = "lwt_unix_blit_from_string" "noalloc" -external unsafe_blit_to_bytes : t -> int -> Bytes.t -> int -> int -> unit = "lwt_unix_blit_to_bytes" "noalloc" -external unsafe_blit : t -> int -> t -> int -> int -> unit = "lwt_unix_blit" "noalloc" + +external unsafe_blit_from_bytes : Bytes.t -> int -> t -> int -> int -> unit + = "lwt_unix_blit_from_bytes" "noalloc" + +external unsafe_blit_from_string : string -> int -> t -> int -> int -> unit + = "lwt_unix_blit_from_string" "noalloc" + +external unsafe_blit_to_bytes : t -> int -> Bytes.t -> int -> int -> unit + = "lwt_unix_blit_to_bytes" "noalloc" + +external unsafe_blit : t -> int -> t -> int -> int -> unit + = "lwt_unix_blit" "noalloc" + [@@@ocaml.warning "+3"] let blit_from_string src_buf src_ofs dst_buf dst_ofs len = - if (len < 0 - || src_ofs < 0 || src_ofs > String.length src_buf - len - || dst_ofs < 0 || dst_ofs > length dst_buf - len) then - invalid_arg "Lwt_bytes.blit_from_string" - else - unsafe_blit_from_string src_buf src_ofs dst_buf dst_ofs len + if + len < 0 + || src_ofs < 0 + || src_ofs > String.length src_buf - len + || dst_ofs < 0 + || dst_ofs > length dst_buf - len + then invalid_arg "Lwt_bytes.blit_from_string" + else unsafe_blit_from_string src_buf src_ofs dst_buf dst_ofs len let blit_from_bytes src_buf src_ofs dst_buf dst_ofs len = - if (len < 0 - || src_ofs < 0 || src_ofs > Bytes.length src_buf - len - || dst_ofs < 0 || dst_ofs > length dst_buf - len) then - invalid_arg "Lwt_bytes.blit_from_bytes" - else - unsafe_blit_from_bytes src_buf src_ofs dst_buf dst_ofs len + if + len < 0 + || src_ofs < 0 + || src_ofs > Bytes.length src_buf - len + || dst_ofs < 0 + || dst_ofs > length dst_buf - len + then invalid_arg "Lwt_bytes.blit_from_bytes" + else unsafe_blit_from_bytes src_buf src_ofs dst_buf dst_ofs len let blit_to_bytes src_buf src_ofs dst_buf dst_ofs len = - if (len < 0 - || src_ofs < 0 || src_ofs > length src_buf - len - || dst_ofs < 0 || dst_ofs > Bytes.length dst_buf - len) then - invalid_arg "Lwt_bytes.blit_to_bytes" - else - unsafe_blit_to_bytes src_buf src_ofs dst_buf dst_ofs len + if + len < 0 + || src_ofs < 0 + || src_ofs > length src_buf - len + || dst_ofs < 0 + || dst_ofs > Bytes.length dst_buf - len + then invalid_arg "Lwt_bytes.blit_to_bytes" + else unsafe_blit_to_bytes src_buf src_ofs dst_buf dst_ofs len let blit src_buf src_ofs dst_buf dst_ofs len = - if (len < 0 - || src_ofs < 0 || src_ofs > length src_buf - len - || dst_ofs < 0 || dst_ofs > length dst_buf - len) then - invalid_arg "Lwt_bytes.blit" - else - unsafe_blit src_buf src_ofs dst_buf dst_ofs len + if + len < 0 + || src_ofs < 0 + || src_ofs > length src_buf - len + || dst_ofs < 0 + || dst_ofs > length dst_buf - len + then invalid_arg "Lwt_bytes.blit" + else unsafe_blit src_buf src_ofs dst_buf dst_ofs len let of_bytes buf = let len = Bytes.length buf in @@ -84,17 +100,15 @@ let to_bytes bytes = str let to_string bytes = Bytes.unsafe_to_string (to_bytes bytes) - let proxy = Array1.sub let extract buf ofs len = if ofs < 0 || len < 0 || ofs > length buf - len then invalid_arg "Lwt_bytes.extract" - else begin + else let buf' = create len in blit buf ofs buf' 0 len; buf' - end let copy buf = let len = length buf in @@ -108,45 +122,41 @@ let copy buf = open Lwt_unix -let read = - Lwt_unix.read_bigarray "Lwt_bytes.read" [@ocaml.warning "-3"] - -let write = - Lwt_unix.write_bigarray "Lwt_bytes.write" [@ocaml.warning "-3"] +let read = (Lwt_unix.read_bigarray "Lwt_bytes.read" [@ocaml.warning "-3"]) +let write = (Lwt_unix.write_bigarray "Lwt_bytes.write" [@ocaml.warning "-3"]) -external stub_recv : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_bytes_recv" +external stub_recv : + Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int + = "lwt_unix_bytes_recv" let recv fd buf pos len flags = if pos < 0 || len < 0 || pos > length buf - len then invalid_arg "Lwt_bytes.recv" else - wrap_syscall Read fd (fun () -> stub_recv (unix_file_descr fd) buf pos len flags) + wrap_syscall Read fd (fun () -> + stub_recv (unix_file_descr fd) buf pos len flags) -external stub_send : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_bytes_send" +external stub_send : + Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int + = "lwt_unix_bytes_send" let send fd buf pos len flags = if pos < 0 || len < 0 || pos > length buf - len then invalid_arg "Lwt_bytes.send" else - wrap_syscall Write fd (fun () -> stub_send (unix_file_descr fd) buf pos len flags) + wrap_syscall Write fd (fun () -> + stub_send (unix_file_descr fd) buf pos len flags) -type io_vector = { - iov_buffer : t; - iov_offset : int; - iov_length : int; -} +type io_vector = { iov_buffer : t; iov_offset : int; iov_length : int } -let io_vector ~buffer ~offset ~length = ({ - iov_buffer = buffer; - iov_offset = offset; - iov_length = length; -} : io_vector) +let io_vector ~buffer ~offset ~length : io_vector = + { iov_buffer = buffer; iov_offset = offset; iov_length = length } let convert_io_vectors old_io_vectors = let io_vectors = IO_vectors.create () in old_io_vectors - |> List.iter (fun ({iov_buffer; iov_offset; iov_length} : io_vector) -> - IO_vectors.append_bigarray io_vectors iov_buffer iov_offset iov_length); + |> List.iter (fun ({ iov_buffer; iov_offset; iov_length } : io_vector) -> + IO_vectors.append_bigarray io_vectors iov_buffer iov_offset iov_length); io_vectors let recv_msg ~socket ~io_vectors = @@ -155,32 +165,49 @@ let recv_msg ~socket ~io_vectors = let send_msg ~socket ~io_vectors ~fds = Lwt_unix.send_msg ~socket ~io_vectors:(convert_io_vectors io_vectors) ~fds -external stub_recvfrom : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr = "lwt_unix_bytes_recvfrom" +external stub_recvfrom : + Unix.file_descr -> + t -> + int -> + int -> + Unix.msg_flag list -> + int * Unix.sockaddr = "lwt_unix_bytes_recvfrom" let recvfrom fd buf pos len flags = if pos < 0 || len < 0 || pos > length buf - len then invalid_arg "Lwt_bytes.recvfrom" else - wrap_syscall Read fd (fun () -> stub_recvfrom (unix_file_descr fd) buf pos len flags) - -external stub_sendto : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int = "lwt_unix_bytes_sendto_byte" "lwt_unix_bytes_sendto" + wrap_syscall Read fd (fun () -> + stub_recvfrom (unix_file_descr fd) buf pos len flags) + +external stub_sendto : + Unix.file_descr -> + t -> + int -> + int -> + Unix.msg_flag list -> + Unix.sockaddr -> + int = "lwt_unix_bytes_sendto_byte" "lwt_unix_bytes_sendto" let sendto fd buf pos len flags addr = if pos < 0 || len < 0 || pos > length buf - len then invalid_arg "Lwt_bytes.sendto" else - wrap_syscall Write fd (fun () -> stub_sendto (unix_file_descr fd) buf pos len flags addr) + wrap_syscall Write fd (fun () -> + stub_sendto (unix_file_descr fd) buf pos len flags addr) (* +-----------------------------------------------------------------+ | Memory mapped files | +-----------------------------------------------------------------+ *) -let map_file ~fd ?pos ~shared ?(size=(-1)) () = - Mmap.V1.map_file fd ?pos char c_layout shared [|size|] +let map_file ~fd ?pos ~shared ?(size = -1) () = + Mmap.V1.map_file fd ?pos char c_layout shared [| size |] |> Bigarray.array1_of_genarray [@@@ocaml.warning "-3"] + external mapped : t -> bool = "lwt_unix_mapped" "noalloc" + [@@@ocaml.warning "+3"] type advice = @@ -199,34 +226,30 @@ external stub_madvise : t -> int -> int -> advice -> unit = "lwt_unix_madvise" let madvise buf pos len advice = if pos < 0 || len < 0 || pos > length buf - len then invalid_arg "Lwt_bytes.madvise" - else - stub_madvise buf pos len advice + else stub_madvise buf pos len advice external get_page_size : unit -> int = "lwt_unix_get_page_size" let page_size = get_page_size () -external stub_mincore : t -> int -> int -> bool array -> unit = "lwt_unix_mincore" +external stub_mincore : t -> int -> int -> bool array -> unit + = "lwt_unix_mincore" let mincore buffer offset states = - if (offset mod page_size <> 0 - || offset < 0 - || length buffer - offset < (Array.length states - 1) * page_size + 1) - then - invalid_arg "Lwt_bytes.mincore" - else - stub_mincore buffer offset (Array.length states * page_size) states + if + offset mod page_size <> 0 + || offset < 0 + || length buffer - offset < ((Array.length states - 1) * page_size) + 1 + then invalid_arg "Lwt_bytes.mincore" + else stub_mincore buffer offset (Array.length states * page_size) states external wait_mincore_job : t -> int -> unit job = "lwt_unix_wait_mincore_job" let wait_mincore buffer offset = if offset < 0 || offset >= length buffer then invalid_arg "Lwt_bytes.wait_mincore" - else begin - let state = [|false|] in + else + let state = [| false |] in mincore buffer (offset - (offset mod page_size)) state; - if state.(0) then - Lwt.return_unit - else - run_job (wait_mincore_job buffer offset) - end + if state.(0) then Lwt.return_unit + else run_job (wait_mincore_job buffer offset) diff --git a/src/unix/lwt_bytes.mli b/src/unix/lwt_bytes.mli index cfd942510e..7136ec2600 100644 --- a/src/unix/lwt_bytes.mli +++ b/src/unix/lwt_bytes.mli @@ -1,142 +1,155 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Byte arrays *) type t = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t - (** Type of array of bytes. *) +(** Type of array of bytes. *) val create : int -> t - (** Creates a new byte array of the given size. *) +(** Creates a new byte array of the given size. *) val length : t -> int - (** Returns the length of the given byte array. *) +(** Returns the length of the given byte array. *) (** {2 Access} *) val get : t -> int -> char - (** [get buffer offset] returns the byte at offset [offset] in - [buffer]. *) +(** [get buffer offset] returns the byte at offset [offset] in [buffer]. *) val set : t -> int -> char -> unit - (** [get buffer offset value] changes the value of the byte at - offset [offset] in [buffer] to [value]. *) +(** [get buffer offset value] changes the value of the byte at offset [offset] + in [buffer] to [value]. *) val unsafe_get : t -> int -> char - (** Same as {!get} but without bounds checking. *) +(** Same as {!get} but without bounds checking. *) val unsafe_set : t -> int -> char -> unit - (** Same as {!set} but without bounds checking. *) +(** Same as {!set} but without bounds checking. *) (** {2 Conversions} *) val of_bytes : bytes -> t - (** [of_bytes buf] returns a newly allocated byte array with the - same contents as [buf]. *) +(** [of_bytes buf] returns a newly allocated byte array with the same contents + as [buf]. *) val of_string : string -> t - (** [of_string buf] returns a newly allocated byte array with the - same contents as [buf]. *) +(** [of_string buf] returns a newly allocated byte array with the same contents + as [buf]. *) val to_bytes : t -> bytes - (** [to_bytes buf] returns newly allocated bytes with the same - contents as [buf]. *) +(** [to_bytes buf] returns newly allocated bytes with the same contents as + [buf]. *) val to_string : t -> string - (** [to_string buf] returns a newly allocated string with the same - contents as [buf]. *) +(** [to_string buf] returns a newly allocated string with the same contents as + [buf]. *) (** {2 Copying} *) val blit : t -> int -> t -> int -> int -> unit - (** [blit buf1 ofs1 buf2 ofs2 len] copies [len] bytes from [buf1] - starting at offset [ofs1] to [buf2] starting at offset [ofs2]. *) +(** [blit buf1 ofs1 buf2 ofs2 len] copies [len] bytes from [buf1] starting at + offset [ofs1] to [buf2] starting at offset [ofs2]. *) val blit_from_string : string -> int -> t -> int -> int -> unit - (** Same as {!blit} but the first buffer is a [String.t] instead of a byte - array. *) +(** Same as {!blit} but the first buffer is a [String.t] instead of a byte + array. *) val blit_from_bytes : bytes -> int -> t -> int -> int -> unit - (** Same as {!blit} but the first buffer is a [Bytes.t] instead of a byte - array. *) +(** Same as {!blit} but the first buffer is a [Bytes.t] instead of a byte array. *) val blit_to_bytes : t -> int -> bytes -> int -> int -> unit - (** Same as {!blit} but the second buffer is a [Bytes.t] instead of a byte - array. *) +(** Same as {!blit} but the second buffer is a [Bytes.t] instead of a byte + array. *) val unsafe_blit : t -> int -> t -> int -> int -> unit - (** Same as {!blit} but without bound checking. *) +(** Same as {!blit} but without bound checking. *) val unsafe_blit_from_bytes : bytes -> int -> t -> int -> int -> unit - (** Same as {!Lwt_bytes.blit_from_bytes} but without bounds checking. *) +(** Same as {!Lwt_bytes.blit_from_bytes} but without bounds checking. *) val unsafe_blit_from_string : string -> int -> t -> int -> int -> unit (** Same as {!Lwt_bytes.blit_from_string} but without bounds checking. *) val unsafe_blit_to_bytes : t -> int -> bytes -> int -> int -> unit - (** Same as {!Lwt_bytes.blit_to_bytes} but without bounds checking. *) +(** Same as {!Lwt_bytes.blit_to_bytes} but without bounds checking. *) val proxy : t -> int -> int -> t - (** [proxy buffer offset length] creates a ``proxy''. The returned - byte array share the data of [buffer] but with different - bounds. *) +(** [proxy buffer offset length] creates a ``proxy''. The returned byte array + share the data of [buffer] but with different bounds. *) val extract : t -> int -> int -> t - (** [extract buffer offset length] creates a new byte array of - length [length] and copy the [length] bytes of [buffer] at - [offset] into it. *) +(** [extract buffer offset length] creates a new byte array of length [length] + and copy the [length] bytes of [buffer] at [offset] into it. *) val copy : t -> t - (** [copy buffer] creates a copy of the given byte array. *) +(** [copy buffer] creates a copy of the given byte array. *) (** {2 Filling} *) val fill : t -> int -> int -> char -> unit - (** [fill buffer offset length value] puts [value] in all [length] - bytes of [buffer] starting at offset [offset]. *) +(** [fill buffer offset length value] puts [value] in all [length] bytes of + [buffer] starting at offset [offset]. *) -external unsafe_fill : t -> int -> int -> char -> unit = "lwt_unix_fill_bytes" "noalloc" +external unsafe_fill : t -> int -> int -> char -> unit + = "lwt_unix_fill_bytes" "noalloc" [@@ocaml.warning "-3"] - (** Same as {!fill} but without bounds checking. *) +(** Same as {!fill} but without bounds checking. *) (** {2 IOs} *) (** The following functions behave similarly to the ones in {!Lwt_unix}, except - they use byte arrays instead of [Bytes.t], and they never perform extra copies - of the data. *) + they use byte arrays instead of [Bytes.t], and they never perform extra + copies of the data. *) val read : Lwt_unix.file_descr -> t -> int -> int -> int Lwt.t val write : Lwt_unix.file_descr -> t -> int -> int -> int Lwt.t -val recv : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int Lwt.t +val recv : + Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int Lwt.t (** Not implemented on Windows. *) -val send : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int Lwt.t +val send : + Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int Lwt.t (** Not implemented on Windows. *) -val recvfrom : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> (int * Unix.sockaddr) Lwt.t +val recvfrom : + Lwt_unix.file_descr -> + t -> + int -> + int -> + Unix.msg_flag list -> + (int * Unix.sockaddr) Lwt.t (** Not implemented on Windows. *) -val sendto : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int Lwt.t +val sendto : + Lwt_unix.file_descr -> + t -> + int -> + int -> + Unix.msg_flag list -> + Unix.sockaddr -> + int Lwt.t (** Not implemented on Windows. *) -type io_vector = { - iov_buffer : t; - iov_offset : int; - iov_length : int; -} +type io_vector = { iov_buffer : t; iov_offset : int; iov_length : int } -val io_vector : buffer : t -> offset : int -> length : int -> io_vector +val io_vector : buffer:t -> offset:int -> length:int -> io_vector -val recv_msg : socket : Lwt_unix.file_descr -> io_vectors : io_vector list -> (int * Unix.file_descr list) Lwt.t +val recv_msg : + socket:Lwt_unix.file_descr -> + io_vectors:io_vector list -> + (int * Unix.file_descr list) Lwt.t [@@ocaml.deprecated " Use Lwt_unix.Versioned.recv_msg_2."] (** Not implemented on Windows. @deprecated Use {!Lwt_unix.Versioned.recv_msg_2}. *) -val send_msg : socket : Lwt_unix.file_descr -> io_vectors : io_vector list -> fds : Unix.file_descr list -> int Lwt.t +val send_msg : + socket:Lwt_unix.file_descr -> + io_vectors:io_vector list -> + fds:Unix.file_descr list -> + int Lwt.t [@@ocaml.deprecated " Use Lwt_unix.Versioned.send_msg_2."] (** Not implemented on Windows. @@ -144,17 +157,17 @@ val send_msg : socket : Lwt_unix.file_descr -> io_vectors : io_vector list -> fd (** {2 Memory mapped files} *) -val map_file : fd : Unix.file_descr -> ?pos : int64 -> shared : bool -> ?size : int -> unit -> t - (** [map_file ~fd ?pos ~shared ?size ()] maps the file descriptor - [fd] to an array of bytes. *) +val map_file : + fd:Unix.file_descr -> ?pos:int64 -> shared:bool -> ?size:int -> unit -> t +(** [map_file ~fd ?pos ~shared ?size ()] maps the file descriptor [fd] to an + array of bytes. *) external mapped : t -> bool = "lwt_unix_mapped" "noalloc" [@@ocaml.warning "-3"] - (** [mapped buffer] returns [true] iff [buffer] is a memory mapped - file. *) +(** [mapped buffer] returns [true] iff [buffer] is a memory mapped file. *) -(** Type of advise that can be sent to the kernel by the program. See - the manual madvise(2) for a description of each. *) +(** Type of advise that can be sent to the kernel by the program. See the manual + madvise(2) for a description of each. *) type advice = | MADV_NORMAL | MADV_RANDOM @@ -167,26 +180,24 @@ type advice = | MADV_NOHUGEPAGE val madvise : t -> int -> int -> advice -> unit - (** [madvise buffer pos len advice] advises the kernel how the - program will use the memory mapped file between [pos] and - [pos + len]. +(** [madvise buffer pos len advice] advises the kernel how the program will use + the memory mapped file between [pos] and [pos + len]. - This call is not available on windows. *) + This call is not available on windows. *) val page_size : int - (** Size of pages. *) +(** Size of pages. *) val mincore : t -> int -> bool array -> unit - (** [mincore buffer offset states] tests whether the given pages are - in the system memory (the RAM). The [offset] argument must be a - multiple of {!page_size}. [states] is used to store the result; - each cases is [true] if the corresponding page is in RAM and - [false] otherwise. +(** [mincore buffer offset states] tests whether the given pages are in the + system memory (the RAM). The [offset] argument must be a multiple of + {!page_size}. [states] is used to store the result; each cases is [true] if + the corresponding page is in RAM and [false] otherwise. - This call is not available on windows and cygwin. *) + This call is not available on windows and cygwin. *) val wait_mincore : t -> int -> unit Lwt.t - (** [wait_mincore buffer offset] waits until the page containing the - byte at offset [offset] is in RAM. +(** [wait_mincore buffer offset] waits until the page containing the byte at + offset [offset] is in RAM. - This functions is not available on windows and cygwin. *) + This functions is not available on windows and cygwin. *) diff --git a/src/unix/lwt_config.ml b/src/unix/lwt_config.ml index 756e7b621f..4fc46e2533 100644 --- a/src/unix/lwt_config.ml +++ b/src/unix/lwt_config.ml @@ -1,13 +1,11 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - include Lwt_features let _HAVE_GET_CREDENTIALS = - _HAVE_GET_CREDENTIALS_LINUX || - _HAVE_GET_CREDENTIALS_NETBSD || - _HAVE_GET_CREDENTIALS_OPENBSD || - _HAVE_GET_CREDENTIALS_FREEBSD || - _HAVE_GETPEEREID + _HAVE_GET_CREDENTIALS_LINUX + || _HAVE_GET_CREDENTIALS_NETBSD + || _HAVE_GET_CREDENTIALS_OPENBSD + || _HAVE_GET_CREDENTIALS_FREEBSD + || _HAVE_GETPEEREID diff --git a/src/unix/lwt_engine.ml b/src/unix/lwt_engine.ml index 78fbffb6f6..deef334aed 100644 --- a/src/unix/lwt_engine.ml +++ b/src/unix/lwt_engine.ml @@ -1,15 +1,15 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] + module Lwt_sequence = Lwt_sequence + [@@@ocaml.warning "+3"] (* +-----------------------------------------------------------------+ @@ -20,22 +20,24 @@ type _event = { stop : unit Lazy.t; (* The stop method of the event. *) node : Obj.t Lwt_sequence.node; - (* The node in the sequence of registered events. *) + (* The node in the sequence of registered events. *) } type event = _event ref -external cast_node : 'a Lwt_sequence.node -> Obj.t Lwt_sequence.node = "%identity" +external cast_node : 'a Lwt_sequence.node -> Obj.t Lwt_sequence.node + = "%identity" let stop_event ev = let ev = !ev in Lwt_sequence.remove ev.node; Lazy.force ev.stop -let _fake_event = { - stop = lazy (); - node = Lwt_sequence.add_l (Obj.repr ()) (Lwt_sequence.create ()); -} +let _fake_event = + { + stop = lazy (); + node = Lwt_sequence.add_l (Obj.repr ()) (Lwt_sequence.create ()); + } let fake_event = ref _fake_event @@ -43,82 +45,112 @@ let fake_event = ref _fake_event | Engines | +-----------------------------------------------------------------+ *) -class virtual abstract = object(self) - method virtual iter : bool -> unit - method virtual private cleanup : unit - method virtual private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t - method virtual private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t - method virtual private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t - - val readables = Lwt_sequence.create () - (* Sequence of callbacks waiting for a file descriptor to become - readable. *) - - val writables = Lwt_sequence.create () - (* Sequence of callbacks waiting for a file descriptor to become - writable. *) - - val timers = Lwt_sequence.create () - (* Sequence of timers. *) - - method destroy = - Lwt_sequence.iter_l (fun (_fd, _f, _g, ev) -> stop_event ev) readables; - Lwt_sequence.iter_l (fun (_fd, _f, _g, ev) -> stop_event ev) writables; - Lwt_sequence.iter_l (fun (_delay, _repeat, _f, _g, ev) -> stop_event ev) - timers; - self#cleanup - - method transfer (engine : abstract) = - Lwt_sequence.iter_l (fun (fd, f, _g, ev) -> - stop_event ev; ev := !(engine#on_readable fd f)) readables; - Lwt_sequence.iter_l (fun (fd, f, _g, ev) -> - stop_event ev; ev := !(engine#on_writable fd f)) writables; - Lwt_sequence.iter_l (fun (delay, repeat, f, _g, ev) -> - stop_event ev; ev := !(engine#on_timer delay repeat f)) timers - - method fake_io fd = - Lwt_sequence.iter_l (fun (fd', _f, g, _stop) -> - if fd = fd' then g ()) readables; - Lwt_sequence.iter_l (fun (fd', _f, g, _stop) -> - if fd = fd' then g ()) writables - - method on_readable fd f = - let ev = ref _fake_event in - let g () = f ev in - let stop = self#register_readable fd g in - ev := { stop = stop; node = cast_node (Lwt_sequence.add_r (fd, f, g, ev) readables) }; - ev - - method on_writable fd f = - let ev = ref _fake_event in - let g () = f ev in - let stop = self#register_writable fd g in - ev := { stop = stop; node = cast_node (Lwt_sequence.add_r (fd, f, g, ev) writables) } ; - ev - - method on_timer delay repeat f = - let ev = ref _fake_event in - let g () = f ev in - let stop = self#register_timer delay repeat g in - ev := { stop = stop; node = cast_node (Lwt_sequence.add_r (delay, repeat, f, g, ev) timers) }; - ev - - method readable_count = Lwt_sequence.length readables - method writable_count = Lwt_sequence.length writables - method timer_count = Lwt_sequence.length timers - - method fork = () -end - -class type t = object - inherit abstract - - method iter : bool -> unit - method private cleanup : unit - method private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t - method private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t - method private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t -end +class virtual abstract = + object (self) + method virtual iter : bool -> unit + method virtual private cleanup : unit + + method virtual private register_readable + : Unix.file_descr -> (unit -> unit) -> unit Lazy.t + + method virtual private register_writable + : Unix.file_descr -> (unit -> unit) -> unit Lazy.t + + method virtual private register_timer + : float -> bool -> (unit -> unit) -> unit Lazy.t + + val readables = Lwt_sequence.create () + (* Sequence of callbacks waiting for a file descriptor to become + readable. *) + + val writables = Lwt_sequence.create () + (* Sequence of callbacks waiting for a file descriptor to become + writable. *) + + val timers = Lwt_sequence.create () + (* Sequence of timers. *) + + method destroy = + Lwt_sequence.iter_l (fun (_fd, _f, _g, ev) -> stop_event ev) readables; + Lwt_sequence.iter_l (fun (_fd, _f, _g, ev) -> stop_event ev) writables; + Lwt_sequence.iter_l + (fun (_delay, _repeat, _f, _g, ev) -> stop_event ev) + timers; + self#cleanup + + method transfer (engine : abstract) = + Lwt_sequence.iter_l + (fun (fd, f, _g, ev) -> + stop_event ev; + ev := !(engine#on_readable fd f)) + readables; + Lwt_sequence.iter_l + (fun (fd, f, _g, ev) -> + stop_event ev; + ev := !(engine#on_writable fd f)) + writables; + Lwt_sequence.iter_l + (fun (delay, repeat, f, _g, ev) -> + stop_event ev; + ev := !(engine#on_timer delay repeat f)) + timers + + method fake_io fd = + Lwt_sequence.iter_l + (fun (fd', _f, g, _stop) -> if fd = fd' then g ()) + readables; + Lwt_sequence.iter_l + (fun (fd', _f, g, _stop) -> if fd = fd' then g ()) + writables + + method on_readable fd f = + let ev = ref _fake_event in + let g () = f ev in + let stop = self#register_readable fd g in + ev := + { stop; node = cast_node (Lwt_sequence.add_r (fd, f, g, ev) readables) }; + ev + + method on_writable fd f = + let ev = ref _fake_event in + let g () = f ev in + let stop = self#register_writable fd g in + ev := + { stop; node = cast_node (Lwt_sequence.add_r (fd, f, g, ev) writables) }; + ev + + method on_timer delay repeat f = + let ev = ref _fake_event in + let g () = f ev in + let stop = self#register_timer delay repeat g in + ev := + { + stop; + node = cast_node (Lwt_sequence.add_r (delay, repeat, f, g, ev) timers); + }; + ev + + method readable_count = Lwt_sequence.length readables + method writable_count = Lwt_sequence.length writables + method timer_count = Lwt_sequence.length timers + method fork = () + end + +class type t = + object + inherit abstract + method iter : bool -> unit + method private cleanup : unit + + method private register_readable : + Unix.file_descr -> (unit -> unit) -> unit Lazy.t + + method private register_writable : + Unix.file_descr -> (unit -> unit) -> unit Lazy.t + + method private register_timer : + float -> bool -> (unit -> unit) -> unit Lazy.t + end (* +-----------------------------------------------------------------+ | The libev engine | @@ -128,8 +160,7 @@ type ev_loop type ev_io type ev_timer -module Ev_backend = -struct +module Ev_backend = struct type t = | EV_DEFAULT | EV_SELECT @@ -163,39 +194,47 @@ external ev_init : Ev_backend.t -> ev_loop = "lwt_libev_init" external ev_stop : ev_loop -> unit = "lwt_libev_stop" external ev_loop : ev_loop -> bool -> unit = "lwt_libev_loop" external ev_unloop : ev_loop -> unit = "lwt_libev_unloop" -external ev_readable_init : ev_loop -> Unix.file_descr -> (unit -> unit) -> ev_io = "lwt_libev_readable_init" -external ev_writable_init : ev_loop -> Unix.file_descr -> (unit -> unit) -> ev_io = "lwt_libev_writable_init" + +external ev_readable_init : + ev_loop -> Unix.file_descr -> (unit -> unit) -> ev_io + = "lwt_libev_readable_init" + +external ev_writable_init : + ev_loop -> Unix.file_descr -> (unit -> unit) -> ev_io + = "lwt_libev_writable_init" + external ev_io_stop : ev_loop -> ev_io -> unit = "lwt_libev_io_stop" -external ev_timer_init : ev_loop -> float -> bool -> (unit -> unit) -> ev_timer = "lwt_libev_timer_init" -external ev_timer_stop : ev_loop -> ev_timer -> unit = "lwt_libev_timer_stop" -class libev ?(backend=Ev_backend.default) () = object - inherit abstract +external ev_timer_init : ev_loop -> float -> bool -> (unit -> unit) -> ev_timer + = "lwt_libev_timer_init" - val loop = ev_init backend - method loop = loop +external ev_timer_stop : ev_loop -> ev_timer -> unit = "lwt_libev_timer_stop" - method private cleanup = ev_stop loop +class libev ?(backend = Ev_backend.default) () = + object + inherit abstract + val loop = ev_init backend + method loop = loop + method private cleanup = ev_stop loop - method iter block = - try - ev_loop loop block - with exn -> - ev_unloop loop; - raise exn + method iter block = + try ev_loop loop block + with exn -> + ev_unloop loop; + raise exn - method private register_readable fd f = - let ev = ev_readable_init loop fd f in - lazy(ev_io_stop loop ev) + method private register_readable fd f = + let ev = ev_readable_init loop fd f in + lazy (ev_io_stop loop ev) - method private register_writable fd f = - let ev = ev_writable_init loop fd f in - lazy(ev_io_stop loop ev) + method private register_writable fd f = + let ev = ev_writable_init loop fd f in + lazy (ev_io_stop loop ev) - method private register_timer delay repeat f = - let ev = ev_timer_init loop delay repeat f in - lazy(ev_timer_stop loop ev) -end + method private register_timer delay repeat f = + let ev = ev_timer_init loop delay repeat f in + lazy (ev_timer_stop loop ev) + end class libev_deprecated = libev () @@ -205,206 +244,214 @@ class libev_deprecated = libev () (* Type of a sleeper for the select engine. *) type sleeper = { - mutable time : float; - (* The time at which the sleeper should be wakeup. *) + mutable time : float; (* The time at which the sleeper should be wakeup. *) + mutable stopped : bool; (* [true] iff the event has been stopped. *) + action : unit -> unit; (* The action for the sleeper. *) +} - mutable stopped : bool; - (* [true] iff the event has been stopped. *) +module Sleep_queue = Lwt_pqueue.Make (struct + type t = sleeper - action : unit -> unit; - (* The action for the sleeper. *) -} + let compare { time = t1; _ } { time = t2; _ } = compare t1 t2 +end) +[@@ocaml.warning "-3"] -module Sleep_queue = - Lwt_pqueue.Make(struct - type t = sleeper - let compare {time = t1; _} {time = t2; _} = compare t1 t2 - end) - [@@ocaml.warning "-3"] +module Fd_map = Map.Make (struct + type t = Unix.file_descr -module Fd_map = Map.Make(struct type t = Unix.file_descr let compare = compare end) + let compare = compare +end) let rec restart_actions sleep_queue now = match Sleep_queue.lookup_min sleep_queue with - | Some{ stopped = true; _ } -> - restart_actions (Sleep_queue.remove_min sleep_queue) now - | Some{ time = time; action = action; _ } when time <= now -> - (* We have to remove the sleeper to the queue before performing - the action. The action can change the sleeper's time, and this - might break the priority queue invariant if the sleeper is - still in the queue. *) - let q = Sleep_queue.remove_min sleep_queue in - action (); - restart_actions q now - | _ -> - sleep_queue + | Some { stopped = true; _ } -> + restart_actions (Sleep_queue.remove_min sleep_queue) now + | Some { time; action; _ } when time <= now -> + (* We have to remove the sleeper to the queue before performing + the action. The action can change the sleeper's time, and this + might break the priority queue invariant if the sleeper is + still in the queue. *) + let q = Sleep_queue.remove_min sleep_queue in + action (); + restart_actions q now + | _ -> sleep_queue let rec get_next_timeout sleep_queue = match Sleep_queue.lookup_min sleep_queue with - | Some{ stopped = true; _ } -> - get_next_timeout (Sleep_queue.remove_min sleep_queue) - | Some{ time = time; _ } -> - max 0. (time -. Unix.gettimeofday ()) - | None -> - -1. + | Some { stopped = true; _ } -> + get_next_timeout (Sleep_queue.remove_min sleep_queue) + | Some { time; _ } -> max 0. (time -. Unix.gettimeofday ()) + | None -> -1. let bad_fd fd = try let _ = Unix.fstat fd in false - with Unix.Unix_error (_, _, _) -> - true + with Unix.Unix_error (_, _, _) -> true let invoke_actions fd map = match Fd_map.find fd map with | exception Not_found -> () | actions -> Lwt_sequence.iter_l (fun f -> f ()) actions -class virtual select_or_poll_based = object - inherit abstract - - val mutable sleep_queue = Sleep_queue.empty - (* Threads waiting for a timeout to expire. *) - - val mutable new_sleeps = [] - (* Sleepers added since the last iteration of the main loop: - - They are not added immediately to the main sleep queue in order - to prevent them from being wakeup immediately. *) - - val mutable wait_readable = Fd_map.empty - (* Sequences of actions waiting for file descriptors to become - readable. *) - - val mutable wait_writable = Fd_map.empty - (* Sequences of actions waiting for file descriptors to become - writable. *) - - method private cleanup = () - - method private register_timer delay repeat f = - if repeat then begin - let rec sleeper = { time = Unix.gettimeofday () +. delay; stopped = false; action = g } - and g () = - sleeper.time <- Unix.gettimeofday () +. delay; +class virtual select_or_poll_based = + object + inherit abstract + val mutable sleep_queue = Sleep_queue.empty + (* Threads waiting for a timeout to expire. *) + + val mutable new_sleeps = [] + (* Sleepers added since the last iteration of the main loop: + + They are not added immediately to the main sleep queue in order + to prevent them from being wakeup immediately. *) + + val mutable wait_readable = Fd_map.empty + (* Sequences of actions waiting for file descriptors to become + readable. *) + + val mutable wait_writable = Fd_map.empty + (* Sequences of actions waiting for file descriptors to become + writable. *) + + method private cleanup = () + + method private register_timer delay repeat f = + if repeat then ( + let rec sleeper = + { time = Unix.gettimeofday () +. delay; stopped = false; action = g } + and g () = + sleeper.time <- Unix.gettimeofday () +. delay; + new_sleeps <- sleeper :: new_sleeps; + f () + in + new_sleeps <- sleeper :: new_sleeps; + lazy (sleeper.stopped <- true)) + else + let sleeper = + { time = Unix.gettimeofday () +. delay; stopped = false; action = f } + in new_sleeps <- sleeper :: new_sleeps; - f () + lazy (sleeper.stopped <- true) + + method private register_readable fd f = + let actions = + try Fd_map.find fd wait_readable + with Not_found -> + let actions = Lwt_sequence.create () in + wait_readable <- Fd_map.add fd actions wait_readable; + actions in - new_sleeps <- sleeper :: new_sleeps; - lazy(sleeper.stopped <- true) - end else begin - let sleeper = { time = Unix.gettimeofday () +. delay; stopped = false; action = f } in - new_sleeps <- sleeper :: new_sleeps; - lazy(sleeper.stopped <- true) - end - - method private register_readable fd f = - let actions = - try - Fd_map.find fd wait_readable - with Not_found -> - let actions = Lwt_sequence.create () in - wait_readable <- Fd_map.add fd actions wait_readable; - actions - in - let node = Lwt_sequence.add_l f actions in - lazy(Lwt_sequence.remove node; - if Lwt_sequence.is_empty actions then wait_readable <- Fd_map.remove fd wait_readable) - - method private register_writable fd f = - let actions = - try - Fd_map.find fd wait_writable - with Not_found -> - let actions = Lwt_sequence.create () in - wait_writable <- Fd_map.add fd actions wait_writable; - actions - in - let node = Lwt_sequence.add_l f actions in - lazy(Lwt_sequence.remove node; - if Lwt_sequence.is_empty actions then wait_writable <- Fd_map.remove fd wait_writable) -end - -class virtual select_based = object(self) - inherit select_or_poll_based - - method private virtual select : Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list - - method iter block = - (* Transfer all sleepers added since the last iteration to the - main sleep queue: *) - sleep_queue <- List.fold_left (fun q e -> Sleep_queue.add e q) sleep_queue new_sleeps; - new_sleeps <- []; - (* Collect file descriptors. *) - let fds_r = Fd_map.fold (fun fd _ l -> fd :: l) wait_readable [] in - let fds_w = Fd_map.fold (fun fd _ l -> fd :: l) wait_writable [] in - (* Compute the timeout. *) - let timeout = if block then get_next_timeout sleep_queue else 0. in - (* Do the blocking call *) - let fds_r, fds_w = - try - self#select fds_r fds_w timeout - with - | Unix.Unix_error (Unix.EINTR, _, _) -> - ([], []) - | Unix.Unix_error (Unix.EBADF, _, _) -> - (* Keeps only bad file descriptors. Actions registered on - them have to handle the error: *) - (List.filter bad_fd fds_r, - List.filter bad_fd fds_w) - in - (* Restart threads waiting for a timeout: *) - sleep_queue <- restart_actions sleep_queue (Unix.gettimeofday ()); - (* Restart threads waiting on a file descriptors: *) - List.iter (fun fd -> invoke_actions fd wait_readable) fds_r; - List.iter (fun fd -> invoke_actions fd wait_writable) fds_w -end - -class virtual poll_based = object(self) - inherit select_or_poll_based - - method private virtual poll : (Unix.file_descr * bool * bool) list -> float -> (Unix.file_descr * bool * bool) list - - method iter block = - (* Transfer all sleepers added since the last iteration to the - main sleep queue: *) - sleep_queue <- List.fold_left (fun q e -> Sleep_queue.add e q) sleep_queue new_sleeps; - new_sleeps <- []; - (* Collect file descriptors. *) - let fds = [] in - let fds = Fd_map.fold (fun fd _ l -> (fd, true, false) :: l) wait_readable fds in - let fds = Fd_map.fold (fun fd _ l -> (fd, false, true) :: l) wait_writable fds in - (* Compute the timeout. *) - let timeout = if block then get_next_timeout sleep_queue else 0. in - (* Do the blocking call *) - let fds = - try - self#poll fds timeout - with - | Unix.Unix_error (Unix.EINTR, _, _) -> - [] - | Unix.Unix_error (Unix.EBADF, _, _) -> - (* Keeps only bad file descriptors. Actions registered on - them have to handle the error: *) - List.filter (fun (fd, _, _) -> bad_fd fd) fds - in - (* Restart threads waiting for a timeout: *) - sleep_queue <- restart_actions sleep_queue (Unix.gettimeofday ()); - (* Restart threads waiting on a file descriptors: *) - List.iter - (fun (fd, readable, writable) -> - if readable then invoke_actions fd wait_readable; - if writable then invoke_actions fd wait_writable) - fds -end - -class select = object - inherit select_based - - method private select fds_r fds_w timeout = - let fds_r, fds_w, _ = Unix.select fds_r fds_w [] timeout in - (fds_r, fds_w) -end + let node = Lwt_sequence.add_l f actions in + lazy + (Lwt_sequence.remove node; + if Lwt_sequence.is_empty actions then + wait_readable <- Fd_map.remove fd wait_readable) + + method private register_writable fd f = + let actions = + try Fd_map.find fd wait_writable + with Not_found -> + let actions = Lwt_sequence.create () in + wait_writable <- Fd_map.add fd actions wait_writable; + actions + in + let node = Lwt_sequence.add_l f actions in + lazy + (Lwt_sequence.remove node; + if Lwt_sequence.is_empty actions then + wait_writable <- Fd_map.remove fd wait_writable) + end + +class virtual select_based = + object (self) + inherit select_or_poll_based + + method virtual private select + : Unix.file_descr list -> + Unix.file_descr list -> + float -> + Unix.file_descr list * Unix.file_descr list + + method iter block = + (* Transfer all sleepers added since the last iteration to the + main sleep queue: *) + sleep_queue <- + List.fold_left (fun q e -> Sleep_queue.add e q) sleep_queue new_sleeps; + new_sleeps <- []; + (* Collect file descriptors. *) + let fds_r = Fd_map.fold (fun fd _ l -> fd :: l) wait_readable [] in + let fds_w = Fd_map.fold (fun fd _ l -> fd :: l) wait_writable [] in + (* Compute the timeout. *) + let timeout = if block then get_next_timeout sleep_queue else 0. in + (* Do the blocking call *) + let fds_r, fds_w = + try self#select fds_r fds_w timeout with + | Unix.Unix_error (Unix.EINTR, _, _) -> ([], []) + | Unix.Unix_error (Unix.EBADF, _, _) -> + (* Keeps only bad file descriptors. Actions registered on + them have to handle the error: *) + (List.filter bad_fd fds_r, List.filter bad_fd fds_w) + in + (* Restart threads waiting for a timeout: *) + sleep_queue <- restart_actions sleep_queue (Unix.gettimeofday ()); + (* Restart threads waiting on a file descriptors: *) + List.iter (fun fd -> invoke_actions fd wait_readable) fds_r; + List.iter (fun fd -> invoke_actions fd wait_writable) fds_w + end + +class virtual poll_based = + object (self) + inherit select_or_poll_based + + method virtual private poll + : (Unix.file_descr * bool * bool) list -> + float -> + (Unix.file_descr * bool * bool) list + + method iter block = + (* Transfer all sleepers added since the last iteration to the + main sleep queue: *) + sleep_queue <- + List.fold_left (fun q e -> Sleep_queue.add e q) sleep_queue new_sleeps; + new_sleeps <- []; + (* Collect file descriptors. *) + let fds = [] in + let fds = + Fd_map.fold (fun fd _ l -> (fd, true, false) :: l) wait_readable fds + in + let fds = + Fd_map.fold (fun fd _ l -> (fd, false, true) :: l) wait_writable fds + in + (* Compute the timeout. *) + let timeout = if block then get_next_timeout sleep_queue else 0. in + (* Do the blocking call *) + let fds = + try self#poll fds timeout with + | Unix.Unix_error (Unix.EINTR, _, _) -> [] + | Unix.Unix_error (Unix.EBADF, _, _) -> + (* Keeps only bad file descriptors. Actions registered on + them have to handle the error: *) + List.filter (fun (fd, _, _) -> bad_fd fd) fds + in + (* Restart threads waiting for a timeout: *) + sleep_queue <- restart_actions sleep_queue (Unix.gettimeofday ()); + (* Restart threads waiting on a file descriptors: *) + List.iter + (fun (fd, readable, writable) -> + if readable then invoke_actions fd wait_readable; + if writable then invoke_actions fd wait_writable) + fds + end + +class select = + object + inherit select_based + + method private select fds_r fds_w timeout = + let fds_r, fds_w, _ = Unix.select fds_r fds_w [] timeout in + (fds_r, fds_w) + end (* +-----------------------------------------------------------------+ | The current engine | @@ -413,13 +460,11 @@ end let current = if Lwt_config._HAVE_LIBEV && Lwt_config.libev_default then ref (new libev () :> t) - else - ref (new select :> t) + else ref (new select :> t) -let get () = - !current +let get () = !current -let set ?(transfer=true) ?(destroy=true) engine = +let set ?(transfer = true) ?(destroy = true) engine = if transfer then !current#transfer (engine : #t :> abstract); if destroy then !current#destroy; current := (engine : #t :> t) @@ -434,8 +479,7 @@ let writable_count () = !current#writable_count let timer_count () = !current#timer_count let fork () = !current#fork -module Versioned = -struct +module Versioned = struct class libev_1 = libev_deprecated class libev_2 = libev end diff --git a/src/unix/lwt_engine.mli b/src/unix/lwt_engine.mli index ced3c50195..808a341acd 100644 --- a/src/unix/lwt_engine.mli +++ b/src/unix/lwt_engine.mli @@ -1,124 +1,132 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Lwt unix main loop engine *) (** {2 Events} *) type event - (** Type of events. An event represent a callback registered to be - called when some event occurs. *) +(** Type of events. An event represent a callback registered to be called when + some event occurs. *) val stop_event : event -> unit - (** [stop_event event] stops the given event. *) +(** [stop_event event] stops the given event. *) val fake_event : event - (** Event which does nothing when stopped. *) +(** Event which does nothing when stopped. *) (** {2 Event loop functions} *) val iter : bool -> unit - (** [iter block] performs one iteration of the main loop. If [block] - is [true] the function must block until one event becomes - available, otherwise it should just check for available events - and return immediately. *) +(** [iter block] performs one iteration of the main loop. If [block] is [true] + the function must block until one event becomes available, otherwise it + should just check for available events and return immediately. *) val on_readable : Unix.file_descr -> (event -> unit) -> event - (** [on_readable fd f] calls [f] each time [fd] becomes readable. *) +(** [on_readable fd f] calls [f] each time [fd] becomes readable. *) val on_writable : Unix.file_descr -> (event -> unit) -> event - (** [on_readable fd f] calls [f] each time [fd] becomes writable. *) +(** [on_readable fd f] calls [f] each time [fd] becomes writable. *) val on_timer : float -> bool -> (event -> unit) -> event - (** [on_timer delay repeat f] calls [f] one time after [delay] - seconds. If [repeat] is [true] then [f] is called each [delay] - seconds, otherwise it is called only one time. *) +(** [on_timer delay repeat f] calls [f] one time after [delay] seconds. If + [repeat] is [true] then [f] is called each [delay] seconds, otherwise it is + called only one time. *) val readable_count : unit -> int - (** Returns the number of events waiting for a file descriptor to - become readable. *) +(** Returns the number of events waiting for a file descriptor to become + readable. *) val writable_count : unit -> int - (** Returns the number of events waiting for a file descriptor to - become writable. *) +(** Returns the number of events waiting for a file descriptor to become + writable. *) val timer_count : unit -> int - (** Returns the number of registered timers. *) +(** Returns the number of registered timers. *) val fake_io : Unix.file_descr -> unit - (** Simulates activity on the given file descriptor. *) +(** Simulates activity on the given file descriptor. *) val fork : unit -> unit - (** Called internally by Lwt_unix.fork to make sure we don't get strange behaviour *) +(** Called internally by Lwt_unix.fork to make sure we don't get strange + behaviour *) (** {2 Engines} *) -(** An engine represents a set of functions used to register different - kinds of callbacks for different kinds of events. *) +(** An engine represents a set of functions used to register different kinds of + callbacks for different kinds of events. *) (** Abstract class for engines. *) -class virtual abstract : object - method destroy : unit - (** Destroy the engine, remove all its events and free its - associated resources. *) - - method transfer : abstract -> unit - (** [transfer engine] moves all events from the current engine to - [engine]. Note that timers are reset in the destination - engine, i.e. if a timer with a delay of 2 seconds was - registered 1 second ago it will occur in 2 seconds in the - destination engine. *) - - (** {2 Event loop methods} *) - - method virtual iter : bool -> unit - method fork : unit - method on_readable : Unix.file_descr -> (event -> unit) -> event - method on_writable : Unix.file_descr -> (event -> unit) -> event - method on_timer : float -> bool -> (event -> unit) -> event - method fake_io : Unix.file_descr -> unit - method readable_count : int - method writable_count : int - method timer_count : int - - (** {2 Backend methods} *) - - (** Notes: - - - the callback passed to register methods is of type [unit -> unit] - and not [event -> unit] - - register methods return a lazy value which unregisters the - event when forced - *) - - method virtual private cleanup : unit +class virtual abstract : + object + method destroy : unit + (** Destroy the engine, remove all its events and free its associated + resources. *) + + method transfer : abstract -> unit + (** [transfer engine] moves all events from the current engine to [engine]. + Note that timers are reset in the destination engine, i.e. if a timer + with a delay of 2 seconds was registered 1 second ago it will occur in 2 + seconds in the destination engine. *) + + (** {2 Event loop methods} *) + + method virtual iter : bool -> unit + method fork : unit + method on_readable : Unix.file_descr -> (event -> unit) -> event + method on_writable : Unix.file_descr -> (event -> unit) -> event + method on_timer : float -> bool -> (event -> unit) -> event + method fake_io : Unix.file_descr -> unit + method readable_count : int + method writable_count : int + method timer_count : int + + (** {2 Backend methods} *) + + (** Notes: + + - the callback passed to register methods is of type [unit -> unit] and + not [event -> unit] + - register methods return a lazy value which unregisters the event when + forced *) + + method virtual private cleanup : unit (** Cleanup resources associated with the engine. *) - method virtual private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t - method virtual private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t - method virtual private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t -end + method virtual private register_readable : + Unix.file_descr -> (unit -> unit) -> unit Lazy.t + + method virtual private register_writable : + Unix.file_descr -> (unit -> unit) -> unit Lazy.t + + method virtual private register_timer : + float -> bool -> (unit -> unit) -> unit Lazy.t + end (** Type of engines. *) -class type t = object - inherit abstract - - method iter : bool -> unit - method private cleanup : unit - method private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t - method private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t - method private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t -end +class type t = + object + inherit abstract + method iter : bool -> unit + method private cleanup : unit + + method private register_readable : + Unix.file_descr -> (unit -> unit) -> unit Lazy.t + + method private register_writable : + Unix.file_descr -> (unit -> unit) -> unit Lazy.t + + method private register_timer : + float -> bool -> (unit -> unit) -> unit Lazy.t + end (** {2 Predefined engines} *) type ev_loop -module Ev_backend : -sig +module Ev_backend : sig type t + val default : t val select : t val poll : t @@ -126,100 +134,114 @@ sig val kqueue : t val devpoll : t val port : t - val pp : Format.formatter -> t -> unit end - (** Type of libev loops. *) +(** Type of libev loops. *) -(** Engine based on libev. If not compiled with libev support, the - creation of the class will raise {!Lwt_sys.Not_available}. *) -class libev : ?backend:Ev_backend.t -> unit -> object - inherit t +(** Engine based on libev. If not compiled with libev support, the creation of + the class will raise {!Lwt_sys.Not_available}. *) +class libev : + ?backend:Ev_backend.t + -> unit + -> object + inherit t - val loop : ev_loop - (** The libev loop used for this engine. *) + val loop : ev_loop + (** The libev loop used for this engine. *) - method loop : ev_loop - (** Returns [loop]. *) -end + method loop : ev_loop + (** Returns [loop]. *) + end -(** Engine based on [Unix.select]. *) class select : t +(** Engine based on [Unix.select]. *) (** Abstract class for engines based on a select-like function. *) -class virtual select_based : object - inherit t +class virtual select_based : + object + inherit t - method private virtual select : Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list + method virtual private select : + Unix.file_descr list -> + Unix.file_descr list -> + float -> + Unix.file_descr list * Unix.file_descr list (** [select fds_r fds_w timeout] waits for either: - one of the file descriptor of [fds_r] to become readable - one of the file descriptor of [fds_w] to become writable - timeout to expire - and returns the list of readable file descriptor and the list - of writable file descriptors. *) -end + and returns the list of readable file descriptor and the list of + writable file descriptors. *) + end (** Abstract class for engines based on a poll-like function. *) -class virtual poll_based : object - inherit t - - method private virtual poll : (Unix.file_descr * bool * bool) list -> float -> (Unix.file_descr * bool * bool) list - (** [poll fds tiomeout], where [fds] is a list of tuples of the - form [(fd, check_readable, check_writable)], waits for either: +class virtual poll_based : + object + inherit t - - one of the file descriptor with [check_readable] set to - [true] to become readable - - one of the file descriptor with [check_writable] set to - [true] to become writable + method virtual private poll : + (Unix.file_descr * bool * bool) list -> + float -> + (Unix.file_descr * bool * bool) list + (** [poll fds tiomeout], where [fds] is a list of tuples of the form + [(fd, check_readable, check_writable)], waits for either: + + - one of the file descriptor with [check_readable] set to [true] to + become readable + - one of the file descriptor with [check_writable] set to [true] to + become writable - timeout to expire - and returns the list of file descriptors with their readable - and writable status. *) -end + and returns the list of file descriptors with their readable and + writable status. *) + end (** {2 The current engine} *) val get : unit -> t - (** [get ()] returns the engine currently in use. *) +(** [get ()] returns the engine currently in use. *) -val set : ?transfer : bool -> ?destroy : bool -> #t -> unit - (** [set ?transfer ?destroy engine] replaces the current engine by - the given one. +val set : ?transfer:bool -> ?destroy:bool -> #t -> unit +(** [set ?transfer ?destroy engine] replaces the current engine by the given + one. - If [transfer] is [true] (the default) all events from the - current engine are transferred to the new one. + If [transfer] is [true] (the default) all events from the current engine are + transferred to the new one. - If [destroy] is [true] (the default) then the current engine is - destroyed before being replaced. *) + If [destroy] is [true] (the default) then the current engine is destroyed + before being replaced. *) -module Versioned : -sig - class libev_1 : object - inherit t - val loop : ev_loop - method loop : ev_loop - end - [@@ocaml.deprecated -" Deprecated in favor of Lwt_engine.libev. See - https://github.com/ocsigen/lwt/pull/269"] +module Versioned : sig (** Old version of {!Lwt_engine.libev}. The current {!Lwt_engine.libev} allows selecting the libev back end. @deprecated Use {!Lwt_engine.libev}. @since 2.7.0 *) + class libev_1 : + object + inherit t + val loop : ev_loop + method loop : ev_loop + end + [@@ocaml.deprecated + " Deprecated in favor of Lwt_engine.libev. See\n\ + \ https://github.com/ocsigen/lwt/pull/269"] - class libev_2 : ?backend:Ev_backend.t -> unit -> object - inherit t - val loop : ev_loop - method loop : ev_loop - end - [@@ocaml.deprecated -" In Lwt >= 3.0.0, this is an alias for Lwt_engine.libev."] (** Since Lwt 3.0.0, this is just an alias for {!Lwt_engine.libev}. @deprecated Use {!Lwt_engine.libev}. @since 2.7.0 *) + class libev_2 : + ?backend:Ev_backend.t + -> unit + -> object + inherit t + val loop : ev_loop + method loop : ev_loop + end + [@@ocaml.deprecated + " In Lwt >= 3.0.0, this is an alias for Lwt_engine.libev."] end diff --git a/src/unix/lwt_fmt.ml b/src/unix/lwt_fmt.ml index 804027bba6..a1ebd0b9e7 100644 --- a/src/unix/lwt_fmt.ml +++ b/src/unix/lwt_fmt.ml @@ -1,64 +1,49 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Lwt.Infix -type formatter = { - commit : unit -> unit Lwt.t ; - fmt : Format.formatter ; -} +type formatter = { commit : unit -> unit Lwt.t; fmt : Format.formatter } let write_pending ppft = ppft.commit () -let flush ppft = Format.pp_print_flush ppft.fmt () ; ppft.commit () -let make_formatter ~commit ~fmt () = { commit ; fmt } +let flush ppft = + Format.pp_print_flush ppft.fmt (); + ppft.commit () +let make_formatter ~commit ~fmt () = { commit; fmt } let get_formatter x = x.fmt (** Stream formatter *) -type order = - | String of string * int * int - | Flush +type order = String of string * int * int | Flush let make_stream () = let stream, push = Lwt_stream.create () in - let out_string s i j = - push @@ Some (String (s, i, j)) - and flush () = - push @@ Some Flush - in + let out_string s i j = push @@ Some (String (s, i, j)) + and flush () = push @@ Some Flush in let fmt = Format.make_formatter out_string flush in (* Not sure about that one *) - Gc.finalise (fun _ -> push None) fmt ; + Gc.finalise (fun _ -> push None) fmt; let commit () = Lwt.return_unit in - stream, make_formatter ~commit ~fmt () + (stream, make_formatter ~commit ~fmt ()) (** Channel formatter *) let write_order oc = function - | String (s, i, j) -> - Lwt_io.write_from_string_exactly oc s i j - | Flush -> - Lwt_io.flush oc + | String (s, i, j) -> Lwt_io.write_from_string_exactly oc s i j + | Flush -> Lwt_io.flush oc let rec write_orders oc queue = - if Queue.is_empty queue then - Lwt.return_unit + if Queue.is_empty queue then Lwt.return_unit else let o = Queue.pop queue in - write_order oc o >>= fun () -> - write_orders oc queue + write_order oc o >>= fun () -> write_orders oc queue let of_channel oc = let q = Queue.create () in - let out_string s i j = - Queue.push (String (s, i, j)) q - and flush () = - Queue.push Flush q - in + let out_string s i j = Queue.push (String (s, i, j)) q + and flush () = Queue.push Flush q in let fmt = Format.make_formatter out_string flush in let commit () = write_orders oc q in make_formatter ~commit ~fmt () @@ -67,16 +52,13 @@ let of_channel oc = let kfprintf k ppft fmt = Format.kfprintf (fun _ppf -> k ppft @@ ppft.commit ()) ppft.fmt fmt + let ikfprintf k ppft fmt = Format.ikfprintf (fun _ppf -> k ppft @@ Lwt.return_unit) ppft.fmt fmt -let fprintf ppft fmt = - kfprintf (fun _ t -> t) ppft fmt -let ifprintf ppft fmt = - ikfprintf (fun _ t -> t) ppft fmt - +let fprintf ppft fmt = kfprintf (fun _ t -> t) ppft fmt +let ifprintf ppft fmt = ikfprintf (fun _ t -> t) ppft fmt let stdout = of_channel Lwt_io.stdout let stderr = of_channel Lwt_io.stderr - let printf fmt = fprintf stdout fmt let eprintf fmt = fprintf stderr fmt diff --git a/src/unix/lwt_fmt.mli b/src/unix/lwt_fmt.mli index 62c38d7952..d73af82db7 100644 --- a/src/unix/lwt_fmt.mli +++ b/src/unix/lwt_fmt.mli @@ -1,32 +1,24 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Format API for Lwt-powered IOs @since 4.1.0 *) -(** This module bridges the gap between - {{:https://ocaml.org/api/Format.html} [Format]} - and {!Lwt}. Although it is not required, it is recommended to use this - module with the {{:http://erratique.ch/software/fmt} [Fmt]} library. +(** This module bridges the gap between {{:https://ocaml.org/api/Format.html} + [Format]} and {!Lwt}. Although it is not required, it is recommended to use + this module with the {{:http://erratique.ch/software/fmt} [Fmt]} library. Compared to regular formatting function, the main difference is that - printing statements will now return promises instead of blocking. -*) + printing statements will now return promises instead of blocking. *) val printf : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a -(** Returns a promise that prints on the standard output. - Similar to - {{:https://ocaml.org/api/Format.html#VALprintf} - [Format.printf]}. *) +(** Returns a promise that prints on the standard output. Similar to + {{:https://ocaml.org/api/Format.html#VALprintf} [Format.printf]}. *) val eprintf : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a -(** Returns a promise that prints on the standard error. - Similar to - {{:https://ocaml.org/api/Format.html#VALeprintf} - [Format.eprintf]}. *) +(** Returns a promise that prints on the standard error. Similar to + {{:https://ocaml.org/api/Format.html#VALeprintf} [Format.eprintf]}. *) (** {1 Formatters} *) @@ -34,14 +26,14 @@ type formatter (** Lwt enabled formatters *) type order = - | String of string * int * int (** [String (s, off, len)] indicate the output of [s] at offset [off] and length [len]. *) - | Flush (** Flush operation *) + | String of string * int * int + (** [String (s, off, len)] indicate the output of [s] at offset [off] and + length [len]. *) + | Flush (** Flush operation *) val make_stream : unit -> order Lwt_stream.t * formatter -(** [make_stream ()] returns a formatter and a stream of all the writing - order given on that stream. -*) - +(** [make_stream ()] returns a formatter and a stream of all the writing order + given on that stream. *) val of_channel : Lwt_io.output_channel -> formatter (** [of_channel oc] creates a formatter that writes to the channel [oc]. *) @@ -55,39 +47,41 @@ val stderr : formatter val make_formatter : commit:(unit -> unit Lwt.t) -> fmt:Format.formatter -> unit -> formatter (** [make_formatter ~commit ~fmt] creates a new lwt formatter based on the - {{:https://ocaml.org/api/Format.html#TYPEformatter} - [Format.formatter]} [fmt]. The [commit] function will be called by the - printing functions to update the underlying channel. -*) + {{:https://ocaml.org/api/Format.html#TYPEformatter} [Format.formatter]} + [fmt]. The [commit] function will be called by the printing functions to + update the underlying channel. *) val get_formatter : formatter -> Format.formatter (** [get_formatter fmt] returns the underlying - {{:https://ocaml.org/api/Format.html#TYPEformatter} - [Format.formatter]}. To access the underlying formatter during printing, it - isvrecommended to use [%t] and [%a]. -*) + {{:https://ocaml.org/api/Format.html#TYPEformatter} [Format.formatter]}. To + access the underlying formatter during printing, it isvrecommended to use + [%t] and [%a]. *) (** {2 Printing} *) -val fprintf : formatter -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a +val fprintf : + formatter -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a val kfprintf : (formatter -> unit Lwt.t -> 'a) -> - formatter -> ('b, Format.formatter, unit, 'a) format4 -> 'b + formatter -> + ('b, Format.formatter, unit, 'a) format4 -> + 'b -val ifprintf : formatter -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a +val ifprintf : + formatter -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a val ikfprintf : (formatter -> unit Lwt.t -> 'a) -> - formatter -> ('b, Format.formatter, unit, 'a) format4 -> 'b + formatter -> + ('b, Format.formatter, unit, 'a) format4 -> + 'b val flush : formatter -> unit Lwt.t (** [flush fmt] flushes the formatter (as with {{:https://ocaml.org/api/Format.html#VALpp_print_flush} - [Format.pp_print_flush]}) and - executes all the printing action on the underlying channel. -*) - + [Format.pp_print_flush]}) and executes all the printing action on the + underlying channel. *) (** Low level functions *) @@ -95,8 +89,6 @@ val write_order : Lwt_io.output_channel -> order -> unit Lwt.t (** [write_order oc o] applies the order [o] on the channel [oc]. *) val write_pending : formatter -> unit Lwt.t -(** Write all the pending orders of a formatter. - Warning: This function flush neither the internal format queues - nor the underlying channel and is intended for low level use only. - You should probably use {!flush} instead. -*) +(** Write all the pending orders of a formatter. Warning: This function flush + neither the internal format queues nor the underlying channel and is + intended for low level use only. You should probably use {!flush} instead. *) diff --git a/src/unix/lwt_gc.ml b/src/unix/lwt_gc.ml index 12b9e107b3..8caede876c 100644 --- a/src/unix/lwt_gc.ml +++ b/src/unix/lwt_gc.ml @@ -1,28 +1,31 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] + module Lwt_sequence = Lwt_sequence + [@@@ocaml.warning "+3"] let ensure_termination t = - if Lwt.state t = Lwt.Sleep then begin + if Lwt.state t = Lwt.Sleep then let hook = - Lwt_sequence.add_l (fun _ -> t) Lwt_main.exit_hooks [@ocaml.warning "-3"] + (Lwt_sequence.add_l + (fun _ -> t) + Lwt_main.exit_hooks [@ocaml.warning "-3"]) in (* Remove the hook when t has terminated *) - ignore ( - Lwt.finalize - (fun () -> t) - (fun () -> Lwt_sequence.remove hook; Lwt.return_unit)) - end + ignore + (Lwt.finalize + (fun () -> t) + (fun () -> + Lwt_sequence.remove hook; + Lwt.return_unit)) let finaliser f = (* In order not to create a reference to the value in the @@ -30,54 +33,45 @@ let finaliser f = which will be filled when the finaliser is called. *) let opt = ref None in let id = - Lwt_unix.make_notification - ~once:true - (fun () -> - match !opt with - | None -> - assert false - | Some x -> - opt := None; - ensure_termination (f x)) + Lwt_unix.make_notification ~once:true (fun () -> + match !opt with + | None -> assert false + | Some x -> + opt := None; + ensure_termination (f x)) in (* The real finaliser: fill the cell and send a notification. *) - (fun x -> - opt := Some x; - Lwt_unix.send_notification id) + fun x -> + opt := Some x; + Lwt_unix.send_notification id -let finalise f x = - Gc.finalise (finaliser f) x +let finalise f x = Gc.finalise (finaliser f) x (* Exit hook for a finalise_or_exit *) let foe_exit f called weak () = match Weak.get weak 0 with | None -> - (* The value has been garbage collected, normally this point - is never reached *) - Lwt.return_unit - | Some x -> - (* Just to avoid double finalisation *) - Weak.set weak 0 None; - if !called then + (* The value has been garbage collected, normally this point + is never reached *) Lwt.return_unit - else begin - called := true; - f x - end + | Some x -> + (* Just to avoid double finalisation *) + Weak.set weak 0 None; + if !called then Lwt.return_unit + else ( + called := true; + f x) (* Finaliser for a finalise_or_exit *) let foe_finaliser f called hook = - finaliser - (fun x -> - (* Remove the exit hook, it is not needed anymore. *) - Lwt_sequence.remove hook; - (* Call the real finaliser. *) - if !called then - Lwt.return_unit - else begin - called := true; - f x - end) + finaliser (fun x -> + (* Remove the exit hook, it is not needed anymore. *) + Lwt_sequence.remove hook; + (* Call the real finaliser. *) + if !called then Lwt.return_unit + else ( + called := true; + f x)) let finalise_or_exit f x = (* Create a weak pointer, so the exit-hook does not keep a reference @@ -86,7 +80,7 @@ let finalise_or_exit f x = Weak.set weak 0 (Some x); let called = ref false in let hook = - Lwt_sequence.add_l (foe_exit f called weak) Lwt_main.exit_hooks - [@ocaml.warning "-3"] + (Lwt_sequence.add_l (foe_exit f called weak) Lwt_main.exit_hooks + [@ocaml.warning "-3"]) in Gc.finalise (foe_finaliser f called hook) x diff --git a/src/unix/lwt_gc.mli b/src/unix/lwt_gc.mli index e69218f5a9..ad86b5613d 100644 --- a/src/unix/lwt_gc.mli +++ b/src/unix/lwt_gc.mli @@ -1,22 +1,19 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Interaction with the garbage collector *) -(** This module offers a convenient way to add a finaliser launching a - thread to a value, without having to use [Lwt_unix.run] in the - finaliser. *) +(** This module offers a convenient way to add a finaliser launching a thread to + a value, without having to use [Lwt_unix.run] in the finaliser. *) val finalise : ('a -> unit Lwt.t) -> 'a -> unit - (** [finalise f x] ensures [f x] is evaluated after [x] has been - garbage collected. If [f x] yields, then Lwt will wait for its - termination at the end of the program. +(** [finalise f x] ensures [f x] is evaluated after [x] has been garbage + collected. If [f x] yields, then Lwt will wait for its termination at the + end of the program. - Note that [f x] is not called at garbage collection time, but - later in the main loop. *) + Note that [f x] is not called at garbage collection time, but later in the + main loop. *) val finalise_or_exit : ('a -> unit Lwt.t) -> 'a -> unit - (** [finalise_or_exit f x] call [f x] when [x] is garbage collected - or (exclusively) when the program exits. *) +(** [finalise_or_exit f x] call [f x] when [x] is garbage collected or + (exclusively) when the program exits. *) diff --git a/src/unix/lwt_io.ml b/src/unix/lwt_io.ml index 5bb2e258cf..8adae16f33 100644 --- a/src/unix/lwt_io.ml +++ b/src/unix/lwt_io.ml @@ -1,15 +1,15 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] + module Lwt_sequence = Lwt_sequence + [@@@ocaml.warning "+3"] open Lwt.Infix @@ -24,8 +24,7 @@ let check_buffer_size fun_name buffer_size = Printf.ksprintf invalid_arg "Lwt_io.%s: too small buffer size" fun_name else if buffer_size > Sys.max_string_length then Printf.ksprintf invalid_arg "Lwt_io.%s: too big buffer size" fun_name - else - () + else () let check_buffer fun_name buffer = check_buffer_size fun_name (Lwt_bytes.length buffer) @@ -38,91 +37,59 @@ let default_buffer_size = ref 4096 type input type output - -type 'a mode = - | Input : input mode - | Output : output mode +type 'a mode = Input : input mode | Output : output mode let input : input mode = Input let output : output mode = Output (* A channel state *) type 'mode state = - | Busy_primitive - (* A primitive is running on the channel *) - - | Busy_atomic of 'mode channel - (* An atomic operations is being performed on the channel. The - argument is the temporary atomic wrapper. *) - - | Waiting_for_busy - (* A queued operation has not yet started. *) - - | Idle - (* The channel is unused *) - - | Closed - (* The channel has been closed *) - + | Busy_primitive (* A primitive is running on the channel *) + | Busy_atomic of 'mode channel (* An atomic operations is being performed on the channel. The + argument is the temporary atomic wrapper. *) + | Waiting_for_busy (* A queued operation has not yet started. *) + | Idle (* The channel is unused *) + | Closed (* The channel has been closed *) | Invalid - (* The channel is a temporary channel created for an atomic - operation which has terminated. *) +(* The channel is a temporary channel created for an atomic + operation which has terminated. *) (* A wrapper, which ensures that io operations are atomic: *) and 'mode channel = { mutable state : 'mode state; - - channel : 'mode _channel; - (* The real channel *) - - mutable queued : unit Lwt.u Lwt_sequence.t; - (* Queued operations *) + channel : 'mode _channel; (* The real channel *) + mutable queued : unit Lwt.u Lwt_sequence.t; (* Queued operations *) } and 'mode _channel = { mutable buffer : Lwt_bytes.t; mutable length : int; - - mutable ptr : int; - (* Current position *) - + mutable ptr : int; (* Current position *) mutable max : int; (* Position of the end of data int the buffer. It is equal to [length] for output channels. *) - abort_waiter : int Lwt.t; (* Thread which is wakeup with an exception when the channel is closed. *) abort_wakener : int Lwt.u; - mutable auto_flushing : bool; (* Whether the auto-flusher is currently running or not *) - - main : 'mode channel; - (* The main wrapper *) - - close : unit Lwt.t Lazy.t; - (* Close function *) - - mode : 'mode mode; - (* The channel mode *) - - mutable offset : int64; - (* Number of bytes really read/written *) - - typ : typ; - (* Type of the channel. *) + main : 'mode channel; (* The main wrapper *) + close : unit Lwt.t Lazy.t; (* Close function *) + mode : 'mode mode; (* The channel mode *) + mutable offset : int64; (* Number of bytes really read/written *) + typ : typ; (* Type of the channel. *) } and typ = | Type_normal of - (Lwt_bytes.t -> int -> int -> int Lwt.t) * - (int64 -> Unix.seek_command -> int64 Lwt.t) + (Lwt_bytes.t -> int -> int -> int Lwt.t) + * (int64 -> Unix.seek_command -> int64 Lwt.t) (* The channel has been created with [make]. The first argument is the refill/flush function and the second is the seek function. *) | Type_bytes - (* The channel has been created with [of_bytes]. *) +(* The channel has been created with [of_bytes]. *) type input_channel = input channel type output_channel = output channel @@ -154,142 +121,115 @@ let hash_output_channel = index := !index + 1; !index -module Outputs = Weak.Make(struct - type t = output_channel - let hash _ = hash_output_channel () - let equal = ( == ) - end) +module Outputs = Weak.Make (struct + type t = output_channel + + let hash _ = hash_output_channel () + let equal = ( == ) +end) (* Table of all opened output channels. On exit they are all flushed: *) let outputs = Outputs.create 32 -let position : type mode. mode channel -> int64 = fun wrapper -> +let position : type mode. mode channel -> int64 = + fun wrapper -> let ch = wrapper.channel in match ch.mode with - | Input -> - Int64.sub ch.offset (Int64.of_int (ch.max - ch.ptr)) - | Output -> - Int64.add ch.offset (Int64.of_int ch.ptr) + | Input -> Int64.sub ch.offset (Int64.of_int (ch.max - ch.ptr)) + | Output -> Int64.add ch.offset (Int64.of_int ch.ptr) -let name : type mode. mode _channel -> string = fun ch -> - match ch.mode with - | Input -> "input" - | Output -> "output" +let name : type mode. mode _channel -> string = + fun ch -> match ch.mode with Input -> "input" | Output -> "output" let closed_channel ch = Channel_closed (name ch) + let invalid_channel ch = Failure (Printf.sprintf "temporary atomic channel %s no more valid" (name ch)) let is_busy ch = match ch.state with - | Invalid -> - raise (invalid_channel ch.channel) - | Idle | Closed -> - false - | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> - true + | Invalid -> raise (invalid_channel ch.channel) + | Idle | Closed -> false + | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> true (* Flush/refill the buffer. No race condition could happen because this function is always called atomically: *) -let perform_io : type mode. mode _channel -> int Lwt.t = fun ch -> +let perform_io : type mode. mode _channel -> int Lwt.t = + fun ch -> match ch.main.state with - | Closed -> - Lwt.fail (closed_channel ch) - - | Invalid -> - Lwt.fail (invalid_channel ch) - - | Idle - | Waiting_for_busy -> - assert false - - | Busy_primitive - | Busy_atomic _ -> - match ch.typ with - | Type_normal (perform, _) -> - let ptr, len = - match ch.mode with - | Input -> - (* Size of data in the buffer *) - let size = ch.max - ch.ptr in - (* If there are still data in the buffer, keep them: *) - if size > 0 then - Lwt_bytes.unsafe_blit ch.buffer ch.ptr ch.buffer 0 size; - (* Update positions: *) - ch.ptr <- 0; - ch.max <- size; - (size, ch.length - size) - | Output -> - (0, ch.ptr) - in - let perform = - if Sys.win32 then - Lwt.catch - (fun () -> - perform ch.buffer ptr len) - (function - | Unix.Unix_error (Unix.EPIPE, _, _) -> - Lwt.return 0 - | exn -> Lwt.fail exn) [@ocaml.warning "-4"] - else - perform ch.buffer ptr len - in - Lwt.pick [ch.abort_waiter; perform] >>= fun n -> - (* Never trust user functions... *) - if n < 0 || n > len then - Lwt.fail - (Failure - (Printf.sprintf - "Lwt_io.perform_io: invalid result of the [%s] function" - (match ch.mode with Input -> "read" | Output -> "write"))) - else begin - (* Update the global offset: *) - ch.offset <- Int64.add ch.offset (Int64.of_int n); - (* Update buffer positions: *) - begin match ch.mode with - | Input -> - ch.max <- ch.max + n + | Closed -> Lwt.fail (closed_channel ch) + | Invalid -> Lwt.fail (invalid_channel ch) + | Idle | Waiting_for_busy -> assert false + | Busy_primitive | Busy_atomic _ -> ( + match ch.typ with + | Type_normal (perform, _) -> + let ptr, len = + match ch.mode with + | Input -> + (* Size of data in the buffer *) + let size = ch.max - ch.ptr in + (* If there are still data in the buffer, keep them: *) + if size > 0 then + Lwt_bytes.unsafe_blit ch.buffer ch.ptr ch.buffer 0 size; + (* Update positions: *) + ch.ptr <- 0; + ch.max <- size; + (size, ch.length - size) + | Output -> (0, ch.ptr) + in + let perform = + if Sys.win32 then + Lwt.catch + (fun () -> perform ch.buffer ptr len) + (function + | Unix.Unix_error (Unix.EPIPE, _, _) -> Lwt.return 0 + | exn -> Lwt.fail exn) [@ocaml.warning "-4"] + else perform ch.buffer ptr len + in + Lwt.pick [ ch.abort_waiter; perform ] >>= fun n -> + (* Never trust user functions... *) + if n < 0 || n > len then + Lwt.fail + (Failure + (Printf.sprintf + "Lwt_io.perform_io: invalid result of the [%s] function" + (match ch.mode with Input -> "read" | Output -> "write"))) + else ( + (* Update the global offset: *) + ch.offset <- Int64.add ch.offset (Int64.of_int n); + (* Update buffer positions: *) + (match ch.mode with + | Input -> ch.max <- ch.max + n + | Output -> + (* Shift remaining data: *) + let len = len - n in + Lwt_bytes.unsafe_blit ch.buffer n ch.buffer 0 len; + ch.ptr <- len); + Lwt.return n) + | Type_bytes -> ( + match ch.mode with + | Input -> Lwt.return 0 | Output -> - (* Shift remaining data: *) - let len = len - n in - Lwt_bytes.unsafe_blit ch.buffer n ch.buffer 0 len; - ch.ptr <- len - end; - Lwt.return n - end - - | Type_bytes -> - begin match ch.mode with - | Input -> - Lwt.return 0 - | Output -> - Lwt.fail - (Failure "cannot flush a channel created with Lwt_io.of_string") - end + Lwt.fail + (Failure "cannot flush a channel created with Lwt_io.of_string") + )) let refill = perform_io let flush_partial = perform_io let rec flush_total oc = - if oc.ptr > 0 then - flush_partial oc >>= fun _ -> - flush_total oc - else - Lwt.return_unit + if oc.ptr > 0 then flush_partial oc >>= fun _ -> flush_total oc + else Lwt.return_unit let safe_flush_total oc = - Lwt.catch - (fun () -> flush_total oc) - (fun _ -> Lwt.return_unit) + Lwt.catch (fun () -> flush_total oc) (fun _ -> Lwt.return_unit) let deepest_wrapper ch = let rec loop wrapper = match wrapper.state with - | Busy_atomic wrapper -> - loop wrapper - | Busy_primitive | Waiting_for_busy | Idle | Closed | Invalid -> - wrapper + | Busy_atomic wrapper -> loop wrapper + | Busy_primitive | Waiting_for_busy | Idle | Closed | Invalid -> wrapper in loop ch.main @@ -298,185 +238,168 @@ let auto_flush oc = let wrapper = deepest_wrapper oc in match wrapper.state with | Busy_primitive | Waiting_for_busy -> - (* The channel is used, cancel auto flushing. It will be - restarted when the channel Lwt.returns to the [Idle] state: *) - oc.auto_flushing <- false; - Lwt.return_unit - + (* The channel is used, cancel auto flushing. It will be + restarted when the channel Lwt.returns to the [Idle] state: *) + oc.auto_flushing <- false; + Lwt.return_unit | Busy_atomic _ -> - (* Cannot happen since we took the deepest wrapper: *) - assert false - + (* Cannot happen since we took the deepest wrapper: *) + assert false | Idle -> - oc.auto_flushing <- false; - wrapper.state <- Busy_primitive; - safe_flush_total oc >>= fun () -> - if wrapper.state = Busy_primitive then - wrapper.state <- Idle; - if not (Lwt_sequence.is_empty wrapper.queued) then - Lwt.wakeup_later (Lwt_sequence.take_l wrapper.queued) (); - Lwt.return_unit - - | Closed | Invalid -> - Lwt.return_unit + oc.auto_flushing <- false; + wrapper.state <- Busy_primitive; + safe_flush_total oc >>= fun () -> + if wrapper.state = Busy_primitive then wrapper.state <- Idle; + if not (Lwt_sequence.is_empty wrapper.queued) then + Lwt.wakeup_later (Lwt_sequence.take_l wrapper.queued) (); + Lwt.return_unit + | Closed | Invalid -> Lwt.return_unit (* A ``locked'' channel is a channel in the state [Busy_primitive] or [Busy_atomic] *) -let unlock : type m. m channel -> unit = fun wrapper -> match wrapper.state with +let unlock : type m. m channel -> unit = + fun wrapper -> + match wrapper.state with | Busy_primitive | Busy_atomic _ -> - if Lwt_sequence.is_empty wrapper.queued then - wrapper.state <- Idle - else begin - wrapper.state <- Waiting_for_busy; - Lwt.wakeup_later (Lwt_sequence.take_l wrapper.queued) () - end; - (* Launches the auto-flusher: *) - let ch = wrapper.channel in - if (* Launch the auto-flusher only if the channel is not busy: *) - (wrapper.state = Idle && - (* Launch the auto-flusher only for output channel: *) - (match ch.mode with Input -> false | Output -> true) && - (* Do not launch two auto-flusher: *) - not ch.auto_flushing && - (* Do not launch the auto-flusher if operations are queued: *) - Lwt_sequence.is_empty wrapper.queued) then begin - ch.auto_flushing <- true; - ignore (auto_flush ch) - end - + if Lwt_sequence.is_empty wrapper.queued then wrapper.state <- Idle + else ( + wrapper.state <- Waiting_for_busy; + Lwt.wakeup_later (Lwt_sequence.take_l wrapper.queued) ()); + (* Launches the auto-flusher: *) + let ch = wrapper.channel in + if + (* Launch the auto-flusher only if the channel is not busy: *) + wrapper.state = Idle + (* Launch the auto-flusher only for output channel: *) + && (match ch.mode with Input -> false | Output -> true) + (* Do not launch two auto-flusher: *) + && (not ch.auto_flushing) + && (* Do not launch the auto-flusher if operations are queued: *) + Lwt_sequence.is_empty wrapper.queued + then ( + ch.auto_flushing <- true; + ignore (auto_flush ch)) | Closed | Invalid -> - (* Do not change channel state if the channel has been closed *) - if not (Lwt_sequence.is_empty wrapper.queued) then - Lwt.wakeup_later (Lwt_sequence.take_l wrapper.queued) () - + (* Do not change channel state if the channel has been closed *) + if not (Lwt_sequence.is_empty wrapper.queued) then + Lwt.wakeup_later (Lwt_sequence.take_l wrapper.queued) () | Idle | Waiting_for_busy -> - (* We must never unlock an unlocked channel *) - assert false + (* We must never unlock an unlocked channel *) + assert false (* Wrap primitives into atomic io operations: *) -let primitive f wrapper = match wrapper.state with +let primitive f wrapper = + match wrapper.state with | Idle -> - wrapper.state <- Busy_primitive; - Lwt.finalize - (fun () -> f wrapper.channel) - (fun () -> - unlock wrapper; - Lwt.return_unit) - - | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> - (Lwt.add_task_r [@ocaml.warning "-3"]) wrapper.queued >>= fun () -> - begin match wrapper.state with + wrapper.state <- Busy_primitive; + Lwt.finalize + (fun () -> f wrapper.channel) + (fun () -> + unlock wrapper; + Lwt.return_unit) + | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> ( + (Lwt.add_task_r [@ocaml.warning "-3"]) wrapper.queued >>= fun () -> + match wrapper.state with | Closed -> - (* The channel has been closed while we were waiting *) - unlock wrapper; - Lwt.fail (closed_channel wrapper.channel) - + (* The channel has been closed while we were waiting *) + unlock wrapper; + Lwt.fail (closed_channel wrapper.channel) | Idle | Waiting_for_busy -> - wrapper.state <- Busy_primitive; - Lwt.finalize - (fun () -> f wrapper.channel) - (fun () -> - unlock wrapper; - Lwt.return_unit) - - | Invalid -> - Lwt.fail (invalid_channel wrapper.channel) - - | Busy_primitive | Busy_atomic _ -> - assert false - end - - | Closed -> - Lwt.fail (closed_channel wrapper.channel) - - | Invalid -> - Lwt.fail (invalid_channel wrapper.channel) + wrapper.state <- Busy_primitive; + Lwt.finalize + (fun () -> f wrapper.channel) + (fun () -> + unlock wrapper; + Lwt.return_unit) + | Invalid -> Lwt.fail (invalid_channel wrapper.channel) + | Busy_primitive | Busy_atomic _ -> assert false) + | Closed -> Lwt.fail (closed_channel wrapper.channel) + | Invalid -> Lwt.fail (invalid_channel wrapper.channel) (* Wrap a sequence of io operations into an atomic operation: *) -let atomic f wrapper = match wrapper.state with +let atomic f wrapper = + match wrapper.state with | Idle -> - let tmp_wrapper = { state = Idle; - channel = wrapper.channel; - queued = Lwt_sequence.create () } in - wrapper.state <- Busy_atomic tmp_wrapper; - Lwt.finalize - (fun () -> f tmp_wrapper) - (fun () -> - (* The temporary wrapper is no more valid: *) - tmp_wrapper.state <- Invalid; - unlock wrapper; - Lwt.return_unit) - - | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> - (Lwt.add_task_r [@ocaml.warning "-3"]) wrapper.queued >>= fun () -> - begin match wrapper.state with + let tmp_wrapper = + { + state = Idle; + channel = wrapper.channel; + queued = Lwt_sequence.create (); + } + in + wrapper.state <- Busy_atomic tmp_wrapper; + Lwt.finalize + (fun () -> f tmp_wrapper) + (fun () -> + (* The temporary wrapper is no more valid: *) + tmp_wrapper.state <- Invalid; + unlock wrapper; + Lwt.return_unit) + | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> ( + (Lwt.add_task_r [@ocaml.warning "-3"]) wrapper.queued >>= fun () -> + match wrapper.state with | Closed -> - (* The channel has been closed while we were waiting *) - unlock wrapper; - Lwt.fail (closed_channel wrapper.channel) - + (* The channel has been closed while we were waiting *) + unlock wrapper; + Lwt.fail (closed_channel wrapper.channel) | Idle | Waiting_for_busy -> - let tmp_wrapper = { state = Idle; - channel = wrapper.channel; - queued = Lwt_sequence.create () } in - wrapper.state <- Busy_atomic tmp_wrapper; - Lwt.finalize - (fun () -> f tmp_wrapper) - (fun () -> - tmp_wrapper.state <- Invalid; - unlock wrapper; - Lwt.return_unit) - - | Invalid -> - Lwt.fail (invalid_channel wrapper.channel) - - | Busy_primitive | Busy_atomic _ -> - assert false - end - - | Closed -> - Lwt.fail (closed_channel wrapper.channel) - - | Invalid -> - Lwt.fail (invalid_channel wrapper.channel) + let tmp_wrapper = + { + state = Idle; + channel = wrapper.channel; + queued = Lwt_sequence.create (); + } + in + wrapper.state <- Busy_atomic tmp_wrapper; + Lwt.finalize + (fun () -> f tmp_wrapper) + (fun () -> + tmp_wrapper.state <- Invalid; + unlock wrapper; + Lwt.return_unit) + | Invalid -> Lwt.fail (invalid_channel wrapper.channel) + | Busy_primitive | Busy_atomic _ -> assert false) + | Closed -> Lwt.fail (closed_channel wrapper.channel) + | Invalid -> Lwt.fail (invalid_channel wrapper.channel) -let rec abort wrapper = match wrapper.state with +let rec abort wrapper = + match wrapper.state with | Busy_atomic tmp_wrapper -> - (* Close the depest opened wrapper: *) - abort tmp_wrapper + (* Close the depest opened wrapper: *) + abort tmp_wrapper | Closed -> - (* Double close, just returns the same thing as before *) - Lazy.force wrapper.channel.close - | Invalid -> - Lwt.fail (invalid_channel wrapper.channel) + (* Double close, just returns the same thing as before *) + Lazy.force wrapper.channel.close + | Invalid -> Lwt.fail (invalid_channel wrapper.channel) | Idle | Busy_primitive | Waiting_for_busy -> - wrapper.state <- Closed; - (* Abort any current real reading/writing operation on the - channel: *) - Lwt.wakeup_exn - wrapper.channel.abort_wakener (closed_channel wrapper.channel); - Lazy.force wrapper.channel.close - -let close : type mode. mode channel -> unit Lwt.t = fun wrapper -> + wrapper.state <- Closed; + (* Abort any current real reading/writing operation on the + channel: *) + Lwt.wakeup_exn wrapper.channel.abort_wakener + (closed_channel wrapper.channel); + Lazy.force wrapper.channel.close + +let close : type mode. mode channel -> unit Lwt.t = + fun wrapper -> let channel = wrapper.channel in if channel.main != wrapper then Lwt.fail - (Failure - "Lwt_io.close: cannot close a channel obtained via Lwt_io.atomic") + (Failure "Lwt_io.close: cannot close a channel obtained via Lwt_io.atomic") else match channel.mode with | Input -> - (* Just close it now: *) - abort wrapper + (* Just close it now: *) + abort wrapper | Output -> - Lwt.catch - (fun () -> - (* Performs all pending actions, flush the buffer, then close it: *) - primitive (fun channel -> - safe_flush_total channel >>= fun () -> abort wrapper) wrapper) - (fun _ -> - abort wrapper) + Lwt.catch + (fun () -> + (* Performs all pending actions, flush the buffer, then close it: *) + primitive + (fun channel -> + safe_flush_total channel >>= fun () -> abort wrapper) + wrapper) + (fun _ -> abort wrapper) let is_closed wrapper = match wrapper.state with @@ -487,9 +410,9 @@ let flush_all () = let wrappers = Outputs.fold (fun x l -> x :: l) outputs [] in Lwt_list.iter_p (fun wrapper -> - Lwt.catch - (fun () -> primitive safe_flush_total wrapper) - (fun _ -> Lwt.return_unit)) + Lwt.catch + (fun () -> primitive safe_flush_total wrapper) + (fun _ -> Lwt.return_unit)) wrappers let () = @@ -501,167 +424,156 @@ let no_seek _pos _cmd = let make : type m. - ?buffer : Lwt_bytes.t -> - ?close : (unit -> unit Lwt.t) -> - ?seek : (int64 -> Unix.seek_command -> int64 Lwt.t) -> - mode : m mode -> + ?buffer:Lwt_bytes.t -> + ?close:(unit -> unit Lwt.t) -> + ?seek:(int64 -> Unix.seek_command -> int64 Lwt.t) -> + mode:m mode -> (Lwt_bytes.t -> int -> int -> int Lwt.t) -> - m channel = - fun ?buffer ?(close=Lwt.return) ?(seek=no_seek) ~mode perform_io -> - let (buffer, size) = + m channel = + fun ?buffer ?(close = Lwt.return) ?(seek = no_seek) ~mode perform_io -> + let buffer, size = match buffer with | Some buffer -> - check_buffer "Lwt_io.make" buffer; - (buffer, Lwt_bytes.length buffer) + check_buffer "Lwt_io.make" buffer; + (buffer, Lwt_bytes.length buffer) | None -> - let size = !default_buffer_size in - (Lwt_bytes.create size, size) + let size = !default_buffer_size in + (Lwt_bytes.create size, size) in let abort_waiter, abort_wakener = Lwt.wait () in - let rec ch = { - buffer = buffer; - length = size; - ptr = 0; - max = (match mode with - | Input -> 0 - | Output -> size); - close = lazy(Lwt.catch close Lwt.fail); - abort_waiter = abort_waiter; - abort_wakener = abort_wakener; - main = wrapper; - auto_flushing = false; - mode = mode; - offset = 0L; - typ = - Type_normal - (perform_io, fun pos cmd -> try seek pos cmd with e -> Lwt.fail e); - } and wrapper = { - state = Idle; - channel = ch; - queued = Lwt_sequence.create (); - } in - (match mode with - | Input -> () - | Output -> Outputs.add outputs wrapper); + let rec ch = + { + buffer; + length = size; + ptr = 0; + max = (match mode with Input -> 0 | Output -> size); + close = lazy (Lwt.catch close Lwt.fail); + abort_waiter; + abort_wakener; + main = wrapper; + auto_flushing = false; + mode; + offset = 0L; + typ = + Type_normal + (perform_io, fun pos cmd -> try seek pos cmd with e -> Lwt.fail e); + } + and wrapper = + { state = Idle; channel = ch; queued = Lwt_sequence.create () } + in + (match mode with Input -> () | Output -> Outputs.add outputs wrapper); wrapper let of_bytes (type m) ~(mode : m mode) bytes = let length = Lwt_bytes.length bytes in let abort_waiter, abort_wakener = Lwt.wait () in - let rec ch = { - buffer = bytes; - length = length; - ptr = 0; - max = length; - close = lazy(Lwt.return_unit); - abort_waiter = abort_waiter; - abort_wakener = abort_wakener; - main = wrapper; - (* Auto flush is set to [true] to prevent writing functions from - trying to launch the auto-fllushed. *) - auto_flushing = true; - mode = mode; - offset = (match mode with - | Output -> 0L - | Input -> Int64.of_int length); - typ = Type_bytes; - } and wrapper = { - state = Idle; - channel = ch; - queued = Lwt_sequence.create (); - } in + let rec ch = + { + buffer = bytes; + length; + ptr = 0; + max = length; + close = lazy Lwt.return_unit; + abort_waiter; + abort_wakener; + main = wrapper; + (* Auto flush is set to [true] to prevent writing functions from + trying to launch the auto-fllushed. *) + auto_flushing = true; + mode; + offset = (match mode with Output -> 0L | Input -> Int64.of_int length); + typ = Type_bytes; + } + and wrapper = + { state = Idle; channel = ch; queued = Lwt_sequence.create () } + in wrapper let of_fd : type m. - ?buffer : Lwt_bytes.t -> - ?close : (unit -> unit Lwt.t) -> - mode : m mode -> + ?buffer:Lwt_bytes.t -> + ?close:(unit -> unit Lwt.t) -> + mode:m mode -> Lwt_unix.file_descr -> - m channel = - fun ?buffer ?close ~mode fd -> - let perform_io = match mode with - | Input -> Lwt_bytes.read fd - | Output -> Lwt_bytes.write fd + m channel = + fun ?buffer ?close ~mode fd -> + let perform_io = + match mode with Input -> Lwt_bytes.read fd | Output -> Lwt_bytes.write fd in - make - ?buffer - ~close:(match close with - | Some f -> f - | None -> (fun () -> Lwt_unix.close fd)) + make ?buffer + ~close: + (match close with Some f -> f | None -> fun () -> Lwt_unix.close fd) ~seek:(fun pos cmd -> Lwt_unix.LargeFile.lseek fd pos cmd) - ~mode - perform_io + ~mode perform_io let of_unix_fd : type m. - ?buffer : Lwt_bytes.t -> - ?close : (unit -> unit Lwt.t) -> - mode : m mode -> Unix.file_descr -> - m channel = - fun ?buffer ?close ~mode fd -> + ?buffer:Lwt_bytes.t -> + ?close:(unit -> unit Lwt.t) -> + mode:m mode -> + Unix.file_descr -> + m channel = + fun ?buffer ?close ~mode fd -> of_fd ?buffer ?close ~mode (Lwt_unix.of_unix_file_descr fd) -let buffered : type m. m channel -> int = fun ch -> +let buffered : type m. m channel -> int = + fun ch -> match ch.channel.mode with | Input -> ch.channel.max - ch.channel.ptr | Output -> ch.channel.ptr let buffer_size ch = ch.channel.length -let resize_buffer : type m. m channel -> int -> unit Lwt.t = fun wrapper len -> +let resize_buffer : type m. m channel -> int -> unit Lwt.t = + fun wrapper len -> if len < min_buffer_size then invalid_arg "Lwt_io.resize_buffer: buffer size too small"; match wrapper.channel.typ with | Type_bytes -> - Lwt.fail - (Failure - ("Lwt_io.resize_buffer: cannot resize the buffer of a channel " ^ - "created with Lwt_io.of_string")) + Lwt.fail + (Failure + ("Lwt_io.resize_buffer: cannot resize the buffer of a channel " + ^ "created with Lwt_io.of_string")) | Type_normal _ -> - let f : type m. m _channel -> unit Lwt.t = fun ch -> - match ch.mode with - | Input -> - let unread_count = ch.max - ch.ptr in - (* Fail if we want to decrease the buffer size and there is - too much unread data in the buffer: *) - if len < unread_count then - Lwt.fail - (Failure - ("Lwt_io.resize_buffer: cannot decrease buffer size, too much " ^ - "unread data")) - else begin - let buffer = Lwt_bytes.create len in - Lwt_bytes.unsafe_blit ch.buffer ch.ptr buffer 0 unread_count; - ch.buffer <- buffer; - ch.length <- len; - ch.ptr <- 0; - ch.max <- unread_count; - Lwt.return_unit - end - | Output -> - (* If we decrease the buffer size, flush the buffer until - the number of buffered bytes fits into the new buffer: *) - let rec loop () = - if ch.ptr > len then - flush_partial ch >>= fun _ -> - loop () - else + let f : type m. m _channel -> unit Lwt.t = + fun ch -> + match ch.mode with + | Input -> + let unread_count = ch.max - ch.ptr in + (* Fail if we want to decrease the buffer size and there is + too much unread data in the buffer: *) + if len < unread_count then + Lwt.fail + (Failure + ("Lwt_io.resize_buffer: cannot decrease buffer size, too \ + much " + ^ "unread data")) + else + let buffer = Lwt_bytes.create len in + Lwt_bytes.unsafe_blit ch.buffer ch.ptr buffer 0 unread_count; + ch.buffer <- buffer; + ch.length <- len; + ch.ptr <- 0; + ch.max <- unread_count; + Lwt.return_unit + | Output -> + (* If we decrease the buffer size, flush the buffer until + the number of buffered bytes fits into the new buffer: *) + let rec loop () = + if ch.ptr > len then flush_partial ch >>= fun _ -> loop () + else Lwt.return_unit + in + loop () >>= fun () -> + let buffer = Lwt_bytes.create len in + Lwt_bytes.unsafe_blit ch.buffer 0 buffer 0 ch.ptr; + ch.buffer <- buffer; + ch.length <- len; + ch.max <- len; Lwt.return_unit - in - loop () >>= fun () -> - let buffer = Lwt_bytes.create len in - Lwt_bytes.unsafe_blit ch.buffer 0 buffer 0 ch.ptr; - ch.buffer <- buffer; - ch.length <- len; - ch.max <- len; - Lwt.return_unit - in - primitive f wrapper - -module Primitives = -struct + in + primitive f wrapper +module Primitives = struct (* This module contains all primitives operations. The operates without protection regarding locking, they are wrapped after into safe operations. *) @@ -673,69 +585,62 @@ struct let rec read_char ic = let ptr = ic.ptr in if ptr = ic.max then - refill ic >>= function - | 0 -> Lwt.fail End_of_file - | _ -> read_char ic - else begin + refill ic >>= function 0 -> Lwt.fail End_of_file | _ -> read_char ic + else ( ic.ptr <- ptr + 1; - Lwt.return (Lwt_bytes.unsafe_get ic.buffer ptr) - end + Lwt.return (Lwt_bytes.unsafe_get ic.buffer ptr)) let read_char_opt ic = Lwt.catch (fun () -> read_char ic >|= fun ch -> Some ch) - (function - | End_of_file -> Lwt.return_none - | exn -> Lwt.fail exn) + (function End_of_file -> Lwt.return_none | exn -> Lwt.fail exn) let read_line ic = let buf = Buffer.create 128 in let rec loop cr_read = - Lwt.try_bind (fun _ -> read_char ic) + Lwt.try_bind + (fun _ -> read_char ic) (function - | '\n' -> - Lwt.return(Buffer.contents buf) + | '\n' -> Lwt.return (Buffer.contents buf) | '\r' -> - if cr_read then Buffer.add_char buf '\r'; - loop true + if cr_read then Buffer.add_char buf '\r'; + loop true | ch -> - if cr_read then Buffer.add_char buf '\r'; - Buffer.add_char buf ch; - loop false) + if cr_read then Buffer.add_char buf '\r'; + Buffer.add_char buf ch; + loop false) (function | End_of_file -> - if cr_read then Buffer.add_char buf '\r'; - Lwt.return(Buffer.contents buf) - | exn -> - Lwt.fail exn) + if cr_read then Buffer.add_char buf '\r'; + Lwt.return (Buffer.contents buf) + | exn -> Lwt.fail exn) in read_char ic >>= function | '\r' -> loop true | '\n' -> Lwt.return "" - | ch -> Buffer.add_char buf ch; loop false + | ch -> + Buffer.add_char buf ch; + loop false let read_line_opt ic = Lwt.catch (fun () -> read_line ic >|= fun ch -> Some ch) - (function - | End_of_file -> Lwt.return_none - | exn -> Lwt.fail exn) + (function End_of_file -> Lwt.return_none | exn -> Lwt.fail exn) let unsafe_read_into' ic blit buf ofs len = let avail = ic.max - ic.ptr in - if avail > 0 then begin + if avail > 0 then ( let len = min len avail in blit ic.buffer ic.ptr buf ofs len; ic.ptr <- ic.ptr + len; - Lwt.return len - end else begin + Lwt.return len) + else refill ic >>= fun n -> let len = min len n in blit ic.buffer 0 buf ofs len; ic.ptr <- len; ic.max <- n; Lwt.return len - end let unsafe_read_into_bigstring ic buf ofs len = unsafe_read_into' ic Lwt_bytes.unsafe_blit buf ofs len @@ -746,38 +651,25 @@ struct let read_into_bigstring ic buf ofs len = if ofs < 0 || len < 0 || ofs + len > Lwt_bytes.length buf then Lwt.fail (Invalid_argument "Lwt_io.read_into_bigstring") - else begin - if len = 0 then - Lwt.return 0 - else - unsafe_read_into_bigstring ic buf ofs len - end + else if len = 0 then Lwt.return 0 + else unsafe_read_into_bigstring ic buf ofs len let read_into ic buf ofs len = if ofs < 0 || len < 0 || ofs + len > Bytes.length buf then Lwt.fail (Invalid_argument "Lwt_io.read_into") - else begin - if len = 0 then - Lwt.return 0 - else - unsafe_read_into ic buf ofs len - end + else if len = 0 then Lwt.return 0 + else unsafe_read_into ic buf ofs len let unsafe_read_into_exactly' read_into ic buf ofs len = let rec loop ic buf ofs len = read_into ic buf ofs len >>= function - | 0 -> - Lwt.fail End_of_file + | 0 -> Lwt.fail End_of_file | n -> let len = len - n in - if len = 0 then - Lwt.return_unit - else - loop ic buf (ofs + n) len + if len = 0 then Lwt.return_unit else loop ic buf (ofs + n) len in loop ic buf ofs len - let unsafe_read_into_exactly_bigstring ic buf ofs len = unsafe_read_into_exactly' unsafe_read_into_bigstring ic buf ofs len @@ -787,32 +679,24 @@ struct let read_into_exactly_bigstring ic buf ofs len = if ofs < 0 || len < 0 || ofs + len > Lwt_bytes.length buf then Lwt.fail (Invalid_argument "Lwt_io.read_into_exactly_bigstring") - else begin - if len = 0 then - Lwt.return_unit - else - unsafe_read_into_exactly_bigstring ic buf ofs len - end + else if len = 0 then Lwt.return_unit + else unsafe_read_into_exactly_bigstring ic buf ofs len let read_into_exactly ic buf ofs len = if ofs < 0 || len < 0 || ofs + len > Bytes.length buf then Lwt.fail (Invalid_argument "Lwt_io.read_into_exactly") - else begin - if len = 0 then - Lwt.return_unit - else - unsafe_read_into_exactly ic buf ofs len - end + else if len = 0 then Lwt.return_unit + else unsafe_read_into_exactly ic buf ofs len let rev_concat len l = let buf = Bytes.create len in let _ = List.fold_left (fun ofs str -> - let len = String.length str in - let ofs = ofs - len in - String.unsafe_blit str 0 buf ofs len; - ofs) + let len = String.length str in + let ofs = ofs - len in + String.unsafe_blit str 0 buf ofs len; + ofs) len l in buf @@ -824,22 +708,18 @@ struct let str = Bytes.unsafe_to_string buf in ic.ptr <- ic.max; refill ic >>= function - | 0 -> - Lwt.return (rev_concat (len + total_len) (str :: acc)) - | _ -> - read_all ic (len + total_len) (str :: acc) + | 0 -> Lwt.return (rev_concat (len + total_len) (str :: acc)) + | _ -> read_all ic (len + total_len) (str :: acc) let read count ic = match count with - | None -> - read_all ic 0 [] >|= Bytes.unsafe_to_string + | None -> read_all ic 0 [] >|= Bytes.unsafe_to_string | Some len -> - let buf = Bytes.create len in - unsafe_read_into ic buf 0 len >>= fun real_len -> - if real_len < len then - Lwt.return Bytes.(sub buf 0 real_len |> unsafe_to_string) - else - Lwt.return (Bytes.unsafe_to_string buf) + let buf = Bytes.create len in + unsafe_read_into ic buf 0 len >>= fun real_len -> + if real_len < len then + Lwt.return Bytes.(sub buf 0 real_len |> unsafe_to_string) + else Lwt.return (Bytes.unsafe_to_string buf) let read_value ic = let header = Bytes.create 20 in @@ -860,36 +740,32 @@ struct let rec write_char oc ch = let ptr = oc.ptr in - if ptr < oc.length then begin + if ptr < oc.length then ( oc.ptr <- ptr + 1; Lwt_bytes.unsafe_set oc.buffer ptr ch; - Lwt.return_unit - end else - flush_partial oc >>= fun _ -> - write_char oc ch + Lwt.return_unit) + else flush_partial oc >>= fun _ -> write_char oc ch let rec unsafe_write_from' blit oc str ofs len = let avail = oc.length - oc.ptr in - if avail >= len then begin + if avail >= len then ( blit str ofs oc.buffer oc.ptr len; oc.ptr <- oc.ptr + len; - Lwt.return 0 - end else begin + Lwt.return 0) + else ( blit str ofs oc.buffer oc.ptr avail; oc.ptr <- oc.length; flush_partial oc >>= fun _ -> let len = len - avail in - if oc.ptr = 0 then begin - if len = 0 then - Lwt.return 0 + if oc.ptr = 0 then + if len = 0 then Lwt.return 0 else (* Everything has been written, try to write more: *) unsafe_write_from' blit oc str (ofs + avail) len - end else + else (* Not everything has been written, just what is remaining: *) - Lwt.return len - end + Lwt.return len) let unsafe_write_from_bigstring oc bytes ofs len = unsafe_write_from' Lwt_bytes.blit oc bytes ofs len @@ -900,24 +776,18 @@ struct let write_from_bigstring oc bytes ofs len = if ofs < 0 || len < 0 || ofs + len > Lwt_bytes.length bytes then Lwt.fail (Invalid_argument "Lwt_io.write_from_bigstring") - else begin - if len = 0 then - Lwt.return 0 - else - unsafe_write_from_bigstring oc bytes ofs len >>= fun remaining -> - Lwt.return (len - remaining) - end + else if len = 0 then Lwt.return 0 + else + unsafe_write_from_bigstring oc bytes ofs len >>= fun remaining -> + Lwt.return (len - remaining) let write_from oc buf ofs len = if ofs < 0 || len < 0 || ofs + len > Bytes.length buf then Lwt.fail (Invalid_argument "Lwt_io.write_from") - else begin - if len = 0 then - Lwt.return 0 - else - unsafe_write_from oc buf ofs len >>= fun remaining -> - Lwt.return (len - remaining) - end + else if len = 0 then Lwt.return 0 + else + unsafe_write_from oc buf ofs len >>= fun remaining -> + Lwt.return (len - remaining) let write_from_string oc buf ofs len = let buf = Bytes.unsafe_of_string buf in @@ -926,10 +796,8 @@ struct let unsafe_write_from_exactly' write_from oc buf ofs len = let rec loop oc buf ofs len = write_from oc buf ofs len >>= function - | 0 -> - Lwt.return_unit - | n -> - loop oc buf (ofs + len - n) n + | 0 -> Lwt.return_unit + | n -> loop oc buf (ofs + len - n) n in loop oc buf ofs len @@ -942,22 +810,14 @@ struct let write_from_exactly oc buf ofs len = if ofs < 0 || len < 0 || ofs + len > Bytes.length buf then Lwt.fail (Invalid_argument "Lwt_io.write_from_exactly") - else begin - if len = 0 then - Lwt.return_unit - else - unsafe_write_from_exactly oc buf ofs len - end + else if len = 0 then Lwt.return_unit + else unsafe_write_from_exactly oc buf ofs len let write_from_exactly_bigstring oc buf ofs len = if ofs < 0 || len < 0 || ofs + len > Lwt_bytes.length buf then Lwt.fail (Invalid_argument "Lwt_io.write_from_exactly_bigstring") - else begin - if len = 0 then - Lwt.return_unit - else - unsafe_write_from_exactly_bigstring oc buf ofs len - end + else if len = 0 then Lwt.return_unit + else unsafe_write_from_exactly_bigstring oc buf ofs len let write_from_string_exactly oc buf ofs len = let buf = Bytes.unsafe_of_string buf in @@ -972,8 +832,7 @@ struct unsafe_write_from_exactly oc buf 0 (Bytes.length buf) >>= fun () -> write_char oc '\n' - let write_value oc ?(flags=[]) x = - write oc (Marshal.to_string x flags) + let write_value oc ?(flags = []) x = write oc (Marshal.to_string x flags) (* +---------------------------------------------------------------+ | Low-level access | @@ -982,109 +841,94 @@ struct let rec read_block_unsafe ic size f = if ic.max - ic.ptr < size then refill ic >>= function - | 0 -> - Lwt.fail End_of_file - | _ -> - read_block_unsafe ic size f - else begin + | 0 -> Lwt.fail End_of_file + | _ -> read_block_unsafe ic size f + else let ptr = ic.ptr in ic.ptr <- ptr + size; f ic.buffer ptr - end let rec write_block_unsafe oc size f = if oc.max - oc.ptr < size then - flush_partial oc >>= fun _ -> - write_block_unsafe oc size f - else begin + flush_partial oc >>= fun _ -> write_block_unsafe oc size f + else let ptr = oc.ptr in oc.ptr <- ptr + size; f oc.buffer ptr - end let block : - type m. - m _channel -> - int -> - (Lwt_bytes.t -> int -> 'a Lwt.t) -> - 'a Lwt.t = - fun ch size f -> + type m. m _channel -> int -> (Lwt_bytes.t -> int -> 'a Lwt.t) -> 'a Lwt.t + = + fun ch size f -> if size < 0 || size > min_buffer_size then Lwt.fail (Invalid_argument "Lwt_io.block") - else - if ch.max - ch.ptr >= size then begin + else if ch.max - ch.ptr >= size then ( let ptr = ch.ptr in ch.ptr <- ptr + size; - f ch.buffer ptr - end else + f ch.buffer ptr) + else match ch.mode with - | Input -> - read_block_unsafe ch size f - | Output -> - write_block_unsafe ch size f + | Input -> read_block_unsafe ch size f + | Output -> write_block_unsafe ch size f let perform token da ch = - if !token then begin + if !token then if da.da_max <> ch.max || da.da_ptr < ch.ptr || da.da_ptr > ch.max then Lwt.fail (Invalid_argument "Lwt_io.direct_access.da_perform") - else begin + else ( ch.ptr <- da.da_ptr; perform_io ch >>= fun count -> da.da_ptr <- ch.ptr; da.da_max <- ch.max; - Lwt.return count - end - end else + Lwt.return count) + else Lwt.fail (Failure - ("Lwt_io.perform: this function can not be called outside " ^ - "Lwt_io.direct_access")) + ("Lwt_io.perform: this function can not be called outside " + ^ "Lwt_io.direct_access")) let direct_access ch f = let token = ref true in - let rec da = { - da_ptr = ch.ptr; - da_max = ch.max; - da_buffer = ch.buffer; - da_perform = (fun _ -> perform token da ch); - } in + let rec da = + { + da_ptr = ch.ptr; + da_max = ch.max; + da_buffer = ch.buffer; + da_perform = (fun _ -> perform token da ch); + } + in f da >>= fun x -> token := false; if da.da_max <> ch.max || da.da_ptr < ch.ptr || da.da_ptr > ch.max then Lwt.fail (Failure "Lwt_io.direct_access: invalid result of [f]") - else begin + else ( ch.ptr <- da.da_ptr; - Lwt.return x - end + Lwt.return x) - module MakeNumberIO (Endian : EndianBigstring.EndianBigstringSig) = - struct + module MakeNumberIO (Endian : EndianBigstring.EndianBigstringSig) = struct (* +-------------------------------------------------------------+ | Reading numbers | +-------------------------------------------------------------+ *) let read_int ic = - read_block_unsafe ic 4 - (fun buffer ptr -> + read_block_unsafe ic 4 (fun buffer ptr -> Lwt.return (Int32.to_int (Endian.get_int32 buffer ptr))) let read_int16 ic = - read_block_unsafe ic 2 - (fun buffer ptr -> + read_block_unsafe ic 2 (fun buffer ptr -> Lwt.return (Endian.get_int16 buffer ptr)) let read_int32 ic = - read_block_unsafe ic 4 - (fun buffer ptr -> + read_block_unsafe ic 4 (fun buffer ptr -> Lwt.return (Endian.get_int32 buffer ptr)) let read_int64 ic = - read_block_unsafe ic 8 - (fun buffer ptr -> + read_block_unsafe ic 8 (fun buffer ptr -> Lwt.return (Endian.get_int64 buffer ptr)) let read_float32 ic = read_int32 ic >>= fun x -> Lwt.return (Int32.float_of_bits x) + let read_float64 ic = read_int64 ic >>= fun x -> Lwt.return (Int64.float_of_bits x) @@ -1093,26 +937,22 @@ struct +-------------------------------------------------------------+ *) let write_int oc v = - write_block_unsafe oc 4 - (fun buffer ptr -> + write_block_unsafe oc 4 (fun buffer ptr -> Endian.set_int32 buffer ptr (Int32.of_int v); Lwt.return_unit) let write_int16 oc v = - write_block_unsafe oc 2 - (fun buffer ptr -> + write_block_unsafe oc 2 (fun buffer ptr -> Endian.set_int16 buffer ptr v; Lwt.return_unit) let write_int32 oc v = - write_block_unsafe oc 4 - (fun buffer ptr -> + write_block_unsafe oc 4 (fun buffer ptr -> Endian.set_int32 buffer ptr v; Lwt.return_unit) let write_int64 oc v = - write_block_unsafe oc 8 - (fun buffer ptr -> + write_block_unsafe oc 8 (fun buffer ptr -> Endian.set_int64 buffer ptr v; Lwt.return_unit) @@ -1128,48 +968,40 @@ struct seek pos Unix.SEEK_SET >>= fun offset -> if offset <> pos then Lwt.fail (Failure (Printf.sprintf "Lwt_io.%s: seek failed" fun_name)) - else - Lwt.return_unit + else Lwt.return_unit - let set_position : - type m. - m _channel -> - int64 -> - unit Lwt.t = - fun ch pos -> - match ch.typ, ch.mode with - | Type_normal(_, seek), Output -> - flush_total ch >>= fun () -> - do_seek "set_position" seek pos >>= fun () -> - ch.offset <- pos; - Lwt.return_unit - | Type_normal(_, seek), Input -> - let current = Int64.sub ch.offset (Int64.of_int (ch.max - ch.ptr)) in - if pos >= current && pos <= ch.offset then begin - ch.ptr <- ch.max - (Int64.to_int (Int64.sub ch.offset pos)); - Lwt.return_unit - end else begin + let set_position : type m. m _channel -> int64 -> unit Lwt.t = + fun ch pos -> + match (ch.typ, ch.mode) with + | Type_normal (_, seek), Output -> + flush_total ch >>= fun () -> do_seek "set_position" seek pos >>= fun () -> ch.offset <- pos; - ch.ptr <- 0; - ch.max <- 0; Lwt.return_unit - end + | Type_normal (_, seek), Input -> + let current = Int64.sub ch.offset (Int64.of_int (ch.max - ch.ptr)) in + if pos >= current && pos <= ch.offset then ( + ch.ptr <- ch.max - Int64.to_int (Int64.sub ch.offset pos); + Lwt.return_unit) + else + do_seek "set_position" seek pos >>= fun () -> + ch.offset <- pos; + ch.ptr <- 0; + ch.max <- 0; + Lwt.return_unit | Type_bytes, _ -> - if pos < 0L || pos > Int64.of_int ch.length then - Lwt.fail (Failure "Lwt_io.set_position: out of bounds") - else begin - ch.ptr <- Int64.to_int pos; - Lwt.return_unit - end + if pos < 0L || pos > Int64.of_int ch.length then + Lwt.fail (Failure "Lwt_io.set_position: out of bounds") + else ( + ch.ptr <- Int64.to_int pos; + Lwt.return_unit) - let length ch = match ch.typ with - | Type_normal(_, seek) -> - seek 0L Unix.SEEK_END >>= fun len -> - do_seek "length" seek ch.offset >>= fun () -> - Lwt.return len - | Type_bytes -> - Lwt.return (Int64.of_int ch.length) + let length ch = + match ch.typ with + | Type_normal (_, seek) -> + seek 0L Unix.SEEK_END >>= fun len -> + do_seek "length" seek ch.offset >>= fun () -> Lwt.return len + | Type_bytes -> Lwt.return (Int64.of_int ch.length) end (* +-----------------------------------------------------------------+ @@ -1181,29 +1013,22 @@ let read_char wrapper = let ptr = channel.ptr in (* Speed-up in case a character is available in the buffer. It increases performances by 10x. *) - if wrapper.state = Idle && ptr < channel.max then begin + if wrapper.state = Idle && ptr < channel.max then ( channel.ptr <- ptr + 1; - Lwt.return (Lwt_bytes.unsafe_get channel.buffer ptr) - end else - primitive Primitives.read_char wrapper + Lwt.return (Lwt_bytes.unsafe_get channel.buffer ptr)) + else primitive Primitives.read_char wrapper let read_char_opt wrapper = let channel = wrapper.channel in let ptr = channel.ptr in - if wrapper.state = Idle && ptr < channel.max then begin + if wrapper.state = Idle && ptr < channel.max then ( channel.ptr <- ptr + 1; - Lwt.return (Some(Lwt_bytes.unsafe_get channel.buffer ptr)) - end else - primitive Primitives.read_char_opt wrapper - -let read_line ic = - primitive Primitives.read_line ic - -let read_line_opt ic = - primitive Primitives.read_line_opt ic + Lwt.return (Some (Lwt_bytes.unsafe_get channel.buffer ptr))) + else primitive Primitives.read_char_opt wrapper -let read ?count ic = - primitive (fun ic -> Primitives.read count ic) ic +let read_line ic = primitive Primitives.read_line ic +let read_line_opt ic = primitive Primitives.read_line_opt ic +let read ?count ic = primitive (fun ic -> Primitives.read count ic) ic let read_into ic str ofs len = primitive (fun ic -> Primitives.read_into ic str ofs len) ic @@ -1215,34 +1040,29 @@ let read_into_bigstring ic bytes ofs len = primitive (fun ic -> Primitives.read_into_bigstring ic bytes ofs len) ic let read_into_exactly_bigstring ic bytes ofs len = - primitive (fun ic -> Primitives.read_into_exactly_bigstring ic bytes ofs len) ic - -let read_value ic = - primitive Primitives.read_value ic + primitive + (fun ic -> Primitives.read_into_exactly_bigstring ic bytes ofs len) + ic +let read_value ic = primitive Primitives.read_value ic let flush oc = primitive Primitives.flush oc let write_char wrapper x = let channel = wrapper.channel in let ptr = channel.ptr in - if wrapper.state = Idle && ptr < channel.max then begin + if wrapper.state = Idle && ptr < channel.max then ( channel.ptr <- ptr + 1; Lwt_bytes.unsafe_set channel.buffer ptr x; (* Fast launching of the auto flusher: *) - if not channel.auto_flushing then begin + if not channel.auto_flushing then ( channel.auto_flushing <- true; ignore (auto_flush channel); - Lwt.return_unit - end else - Lwt.return_unit - end else - primitive (fun oc -> Primitives.write_char oc x) wrapper + Lwt.return_unit) + else Lwt.return_unit) + else primitive (fun oc -> Primitives.write_char oc x) wrapper -let write oc str = - primitive (fun oc -> Primitives.write oc str) oc - -let write_line oc x = - primitive (fun oc -> Primitives.write_line oc x) oc +let write oc str = primitive (fun oc -> Primitives.write oc str) oc +let write_line oc x = primitive (fun oc -> Primitives.write_line oc x) oc let write_from oc str ofs len = primitive (fun oc -> Primitives.write_from oc str ofs len) oc @@ -1257,7 +1077,9 @@ let write_from_exactly oc str ofs len = primitive (fun oc -> Primitives.write_from_exactly oc str ofs len) oc let write_from_exactly_bigstring oc bytes ofs len = - primitive (fun oc -> Primitives.write_from_exactly_bigstring oc bytes ofs len) oc + primitive + (fun oc -> Primitives.write_from_exactly_bigstring oc bytes ofs len) + oc let write_from_string_exactly oc str ofs len = primitive (fun oc -> Primitives.write_from_string_exactly oc str ofs len) oc @@ -1265,17 +1087,13 @@ let write_from_string_exactly oc str ofs len = let write_value oc ?flags x = primitive (fun oc -> Primitives.write_value oc ?flags x) oc -let block ch size f = - primitive (fun ch -> Primitives.block ch size f) ch - -let direct_access ch f = - primitive (fun ch -> Primitives.direct_access ch f) ch +let block ch size f = primitive (fun ch -> Primitives.block ch size f) ch +let direct_access ch f = primitive (fun ch -> Primitives.direct_access ch f) ch let set_position ch pos = primitive (fun ch -> Primitives.set_position ch pos) ch -let length ch = - primitive Primitives.length ch +let length ch = primitive Primitives.length ch module type NumberIO = sig val read_int : input_channel -> int Lwt.t @@ -1292,8 +1110,7 @@ module type NumberIO = sig val write_float64 : output_channel -> float -> unit Lwt.t end -module MakeNumberIO (Endian : EndianBigstring.EndianBigstringSig) = -struct +module MakeNumberIO (Endian : EndianBigstring.EndianBigstringSig) = struct module Primitives = Primitives.MakeNumberIO (Endian) let read_int ic = primitive Primitives.read_int ic @@ -1302,13 +1119,14 @@ struct let read_int64 ic = primitive Primitives.read_int64 ic let read_float32 ic = primitive Primitives.read_float32 ic let read_float64 ic = primitive Primitives.read_float64 ic - let write_int oc x = primitive (fun oc -> Primitives.write_int oc x) oc let write_int16 oc x = primitive (fun oc -> Primitives.write_int16 oc x) oc let write_int32 oc x = primitive (fun oc -> Primitives.write_int32 oc x) oc let write_int64 oc x = primitive (fun oc -> Primitives.write_int64 oc x) oc + let write_float32 oc x = primitive (fun oc -> Primitives.write_float32 oc x) oc + let write_float64 oc x = primitive (fun oc -> Primitives.write_float64 oc x) oc end @@ -1317,33 +1135,35 @@ module LE = MakeNumberIO (EndianBigstring.LittleEndian_unsafe) module BE = MakeNumberIO (EndianBigstring.BigEndian_unsafe) type byte_order = Lwt_sys.byte_order = Little_endian | Big_endian + let system_byte_order = Lwt_sys.byte_order -include (val (match system_byte_order with - | Little_endian -> (module LE : NumberIO) - | Big_endian -> (module BE : NumberIO)) : NumberIO) +include (val match system_byte_order with + | Little_endian -> (module LE : NumberIO) + | Big_endian -> (module BE : NumberIO) : NumberIO) (* +-----------------------------------------------------------------+ | Other | +-----------------------------------------------------------------+ *) let read_chars ic = Lwt_stream.from (fun _ -> read_char_opt ic) + let write_chars oc chars = Lwt_stream.iter_s (fun char -> write_char oc char) chars + let read_lines ic = Lwt_stream.from (fun _ -> read_line_opt ic) + let write_lines oc lines = Lwt_stream.iter_s (fun line -> write_line oc line) lines let zero = - make - ~mode:input - ~buffer:(Lwt_bytes.create min_buffer_size) - (fun str ofs len -> Lwt_bytes.fill str ofs len '\x00'; Lwt.return len) + make ~mode:input ~buffer:(Lwt_bytes.create min_buffer_size) + (fun str ofs len -> + Lwt_bytes.fill str ofs len '\x00'; + Lwt.return len) let null = - make - ~mode:output - ~buffer:(Lwt_bytes.create min_buffer_size) + make ~mode:output ~buffer:(Lwt_bytes.create min_buffer_size) (fun _str _ofs len -> Lwt.return len) (* Do not close standard ios on close, otherwise uncaught exceptions @@ -1351,17 +1171,14 @@ let null = let stdin = of_fd ~mode:input Lwt_unix.stdin let stdout = of_fd ~mode:output Lwt_unix.stdout let stderr = of_fd ~mode:output Lwt_unix.stderr - let fprint oc txt = write oc txt let fprintl oc txt = write_line oc txt let fprintf oc fmt = Printf.ksprintf (fun txt -> write oc txt) fmt let fprintlf oc fmt = Printf.ksprintf (fun txt -> write_line oc txt) fmt - let print txt = write stdout txt let printl txt = write_line stdout txt let printf fmt = Printf.ksprintf print fmt let printlf fmt = Printf.ksprintf printl fmt - let eprint txt = write stderr txt let eprintl txt = write_line stderr txt let eprintf fmt = Printf.ksprintf eprint fmt @@ -1369,43 +1186,38 @@ let eprintlf fmt = Printf.ksprintf eprintl fmt let pipe ?in_buffer ?out_buffer _ = let fd_r, fd_w = Lwt_unix.pipe () in - (of_fd ?buffer:in_buffer ~mode:input fd_r, - of_fd ?buffer:out_buffer ~mode:output fd_w) + ( of_fd ?buffer:in_buffer ~mode:input fd_r, + of_fd ?buffer:out_buffer ~mode:output fd_w ) type file_name = string let open_file : type m. - ?buffer : Lwt_bytes.t -> - ?flags : Unix.open_flag list -> - ?perm : Unix.file_perm -> - mode : m mode -> + ?buffer:Lwt_bytes.t -> + ?flags:Unix.open_flag list -> + ?perm:Unix.file_perm -> + mode:m mode -> file_name -> - m channel Lwt.t = - fun ?buffer ?flags ?perm ~mode filename -> - let flags = match flags, mode with - | Some l, _ -> - l - | None, Input -> - [Unix.O_RDONLY; Unix.O_NONBLOCK] - | None, Output -> - [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_NONBLOCK] - and perm = match perm, mode with - | Some p, _ -> - p - | None, Input -> - 0 + m channel Lwt.t = + fun ?buffer ?flags ?perm ~mode filename -> + let flags = + match (flags, mode) with + | Some l, _ -> l + | None, Input -> [ Unix.O_RDONLY; Unix.O_NONBLOCK ] | None, Output -> - 0o666 + [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_NONBLOCK ] + and perm = + match (perm, mode) with + | Some p, _ -> p + | None, Input -> 0 + | None, Output -> 0o666 in Lwt_unix.openfile filename flags perm >>= fun fd -> Lwt.return (of_fd ?buffer ~mode fd) let with_file ?buffer ?flags ?perm ~mode filename f = open_file ?buffer ?flags ?perm ~mode filename >>= fun ic -> - Lwt.finalize - (fun () -> f ic) - (fun () -> close ic) + Lwt.finalize (fun () -> f ic) (fun () -> close ic) let prng = lazy (Random.State.make_self_init ()) @@ -1416,7 +1228,7 @@ let temp_file_name temp_dir prefix suffix = let open_temp_file ?buffer ?flags ?perm ?temp_dir ?prefix ?(suffix = "") () = let flags = match flags with - | None -> [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_EXCL; Unix.O_CLOEXEC] + | None -> [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_EXCL; Unix.O_CLOEXEC ] | Some flags -> flags in let dir = @@ -1425,9 +1237,7 @@ let open_temp_file ?buffer ?flags ?perm ?temp_dir ?prefix ?(suffix = "") () = | Some dirname -> dirname in let prefix = - match prefix with - | None -> "lwt_io_temp_file_" - | Some prefix -> prefix + match prefix with None -> "lwt_io_temp_file_" | Some prefix -> prefix in let rec attempt n = @@ -1443,30 +1253,21 @@ let open_temp_file ?buffer ?flags ?perm ?temp_dir ?prefix ?(suffix = "") () = attempt 0 let with_temp_file ?buffer ?flags ?perm ?temp_dir ?prefix ?suffix f = - open_temp_file - ?buffer ?flags ?perm ?temp_dir ?prefix ?suffix () >>= fun (fname, chan) -> + open_temp_file ?buffer ?flags ?perm ?temp_dir ?prefix ?suffix () + >>= fun (fname, chan) -> Lwt.finalize - (fun () -> - f (fname, chan)) - (fun () -> - close chan >>= fun () -> - Lwt_unix.unlink fname) - -let create_temp_dir - ?(perm = 0o755) - ?(parent = Filename.get_temp_dir_name ()) - ?(prefix = "lwt_io_temp_dir_") - ?(suffix = "") - () = + (fun () -> f (fname, chan)) + (fun () -> close chan >>= fun () -> Lwt_unix.unlink fname) + +let create_temp_dir ?(perm = 0o755) ?(parent = Filename.get_temp_dir_name ()) + ?(prefix = "lwt_io_temp_dir_") ?(suffix = "") () = let rec attempt n = let name = temp_file_name parent prefix suffix in Lwt.catch - (fun () -> - Lwt_unix.mkdir name perm >>= fun () -> - Lwt.return name) + (fun () -> Lwt_unix.mkdir name perm >>= fun () -> Lwt.return name) (function - | Unix.Unix_error (Unix.EEXIST, _, _) when n < 1000 -> attempt (n + 1) - | exn -> Lwt.fail exn) + | Unix.Unix_error (Unix.EEXIST, _, _) when n < 1000 -> attempt (n + 1) + | exn -> Lwt.fail exn) in attempt 0 @@ -1474,111 +1275,97 @@ let win32_unlink fn = Lwt.catch (fun () -> Lwt_unix.unlink fn) (function - | Unix.Unix_error (Unix.EACCES, _, _) as exn -> - (* Try removing the read-only attribute before retrying unlink. We catch - any exception here and ignore it in favour of the original [exn]. *) - Lwt.catch - (fun () -> - Lwt_unix.lstat fn >>= fun {st_perm; _} -> - Lwt_unix.chmod fn 0o666 >>= fun () -> - Lwt.catch - (fun () -> Lwt_unix.unlink fn) - (function _ -> - (* If everything succeeded but the final removal still failed, - restore original permissions *) - Lwt_unix.chmod fn st_perm >>= fun () -> - Lwt.fail exn) - ) - (fun _ -> Lwt.fail exn) - | exn -> Lwt.fail exn) - -let unlink = - if Sys.win32 then - win32_unlink - else - Lwt_unix.unlink + | Unix.Unix_error (Unix.EACCES, _, _) as exn -> + (* Try removing the read-only attribute before retrying unlink. We catch + any exception here and ignore it in favour of the original [exn]. *) + Lwt.catch + (fun () -> + Lwt_unix.lstat fn >>= fun { st_perm; _ } -> + Lwt_unix.chmod fn 0o666 >>= fun () -> + Lwt.catch + (fun () -> Lwt_unix.unlink fn) + (function + | _ -> + (* If everything succeeded but the final removal still failed, + restore original permissions *) + Lwt_unix.chmod fn st_perm >>= fun () -> Lwt.fail exn)) + (fun _ -> Lwt.fail exn) + | exn -> Lwt.fail exn) + +let unlink = if Sys.win32 then win32_unlink else Lwt_unix.unlink (* This is likely VERY slow for directories with many files. That is probably best addressed by switching to blocking calls run inside a worker thread, i.e. with Lwt_preemptive. *) let rec delete_recursively directory = Lwt_unix.files_of_directory directory - |> Lwt_stream.iter_s begin fun entry -> - if entry = Filename.current_dir_name || - entry = Filename.parent_dir_name then - Lwt.return () - else - let path = Filename.concat directory entry in - Lwt_unix.lstat path >>= fun {Lwt_unix.st_kind; _} -> - match st_kind with - | S_DIR -> delete_recursively path - | S_LNK when (Sys.win32 || Sys.cygwin) -> - Lwt_unix.stat path >>= fun {Lwt_unix.st_kind; _} -> - begin match st_kind with - | S_DIR -> Lwt_unix.rmdir path - | _ -> unlink path - end - | _ -> unlink path - end >>= fun () -> - Lwt_unix.rmdir directory + |> Lwt_stream.iter_s (fun entry -> + if + entry = Filename.current_dir_name || entry = Filename.parent_dir_name + then Lwt.return () + else + let path = Filename.concat directory entry in + Lwt_unix.lstat path >>= fun { Lwt_unix.st_kind; _ } -> + match st_kind with + | S_DIR -> delete_recursively path + | S_LNK when Sys.win32 || Sys.cygwin -> ( + Lwt_unix.stat path >>= fun { Lwt_unix.st_kind; _ } -> + match st_kind with + | S_DIR -> Lwt_unix.rmdir path + | _ -> unlink path) + | _ -> unlink path) + >>= fun () -> Lwt_unix.rmdir directory let with_temp_dir ?perm ?parent ?prefix ?suffix f = create_temp_dir ?perm ?parent ?prefix ?suffix () >>= fun name -> - Lwt.finalize - (fun () -> - f name) - (fun () -> - delete_recursively name) + Lwt.finalize (fun () -> f name) (fun () -> delete_recursively name) let file_length filename = Lwt_unix.stat filename >>= fun stat -> if stat.Unix.st_kind = Unix.S_DIR then - Lwt.fail (Unix.(Unix_error (EISDIR, "file_length", filename))) - else - with_file ~mode:input filename length + Lwt.fail Unix.(Unix_error (EISDIR, "file_length", filename)) + else with_file ~mode:input filename length let close_socket fd = Lwt.finalize (fun () -> - Lwt.catch + (Lwt.catch (fun () -> - Lwt_unix.shutdown fd Unix.SHUTDOWN_ALL; - Lwt.return_unit) + Lwt_unix.shutdown fd Unix.SHUTDOWN_ALL; + Lwt.return_unit) (function (* Occurs if the peer closes the connection first. *) | Unix.Unix_error (Unix.ENOTCONN, _, _) -> Lwt.return_unit - | exn -> Lwt.fail exn) [@ocaml.warning "-4"]) - (fun () -> - Lwt_unix.close fd) + | exn -> Lwt.fail exn) [@ocaml.warning "-4"])) + (fun () -> Lwt_unix.close fd) let open_connection ?fd ?in_buffer ?out_buffer sockaddr = let fd = match fd with | None -> - Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 - | Some fd -> - fd + Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 + | Some fd -> fd in let close = lazy (close_socket fd) in Lwt.catch (fun () -> - Lwt_unix.connect fd sockaddr >>= fun () -> - (try Lwt_unix.set_close_on_exec fd with Invalid_argument _ -> ()); - Lwt.return (make ?buffer:in_buffer - ~close:(fun _ -> Lazy.force close) - ~mode:input (Lwt_bytes.read fd), - make ?buffer:out_buffer - ~close:(fun _ -> Lazy.force close) - ~mode:output (Lwt_bytes.write fd))) - (fun exn -> - Lwt_unix.close fd >>= fun () -> - Lwt.fail exn) + Lwt_unix.connect fd sockaddr >>= fun () -> + (try Lwt_unix.set_close_on_exec fd with Invalid_argument _ -> ()); + Lwt.return + ( make ?buffer:in_buffer + ~close:(fun _ -> Lazy.force close) + ~mode:input (Lwt_bytes.read fd), + make ?buffer:out_buffer + ~close:(fun _ -> Lazy.force close) + ~mode:output (Lwt_bytes.write fd) )) + (fun exn -> Lwt_unix.close fd >>= fun () -> Lwt.fail exn) let with_close_connection f (ic, oc) = (* If the user already tried to close the socket and got an exception, we don't want to raise that exception again during implicit close. *) let close_if_not_closed channel = - if is_closed channel then Lwt.return_unit else close channel in + if is_closed channel then Lwt.return_unit else close channel + in Lwt.finalize (fun () -> f (ic, oc)) @@ -1588,9 +1375,7 @@ let with_connection ?fd ?in_buffer ?out_buffer sockaddr f = open_connection ?fd ?in_buffer ?out_buffer sockaddr >>= fun channels -> with_close_connection f channels -type server = { - shutdown : unit Lwt.t Lazy.t; -} +type server = { shutdown : unit Lwt.t Lazy.t } let shutdown_server server = Lazy.force server.shutdown @@ -1600,79 +1385,66 @@ let shutdown_server_deprecated server = (* There are several variants of establish_server that have accumulated over the years in Lwt_io. This is their underlying implementation. The functions exposed in the API are various wrappers around this one. *) -let establish_server_generic - bind_function - ?fd:preexisting_socket_for_listening - ?(backlog = Lwt_unix.somaxconn () [@ocaml.warning "-3"]) - listening_address +let establish_server_generic bind_function ?fd:preexisting_socket_for_listening + ?(backlog = (Lwt_unix.somaxconn () [@ocaml.warning "-3"])) listening_address connection_handler_callback = - let listening_socket = match preexisting_socket_for_listening with | None -> - Lwt_unix.socket - (Unix.domain_of_sockaddr listening_address) Unix.SOCK_STREAM 0 - | Some socket -> - socket + Lwt_unix.socket + (Unix.domain_of_sockaddr listening_address) + Unix.SOCK_STREAM 0 + | Some socket -> socket in Lwt_unix.setsockopt listening_socket Unix.SO_REUSEADDR true; (* This promise gets resolved with `Should_stop when the user calls Lwt_io.shutdown_server. This begins the shutdown procedure. *) - let should_stop, notify_should_stop = - Lwt.wait () in + let should_stop, notify_should_stop = Lwt.wait () in (* Some time after Lwt_io.shutdown_server is called, this function establish_server_generic will actually close the listening socket. At that point, this promise is resolved. This ends the shutdown procedure. *) let wait_until_listening_socket_closed, notify_listening_socket_closed = - Lwt.wait () in + Lwt.wait () + in let rec accept_loop () = let try_to_accept = Lwt.catch - (fun () -> - Lwt_unix.accept listening_socket >|= fun x -> - `Accepted x) + (fun () -> Lwt_unix.accept listening_socket >|= fun x -> `Accepted x) (function - | Unix.Unix_error (Unix.ECONNABORTED, _, _) -> - Lwt.return `Try_again + | Unix.Unix_error (Unix.ECONNABORTED, _, _) -> Lwt.return `Try_again | e -> Lwt.fail e) in - Lwt.pick [try_to_accept; should_stop] >>= function + Lwt.pick [ try_to_accept; should_stop ] >>= function | `Accepted (client_socket, client_address) -> - begin - try Lwt_unix.set_close_on_exec client_socket - with Invalid_argument _ -> () - end; - - connection_handler_callback client_address client_socket; + (try Lwt_unix.set_close_on_exec client_socket + with Invalid_argument _ -> ()); - accept_loop () + connection_handler_callback client_address client_socket; + accept_loop () | `Should_stop -> - Lwt_unix.close listening_socket >>= fun () -> + Lwt_unix.close listening_socket >>= fun () -> + (match[@ocaml.warning "-4"] listening_address with + | Unix.ADDR_UNIX path when path <> "" && path.[0] <> '\x00' -> + Unix.unlink path + | _ -> ()); - begin match listening_address with - | Unix.ADDR_UNIX path when path <> "" && path.[0] <> '\x00' -> - Unix.unlink path - | _ -> - () - end [@ocaml.warning "-4"]; - - Lwt.wakeup_later notify_listening_socket_closed (); - Lwt.return_unit - | `Try_again -> - accept_loop () + Lwt.wakeup_later notify_listening_socket_closed (); + Lwt.return_unit + | `Try_again -> accept_loop () in let server = - {shutdown = - lazy begin - Lwt.wakeup_later notify_should_stop `Should_stop; - wait_until_listening_socket_closed - end} + { + shutdown = + lazy + (Lwt.wakeup_later notify_should_stop `Should_stop; + wait_until_listening_socket_closed); + } in (* Actually start the server. *) @@ -1685,51 +1457,41 @@ let establish_server_generic Lwt.return_unit in - server, server_has_started + (server, server_has_started) -let establish_server_with_client_socket - ?server_fd ?backlog ?(no_close = false) sockaddr f = +let establish_server_with_client_socket ?server_fd ?backlog ?(no_close = false) + sockaddr f = let handler client_address client_socket = - Lwt.async begin fun () -> - (* Not using Lwt.finalize here, to make sure that exceptions from [f] - reach !Lwt.async_exception_hook before exceptions from closing the - channels. *) - Lwt.catch - (fun () -> f client_address client_socket) - (fun exn -> - !Lwt.async_exception_hook exn; - Lwt.return_unit) - - >>= fun () -> - if no_close then Lwt.return_unit - else - if Lwt_unix.state client_socket = Lwt_unix.Closed then + Lwt.async (fun () -> + (* Not using Lwt.finalize here, to make sure that exceptions from [f] + reach !Lwt.async_exception_hook before exceptions from closing the + channels. *) + Lwt.catch + (fun () -> f client_address client_socket) + (fun exn -> + !Lwt.async_exception_hook exn; + Lwt.return_unit) + >>= fun () -> + if no_close then Lwt.return_unit + else if Lwt_unix.state client_socket = Lwt_unix.Closed then Lwt.return_unit else Lwt.catch (fun () -> close_socket client_socket) (fun exn -> !Lwt.async_exception_hook exn; - Lwt.return_unit) - end + Lwt.return_unit)) in let server, server_started = - establish_server_generic - Lwt_unix.bind ?fd:server_fd ?backlog sockaddr handler + establish_server_generic Lwt_unix.bind ?fd:server_fd ?backlog sockaddr + handler in - server_started >>= fun () -> - Lwt.return server - -let establish_server_with_client_address_generic - bind_function - ?fd - ?(buffer_size = !default_buffer_size) - ?backlog - ?(no_close = false) - sockaddr - handler = + server_started >>= fun () -> Lwt.return server +let establish_server_with_client_address_generic bind_function ?fd + ?(buffer_size = !default_buffer_size) ?backlog ?(no_close = false) sockaddr + handler = let best_effort_close channel = (* First, check whether the channel is closed. f may have already tried to close the channel, received an exception, and handled it somehow. If so, @@ -1737,8 +1499,7 @@ let establish_server_with_client_address_generic will go to !Lwt.async_exception_hook, despite the user's efforts. *) (* The Invalid state is not possible on the channel, because it was not created using Lwt_io.atomic. *) - if is_closed channel then - Lwt.return_unit + if is_closed channel then Lwt.return_unit else Lwt.catch (fun () -> close channel) @@ -1749,61 +1510,58 @@ let establish_server_with_client_address_generic let handler client_address client_socket = Lwt.async (fun () -> - let close = lazy (close_socket client_socket) in - let input_channel = - of_fd - ~buffer:(Lwt_bytes.create buffer_size) - ~mode:input - ~close:(fun () -> Lazy.force close) - client_socket - in - let output_channel = - of_fd - ~buffer:(Lwt_bytes.create buffer_size) - ~mode:output - ~close:(fun () -> Lazy.force close) - client_socket - in - - (* Not using Lwt.finalize here, to make sure that exceptions from [f] - reach !Lwt.async_exception_hook before exceptions from closing the - channels. *) - Lwt.catch - (fun () -> - handler client_address (input_channel, output_channel)) - (fun exn -> - !Lwt.async_exception_hook exn; - Lwt.return_unit) + let close = lazy (close_socket client_socket) in + let input_channel = + of_fd + ~buffer:(Lwt_bytes.create buffer_size) + ~mode:input + ~close:(fun () -> Lazy.force close) + client_socket + in + let output_channel = + of_fd + ~buffer:(Lwt_bytes.create buffer_size) + ~mode:output + ~close:(fun () -> Lazy.force close) + client_socket + in - >>= fun () -> - if no_close then Lwt.return_unit - else - best_effort_close input_channel >>= fun () -> - best_effort_close output_channel) + (* Not using Lwt.finalize here, to make sure that exceptions from [f] + reach !Lwt.async_exception_hook before exceptions from closing the + channels. *) + Lwt.catch + (fun () -> handler client_address (input_channel, output_channel)) + (fun exn -> + !Lwt.async_exception_hook exn; + Lwt.return_unit) + >>= fun () -> + if no_close then Lwt.return_unit + else + best_effort_close input_channel >>= fun () -> + best_effort_close output_channel) in establish_server_generic bind_function ?fd ?backlog sockaddr handler -let establish_server_with_client_address - ?fd ?buffer_size ?backlog ?no_close sockaddr handler = +let establish_server_with_client_address ?fd ?buffer_size ?backlog ?no_close + sockaddr handler = let server, server_started = - establish_server_with_client_address_generic - Lwt_unix.bind ?fd ?buffer_size ?backlog ?no_close sockaddr handler + establish_server_with_client_address_generic Lwt_unix.bind ?fd ?buffer_size + ?backlog ?no_close sockaddr handler in - server_started >>= fun () -> - Lwt.return server + server_started >>= fun () -> Lwt.return server let establish_server ?fd ?buffer_size ?backlog ?no_close sockaddr f = let f _addr c = f c in - establish_server_with_client_address - ?fd ?buffer_size ?backlog ?no_close sockaddr f + establish_server_with_client_address ?fd ?buffer_size ?backlog ?no_close + sockaddr f (* Old, deprecated version of [establish_server]. This function has to persist for a while, in some form, until it is no longer exposed as [Lwt_io.Versioned.establish_server_1]. *) let establish_server_deprecated ?fd ?buffer_size ?backlog sockaddr f = let blocking_bind fd addr = - Lwt.return (Lwt_unix.Versioned.bind_1 fd addr) [@ocaml.warning "-3"] + (Lwt.return (Lwt_unix.Versioned.bind_1 fd addr) [@ocaml.warning "-3"]) in let f _addr c = f c; @@ -1811,8 +1569,8 @@ let establish_server_deprecated ?fd ?buffer_size ?backlog sockaddr f = in let server, server_started = - establish_server_with_client_address_generic - blocking_bind ?fd ?buffer_size ?backlog ~no_close:true sockaddr f + establish_server_with_client_address_generic blocking_bind ?fd ?buffer_size + ?backlog ~no_close:true sockaddr f in (* Poll for exceptions in server startup that may have occurred synchronously. @@ -1820,32 +1578,28 @@ let establish_server_deprecated ?fd ?buffer_size ?backlog sockaddr f = Lwt.ignore_result server_started; server -let ignore_close ch = - ignore (close ch) +let ignore_close ch = ignore (close ch) let make_stream f lazy_ic = let lazy_ic = - lazy(Lazy.force lazy_ic >>= fun ic -> - Gc.finalise ignore_close ic; - Lwt.return ic) + lazy + ( Lazy.force lazy_ic >>= fun ic -> + Gc.finalise ignore_close ic; + Lwt.return ic ) in Lwt_stream.from (fun _ -> - Lazy.force lazy_ic >>= fun ic -> - f ic >>= fun x -> - if x = None then - close ic >>= fun () -> - Lwt.return x - else - Lwt.return x) + Lazy.force lazy_ic >>= fun ic -> + f ic >>= fun x -> + if x = None then close ic >>= fun () -> Lwt.return x else Lwt.return x) let lines_of_file filename = - make_stream read_line_opt (lazy(open_file ~mode:input filename)) + make_stream read_line_opt (lazy (open_file ~mode:input filename)) let lines_to_file filename lines = with_file ~mode:output filename (fun oc -> write_lines oc lines) let chars_of_file filename = - make_stream read_char_opt (lazy(open_file ~mode:input filename)) + make_stream read_char_opt (lazy (open_file ~mode:input filename)) let chars_to_file filename chars = with_file ~mode:output filename (fun oc -> write_chars oc chars) @@ -1856,13 +1610,12 @@ let hexdump oc buf = hexdump_stream oc (Lwt_stream.of_string buf) let set_default_buffer_size size = check_buffer_size "set_default_buffer_size" size; default_buffer_size := size + let default_buffer_size _ = !default_buffer_size -module Versioned = -struct +module Versioned = struct let establish_server_1 = establish_server_deprecated let establish_server_2 = establish_server - let shutdown_server_1 = shutdown_server_deprecated let shutdown_server_2 = shutdown_server end diff --git a/src/unix/lwt_io.mli b/src/unix/lwt_io.mli index 030b6482c6..bd7f42acb9 100644 --- a/src/unix/lwt_io.mli +++ b/src/unix/lwt_io.mli @@ -1,170 +1,166 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Buffered byte channels *) -(** A {b channel} is a high-level object for performing input/output - (IO). It allows to read/write from/to the outside world in an - efficient way, by minimising the number of system calls. +(** A {b channel} is a high-level object for performing input/output (IO). It + allows to read/write from/to the outside world in an efficient way, by + minimising the number of system calls. - An {b output channel} is used to send data and an {b input - channel} is used to receive data. + An {b output channel} is used to send data and an {b input channel} is used + to receive data. - If you are familiar with buffered channels you may be familiar too - with the {b flush} operation. Note that byte channels of this - module are automatically flushed when there is nothing else to do - (i.e. before the program becomes idle), so this means that you no - longer have to write: + If you are familiar with buffered channels you may be familiar too with the + {b flush} operation. Note that byte channels of this module are + automatically flushed when there is nothing else to do (i.e. before the + program becomes idle), so this means that you no longer have to write: {[ eprintf "log message\n"; - flush stderr; + flush stderr ]} to have your messages displayed. - Note about errors: input functions of this module raise - [End_of_file] when the end-of-file is reached (i.e. when the read - function returns [0]). Other exceptions are ones caused by the - backend read/write functions, such as [Unix.Unix_error]. -*) + Note about errors: input functions of this module raise [End_of_file] when + the end-of-file is reached (i.e. when the read function returns [0]). Other + exceptions are ones caused by the backend read/write functions, such as + [Unix.Unix_error]. *) exception Channel_closed of string - (** Exception raised when a channel is closed. The parameter is a - description of the channel. *) +(** Exception raised when a channel is closed. The parameter is a description of + the channel. *) (** {2 Types} *) type 'mode channel - (** Type of buffered byte channels *) +(** Type of buffered byte channels *) type input - (** Input mode *) +(** Input mode *) type output - (** Output mode *) +(** Output mode *) (** Channel mode *) -type 'a mode = - | Input : input mode - | Output : output mode +type 'a mode = Input : input mode | Output : output mode val input : input mode - (** [input] input mode representation *) +(** [input] input mode representation *) val output : output mode - (** [output] output mode representation *) +(** [output] output mode representation *) type input_channel = input channel - (** Type of input channels *) +(** Type of input channels *) type output_channel = output channel - (** Type of output channels *) +(** Type of output channels *) val mode : 'a channel -> 'a mode - (** [mode ch] returns the mode of a channel *) +(** [mode ch] returns the mode of a channel *) (** {2 Well-known instances} *) val stdin : input_channel - (** The standard input, it reads data from {!Lwt_unix.stdin} *) +(** The standard input, it reads data from {!Lwt_unix.stdin} *) val stdout : output_channel - (** The standard output, it writes data to {!Lwt_unix.stdout} *) +(** The standard output, it writes data to {!Lwt_unix.stdout} *) val stderr : output_channel - (** The standard output for error messages, it writes data to - {!Lwt_unix.stderr} *) +(** The standard output for error messages, it writes data to {!Lwt_unix.stderr} *) val zero : input_channel - (** Inputs which returns always ['\x00'] *) +(** Inputs which returns always ['\x00'] *) val null : output_channel - (** Output which drops everything *) +(** Output which drops everything *) (** {2 Channels creation/manipulation} *) -val pipe : ?in_buffer : Lwt_bytes.t -> ?out_buffer : Lwt_bytes.t -> unit -> +val pipe : + ?in_buffer:Lwt_bytes.t -> + ?out_buffer:Lwt_bytes.t -> + unit -> input_channel * output_channel - (** [pipe ?in_buffer ?out_buffer ()] creates a pipe using - {!Lwt_unix.pipe} and makes two channels from the two returned file - descriptors *) +(** [pipe ?in_buffer ?out_buffer ()] creates a pipe using {!Lwt_unix.pipe} and + makes two channels from the two returned file descriptors *) val make : - ?buffer : Lwt_bytes.t -> - ?close : (unit -> unit Lwt.t) -> - ?seek : (int64 -> Unix.seek_command -> int64 Lwt.t) -> - mode : 'mode mode -> - (Lwt_bytes.t -> int -> int -> int Lwt.t) -> 'mode channel - (** [make ?buffer ?close ~mode perform_io] is the - main function for creating new channels. - - @param buffer user-supplied buffer. When this argument is - present, its value will be used as the buffer for the created - channel. The size of buffer must conform to the limitations - described in {!set_default_buffer_size}. When this argument is - not present, a new internal buffer of default size will be - allocated for this channel. - - Warning: do not use the same buffer for simultaneous work with more - than one channel. - - There are other functions in this module that take a [buffer] - argument, sharing the same semantics. - - @param close close function of the channel. It defaults to - [Lwt.return] - - @param seek same meaning as [Unix.lseek] - - @param mode either {!input} or {!output} - - @param perform_io is the read or write function. It is called - when more input is needed or when the buffer need to be - flushed. *) - -val of_bytes : mode : 'mode mode -> Lwt_bytes.t -> 'mode channel - (** Create a channel from a byte array. Reading/writing is done - directly on the provided array. *) - -val of_fd : ?buffer : Lwt_bytes.t -> ?close : (unit -> unit Lwt.t) -> - mode : 'mode mode -> Lwt_unix.file_descr -> 'mode channel - (** [of_fd ?buffer ?close ~mode fd] creates a channel from a - file descriptor. + ?buffer:Lwt_bytes.t -> + ?close:(unit -> unit Lwt.t) -> + ?seek:(int64 -> Unix.seek_command -> int64 Lwt.t) -> + mode:'mode mode -> + (Lwt_bytes.t -> int -> int -> int Lwt.t) -> + 'mode channel +(** [make ?buffer ?close ~mode perform_io] is the main function for creating new + channels. + + @param buffer + user-supplied buffer. When this argument is present, its value will be + used as the buffer for the created channel. The size of buffer must + conform to the limitations described in {!set_default_buffer_size}. When + this argument is not present, a new internal buffer of default size will + be allocated for this channel. + + Warning: do not use the same buffer for simultaneous work with more than + one channel. + + There are other functions in this module that take a [buffer] argument, + sharing the same semantics. + @param close close function of the channel. It defaults to [Lwt.return] + @param seek same meaning as [Unix.lseek] + @param mode either {!input} or {!output} + @param perform_io + is the read or write function. It is called when more input is needed or + when the buffer need to be flushed. *) + +val of_bytes : mode:'mode mode -> Lwt_bytes.t -> 'mode channel +(** Create a channel from a byte array. Reading/writing is done directly on the + provided array. *) + +val of_fd : + ?buffer:Lwt_bytes.t -> + ?close:(unit -> unit Lwt.t) -> + mode:'mode mode -> + Lwt_unix.file_descr -> + 'mode channel +(** [of_fd ?buffer ?close ~mode fd] creates a channel from a file descriptor. - @param close defaults to closing the file descriptor. *) + @param close defaults to closing the file descriptor. *) -val of_unix_fd : ?buffer : Lwt_bytes.t -> ?close : (unit -> unit Lwt.t) -> - mode : 'mode mode -> Unix.file_descr -> 'mode channel - (** [of_unix_fd ?buffer ?close ~mode fd] is a short-hand for: +val of_unix_fd : + ?buffer:Lwt_bytes.t -> + ?close:(unit -> unit Lwt.t) -> + mode:'mode mode -> + Unix.file_descr -> + 'mode channel +(** [of_unix_fd ?buffer ?close ~mode fd] is a short-hand for: - [of_fd ?buffer ?close (Lwt_unix.of_unix_file_descr fd)] *) + [of_fd ?buffer ?close (Lwt_unix.of_unix_file_descr fd)] *) val close : 'a channel -> unit Lwt.t - (** [close ch] closes the given channel. If [ch] is an output - channel, it performs all pending actions, flushes it and closes - it. If [ch] is an input channel, it just closes it immediately. +(** [close ch] closes the given channel. If [ch] is an output channel, it + performs all pending actions, flushes it and closes it. If [ch] is an input + channel, it just closes it immediately. - [close] returns the result of the close function of the - channel. Multiple calls to [close] will return exactly the same - value. + [close] returns the result of the close function of the channel. Multiple + calls to [close] will return exactly the same value. - Note: you cannot use [close] on channels obtained with - {!atomic}. *) + Note: you cannot use [close] on channels obtained with {!atomic}. *) val abort : 'a channel -> unit Lwt.t - (** [abort ch] abort current operations and close the channel - immediately. *) +(** [abort ch] abort current operations and close the channel immediately. *) -val atomic : ('a channel -> 'b Lwt.t) -> ('a channel -> 'b Lwt.t) - (** [atomic f] transforms a sequence of io operations into one - single atomic io operation. +val atomic : ('a channel -> 'b Lwt.t) -> 'a channel -> 'b Lwt.t +(** [atomic f] transforms a sequence of io operations into one single atomic io + operation. - Note: - - the channel passed to [f] is invalid after [f] terminates - - [atomic] can be called inside another [atomic] *) + Note: + + - the channel passed to [f] is invalid after [f] terminates + - [atomic] can be called inside another [atomic] *) val file_length : string -> int64 Lwt.t (** Retrieves the length of the file at the given path. If the path refers to a @@ -172,42 +168,41 @@ val file_length : string -> int64 Lwt.t [Unix.(Unix_error (EISDIR, _, _))]. *) val buffered : 'a channel -> int - (** [buffered oc] returns the number of bytes in the buffer *) +(** [buffered oc] returns the number of bytes in the buffer *) val flush : output_channel -> unit Lwt.t - (** [flush oc] performs all pending writes on [oc] *) +(** [flush oc] performs all pending writes on [oc] *) val flush_all : unit -> unit Lwt.t - (** [flush_all ()] flushes all open output channels *) +(** [flush_all ()] flushes all open output channels *) val buffer_size : 'a channel -> int - (** Returns the size of the internal buffer. *) +(** Returns the size of the internal buffer. *) val resize_buffer : 'a channel -> int -> unit Lwt.t - (** Resize the internal buffer to the given size *) +(** Resize the internal buffer to the given size *) val is_busy : 'a channel -> bool - (** [is_busy channel] returns whether the given channel is currently - busy. A channel is busy when there is at least one job using it - that has not yet terminated. *) +(** [is_busy channel] returns whether the given channel is currently busy. A + channel is busy when there is at least one job using it that has not yet + terminated. *) val is_closed : 'a channel -> bool - (** [is_closed channel] returns whether the given channel is currently - closed. +(** [is_closed channel] returns whether the given channel is currently closed. - @since 4.2.0 *) + @since 4.2.0 *) (** {2 Random access} *) val position : 'a channel -> int64 - (** [position ch] Returns the current position in the channel. *) +(** [position ch] Returns the current position in the channel. *) val set_position : 'a channel -> int64 -> unit Lwt.t - (** [set_position ch pos] Sets the position in the output channel. This - does not work if the channel does not support random access. *) +(** [set_position ch pos] Sets the position in the output channel. This does not + work if the channel does not support random access. *) val length : 'a channel -> int64 Lwt.t - (** Returns the length of the channel in bytes *) +(** Returns the length of the channel in bytes *) (** {2 Reading} *) @@ -215,36 +210,32 @@ val length : 'a channel -> int64 Lwt.t {!read_lines}) all functions are {b atomic}. *) val read_char : input_channel -> char Lwt.t - (** [read_char ic] reads the next character of [ic]. +(** [read_char ic] reads the next character of [ic]. - @raise End_of_file if the end of the file is reached *) + @raise End_of_file if the end of the file is reached *) val read_char_opt : input_channel -> char option Lwt.t - (** Same as {!Lwt_io.read_char}, but does not raise [End_of_file] on end of - input *) +(** Same as {!Lwt_io.read_char}, but does not raise [End_of_file] on end of + input *) val read_chars : input_channel -> char Lwt_stream.t - (** [read_chars ic] returns a stream holding all characters of - [ic] *) +(** [read_chars ic] returns a stream holding all characters of [ic] *) val read_line : input_channel -> string Lwt.t - (** [read_line ic] reads one complete line from [ic] and returns it - without the end of line. End of line is either ["\n"] or - ["\r\n"]. +(** [read_line ic] reads one complete line from [ic] and returns it without the + end of line. End of line is either ["\n"] or ["\r\n"]. - If the end of input is reached before reading any character, - [End_of_file] is raised. If it is reached before reading an end - of line but characters have already been read, they are - returned. *) + If the end of input is reached before reading any character, [End_of_file] + is raised. If it is reached before reading an end of line but characters + have already been read, they are returned. *) val read_line_opt : input_channel -> string option Lwt.t - (** Same as {!read_line} but do not raise [End_of_file] on end of - input. *) +(** Same as {!read_line} but do not raise [End_of_file] on end of input. *) val read_lines : input_channel -> string Lwt_stream.t - (** [read_lines ic] returns a stream holding all lines of [ic] *) +(** [read_lines ic] returns a stream holding all lines of [ic] *) -val read : ?count : int -> input_channel -> string Lwt.t +val read : ?count:int -> input_channel -> string Lwt.t (** If [~count] is specified, [read ~count ic] reads at most [~count] bytes from [ic] in one read operation. Note that fewer than [~count] bytes can be read. This can happen for multiple reasons, including end of input, or no more @@ -255,111 +246,112 @@ val read : ?count : int -> input_channel -> string Lwt.t input. *) val read_into : input_channel -> bytes -> int -> int -> int Lwt.t - (** [read_into ic buffer offset length] reads up to [length] bytes, - stores them in [buffer] at offset [offset], and returns the - number of bytes read. +(** [read_into ic buffer offset length] reads up to [length] bytes, stores them + in [buffer] at offset [offset], and returns the number of bytes read. - Note: [read_into] does not raise [End_of_file], it returns a - length of [0] instead. *) + Note: [read_into] does not raise [End_of_file], it returns a length of [0] + instead. *) val read_into_exactly : input_channel -> bytes -> int -> int -> unit Lwt.t - (** [read_into_exactly ic buffer offset length] reads exactly - [length] bytes and stores them in [buffer] at offset [offset]. +(** [read_into_exactly ic buffer offset length] reads exactly [length] bytes and + stores them in [buffer] at offset [offset]. - @raise End_of_file on end of input *) + @raise End_of_file on end of input *) -val read_into_bigstring : input_channel -> Lwt_bytes.t -> int -> int -> int Lwt.t +val read_into_bigstring : + input_channel -> Lwt_bytes.t -> int -> int -> int Lwt.t -val read_into_exactly_bigstring : input_channel -> Lwt_bytes.t -> int -> int -> unit Lwt.t +val read_into_exactly_bigstring : + input_channel -> Lwt_bytes.t -> int -> int -> unit Lwt.t val read_value : input_channel -> 'a Lwt.t (** [read_value channel] reads a marshaled value from [channel]; it corresponds to the standard library's - {{:https://ocaml.org/api/Marshal.html#VALfrom_channel} [Marshal.from_channel]}. - The corresponding writing function is {!write_value}. + {{:https://ocaml.org/api/Marshal.html#VALfrom_channel} + [Marshal.from_channel]}. The corresponding writing function is + {!write_value}. Note that reading marshaled values is {e not}, in general, type-safe. See the warning in the description of module - {{:https://ocaml.org/api/Marshal.html} - [Marshal]} for details. The short version is: if you read a value of one - type, such as [string], when a value of another type, such as [int] has - actually been marshaled to [channel], you may get arbitrary behavior, - including segmentation faults, access violations, security bugs, etc. *) + {{:https://ocaml.org/api/Marshal.html} [Marshal]} for details. The short + version is: if you read a value of one type, such as [string], when a value + of another type, such as [int] has actually been marshaled to [channel], you + may get arbitrary behavior, including segmentation faults, access + violations, security bugs, etc. *) (** {2 Writing} *) -(** Note: as for reading functions, all functions except - {!write_chars} and {!write_lines} are {b atomic}. +(** Note: as for reading functions, all functions except {!write_chars} and + {!write_lines} are {b atomic}. - For example if you use {!write_line} in two different threads, the - two operations will be serialized, and lines cannot be mixed. -*) + For example if you use {!write_line} in two different threads, the two + operations will be serialized, and lines cannot be mixed. *) val write_char : output_channel -> char -> unit Lwt.t - (** [write_char oc char] writes [char] on [oc] *) +(** [write_char oc char] writes [char] on [oc] *) val write_chars : output_channel -> char Lwt_stream.t -> unit Lwt.t - (** [write_chars oc chars] writes all characters of [chars] on - [oc] *) +(** [write_chars oc chars] writes all characters of [chars] on [oc] *) val write : output_channel -> string -> unit Lwt.t - (** [write oc str] writes all characters of [str] on [oc] *) +(** [write oc str] writes all characters of [str] on [oc] *) val write_line : output_channel -> string -> unit Lwt.t - (** [write_line oc str] writes [str] on [oc] followed by a - new-line. *) +(** [write_line oc str] writes [str] on [oc] followed by a new-line. *) val write_lines : output_channel -> string Lwt_stream.t -> unit Lwt.t - (** [write_lines oc lines] writes all lines of [lines] to [oc] *) +(** [write_lines oc lines] writes all lines of [lines] to [oc] *) val write_from : output_channel -> bytes -> int -> int -> int Lwt.t - (** [write_from oc buffer offset length] writes up to [length] bytes - to [oc], from [buffer] at offset [offset] and returns the number - of bytes actually written *) +(** [write_from oc buffer offset length] writes up to [length] bytes to [oc], + from [buffer] at offset [offset] and returns the number of bytes actually + written *) -val write_from_bigstring : output_channel -> Lwt_bytes.t -> int -> int -> int Lwt.t +val write_from_bigstring : + output_channel -> Lwt_bytes.t -> int -> int -> int Lwt.t val write_from_string : output_channel -> string -> int -> int -> int Lwt.t - (** See {!write}. *) +(** See {!write}. *) val write_from_exactly : output_channel -> bytes -> int -> int -> unit Lwt.t - (** [write_from_exactly oc buffer offset length] writes all [length] - bytes from [buffer] at offset [offset] to [oc] *) +(** [write_from_exactly oc buffer offset length] writes all [length] bytes from + [buffer] at offset [offset] to [oc] *) -val write_from_exactly_bigstring : output_channel -> Lwt_bytes.t -> int -> int -> unit Lwt.t +val write_from_exactly_bigstring : + output_channel -> Lwt_bytes.t -> int -> int -> unit Lwt.t val write_from_string_exactly : output_channel -> string -> int -> int -> unit Lwt.t - (** See {!write_from_exactly}. *) +(** See {!write_from_exactly}. *) val write_value : - output_channel -> ?flags : Marshal.extern_flags list -> 'a -> unit Lwt.t + output_channel -> ?flags:Marshal.extern_flags list -> 'a -> unit Lwt.t (** [write_value channel ?flags v] writes [v] to [channel] using the [Marshal] module of the standard library. See - {{:https://ocaml.org/api/Marshal.html#VALto_channel} - [Marshal.to_channel]} for an explanation of [?flags]. + {{:https://ocaml.org/api/Marshal.html#VALto_channel} [Marshal.to_channel]} + for an explanation of [?flags]. The corresponding reading function is {!read_value}. See warnings about type safety in the description of {!read_value}. *) (** {2 Printing} *) -(** These functions are basically helpers. Also you may prefer - using the name {!printl} rather than {!write_line} because it is - shorter. +(** These functions are basically helpers. Also you may prefer using the name + {!printl} rather than {!write_line} because it is shorter. The general name of a printing function is [print], where [] is one of: + - ['f'], which means that the function takes as argument a channel - nothing, which means that the function prints on {!stdout} - ['e'], which means that the function prints on {!stderr} and [] is a combination of: + - ['l'] which means that a new-line character is printed after the message - ['f'] which means that the function takes as argument a {b format} instead - of a string -*) + of a string *) val fprint : output_channel -> string -> unit Lwt.t val fprintl : output_channel -> string -> unit Lwt.t @@ -374,37 +366,33 @@ val print : string -> unit Lwt.t val printl : string -> unit Lwt.t val printf : ('a, unit, string, unit Lwt.t) format4 -> 'a -(** [%!] does nothing here. To flush the channel, use - [Lwt_io.(flush stdout)]. *) +(** [%!] does nothing here. To flush the channel, use [Lwt_io.(flush stdout)]. *) val printlf : ('a, unit, string, unit Lwt.t) format4 -> 'a -(** [%!] does nothing here. To flush the channel, use - [Lwt_io.(flush stdout)]. *) +(** [%!] does nothing here. To flush the channel, use [Lwt_io.(flush stdout)]. *) val eprint : string -> unit Lwt.t val eprintl : string -> unit Lwt.t val eprintf : ('a, unit, string, unit Lwt.t) format4 -> 'a -(** [%!] does nothing here. To flush the channel, use - [Lwt_io.(flush stderr)]. *) +(** [%!] does nothing here. To flush the channel, use [Lwt_io.(flush stderr)]. *) val eprintlf : ('a, unit, string, unit Lwt.t) format4 -> 'a -(** [%!] does nothing here. To flush the channel, use - [Lwt_io.(flush stderr)]. *) +(** [%!] does nothing here. To flush the channel, use [Lwt_io.(flush stderr)]. *) (** {2 Utilities} *) val hexdump_stream : output_channel -> char Lwt_stream.t -> unit Lwt.t - (** [hexdump_stream oc byte_stream] produces the same output as the - command [hexdump -C]. *) +(** [hexdump_stream oc byte_stream] produces the same output as the command + [hexdump -C]. *) val hexdump : output_channel -> string -> unit Lwt.t - (** [hexdump oc str = hexdump_stream oc (Lwt_stream.of_string str)] *) +(** [hexdump oc str = hexdump_stream oc (Lwt_stream.of_string str)] *) (** {2 File utilities} *) type file_name = string - (** Type of file names *) +(** Type of file names *) val open_file : ?buffer:Lwt_bytes.t -> @@ -412,7 +400,7 @@ val open_file : ?perm:Unix.file_perm -> mode:'a mode -> file_name -> - 'a channel Lwt.t + 'a channel Lwt.t (** [Lwt_io.open_file ~mode file] opens the given file, either for reading (with [~mode:Input]) or for writing (with [~mode:Output]). The returned channel provides buffered I/O on the file. @@ -420,13 +408,13 @@ val open_file : If [~buffer] is supplied, it is used as the I/O buffer. If [~flags] is supplied, the file is opened with the given flags (see - {{: https://ocaml.org/api/Unix.html#TYPEopen_flag} - [Unix.open_flag]}). Note that [~flags] is used {e exactly} as given. For - example, opening a file with [~flags] and [~mode:Input] does {e not} - implicitly add [O_RDONLY]. So, you should include [O_RDONLY] when opening - for reading ([~mode:Input]), and [O_WRONLY] when opening for writing - ([~mode:Input]). It is also recommended to include [O_NONBLOCK], unless you - are sure that the file cannot be a socket or a named pipe. + {{:https://ocaml.org/api/Unix.html#TYPEopen_flag} [Unix.open_flag]}). Note + that [~flags] is used {e exactly} as given. For example, opening a file with + [~flags] and [~mode:Input] does {e not} implicitly add [O_RDONLY]. So, you + should include [O_RDONLY] when opening for reading ([~mode:Input]), and + [O_WRONLY] when opening for writing ([~mode:Input]). It is also recommended + to include [O_NONBLOCK], unless you are sure that the file cannot be a + socket or a named pipe. The default permissions used for creating new files are [0o666], i.e. reading and writing are allowed for the file owner, group, and everyone. @@ -446,7 +434,7 @@ val with_file : mode:'a mode -> file_name -> ('a channel -> 'b Lwt.t) -> - 'b Lwt.t + 'b Lwt.t (** [Lwt_io.with_file ~mode filename f] opens the given using {!Lwt_io.open_file}, and passes the resulting channel to [f]. [Lwt_io.with_file] ensures that the channel is closed when the promise @@ -463,7 +451,7 @@ val open_temp_file : ?prefix:string -> ?suffix:string -> unit -> - (string * output_channel) Lwt.t + (string * output_channel) Lwt.t (** [open_temp_file ()] starts creating a new temporary file, and evaluates to a promise for the pair of the file's name, and an output channel for writing to the file. @@ -475,16 +463,16 @@ val open_temp_file : to {!Lwt_io.open_file}. If not specified, [?flags] defaults to - [[O_CREATE; O_EXCL; O_WRONLY; O_CLOEXEC]]. If specified, the specified flags - are used exactly. Note that these should typically contain at least + [\[O_CREATE; O_EXCL; O_WRONLY; O_CLOEXEC\]]. If specified, the specified + flags are used exactly. Note that these should typically contain at least [O_CREAT] and [O_EXCL], otherwise [open_temp_file] may open an existing file. [?temp_dir] can be used to choose the directory in which the file is created. For the current directory, use - {{: https://ocaml.org/api/Filename.html#VALcurrent_dir_name} + {{:https://ocaml.org/api/Filename.html#VALcurrent_dir_name} [Filename.current_dir_name]}. If not specified, the directory is taken from - {{: https://ocaml.org/api/Filename.html#VALget_temp_dir_name} + {{:https://ocaml.org/api/Filename.html#VALget_temp_dir_name} [Filename.get_temp_dir_name]}, which is typically set to your system temporary file directory. @@ -506,7 +494,7 @@ val with_temp_file : ?prefix:string -> ?suffix:string -> (string * output_channel -> 'b Lwt.t) -> - 'b Lwt.t + 'b Lwt.t (** [with_temp_file f] calls {!open_temp_file}[ ()], passing all optional arguments directly to it. It then attaches [f] to run after the file is created, passing the filename and output channel to [f]. When the promise @@ -521,7 +509,7 @@ val create_temp_dir : ?prefix:string -> ?suffix:string -> unit -> - string Lwt.t + string Lwt.t (** Creates a temporary directory, and returns a promise that resolves to its path. The caller must take care to remove the directory. Alternatively, see {!Lwt_io.with_temp_dir}. @@ -544,7 +532,7 @@ val with_temp_dir : ?prefix:string -> ?suffix:string -> (string -> 'a Lwt.t) -> - 'a Lwt.t + 'a Lwt.t (** [with_temp_dir f] first calls {!create_temp_dir}, forwarding all optional arguments to it. Once the temporary directory is created at [path], [with_temp_dir f] calls [f path]. When the promise returned by [f path] is @@ -554,44 +542,46 @@ val with_temp_dir : @since 4.4.0 *) val open_connection : - ?fd : Lwt_unix.file_descr -> - ?in_buffer : Lwt_bytes.t -> ?out_buffer : Lwt_bytes.t -> - Unix.sockaddr -> (input_channel * output_channel) Lwt.t - (** [open_connection ?fd ?in_buffer ?out_buffer addr] opens a - connection to the given address and returns two channels for using - it. If [fd] is not specified, a fresh one will be used. + ?fd:Lwt_unix.file_descr -> + ?in_buffer:Lwt_bytes.t -> + ?out_buffer:Lwt_bytes.t -> + Unix.sockaddr -> + (input_channel * output_channel) Lwt.t +(** [open_connection ?fd ?in_buffer ?out_buffer addr] opens a connection to the + given address and returns two channels for using it. If [fd] is not + specified, a fresh one will be used. - The connection is completely closed when you close both - channels. + The connection is completely closed when you close both channels. - @raise Unix.Unix_error on error. - *) + @raise Unix.Unix_error on error. *) val with_connection : - ?fd : Lwt_unix.file_descr -> - ?in_buffer : Lwt_bytes.t -> ?out_buffer : Lwt_bytes.t -> - Unix.sockaddr -> (input_channel * output_channel -> 'a Lwt.t) -> 'a Lwt.t - (** [with_connection ?fd ?in_buffer ?out_buffer addr f] opens a - connection to the given address and passes the channels to - [f] *) + ?fd:Lwt_unix.file_descr -> + ?in_buffer:Lwt_bytes.t -> + ?out_buffer:Lwt_bytes.t -> + Unix.sockaddr -> + (input_channel * output_channel -> 'a Lwt.t) -> + 'a Lwt.t +(** [with_connection ?fd ?in_buffer ?out_buffer addr f] opens a connection to + the given address and passes the channels to [f] *) (**/**) +val with_close_connection : + (input_channel * output_channel -> 'a Lwt.t) -> + input_channel * output_channel -> + 'a Lwt.t (** This function is not public API and can be changed or removed without notice. It is exposed in order to test [with_connection]. [with_close_connection f (ic, oc)] calls [f (ic, oc)] and makes sure that [ic] and [oc] are closed, whether [f] returns or fails with an exception. Does not fail if [ic] or [oc] is already closed. *) -val with_close_connection : - (input_channel * output_channel -> 'a Lwt.t) -> - input_channel * output_channel -> - 'a Lwt.t (**/**) type server - (** Type of a server *) +(** Type of a server *) val establish_server_with_client_socket : ?server_fd:Lwt_unix.file_descr -> @@ -599,15 +589,13 @@ val establish_server_with_client_socket : ?no_close:bool -> Unix.sockaddr -> (Lwt_unix.sockaddr -> Lwt_unix.file_descr -> unit Lwt.t) -> - server Lwt.t + server Lwt.t (** [establish_server_with_client_socket listen_address f] creates a server which listens for incoming connections on [listen_address]. When a client makes a new connection, it is passed to [f]: more precisely, the server calls -{[ -f client_address client_socket -]} + {[ f client_address client_socket ]} where [client_address] is the address (peer name) of the new client, and [client_socket] is the socket connected to the client. @@ -653,7 +641,7 @@ val establish_server_with_client_address : ?no_close:bool -> Unix.sockaddr -> (Lwt_unix.sockaddr -> input_channel * output_channel -> unit Lwt.t) -> - server Lwt.t + server Lwt.t (** Like {!Lwt_io.establish_server_with_client_socket}, but passes two buffered channels to the connection handler [f]. These channels wrap the client socket. @@ -672,128 +660,124 @@ val shutdown_server : server -> unit Lwt.t @since 3.0.0 *) val lines_of_file : file_name -> string Lwt_stream.t - (** [lines_of_file name] returns a stream of all lines of the file - with name [name]. The file is automatically closed when all - lines have been read. *) +(** [lines_of_file name] returns a stream of all lines of the file with name + [name]. The file is automatically closed when all lines have been read. *) val lines_to_file : file_name -> string Lwt_stream.t -> unit Lwt.t - (** [lines_to_file name lines] writes all lines of [lines] to - file with name [name]. *) +(** [lines_to_file name lines] writes all lines of [lines] to file with name + [name]. *) val chars_of_file : file_name -> char Lwt_stream.t - (** [chars_of_file name] returns a stream of all characters of the - file with name [name]. As for {!lines_of_file} the file is - closed when all characters have been read. *) +(** [chars_of_file name] returns a stream of all characters of the file with + name [name]. As for {!lines_of_file} the file is closed when all characters + have been read. *) val chars_to_file : file_name -> char Lwt_stream.t -> unit Lwt.t - (** [chars_to_file name chars] writes all characters of [chars] to - [name] *) +(** [chars_to_file name chars] writes all characters of [chars] to [name] *) (** {2 Input/output of integers} *) (** Common interface for reading/writing integers in binary *) module type NumberIO = sig - (** {3 Reading} *) val read_int : input_channel -> int Lwt.t - (** Reads a 32-bits integer as an ocaml int *) + (** Reads a 32-bits integer as an ocaml int *) val read_int16 : input_channel -> int Lwt.t val read_int32 : input_channel -> int32 Lwt.t val read_int64 : input_channel -> int64 Lwt.t val read_float32 : input_channel -> float Lwt.t - (** Reads an IEEE single precision floating point value *) + (** Reads an IEEE single precision floating point value *) val read_float64 : input_channel -> float Lwt.t - (** Reads an IEEE double precision floating point value *) + (** Reads an IEEE double precision floating point value *) (** {3 Writing} *) val write_int : output_channel -> int -> unit Lwt.t - (** Writes an ocaml int as a 32-bits integer *) + (** Writes an ocaml int as a 32-bits integer *) val write_int16 : output_channel -> int -> unit Lwt.t val write_int32 : output_channel -> int32 -> unit Lwt.t val write_int64 : output_channel -> int64 -> unit Lwt.t val write_float32 : output_channel -> float -> unit Lwt.t - (** Writes an IEEE single precision floating point value *) + (** Writes an IEEE single precision floating point value *) val write_float64 : output_channel -> float -> unit Lwt.t - (** Writes an IEEE double precision floating point value *) + (** Writes an IEEE double precision floating point value *) end module LE : NumberIO - (** Reading/writing of numbers in little-endian *) +(** Reading/writing of numbers in little-endian *) module BE : NumberIO - (** Reading/writing of numbers in big-endian *) +(** Reading/writing of numbers in big-endian *) include NumberIO (** Reading/writing of numbers in the system endianness. *) -type byte_order = Lwt_sys.byte_order = Little_endian | Big_endian - (** Type of byte order *) +type byte_order = Lwt_sys.byte_order = + | Little_endian + | Big_endian (** Type of byte order *) val system_byte_order : byte_order - (** Same as {!Lwt_sys.byte_order}. *) +(** Same as {!Lwt_sys.byte_order}. *) (** {2 Low-level access to the internal buffer} *) -val block : 'a channel -> int -> (Lwt_bytes.t -> int -> 'b Lwt.t) -> 'b Lwt.t - (** [block ch size f] pass to [f] the internal buffer and an - offset. The buffer contains [size] chars at [offset]. [f] may - read or write these chars. [size] must satisfy [0 <= size <= 16] *) +val block : 'a channel -> int -> (Lwt_bytes.t -> int -> 'b Lwt.t) -> 'b Lwt.t +(** [block ch size f] pass to [f] the internal buffer and an offset. The buffer + contains [size] chars at [offset]. [f] may read or write these chars. [size] + must satisfy [0 <= size <= 16] *) -(** Information for directly accessing the internal buffer of a - channel *) type direct_access = { - da_buffer : Lwt_bytes.t; - (** The internal buffer *) + da_buffer : Lwt_bytes.t; (** The internal buffer *) mutable da_ptr : int; - (** The pointer to: - - the beginning of free space for output channels - - the beginning of data for input channels *) - mutable da_max : int; - (** The maximum offset *) + (** The pointer to: + + - the beginning of free space for output channels + - the beginning of data for input channels *) + mutable da_max : int; (** The maximum offset *) da_perform : unit -> int Lwt.t; - (** - for input channels: - refills the buffer and returns how many bytes have been read - - for output channels: - flush partially the buffer and returns how many bytes have been - written *) + (** - for input channels: refills the buffer and returns how many bytes + have been read + - for output channels: flush partially the buffer and returns how many + bytes have been written *) } +(** Information for directly accessing the internal buffer of a channel *) val direct_access : 'a channel -> (direct_access -> 'b Lwt.t) -> 'b Lwt.t - (** [direct_access ch f] passes to [f] a {!direct_access} - structure. [f] must use it and update [da_ptr] to reflect how - many bytes have been read/written. *) +(** [direct_access ch f] passes to [f] a {!direct_access} structure. [f] must + use it and update [da_ptr] to reflect how many bytes have been read/written. *) (** {2 Misc} *) val default_buffer_size : unit -> int - (** Return the default size for buffers. Channels that are created - without a specific buffer use new buffer of this size. *) +(** Return the default size for buffers. Channels that are created without a + specific buffer use new buffer of this size. *) val set_default_buffer_size : int -> unit - (** Change the default buffer size. +(** Change the default buffer size. - @raise Invalid_argument if the given size is smaller than [16] - or greater than [Sys.max_string_length] *) + @raise Invalid_argument + if the given size is smaller than [16] or greater than + [Sys.max_string_length] *) (** {2 Deprecated} *) val establish_server : - ?fd : Lwt_unix.file_descr -> - ?buffer_size : int -> - ?backlog : int -> - ?no_close : bool -> - Unix.sockaddr -> (input_channel * output_channel -> unit Lwt.t) -> - server Lwt.t + ?fd:Lwt_unix.file_descr -> + ?buffer_size:int -> + ?backlog:int -> + ?no_close:bool -> + Unix.sockaddr -> + (input_channel * output_channel -> unit Lwt.t) -> + server Lwt.t [@@ocaml.deprecated -" Since Lwt 3.1.0, use Lwt_io.establish_server_with_client_address"] + " Since Lwt 3.1.0, use Lwt_io.establish_server_with_client_address"] (** Like [establish_server_with_client_address], but does not pass the client address or fd to the callback [f]. @@ -801,17 +785,17 @@ val establish_server : @since 3.0.0 *) (** Versioned variants of APIs undergoing breaking changes. *) -module Versioned : -sig +module Versioned : sig val establish_server_1 : - ?fd : Lwt_unix.file_descr -> - ?buffer_size : int -> - ?backlog : int -> - Unix.sockaddr -> (input_channel * output_channel -> unit) -> - server + ?fd:Lwt_unix.file_descr -> + ?buffer_size:int -> + ?backlog:int -> + Unix.sockaddr -> + (input_channel * output_channel -> unit) -> + server [@@ocaml.deprecated -" Deprecated in favor of Lwt_io.establish_server. See - https://github.com/ocsigen/lwt/pull/258"] + " Deprecated in favor of Lwt_io.establish_server. See\n\ + \ https://github.com/ocsigen/lwt/pull/258"] (** Old version of {!Lwt_io.establish_server}. The current {!Lwt_io.establish_server} automatically closes channels passed to the callback, and notifies the caller when the server's listening socket is @@ -821,14 +805,15 @@ sig @since 2.7.0 *) val establish_server_2 : - ?fd : Lwt_unix.file_descr -> - ?buffer_size : int -> - ?backlog : int -> - ?no_close : bool -> - Unix.sockaddr -> (input_channel * output_channel -> unit Lwt.t) -> - server Lwt.t + ?fd:Lwt_unix.file_descr -> + ?buffer_size:int -> + ?backlog:int -> + ?no_close:bool -> + Unix.sockaddr -> + (input_channel * output_channel -> unit Lwt.t) -> + server Lwt.t [@@ocaml.deprecated -" In Lwt >= 3.0.0, this is an alias for Lwt_io.establish_server."] + " In Lwt >= 3.0.0, this is an alias for Lwt_io.establish_server."] (** Since Lwt 3.0.0, this is just an alias for {!Lwt_io.establish_server}. @deprecated Use {!Lwt_io.establish_server_with_client_address}. @@ -836,8 +821,8 @@ sig val shutdown_server_1 : server -> unit [@@ocaml.deprecated -" Deprecated in favor of Lwt_io.shutdown_server. See - https://github.com/ocsigen/lwt/issues/259"] + " Deprecated in favor of Lwt_io.shutdown_server. See\n\ + \ https://github.com/ocsigen/lwt/issues/259"] (** Old version of {!Lwt_io.shutdown_server}. The current {!Lwt_io.shutdown_server} returns a promise, which resolves when the server's listening socket is closed. @@ -847,7 +832,7 @@ sig val shutdown_server_2 : server -> unit Lwt.t [@@ocaml.deprecated -" In Lwt >= 3.0.0, this is an alias for Lwt_io.shutdown_server."] + " In Lwt >= 3.0.0, this is an alias for Lwt_io.shutdown_server."] (** Since Lwt 3.0.0, this is just an alias for {!Lwt_io.shutdown_server}. @deprecated Use {!Lwt_io.shutdown_server}. diff --git a/src/unix/lwt_main.ml b/src/unix/lwt_main.ml index 0cac449b87..75f4298828 100644 --- a/src/unix/lwt_main.ml +++ b/src/unix/lwt_main.ml @@ -1,15 +1,15 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] + module Lwt_sequence = Lwt_sequence + [@@@ocaml.warning "+3"] open Lwt.Infix @@ -17,7 +17,6 @@ open Lwt.Infix let enter_iter_hooks = Lwt_sequence.create () let leave_iter_hooks = Lwt_sequence.create () let yielded = Lwt_sequence.create () - let yield () = (Lwt.add_task_r [@ocaml.warning "-3"]) yielded let abandon_yielded_and_paused () = @@ -29,32 +28,31 @@ let run p = (* Fulfill paused promises now. *) Lwt.wakeup_paused (); match Lwt.poll p with - | Some x -> - x + | Some x -> x | None -> - (* Call enter hooks. *) - Lwt_sequence.iter_l (fun f -> f ()) enter_iter_hooks; + (* Call enter hooks. *) + Lwt_sequence.iter_l (fun f -> f ()) enter_iter_hooks; - (* Do the main loop call. *) - let should_block_waiting_for_io = - Lwt.paused_count () = 0 && Lwt_sequence.is_empty yielded in - Lwt_engine.iter should_block_waiting_for_io; + (* Do the main loop call. *) + let should_block_waiting_for_io = + Lwt.paused_count () = 0 && Lwt_sequence.is_empty yielded + in + Lwt_engine.iter should_block_waiting_for_io; - (* Fulfill paused promises again. *) - Lwt.wakeup_paused (); + (* Fulfill paused promises again. *) + Lwt.wakeup_paused (); - (* Fulfill yield promises. *) - if not (Lwt_sequence.is_empty yielded) then begin - let tmp = Lwt_sequence.create () in - Lwt_sequence.transfer_r yielded tmp; - Lwt_sequence.iter_l (fun resolver -> Lwt.wakeup resolver ()) tmp - end; + (* Fulfill yield promises. *) + if not (Lwt_sequence.is_empty yielded) then ( + let tmp = Lwt_sequence.create () in + Lwt_sequence.transfer_r yielded tmp; + Lwt_sequence.iter_l (fun resolver -> Lwt.wakeup resolver ()) tmp); - (* Call leave hooks. *) - Lwt_sequence.iter_l (fun f -> f ()) leave_iter_hooks; + (* Call leave hooks. *) + Lwt_sequence.iter_l (fun f -> f ()) leave_iter_hooks; - (* Repeat. *) - run_loop () + (* Repeat. *) + run_loop () in run_loop () @@ -86,67 +84,60 @@ let run p = This can be addressed with detection. Starting with 4.04, there is a type [Sys.backend_type] that could be used. *) | `From backtrace_string -> - Some (Printf.sprintf "%s\n%s\n%s" - "Nested calls to Lwt_main.run are not allowed" - "Lwt_main.run already called from:" - backtrace_string) - | `From_somewhere -> - Some ("Nested calls to Lwt_main.run are not allowed") + Some + (Printf.sprintf "%s\n%s\n%s" + "Nested calls to Lwt_main.run are not allowed" + "Lwt_main.run already called from:" backtrace_string) + | `From_somewhere -> Some "Nested calls to Lwt_main.run are not allowed" | `No -> - let called_from = - (* See comment above. - if Printexc.backtrace_status () then - let backtrace = - try raise Exit - with Exit -> Printexc.get_backtrace () - in - `From backtrace - else *) + let called_from = + (* See comment above. + if Printexc.backtrace_status () then + let backtrace = + try raise Exit + with Exit -> Printexc.get_backtrace () + in + `From backtrace + else *) `From_somewhere - in - run_already_called := called_from; - None + in + run_already_called := called_from; + None in Mutex.unlock run_already_called_mutex; - begin match error_message_if_call_is_nested with + (match error_message_if_call_is_nested with | Some message -> failwith message - | None -> () - end; + | None -> ()); match run p with | result -> - finished (); - result + finished (); + result | exception exn -> - finished (); - raise exn + finished (); + raise exn let exit_hooks = Lwt_sequence.create () let rec call_hooks () = match Lwt_sequence.take_opt_l exit_hooks with - | None -> - Lwt.return_unit + | None -> Lwt.return_unit | Some f -> - Lwt.catch - (fun () -> f ()) - (fun _ -> Lwt.return_unit) >>= fun () -> - call_hooks () + Lwt.catch (fun () -> f ()) (fun _ -> Lwt.return_unit) >>= fun () -> + call_hooks () let () = at_exit (fun () -> - if not (Lwt_sequence.is_empty exit_hooks) then begin - Lwt.abandon_wakeups (); - finished (); - run (call_hooks ()) - end) + if not (Lwt_sequence.is_empty exit_hooks) then ( + Lwt.abandon_wakeups (); + finished (); + run (call_hooks ()))) let at_exit f = ignore (Lwt_sequence.add_l f exit_hooks) -module type Hooks = -sig +module type Hooks = sig type 'return_value kind type hook @@ -156,14 +147,13 @@ sig val remove_all : unit -> unit end -module type Hook_sequence = -sig +module type Hook_sequence = sig type 'return_value kind + val sequence : (unit -> unit kind) Lwt_sequence.t end -module Wrap_hooks (Sequence : Hook_sequence) = -struct +module Wrap_hooks (Sequence : Hook_sequence) = struct type 'a kind = 'a Sequence.kind type hook = (unit -> unit Sequence.kind) Lwt_sequence.node @@ -175,27 +165,26 @@ struct let hook_node = Lwt_sequence.add_r hook_fn Sequence.sequence in hook_node - let remove hook_node = - Lwt_sequence.remove hook_node + let remove hook_node = Lwt_sequence.remove hook_node let remove_all () = Lwt_sequence.iter_node_l Lwt_sequence.remove Sequence.sequence end -module Enter_iter_hooks = - Wrap_hooks (struct - type 'return_value kind = 'return_value - let sequence = enter_iter_hooks - end) - -module Leave_iter_hooks = - Wrap_hooks (struct - type 'return_value kind = 'return_value - let sequence = leave_iter_hooks - end) - -module Exit_hooks = - Wrap_hooks (struct - type 'return_value kind = 'return_value Lwt.t - let sequence = exit_hooks - end) +module Enter_iter_hooks = Wrap_hooks (struct + type 'return_value kind = 'return_value + + let sequence = enter_iter_hooks +end) + +module Leave_iter_hooks = Wrap_hooks (struct + type 'return_value kind = 'return_value + + let sequence = leave_iter_hooks +end) + +module Exit_hooks = Wrap_hooks (struct + type 'return_value kind = 'return_value Lwt.t + + let sequence = exit_hooks +end) diff --git a/src/unix/lwt_main.mli b/src/unix/lwt_main.mli index 75a3a6e394..02e1c39f47 100644 --- a/src/unix/lwt_main.mli +++ b/src/unix/lwt_main.mli @@ -1,78 +1,73 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Main loop and event queue *) (** This module controls the ``main-loop'' of Lwt. *) val run : 'a Lwt.t -> 'a - (** [Lwt_main.run p] calls the Lwt scheduler, performing I/O until [p] - resolves. [Lwt_main.run p] returns the value in [p] if [p] is fulfilled. - If [p] is rejected with an exception instead, [Lwt_main.run p] raises that - exception. - - Every native and bytecode program that uses Lwt should call this function - at its top level. It implements the Lwt main loop. - - Example: - {[ -let main () = Lwt_io.write_line Lwt_io.stdout "hello world" - -let () = Lwt_main.run (main ()) - ]} - - [Lwt_main.run] is not available when targeting JavaScript, because the - environment (such as Node.js or the browser's script engine) implements - the I/O loop. - - On Unix, calling [Lwt_main.run] installs a [SIGCHLD] handler, which is - needed for the implementations of {!Lwt_unix.waitpid} and - {!Lwt_unix.wait4}. As a result, programs that call [Lwt_main.run] and also - use non-Lwt system calls need to handle those system calls failing with - [EINTR]. - - Nested calls to [Lwt_main.run] are not allowed. That is, do not call - [Lwt_main.run] in a callback triggered by a promise that is resolved by - an outer invocation of [Lwt_main.run]. If your program makes such a call, - [Lwt_main.run] will raise [Failure]. This should be considered a logic - error (i.e., code making such a call is inherently broken). - - It is not safe to call [Lwt_main.run] in a function registered with - [Pervasives.at_exit], use {!Lwt_main.at_exit} instead. *) - -val yield : unit -> unit Lwt.t [@@deprecated "Use Lwt.pause instead"] - (** [yield ()] is a pending promise that is fulfilled after Lwt finishes - calling all currently ready callbacks, i.e. it is fulfilled on the next - “tick.” - - @deprecated Since 5.5.0 [yield] is deprecated in favor of the more general +(** [Lwt_main.run p] calls the Lwt scheduler, performing I/O until [p] resolves. + [Lwt_main.run p] returns the value in [p] if [p] is fulfilled. If [p] is + rejected with an exception instead, [Lwt_main.run p] raises that exception. + + Every native and bytecode program that uses Lwt should call this function at + its top level. It implements the Lwt main loop. + + Example: + + {[ + let main () = Lwt_io.write_line Lwt_io.stdout "hello world" + let () = Lwt_main.run (main ()) + ]} + + [Lwt_main.run] is not available when targeting JavaScript, because the + environment (such as Node.js or the browser's script engine) implements the + I/O loop. + + On Unix, calling [Lwt_main.run] installs a [SIGCHLD] handler, which is + needed for the implementations of {!Lwt_unix.waitpid} and {!Lwt_unix.wait4}. + As a result, programs that call [Lwt_main.run] and also use non-Lwt system + calls need to handle those system calls failing with [EINTR]. + + Nested calls to [Lwt_main.run] are not allowed. That is, do not call + [Lwt_main.run] in a callback triggered by a promise that is resolved by an + outer invocation of [Lwt_main.run]. If your program makes such a call, + [Lwt_main.run] will raise [Failure]. This should be considered a logic error + (i.e., code making such a call is inherently broken). + + It is not safe to call [Lwt_main.run] in a function registered with + [Pervasives.at_exit], use {!Lwt_main.at_exit} instead. *) + +val yield : unit -> unit Lwt.t + [@@deprecated "Use Lwt.pause instead"] +(** [yield ()] is a pending promise that is fulfilled after Lwt finishes calling + all currently ready callbacks, i.e. it is fulfilled on the next “tick.” + + @deprecated + Since 5.5.0 [yield] is deprecated in favor of the more general {!Lwt.pause} in order to avoid discrepancies in resolution (see below) and - stay compatible with other execution environments such as js_of_ocaml. + stay compatible with other execution environments such as + js_of_ocaml. - Currently, paused promises are resolved more frequently than yielded promises. - The difference is unintended but existing applications could depend on it. - Unifying the two pools of promises into one in the future would eliminate - possible discrepancies and simplify the code. *) + Currently, paused promises are resolved more frequently than yielded + promises. The difference is unintended but existing applications could + depend on it. Unifying the two pools of promises into one in the future + would eliminate possible discrepancies and simplify the code. *) val abandon_yielded_and_paused : unit -> unit (** Causes promises created with {!Lwt.pause} and {!Lwt_main.yield} to remain forever pending. - [yield] is now deprecated in favor of the more general {!Lwt.pause}. - Once [yield] is phased out, this function will be deprecated as well. + [yield] is now deprecated in favor of the more general {!Lwt.pause}. Once + [yield] is phased out, this function will be deprecated as well. This is meant for use with {!Lwt.fork}, as a way to "abandon" more promise chains that are pending in your process. *) - - (** Hook sequences. Each module of this type is a set of hooks, to be run by Lwt at certain points during execution. See modules {!Enter_iter_hooks}, {!Leave_iter_hooks}, and {!Exit_hooks}. *) -module type Hooks = -sig +module type Hooks = sig type 'return_value kind (** Hooks are functions of either type [unit -> unit] or [unit -> unit Lwt.t]; this type constructor is used only to express both possibilities in one @@ -97,50 +92,40 @@ sig (** Removes all hooks from the hook sequence underlying this module. *) end +module Enter_iter_hooks : Hooks with type 'return_value kind = 'return_value (** Hooks, of type [unit -> unit], that are called before each iteration of the Lwt main loop. @since 4.2.0 *) -module Enter_iter_hooks : - Hooks with type 'return_value kind = 'return_value +module Leave_iter_hooks : Hooks with type 'return_value kind = 'return_value (** Hooks, of type [unit -> unit], that are called after each iteration of the Lwt main loop. @since 4.2.0 *) -module Leave_iter_hooks : - Hooks with type 'return_value kind = 'return_value +module Exit_hooks : Hooks with type 'return_value kind = 'return_value Lwt.t (** Promise-returning hooks, of type [unit -> unit Lwt.t], that are called at process exit. Exceptions raised by these hooks are ignored. @since 4.2.0 *) -module Exit_hooks : - Hooks with type 'return_value kind = 'return_value Lwt.t - - [@@@ocaml.warning "-3"] val enter_iter_hooks : (unit -> unit) Lwt_sequence.t - [@@ocaml.deprecated - " Use module Lwt_main.Enter_iter_hooks."] + [@@ocaml.deprecated " Use module Lwt_main.Enter_iter_hooks."] (** @deprecated Use module {!Enter_iter_hooks}. *) val leave_iter_hooks : (unit -> unit) Lwt_sequence.t - [@@ocaml.deprecated - " Use module Lwt_main.Leave_iter_hooks."] + [@@ocaml.deprecated " Use module Lwt_main.Leave_iter_hooks."] (** @deprecated Use module {!Leave_iter_hooks}. *) val exit_hooks : (unit -> unit Lwt.t) Lwt_sequence.t - [@@ocaml.deprecated - " Use module Lwt_main.Exit_hooks."] + [@@ocaml.deprecated " Use module Lwt_main.Exit_hooks."] (** @deprecated Use module {!Exit_hooks}. *) [@@@ocaml.warning "+3"] - - val at_exit : (unit -> unit Lwt.t) -> unit (** [Lwt_main.at_exit hook] is the same as [ignore (Lwt_main.Exit_hooks.add_first hook)]. *) diff --git a/src/unix/lwt_preemptive.ml b/src/unix/lwt_preemptive.ml index f4b71ecdd9..3af53ecea3 100644 --- a/src/unix/lwt_preemptive.ml +++ b/src/unix/lwt_preemptive.ml @@ -1,15 +1,15 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] + module Lwt_sequence = Lwt_sequence + [@@@ocaml.warning "+3"] open Lwt.Infix @@ -26,9 +26,7 @@ let max_threads : int ref = ref 0 (* Size of the waiting queue: *) let max_thread_queued = ref 1000 - -let get_max_number_of_threads_queued _ = - !max_thread_queued +let get_max_number_of_threads_queued _ = !max_thread_queued let set_max_number_of_threads_queued n = if n < 0 then invalid_arg "Lwt_preemptive.set_max_number_of_threads_queued"; @@ -41,20 +39,14 @@ let threads_count = ref 0 | Preemptive threads management | +-----------------------------------------------------------------+ *) -module CELL : -sig +module CELL : sig type 'a t val make : unit -> 'a t val get : 'a t -> 'a val set : 'a t -> 'a -> unit -end = -struct - type 'a t = { - m : Mutex.t; - cv : Condition.t; - mutable cell : 'a option; - } +end = struct + type 'a t = { m : Mutex.t; cv : Condition.t; mutable cell : 'a option } let make () = { m = Mutex.create (); cv = Condition.create (); cell = None } @@ -62,12 +54,12 @@ struct let rec await_value t = match t.cell with | None -> - Condition.wait t.cv t.m; - await_value t + Condition.wait t.cv t.m; + await_value t | Some v -> - t.cell <- None; - Mutex.unlock t.m; - v + t.cell <- None; + Mutex.unlock t.m; + v in Mutex.lock t.m; await_value t @@ -80,16 +72,13 @@ struct end type thread = { - task_cell: (int * (unit -> unit)) CELL.t; + task_cell : (int * (unit -> unit)) CELL.t; (* Channel used to communicate notification id and tasks to the worker thread. *) - - mutable thread : Thread.t; - (* The worker thread. *) - + mutable thread : Thread.t; (* The worker thread. *) mutable reuse : bool; - (* Whether the thread must be re-added to the pool when the work is - done. *) + (* Whether the thread must be re-added to the pool when the work is + done. *) } (* Pool of worker threads: *) @@ -112,30 +101,23 @@ let rec worker_loop worker = (* create a new worker: *) let make_worker () = incr threads_count; - let worker = { - task_cell = CELL.make (); - thread = Thread.self (); - reuse = true; - } in + let worker = + { task_cell = CELL.make (); thread = Thread.self (); reuse = true } + in worker.thread <- Thread.create worker_loop worker; worker (* Add a worker to the pool: *) let add_worker worker = match Lwt_sequence.take_opt_l waiters with - | None -> - Queue.add worker workers - | Some w -> - Lwt.wakeup w worker + | None -> Queue.add worker workers + | Some w -> Lwt.wakeup w worker (* Wait for worker to be available, then return it: *) let get_worker () = - if not (Queue.is_empty workers) then - Lwt.return (Queue.take workers) - else if !threads_count < !max_threads then - Lwt.return (make_worker ()) - else - (Lwt.add_task_r [@ocaml.warning "-3"]) waiters + if not (Queue.is_empty workers) then Lwt.return (Queue.take workers) + else if !threads_count < !max_threads then Lwt.return (make_worker ()) + else (Lwt.add_task_r [@ocaml.warning "-3"]) waiters (* +-----------------------------------------------------------------+ | Initialisation, and dynamic parameters reset | @@ -160,10 +142,9 @@ let init min max _errlog = set_bounds (min, max) let simple_init () = - if not !initialized then begin + if not !initialized then ( initialized := true; - set_bounds (0, 4) - end + set_bounds (0, 4)) let nbthreads () = !threads_count let nbthreadsqueued () = Lwt_sequence.fold_l (fun _ x -> x + 1) waiters 0 @@ -180,33 +161,29 @@ let detach f args = let result = ref init_result in (* The task for the worker thread: *) let task () = - try - result := Result.Ok (f args) - with exn -> - result := Result.Error exn + try result := Result.Ok (f args) with exn -> result := Result.Error exn in get_worker () >>= fun worker -> let waiter, wakener = Lwt.wait () in let id = - Lwt_unix.make_notification ~once:true - (fun () -> Lwt.wakeup_result wakener !result) + Lwt_unix.make_notification ~once:true (fun () -> + Lwt.wakeup_result wakener !result) in Lwt.finalize (fun () -> - (* Send the id and the task to the worker: *) - CELL.set worker.task_cell (id, task); - waiter) + (* Send the id and the task to the worker: *) + CELL.set worker.task_cell (id, task); + waiter) (fun () -> - if worker.reuse then - (* Put back the worker to the pool: *) - add_worker worker - else begin - decr threads_count; - (* Or wait for the thread to terminates, to free its associated - resources: *) - Thread.join worker.thread - end; - Lwt.return_unit) + if worker.reuse then + (* Put back the worker to the pool: *) + add_worker worker + else ( + decr threads_count; + (* Or wait for the thread to terminates, to free its associated + resources: *) + Thread.join worker.thread); + Lwt.return_unit) (* +-----------------------------------------------------------------+ | Running Lwt threads in the main thread | @@ -219,14 +196,13 @@ let jobs = Queue.create () let jobs_mutex = Mutex.create () let job_notification = - Lwt_unix.make_notification - (fun () -> - (* Take the first job. The queue is never empty at this - point. *) - Mutex.lock jobs_mutex; - let thunk = Queue.take jobs in - Mutex.unlock jobs_mutex; - ignore (thunk ())) + Lwt_unix.make_notification (fun () -> + (* Take the first job. The queue is never empty at this + point. *) + Mutex.lock jobs_mutex; + let thunk = Queue.take jobs in + Mutex.unlock jobs_mutex; + ignore (thunk ())) (* There is a potential performance issue from creating a cell every time this function is called. See: @@ -240,7 +216,8 @@ let run_in_main f = (* Execute [f] and wait for its result. *) Lwt.try_bind f (fun ret -> Lwt.return (Result.Ok ret)) - (fun exn -> Lwt.return (Result.Error exn)) >>= fun result -> + (fun exn -> Lwt.return (Result.Error exn)) + >>= fun result -> (* Send the result. *) CELL.set cell result; Lwt.return_unit diff --git a/src/unix/lwt_preemptive.mli b/src/unix/lwt_preemptive.mli index 9f06f9b6ab..11a96892d3 100644 --- a/src/unix/lwt_preemptive.mli +++ b/src/unix/lwt_preemptive.mli @@ -1,50 +1,46 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) +(** This module allows to mix preemptive threads with [Lwt] cooperative threads. + It maintains an extensible pool of preemptive threads to which you can + detach computations. - -(** This module allows to mix preemptive threads with [Lwt] - cooperative threads. It maintains an extensible pool of preemptive - threads to which you can detach computations. - - See {{:https://github.com/hcarty/mwt} Mwt} for a more modern - implementation. *) + See {{:https://github.com/hcarty/mwt} Mwt} for a more modern implementation. *) val detach : ('a -> 'b) -> 'a -> 'b Lwt.t - (** [detach f x] runs the computation [f x] in a separate preemptive thread. - [detach] evaluates to an Lwt promise, which is pending until the - preemptive thread completes. +(** [detach f x] runs the computation [f x] in a separate preemptive thread. + [detach] evaluates to an Lwt promise, which is pending until the preemptive + thread completes. - [detach] calls {!simple_init} internally, which means that the number of - preemptive threads is capped by default at four. If you would like a - higher limit, call {!init} or {!set_bounds} directly. + [detach] calls {!simple_init} internally, which means that the number of + preemptive threads is capped by default at four. If you would like a higher + limit, call {!init} or {!set_bounds} directly. - Note that Lwt thread-local storage (i.e., {!Lwt.with_value}) cannot be - safely used from within [f]. The same goes for most of the rest of Lwt. If - you need to run an Lwt thread in [f], use {!run_in_main}. *) + Note that Lwt thread-local storage (i.e., {!Lwt.with_value}) cannot be + safely used from within [f]. The same goes for most of the rest of Lwt. If + you need to run an Lwt thread in [f], use {!run_in_main}. *) val run_in_main : (unit -> 'a Lwt.t) -> 'a - (** [run_in_main f] can be called from a detached computation to execute - [f ()] in the main preemptive thread, i.e. the one executing - {!Lwt_main.run}. [run_in_main f] blocks until [f ()] completes, then - returns its result. If [f ()] raises an exception, [run_in_main f] raises - the same exception. +(** [run_in_main f] can be called from a detached computation to execute [f ()] + in the main preemptive thread, i.e. the one executing {!Lwt_main.run}. + [run_in_main f] blocks until [f ()] completes, then returns its result. If + [f ()] raises an exception, [run_in_main f] raises the same exception. - {!Lwt.with_value} may be used inside [f ()]. {!Lwt.get} can correctly - retrieve values set this way inside [f ()], but not values set using - {!Lwt.with_value} outside [f ()]. *) + {!Lwt.with_value} may be used inside [f ()]. {!Lwt.get} can correctly + retrieve values set this way inside [f ()], but not values set using + {!Lwt.with_value} outside [f ()]. *) val init : int -> int -> (string -> unit) -> unit - (** [init min max log] initialises this module. i.e. it launches the - minimum number of preemptive threads and starts the {b - dispatcher}. +(** [init min max log] initialises this module. i.e. it launches the minimum + number of preemptive threads and starts the {b dispatcher}. - @param min is the minimum number of threads - @param max is the maximum number of threads - @param log is used to log error messages + @param min is the minimum number of threads + @param max is the maximum number of threads + @param log + is used to log error messages - If {!Lwt_preemptive} has already been initialised, this call - only modify bounds and the log function. *) + If {!Lwt_preemptive} has already been initialised, this call only modify + bounds and the log function. *) val simple_init : unit -> unit (** [simple_init ()] checks if the library is not yet initialized, and if not, @@ -55,23 +51,23 @@ val simple_init : unit -> unit Note: this function is automatically called by {!detach}. *) val get_bounds : unit -> int * int - (** [get_bounds ()] returns the minimum and the maximum number of - preemptive threads. *) +(** [get_bounds ()] returns the minimum and the maximum number of preemptive + threads. *) val set_bounds : int * int -> unit - (** [set_bounds (min, max)] set the minimum and the maximum number - of preemptive threads. *) +(** [set_bounds (min, max)] set the minimum and the maximum number of preemptive + threads. *) val set_max_number_of_threads_queued : int -> unit - (** Sets the size of the waiting queue, if no more preemptive - threads are available. When the queue is full, {!detach} will - sleep until a thread is available. *) +(** Sets the size of the waiting queue, if no more preemptive threads are + available. When the queue is full, {!detach} will sleep until a thread is + available. *) val get_max_number_of_threads_queued : unit -> int - (** Returns the size of the waiting queue, if no more threads are - available *) +(** Returns the size of the waiting queue, if no more threads are available *) (**/**) + val nbthreads : unit -> int val nbthreadsbusy : unit -> int val nbthreadsqueued : unit -> int diff --git a/src/unix/lwt_process.ml b/src/unix/lwt_process.ml index f6534938da..7b8b3e198f 100644 --- a/src/unix/lwt_process.ml +++ b/src/unix/lwt_process.ml @@ -1,17 +1,13 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Lwt.Infix type command = string * string array let shell = - if Sys.win32 then - fun cmd -> ("", [|"cmd.exe"; "/c"; "\000" ^ cmd|]) - else - fun cmd -> ("", [|"/bin/sh"; "-c"; cmd|]) + if Sys.win32 then fun cmd -> ("", [| "cmd.exe"; "/c"; "\000" ^ cmd |]) + else fun cmd -> ("", [| "/bin/sh"; "-c"; cmd |]) type redirection = [ `Keep @@ -27,180 +23,141 @@ type redirection = type proc = { id : int; (* The process id. *) - fd : Unix.file_descr; - (* A handle on windows, and a dummy value of Unix. *) + fd : Unix.file_descr; (* A handle on windows, and a dummy value of Unix. *) } let win32_get_fd fd redirection = match redirection with - | `Keep -> - Some fd - | `Dev_null -> - Some (Unix.openfile "nul" [Unix.O_RDWR] 0o666) - | `Close -> - None - | `FD_copy fd' -> - Some fd' - | `FD_move fd' -> - Some fd' + | `Keep -> Some fd + | `Dev_null -> Some (Unix.openfile "nul" [ Unix.O_RDWR ] 0o666) + | `Close -> None + | `FD_copy fd' -> Some fd' + | `FD_move fd' -> Some fd' external win32_create_process : - string option -> string -> string option -> string option -> - (Unix.file_descr option * Unix.file_descr option * Unix.file_descr option) -> - proc = "lwt_process_create_process" + string option -> + string -> + string option -> + string option -> + Unix.file_descr option * Unix.file_descr option * Unix.file_descr option -> + proc = "lwt_process_create_process" let win32_quote arg = if String.length arg > 0 && arg.[0] = '\000' then String.sub arg 1 (String.length arg - 1) - else - Filename.quote arg - -let win32_spawn - (prog, args) env ?cwd - ?(stdin:redirection=`Keep) - ?(stdout:redirection=`Keep) - ?(stderr:redirection=`Keep) - toclose = + else Filename.quote arg + +let win32_spawn (prog, args) env ?cwd ?(stdin : redirection = `Keep) + ?(stdout : redirection = `Keep) ?(stderr : redirection = `Keep) toclose = let cmdline = String.concat " " (List.map win32_quote (Array.to_list args)) in let env = match env with - | None -> - None + | None -> None | Some env -> - let len = - Array.fold_left (fun len str -> String.length str + len + 1) 1 env in - let res = Bytes.create len in - let ofs = - Array.fold_left - (fun ofs str -> - let len = String.length str in - String.blit str 0 res ofs len; - Bytes.set res (ofs + len) '\000'; - ofs + len + 1) - 0 env - in - Bytes.set res ofs '\000'; - Some (Bytes.unsafe_to_string res) + let len = + Array.fold_left (fun len str -> String.length str + len + 1) 1 env + in + let res = Bytes.create len in + let ofs = + Array.fold_left + (fun ofs str -> + let len = String.length str in + String.blit str 0 res ofs len; + Bytes.set res (ofs + len) '\000'; + ofs + len + 1) + 0 env + in + Bytes.set res ofs '\000'; + Some (Bytes.unsafe_to_string res) in List.iter Unix.set_close_on_exec toclose; - let stdin_fd = win32_get_fd Unix.stdin stdin + let stdin_fd = win32_get_fd Unix.stdin stdin and stdout_fd = win32_get_fd Unix.stdout stdout and stderr_fd = win32_get_fd Unix.stderr stderr in let proc = win32_create_process - (if prog = "" then None else Some prog) cmdline env cwd + (if prog = "" then None else Some prog) + cmdline env cwd (stdin_fd, stdout_fd, stderr_fd) in let close fd fd' = match fd with - | `FD_move fd -> - Unix.close fd - | `Dev_null -> - begin match fd' with - | Some fd' -> Unix.close fd' - | None -> assert false - end - | _ -> - () + | `FD_move fd -> Unix.close fd + | `Dev_null -> ( + match fd' with Some fd' -> Unix.close fd' | None -> assert false) + | _ -> () in close stdin stdin_fd; close stdout stdout_fd; close stderr stderr_fd; proc -external win32_wait_job : Unix.file_descr -> int Lwt_unix.job = - "lwt_process_wait_job" +external win32_wait_job : Unix.file_descr -> int Lwt_unix.job + = "lwt_process_wait_job" let win32_waitproc proc = Lwt_unix.run_job (win32_wait_job proc.fd) >>= fun code -> Lwt.return - (proc.id, - Lwt_unix.WEXITED code, - {Lwt_unix.ru_utime = 0.; Lwt_unix.ru_stime = 0.}) + ( proc.id, + Lwt_unix.WEXITED code, + { Lwt_unix.ru_utime = 0.; Lwt_unix.ru_stime = 0. } ) -external win32_terminate_process : Unix.file_descr -> int -> unit = - "lwt_process_terminate_process" +external win32_terminate_process : Unix.file_descr -> int -> unit + = "lwt_process_terminate_process" -let win32_terminate proc = - win32_terminate_process proc.fd 1 +let win32_terminate proc = win32_terminate_process proc.fd 1 -let unix_redirect fd redirection = match redirection with - | `Keep -> - () +let unix_redirect fd redirection = + match redirection with + | `Keep -> () | `Dev_null -> - Unix.close fd; - let dev_null = Unix.openfile "/dev/null" [Unix.O_RDWR] 0o666 in - if fd <> dev_null then begin - Unix.dup2 dev_null fd; - Unix.close dev_null - end - | `Close -> - Unix.close fd - | `FD_copy fd' -> - Unix.dup2 fd' fd + Unix.close fd; + let dev_null = Unix.openfile "/dev/null" [ Unix.O_RDWR ] 0o666 in + if fd <> dev_null then ( + Unix.dup2 dev_null fd; + Unix.close dev_null) + | `Close -> Unix.close fd + | `FD_copy fd' -> Unix.dup2 fd' fd | `FD_move fd' -> - Unix.dup2 fd' fd; - Unix.close fd' + Unix.dup2 fd' fd; + Unix.close fd' external unix_exit : int -> 'a = "unix_exit" -let unix_spawn - (prog, args) env ?cwd - ?(stdin:redirection=`Keep) - ?(stdout:redirection=`Keep) - ?(stderr:redirection=`Keep) - toclose = +let unix_spawn (prog, args) env ?cwd ?(stdin : redirection = `Keep) + ?(stdout : redirection = `Keep) ?(stderr : redirection = `Keep) toclose = let prog = if prog = "" && Array.length args > 0 then args.(0) else prog in match Lwt_unix.fork () with - | 0 -> - unix_redirect Unix.stdin stdin; - unix_redirect Unix.stdout stdout; - unix_redirect Unix.stderr stderr; - List.iter Unix.close toclose; - begin + | 0 -> ( + unix_redirect Unix.stdin stdin; + unix_redirect Unix.stdout stdout; + unix_redirect Unix.stderr stderr; + List.iter Unix.close toclose; try - begin match cwd with - | None -> () - | Some dir -> - Sys.chdir dir - end; + (match cwd with None -> () | Some dir -> Sys.chdir dir); match env with - | None -> - Unix.execvp prog args - | Some env -> - Unix.execvpe prog args env - with _ -> - (* Do not run at_exit hooks *) - unix_exit 127 - end + | None -> Unix.execvp prog args + | Some env -> Unix.execvpe prog args env + with _ -> (* Do not run at_exit hooks *) + unix_exit 127) | id -> - let close = function - | `FD_move fd -> - Unix.close fd - | _ -> - () - in - close stdin; - close stdout; - close stderr; - {id; fd = Unix.stdin} + let close = function `FD_move fd -> Unix.close fd | _ -> () in + close stdin; + close stdout; + close stderr; + { id; fd = Unix.stdin } let unix_waitproc proc = Lwt_unix.wait4 [] proc.id - -let unix_terminate proc = - Unix.kill proc.id Sys.sigkill - -let spawn = if Sys.win32 then win32_spawn else unix_spawn -let waitproc = if Sys.win32 then win32_waitproc else unix_waitproc +let unix_terminate proc = Unix.kill proc.id Sys.sigkill +let spawn = if Sys.win32 then win32_spawn else unix_spawn +let waitproc = if Sys.win32 then win32_waitproc else unix_waitproc let terminate = if Sys.win32 then win32_terminate else unix_terminate (* +-----------------------------------------------------------------+ | Objects | +-----------------------------------------------------------------+ *) -type state = - | Running - | Exited of Unix.process_status +type state = Running | Exited of Unix.process_status let status (_pid, status, _rusage) = status let rusage (_pid, _status, rusage) = rusage @@ -212,9 +169,8 @@ let ignore_close chan = ignore (Lwt_io.close chan) class virtual common timeout proc channels = let wait = waitproc proc in - object(self) + object (self) val mutable closed = false - method pid = proc.id method state = @@ -223,49 +179,46 @@ class virtual common timeout proc channels = | Some (_pid, status, _rusage) -> Exited status method kill signum = - if Lwt.state wait = Lwt.Sleep then - Unix.kill proc.id signum + if Lwt.state wait = Lwt.Sleep then Unix.kill proc.id signum - method terminate = - if Lwt.state wait = Lwt.Sleep then - terminate proc + method terminate = if Lwt.state wait = Lwt.Sleep then terminate proc method close = if closed then self#status else ( closed <- true; - Lwt.protected (Lwt.join (List.map Lwt_io.close channels)) - >>= fun () -> self#status - ) + Lwt.protected (Lwt.join (List.map Lwt_io.close channels)) >>= fun () -> + self#status) + method status = Lwt.protected wait >|= status method rusage = Lwt.protected wait >|= rusage initializer - (* Ensure channels are closed when no longer used. *) - List.iter (Gc.finalise ignore_close) channels; - (* Handle timeout. *) - match timeout with - | None -> - () - | Some dt -> - ignore ( - (* Ignore errors since they can be obtained by - self#close. *) - Lwt.try_bind - (fun () -> - Lwt.choose [(Lwt_unix.sleep dt >>= fun () -> Lwt.return_false); - (wait >>= fun _ -> Lwt.return_true)]) - (function - | true -> - Lwt.return_unit - | false -> - self#terminate; - self#close >>= fun _ -> Lwt.return_unit) - (fun _ -> + (* Ensure channels are closed when no longer used. *) + List.iter (Gc.finalise ignore_close) channels; + (* Handle timeout. *) + match timeout with + | None -> () + | Some dt -> + ignore + ((* Ignore errors since they can be obtained by + self#close. *) + Lwt.try_bind + (fun () -> + Lwt.choose + [ + (Lwt_unix.sleep dt >>= fun () -> Lwt.return_false); + (wait >>= fun _ -> Lwt.return_true); + ]) + (function + | true -> Lwt.return_unit + | false -> + self#terminate; + self#close >>= fun _ -> Lwt.return_unit) + (fun _ -> (* The exception is dropped because it can be obtained with self#close. *) - Lwt.return_unit) - ) + Lwt.return_unit)) end class process_none ?timeout ?env ?cwd ?stdin ?stdout ?stderr cmd = @@ -277,35 +230,35 @@ class process_none ?timeout ?env ?cwd ?stdin ?stdout ?stderr cmd = class process_in ?timeout ?env ?cwd ?stdin ?stderr cmd = let stdout_r, stdout_w = Unix.pipe () in let proc = - spawn cmd env ?cwd ?stdin ~stdout:(`FD_move stdout_w) ?stderr [stdout_r] in + spawn cmd env ?cwd ?stdin ~stdout:(`FD_move stdout_w) ?stderr [ stdout_r ] + in let stdout = Lwt_io.of_unix_fd ~mode:Lwt_io.input stdout_r in object - inherit common timeout proc [cast_chan stdout] + inherit common timeout proc [ cast_chan stdout ] method stdout = stdout end class process_out ?timeout ?env ?cwd ?stdout ?stderr cmd = let stdin_r, stdin_w = Unix.pipe () in let proc = - spawn cmd env ?cwd ~stdin:(`FD_move stdin_r) ?stdout ?stderr [stdin_w] in + spawn cmd env ?cwd ~stdin:(`FD_move stdin_r) ?stdout ?stderr [ stdin_w ] + in let stdin = Lwt_io.of_unix_fd ~mode:Lwt_io.output stdin_w in object - inherit common timeout proc [cast_chan stdin] + inherit common timeout proc [ cast_chan stdin ] method stdin = stdin end class process ?timeout ?env ?cwd ?stderr cmd = - let stdin_r, stdin_w = Unix.pipe () - and stdout_r, stdout_w = Unix.pipe () in + let stdin_r, stdin_w = Unix.pipe () and stdout_r, stdout_w = Unix.pipe () in let proc = - spawn - cmd env ?cwd ~stdin:(`FD_move stdin_r) ~stdout:(`FD_move stdout_w) ?stderr - [stdin_w; stdout_r] + spawn cmd env ?cwd ~stdin:(`FD_move stdin_r) ~stdout:(`FD_move stdout_w) + ?stderr [ stdin_w; stdout_r ] in let stdin = Lwt_io.of_unix_fd ~mode:Lwt_io.output stdin_w and stdout = Lwt_io.of_unix_fd ~mode:Lwt_io.input stdout_r in object - inherit common timeout proc [cast_chan stdin; cast_chan stdout] + inherit common timeout proc [ cast_chan stdin; cast_chan stdout ] method stdin = stdin method stdout = stdout end @@ -315,19 +268,19 @@ class process_full ?timeout ?env ?cwd cmd = and stdout_r, stdout_w = Unix.pipe () and stderr_r, stderr_w = Unix.pipe () in let proc = - spawn - cmd env ?cwd - ~stdin:(`FD_move stdin_r) - ~stdout:(`FD_move stdout_w) + spawn cmd env ?cwd ~stdin:(`FD_move stdin_r) ~stdout:(`FD_move stdout_w) ~stderr:(`FD_move stderr_w) - [stdin_w; stdout_r; stderr_r] + [ stdin_w; stdout_r; stderr_r ] in let stdin = Lwt_io.of_unix_fd ~mode:Lwt_io.output stdin_w and stdout = Lwt_io.of_unix_fd ~mode:Lwt_io.input stdout_r and stderr = Lwt_io.of_unix_fd ~mode:Lwt_io.input stderr_r in object inherit - common timeout proc [cast_chan stdin; cast_chan stdout; cast_chan stderr] + common + timeout proc + [ cast_chan stdin; cast_chan stdout; cast_chan stderr ] + method stdin = stdin method stdout = stdout method stderr = stderr @@ -352,9 +305,7 @@ let make_with backend ?timeout ?env ?cwd cmd f = let process = backend ?timeout ?env ?cwd cmd in Lwt.finalize (fun () -> f process) - (fun () -> - process#close >>= fun _ -> - Lwt.return_unit) + (fun () -> process#close >>= fun _ -> Lwt.return_unit) let with_process_none ?timeout ?env ?cwd ?stdin ?stdout ?stderr cmd f = make_with (open_process_none ?stdin ?stdout ?stderr) ?timeout ?env ?cwd cmd f @@ -378,56 +329,42 @@ let with_process_full ?timeout ?env ?cwd cmd f = let exec ?timeout ?env ?cwd ?stdin ?stdout ?stderr cmd = (open_process_none ?timeout ?env ?cwd ?stdin ?stdout ?stderr cmd)#close -let ignore_close ch = - ignore (Lwt_io.close ch) +let ignore_close ch = ignore (Lwt_io.close ch) let read_opt read ic = - Lwt.catch - (fun () -> read ic >|= fun x -> Some x) - (function - | Unix.Unix_error (Unix.EPIPE, _, _) | End_of_file -> - Lwt.return_none - | exn -> Lwt.fail exn) [@ocaml.warning "-4"] + (Lwt.catch + (fun () -> read ic >|= fun x -> Some x) + (function + | Unix.Unix_error (Unix.EPIPE, _, _) | End_of_file -> Lwt.return_none + | exn -> Lwt.fail exn) [@ocaml.warning "-4"]) let recv_chars pr = let ic = pr#stdout in Gc.finalise ignore_close ic; Lwt_stream.from (fun _ -> - read_opt Lwt_io.read_char ic >>= fun x -> - if x = None then begin - Lwt_io.close ic >>= fun () -> - Lwt.return x - end else - Lwt.return x) + read_opt Lwt_io.read_char ic >>= fun x -> + if x = None then Lwt_io.close ic >>= fun () -> Lwt.return x + else Lwt.return x) let recv_lines pr = let ic = pr#stdout in Gc.finalise ignore_close ic; Lwt_stream.from (fun _ -> - read_opt Lwt_io.read_line ic >>= fun x -> - if x = None then begin - Lwt_io.close ic >>= fun () -> - Lwt.return x - end else - Lwt.return x) + read_opt Lwt_io.read_line ic >>= fun x -> + if x = None then Lwt_io.close ic >>= fun () -> Lwt.return x + else Lwt.return x) let recv pr = let ic = pr#stdout in - Lwt.finalize - (fun () -> Lwt_io.read ic) - (fun () -> Lwt_io.close ic) + Lwt.finalize (fun () -> Lwt_io.read ic) (fun () -> Lwt_io.close ic) let recv_line pr = let ic = pr#stdout in - Lwt.finalize - (fun () -> Lwt_io.read_line ic) - (fun () -> Lwt_io.close ic) + Lwt.finalize (fun () -> Lwt_io.read_line ic) (fun () -> Lwt_io.close ic) let send f pr data = let oc = pr#stdin in - Lwt.finalize - (fun () -> f oc data) - (fun () -> Lwt_io.close oc) + Lwt.finalize (fun () -> f oc data) (fun () -> Lwt_io.close oc) (* Receiving *) @@ -446,66 +383,60 @@ let pread_lines ?timeout ?env ?cwd ?stdin ?stderr cmd = (* Sending *) let pwrite ?timeout ?env ?cwd ?stdout ?stderr cmd text = - send Lwt_io.write (open_process_out ?timeout ?env ?cwd ?stdout ?stderr cmd) text + send Lwt_io.write + (open_process_out ?timeout ?env ?cwd ?stdout ?stderr cmd) + text let pwrite_chars ?timeout ?env ?cwd ?stdout ?stderr cmd chars = - send - Lwt_io.write_chars + send Lwt_io.write_chars (open_process_out ?timeout ?env ?cwd ?stdout ?stderr cmd) chars let pwrite_line ?timeout ?env ?cwd ?stdout ?stderr cmd line = - send - Lwt_io.write_line + send Lwt_io.write_line (open_process_out ?timeout ?env ?cwd ?stdout ?stderr cmd) line let pwrite_lines ?timeout ?env ?cwd ?stdout ?stderr cmd lines = - send - Lwt_io.write_lines + send Lwt_io.write_lines (open_process_out ?timeout ?env ?cwd ?stdout ?stderr cmd) lines (* Mapping *) -type 'a map_state = - | Init - | Save of 'a option Lwt.t - | Done +type 'a map_state = Init | Save of 'a option Lwt.t | Done (* Monitor the thread [sender] in the stream [st] so write errors are reported. *) let monitor sender st = let sender = sender >|= fun () -> None in let state = ref Init in - Lwt_stream.from - (fun () -> - match !state with - | Init -> - let getter = Lwt.apply Lwt_stream.get st in - let result _ = - match Lwt.state sender with - | Lwt.Sleep -> - (* The sender is still sleeping, behave as the - getter. *) - getter - | Lwt.Return _ -> - (* The sender terminated successfully, we are - done monitoring it. *) - state := Done; - getter - | Lwt.Fail _ -> - (* The sender failed, behave as the sender for - this element and save current getter. *) - state := Save getter; - sender - in - Lwt.try_bind (fun () -> Lwt.choose [sender; getter]) result result - | Save t -> - state := Done; - t - | Done -> - Lwt_stream.get st) + Lwt_stream.from (fun () -> + match !state with + | Init -> + let getter = Lwt.apply Lwt_stream.get st in + let result _ = + match Lwt.state sender with + | Lwt.Sleep -> + (* The sender is still sleeping, behave as the + getter. *) + getter + | Lwt.Return _ -> + (* The sender terminated successfully, we are + done monitoring it. *) + state := Done; + getter + | Lwt.Fail _ -> + (* The sender failed, behave as the sender for + this element and save current getter. *) + state := Save getter; + sender + in + Lwt.try_bind (fun () -> Lwt.choose [ sender; getter ]) result result + | Save t -> + state := Done; + t + | Done -> Lwt_stream.get st) let pmap ?timeout ?env ?cwd ?stderr cmd text = let pr = open_process ?timeout ?env ?cwd ?stderr cmd in @@ -514,14 +445,14 @@ let pmap ?timeout ?env ?cwd ?stderr cmd text = let getter = recv pr in Lwt.catch (fun () -> - (* Wait for both to terminate, returning the result of the - getter. *) - sender >>= fun () -> getter) + (* Wait for both to terminate, returning the result of the + getter. *) + sender >>= fun () -> getter) (function | Lwt.Canceled as exn -> - (* Cancel the getter if the sender was canceled. *) - Lwt.cancel getter; - Lwt.fail exn + (* Cancel the getter if the sender was canceled. *) + Lwt.cancel getter; + Lwt.fail exn | exn -> Lwt.fail exn) let pmap_chars ?timeout ?env ?cwd ?stderr cmd chars = @@ -536,14 +467,14 @@ let pmap_line ?timeout ?env ?cwd ?stderr cmd line = let getter = recv_line pr in Lwt.catch (fun () -> - (* Wait for both to terminate, returning the result of the - getter. *) - sender >>= fun () -> getter) + (* Wait for both to terminate, returning the result of the + getter. *) + sender >>= fun () -> getter) (function | Lwt.Canceled as exn -> - (* Cancel the getter if the sender was canceled. *) - Lwt.cancel getter; - Lwt.fail exn + (* Cancel the getter if the sender was canceled. *) + Lwt.cancel getter; + Lwt.fail exn | exn -> Lwt.fail exn) let pmap_lines ?timeout ?env ?cwd ?stderr cmd lines = diff --git a/src/unix/lwt_process.mli b/src/unix/lwt_process.mli index 8bfcaed637..e42c4a7d64 100644 --- a/src/unix/lwt_process.mli +++ b/src/unix/lwt_process.mli @@ -1,63 +1,52 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Process management *) (** This module allows you to spawn processes and communicate with them. *) type command = string * string array - (** A command. The first field is the name of the executable and - the second is the list of arguments. For example: +(** A command. The first field is the name of the executable and the second is + the list of arguments. For example: - {[ - ("ls", [|"ls"; "-l"|]) - ]} + {[ "ls", [| "ls"; "-l" |] ]} - Notes: + Notes: - - if the name is the empty string, then the first argument - will be used. You should specify a name only if you do not - want the executable to be searched in the PATH. On Windows the - only way to enable automatic search in PATH is to pass an empty - name. + - if the name is the empty string, then the first argument will be used. You + should specify a name only if you do not want the executable to be + searched in the PATH. On Windows the only way to enable automatic search + in PATH is to pass an empty name. - - it is possible to ``inline'' an argument, i.e. split it into - multiple arguments. To do that prefix it with ["\000"]. For - example: + - it is possible to ``inline'' an argument, i.e. split it into multiple + arguments. To do that prefix it with ["\000"]. For example: - {[ - ("", [|"echo"; "\000foo bar"|]) - ]} + {[ "", [| "echo"; "\000foo bar" |] ]} - is the same as: + is the same as: - {[ - ("", [|"echo"; "foo"; "bar"|]) - ]} - *) + {[ "", [| "echo"; "foo"; "bar" |] ]} *) val shell : string -> command - (** A command executed with the shell. (with ["/bin/sh -c "] on - Unix and ["cmd.exe /c "] on Windows). *) +(** A command executed with the shell. (with ["/bin/sh -c "] on Unix and + ["cmd.exe /c "] on Windows). *) -(** All the following functions take an optional argument - [timeout]. If specified, after expiration, the process will be - sent a [Unix.sigkill] signal and channels will be closed. When the channels - are closed, any pending I/O operations on them (such as - {!Lwt_io.read_chars}) fail with exception {!Lwt_io.Channel_closed}. *) +(** All the following functions take an optional argument [timeout]. If + specified, after expiration, the process will be sent a [Unix.sigkill] + signal and channels will be closed. When the channels are closed, any + pending I/O operations on them (such as {!Lwt_io.read_chars}) fail with + exception {!Lwt_io.Channel_closed}. *) (** {2 High-level functions} *) (** {3 Redirections} *) type redirection = - [ `Keep - | `Dev_null - | `Close - | `FD_copy of Unix.file_descr - | `FD_move of Unix.file_descr] + [ `Keep + | `Dev_null + | `Close + | `FD_copy of Unix.file_descr + | `FD_move of Unix.file_descr ] (** File descriptor redirections. These are used with the [~stdin], [~stdout], and [~stderr] arguments below to specify how the standard file descriptors should be redirected in the child process. @@ -74,270 +63,311 @@ type redirection = (** {3 Executing} *) val exec : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stdin : redirection -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> Unix.process_status Lwt.t - (** Executes the given command and returns its exit status. *) + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stdin:redirection -> + ?stdout:redirection -> + ?stderr:redirection -> + command -> + Unix.process_status Lwt.t +(** Executes the given command and returns its exit status. *) (** {3 Receiving} *) val pread : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stdin : redirection -> - ?stderr : redirection -> - command -> string Lwt.t + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stdin:redirection -> + ?stderr:redirection -> + command -> + string Lwt.t + val pread_chars : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stdin : redirection -> - ?stderr : redirection -> - command -> char Lwt_stream.t + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stdin:redirection -> + ?stderr:redirection -> + command -> + char Lwt_stream.t + val pread_line : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stdin : redirection -> - ?stderr : redirection -> - command -> string Lwt.t + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stdin:redirection -> + ?stderr:redirection -> + command -> + string Lwt.t + val pread_lines : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stdin : redirection -> - ?stderr : redirection -> - command -> string Lwt_stream.t + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stdin:redirection -> + ?stderr:redirection -> + command -> + string Lwt_stream.t (** {3 Sending} *) val pwrite : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> string -> unit Lwt.t + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stdout:redirection -> + ?stderr:redirection -> + command -> + string -> + unit Lwt.t + val pwrite_chars : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> char Lwt_stream.t -> unit Lwt.t + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stdout:redirection -> + ?stderr:redirection -> + command -> + char Lwt_stream.t -> + unit Lwt.t + val pwrite_line : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> string -> unit Lwt.t + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stdout:redirection -> + ?stderr:redirection -> + command -> + string -> + unit Lwt.t + val pwrite_lines : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> string Lwt_stream.t -> unit Lwt.t + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stdout:redirection -> + ?stderr:redirection -> + command -> + string Lwt_stream.t -> + unit Lwt.t (** {3 Mapping} *) val pmap : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stderr : redirection -> - command -> string -> string Lwt.t + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stderr:redirection -> + command -> + string -> + string Lwt.t + val pmap_chars : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stderr : redirection -> - command -> char Lwt_stream.t -> char Lwt_stream.t + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stderr:redirection -> + command -> + char Lwt_stream.t -> + char Lwt_stream.t + val pmap_line : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stderr : redirection -> - command -> string -> string Lwt.t + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stderr:redirection -> + command -> + string -> + string Lwt.t + val pmap_lines : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stderr : redirection -> - command -> string Lwt_stream.t -> string Lwt_stream.t + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stderr:redirection -> + command -> + string Lwt_stream.t -> + string Lwt_stream.t (** {2 Spawning processes} *) (** State of a sub-process *) type state = - | Running - (** The process is still running *) - | Exited of Unix.process_status - (** The process has exited *) + | Running (** The process is still running *) + | Exited of Unix.process_status (** The process has exited *) class process_none : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stdin : redirection -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> -object - method pid : int - (** Pid of the sub-process *) - - method state : state - (** Return the state of the process *) - - method kill : int -> unit - (** [kill signum] sends [signum] to the process if it is still - running. *) - - method terminate : unit - (** Terminates the process. It is equivalent to [kill Sys.sigkill] - on Unix but also works on Windows (unlike {!kill}). *) - - method status : Unix.process_status Lwt.t - (** Threads which wait for the sub-process to exit then returns its - exit status *) - - method rusage : Lwt_unix.resource_usage Lwt.t - (** Threads which wait for the sub-process to exit then returns - its resource usages *) - - method close : Unix.process_status Lwt.t - (** Closes the process and returns its exit status. This closes all - channels used to communicate with the process *) -end + ?timeout:float + -> ?env:string array + -> ?cwd:string + -> ?stdin:redirection + -> ?stdout:redirection + -> ?stderr:redirection + -> command + -> object + method pid : int + (** Pid of the sub-process *) + + method state : state + (** Return the state of the process *) + + method kill : int -> unit + (** [kill signum] sends [signum] to the process if it is still running. *) + + method terminate : unit + (** Terminates the process. It is equivalent to [kill Sys.sigkill] on + Unix but also works on Windows (unlike {!kill}). *) + + method status : Unix.process_status Lwt.t + (** Threads which wait for the sub-process to exit then returns its exit + status *) + + method rusage : Lwt_unix.resource_usage Lwt.t + (** Threads which wait for the sub-process to exit then returns its + resource usages *) + + method close : Unix.process_status Lwt.t + (** Closes the process and returns its exit status. This closes all + channels used to communicate with the process *) + end val open_process_none : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stdin : redirection -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> process_none -val with_process_none : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stdin : redirection -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> (process_none -> 'a Lwt.t) -> 'a Lwt.t + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stdin:redirection -> + ?stdout:redirection -> + ?stderr:redirection -> + command -> + process_none -class process_in : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stdin : redirection -> - ?stderr : redirection -> +val with_process_none : + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stdin:redirection -> + ?stdout:redirection -> + ?stderr:redirection -> command -> -object - inherit process_none + (process_none -> 'a Lwt.t) -> + 'a Lwt.t - method stdout : Lwt_io.input_channel - (** The standard output of the process *) -end +class process_in : + ?timeout:float + -> ?env:string array + -> ?cwd:string + -> ?stdin:redirection + -> ?stderr:redirection + -> command + -> object + inherit process_none + + method stdout : Lwt_io.input_channel + (** The standard output of the process *) + end val open_process_in : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stdin : redirection -> - ?stderr : redirection -> - command -> process_in -val with_process_in : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stdin : redirection -> - ?stderr : redirection -> - command -> (process_in -> 'a Lwt.t) -> 'a Lwt.t + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stdin:redirection -> + ?stderr:redirection -> + command -> + process_in -class process_out : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stdout : redirection -> - ?stderr : redirection -> +val with_process_in : + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stdin:redirection -> + ?stderr:redirection -> command -> -object - inherit process_none + (process_in -> 'a Lwt.t) -> + 'a Lwt.t - method stdin : Lwt_io.output_channel - (** The standard input of the process *) -end +class process_out : + ?timeout:float + -> ?env:string array + -> ?cwd:string + -> ?stdout:redirection + -> ?stderr:redirection + -> command + -> object + inherit process_none + + method stdin : Lwt_io.output_channel + (** The standard input of the process *) + end val open_process_out : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> process_out -val with_process_out : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> (process_out -> 'a Lwt.t) -> 'a Lwt.t + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stdout:redirection -> + ?stderr:redirection -> + command -> + process_out -class process : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stderr : redirection -> +val with_process_out : + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stdout:redirection -> + ?stderr:redirection -> command -> -object - inherit process_none + (process_out -> 'a Lwt.t) -> + 'a Lwt.t - method stdin : Lwt_io.output_channel - method stdout : Lwt_io.input_channel -end +class process : + ?timeout:float + -> ?env:string array + -> ?cwd:string + -> ?stderr:redirection + -> command + -> object + inherit process_none + method stdin : Lwt_io.output_channel + method stdout : Lwt_io.input_channel + end val open_process : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stderr : redirection -> - command -> process -val with_process : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - ?stderr : redirection -> - command -> (process -> 'a Lwt.t) -> 'a Lwt.t + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stderr:redirection -> + command -> + process -class process_full : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> +val with_process : + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + ?stderr:redirection -> command -> -object - inherit process_none + (process -> 'a Lwt.t) -> + 'a Lwt.t - method stdin : Lwt_io.output_channel - method stdout : Lwt_io.input_channel - method stderr : Lwt_io.input_channel -end +class process_full : + ?timeout:float + -> ?env:string array + -> ?cwd:string + -> command + -> object + inherit process_none + method stdin : Lwt_io.output_channel + method stdout : Lwt_io.input_channel + method stderr : Lwt_io.input_channel + end val open_process_full : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - command -> process_full + ?timeout:float -> ?env:string array -> ?cwd:string -> command -> process_full + val with_process_full : - ?timeout : float -> - ?env : string array -> - ?cwd : string -> - command -> (process_full -> 'a Lwt.t) -> 'a Lwt.t + ?timeout:float -> + ?env:string array -> + ?cwd:string -> + command -> + (process_full -> 'a Lwt.t) -> + 'a Lwt.t diff --git a/src/unix/lwt_sys.ml b/src/unix/lwt_sys.ml index 489cbad594..6bdf059824 100644 --- a/src/unix/lwt_sys.ml +++ b/src/unix/lwt_sys.ml @@ -1,12 +1,9 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - exception Not_available of string let () = Callback.register_exception "lwt:not-available" (Not_available "") - let windows = Sys.win32 type feature = @@ -24,14 +21,10 @@ type feature = | `libev ] let have = function - | `wait4 - | `recv_msg - | `send_msg - | `madvise -> not Sys.win32 + | `wait4 | `recv_msg | `send_msg | `madvise -> not Sys.win32 | `mincore -> not (Sys.win32 || Sys.cygwin) | `get_cpu -> Lwt_config._HAVE_GETCPU - | `get_affinity - | `set_affinity -> Lwt_config._HAVE_AFFINITY + | `get_affinity | `set_affinity -> Lwt_config._HAVE_AFFINITY | `fd_passing -> Lwt_config._HAVE_FD_PASSING | `get_credentials -> Lwt_config._HAVE_GET_CREDENTIALS | `fdatasync -> Lwt_config._HAVE_FDATASYNC diff --git a/src/unix/lwt_sys.mli b/src/unix/lwt_sys.mli index 8a12959ed4..cac111cfba 100644 --- a/src/unix/lwt_sys.mli +++ b/src/unix/lwt_sys.mli @@ -1,39 +1,35 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** System informations. *) exception Not_available of string - (** [Not_available(feature)] is an exception that may be raised when - a feature is not available on the current system. *) +(** [Not_available(feature)] is an exception that may be raised when a feature + is not available on the current system. *) -(** Features that can be tested. *) type feature = - [ `wait4 - | `get_cpu - | `get_affinity - | `set_affinity - | `recv_msg - | `send_msg - | `fd_passing - | `get_credentials - | `mincore - | `madvise - | `fdatasync - | `libev ] + [ `wait4 + | `get_cpu + | `get_affinity + | `set_affinity + | `recv_msg + | `send_msg + | `fd_passing + | `get_credentials + | `mincore + | `madvise + | `fdatasync + | `libev ] +(** Features that can be tested. *) val have : feature -> bool - (** Test whether the given feature is available on the current - system. *) +(** Test whether the given feature is available on the current system. *) -type byte_order = Little_endian | Big_endian - (** Type of byte order *) +type byte_order = Little_endian | Big_endian (** Type of byte order *) val byte_order : byte_order - (** The byte order used by the computer running the program. *) +(** The byte order used by the computer running the program. *) val windows : bool [@@ocaml.deprecated " Use Sys.win32."] - (** @deprecated Use [Sys.win32]. *) +(** @deprecated Use [Sys.win32]. *) diff --git a/src/unix/lwt_throttle.ml b/src/unix/lwt_throttle.ml index fb1628f7e1..63a9d16470 100644 --- a/src/unix/lwt_throttle.ml +++ b/src/unix/lwt_throttle.ml @@ -1,8 +1,6 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Lwt.Infix module type S = sig @@ -13,14 +11,11 @@ module type S = sig val wait : t -> key -> bool Lwt.t end -module Make (H : Hashtbl.HashedType) : (S with type key = H.t) = struct - module MH = Hashtbl.Make(H) +module Make (H : Hashtbl.HashedType) : S with type key = H.t = struct + module MH = Hashtbl.Make (H) type key = H.t - type elt = { - mutable consumed : int; - queue : bool Lwt.u Queue.t; - } + type elt = { mutable consumed : int; queue : bool Lwt.u Queue.t } type t = { rate : int; @@ -31,40 +26,30 @@ module Make (H : Hashtbl.HashedType) : (S with type key = H.t) = struct } let create ~rate ~max ~n = - if rate < 1 || max < 1 || n < 0 then - invalid_arg "Lwt_throttle.S.create" - else { - rate = rate; - max = max; - waiting = 0; - table = MH.create n; - cleaning = None; - } + if rate < 1 || max < 1 || n < 0 then invalid_arg "Lwt_throttle.S.create" + else { rate; max; waiting = 0; table = MH.create n; cleaning = None } - let update_key t key elt (old_waiting,to_run) = + let update_key t key elt (old_waiting, to_run) = let rec update to_run = function - | 0 -> 0, Queue.length elt.queue, to_run - | i -> - try - let to_run = (Queue.take elt.queue)::to_run in - update to_run (i-1) - with - | Queue.Empty -> i, 0, to_run + | 0 -> (0, Queue.length elt.queue, to_run) + | i -> ( + try + let to_run = Queue.take elt.queue :: to_run in + update to_run (i - 1) + with Queue.Empty -> (i, 0, to_run)) in let not_consumed, waiting, to_run = update to_run t.rate in let consumed = t.rate - not_consumed in - if consumed = 0 - then + if consumed = 0 then (* there is no waiting threads for this key: we can clean the table *) MH.remove t.table key else elt.consumed <- consumed; - (old_waiting+waiting, to_run) + (old_waiting + waiting, to_run) let rec clean_table t = - let waiting,to_run = MH.fold (update_key t) t.table (0,[]) in + let waiting, to_run = MH.fold (update_key t) t.table (0, []) in t.waiting <- waiting; - if waiting = 0 && to_run = [] - then + if waiting = 0 && to_run = [] then (* the table is empty: we do not need to clean in 1 second *) t.cleaning <- None else launch_cleaning t; @@ -72,47 +57,42 @@ module Make (H : Hashtbl.HashedType) : (S with type key = H.t) = struct and launch_cleaning t = t.cleaning <- - let t = - Lwt_unix.sleep 1. >>= fun () -> - Lwt.catch - (fun () -> + (let t = + Lwt_unix.sleep 1. >>= fun () -> + Lwt.catch + (fun () -> clean_table t; Lwt.return_unit) - (fun _exn -> + (fun _exn -> (* Not good practice, but not worse than the code it is replacing. *) prerr_endline "internal error"; Printexc.print_backtrace stderr; Lwt.return ()) - in - Some t + in + Some t) let really_wait t elt = - let w,u = Lwt.task () in - if t.max > t.waiting - then (Queue.add u elt.queue; - t.waiting <- succ t.waiting; - w) + let w, u = Lwt.task () in + if t.max > t.waiting then ( + Queue.add u elt.queue; + t.waiting <- succ t.waiting; + w) else Lwt.return_false let wait t key = let res = try let elt = MH.find t.table key in - if elt.consumed >= t.rate - then really_wait t elt - else (elt.consumed <- succ elt.consumed; - Lwt.return_true) - with - | Not_found -> - let elt = { consumed = 1; - queue = Queue.create () } in + if elt.consumed >= t.rate then really_wait t elt + else ( + elt.consumed <- succ elt.consumed; + Lwt.return_true) + with Not_found -> + let elt = { consumed = 1; queue = Queue.create () } in MH.add t.table key elt; Lwt.return_true in - (match t.cleaning with - | None -> launch_cleaning t - | Some _ -> ()); + (match t.cleaning with None -> launch_cleaning t | Some _ -> ()); res - end diff --git a/src/unix/lwt_throttle.mli b/src/unix/lwt_throttle.mli index f3f8d25713..627bc355e7 100644 --- a/src/unix/lwt_throttle.mli +++ b/src/unix/lwt_throttle.mli @@ -1,8 +1,6 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Rate limiters. A rate limiter allows generating sets of promises that will be resolved in @@ -20,9 +18,10 @@ module type S = sig (** Creates a rate limiter. @param rate Maximum number of promise resolutions per second, per channel. - @param max Maximum number of pending promises allowed at once, over all - channels. - @param n Initial size of the internal channel hash table. This should be + @param max + Maximum number of pending promises allowed at once, over all channels. + @param n + Initial size of the internal channel hash table. This should be approximately the number of different channels that will be used. *) val wait : t -> key -> bool Lwt.t diff --git a/src/unix/lwt_timeout.ml b/src/unix/lwt_timeout.ml index 77993038b3..f215081b40 100644 --- a/src/unix/lwt_timeout.ml +++ b/src/unix/lwt_timeout.ml @@ -1,14 +1,15 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - -type t = - { mutable delay : int; action : unit -> unit; - mutable prev : t; mutable next : t } +type t = { + mutable delay : int; + action : unit -> unit; + mutable prev : t; + mutable next : t; +} let make delay action = - let rec x = { delay = delay; action = action; prev = x; next = x } in + let rec x = { delay; action; prev = x; next = x } in x let lst_empty () = make (-1) (fun () -> ()) @@ -29,63 +30,58 @@ let lst_insert p x = n.prev <- x let lst_in_list x = x.next != x - let lst_is_empty set = set.next == set -let lst_peek s = let x = s.next in lst_remove x; x +let lst_peek s = + let x = s.next in + lst_remove x; + x (****) let count = ref 0 - let buckets = ref [||] - let curr = ref 0 - let stopped = ref true let size l = let len = Array.length !buckets in - if l >= len then begin + if l >= len then ( let b = Array.init (l + 1) (fun _ -> lst_empty ()) in Array.blit !buckets !curr b 0 (len - !curr); Array.blit !buckets 0 b (len - !curr) !curr; - buckets := b; curr := 0; - end + buckets := b; + curr := 0) (****) -let handle_exn = - ref - (fun exn -> - !Lwt.async_exception_hook exn) - +let handle_exn = ref (fun exn -> !Lwt.async_exception_hook exn) let set_exn_handler f = handle_exn := f let rec loop () = stopped := false; Lwt.bind (Lwt_unix.sleep 1.) (fun () -> - let s = !buckets.(!curr) in - while not (lst_is_empty s) do - let x = lst_peek s in - decr count; - (*XXX Should probably report any exception *) - try - x.action () - with e -> !handle_exn e - done; - curr := (!curr + 1) mod (Array.length !buckets); - if !count > 0 then loop () else begin stopped := true; Lwt.return_unit end) + let s = !buckets.(!curr) in + while not (lst_is_empty s) do + let x = lst_peek s in + decr count; + (*XXX Should probably report any exception *) + try x.action () with e -> !handle_exn e + done; + curr := (!curr + 1) mod Array.length !buckets; + if !count > 0 then loop () + else ( + stopped := true; + Lwt.return_unit)) let start x = let in_list = lst_in_list x in - let slot = (!curr + x.delay) mod (Array.length !buckets) in + let slot = (!curr + x.delay) mod Array.length !buckets in lst_remove x; lst_insert !buckets.(slot) x; - if not in_list then begin + if not in_list then ( incr count; - if !count = 1 && !stopped then ignore (loop ()) - end + if !count = 1 && !stopped then ignore (loop ())) let create delay action = if delay < 1 then invalid_arg "Lwt_timeout.create"; @@ -94,10 +90,9 @@ let create delay action = x let stop x = - if lst_in_list x then begin + if lst_in_list x then ( lst_remove x; - decr count - end + decr count) let change x delay = if delay < 1 then invalid_arg "Lwt_timeout.change"; diff --git a/src/unix/lwt_timeout.mli b/src/unix/lwt_timeout.mli index b6f8a7811e..8ea9bd7809 100644 --- a/src/unix/lwt_timeout.mli +++ b/src/unix/lwt_timeout.mli @@ -1,8 +1,6 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Cancelable timeouts. *) type t @@ -18,12 +16,11 @@ val start : t -> unit (** Starts the given timeout. Starting a timeout that has already been started has the same effect as - stopping it, and then restarting it with its original duration. So, - suppose you have [timeout] with a duration of three seconds, which was - started two seconds ago. The next call to its action is scheduled for one - second in the future. Calling [Lwt_timeout.start timeout] at this point - cancels this upcoming action call, and schedules a call three seconds from - now. *) + stopping it, and then restarting it with its original duration. So, suppose + you have [timeout] with a duration of three seconds, which was started two + seconds ago. The next call to its action is scheduled for one second in the + future. Calling [Lwt_timeout.start timeout] at this point cancels this + upcoming action call, and schedules a call three seconds from now. *) val stop : t -> unit (** Stops (cancels) the given timeout. *) diff --git a/test/core/main.ml b/test/core/main.ml index 9794276550..3a432c603f 100644 --- a/test/core/main.ml +++ b/test/core/main.ml @@ -1,20 +1,19 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - Test.run "core" - (Test_lwt.suites @ [ - Test_lwt_stream.suite; - Test_lwt_list.suite_primary; - Test_lwt_list.suite_intensive; - Test_lwt_switch.suite; - Test_lwt_mutex.suite; - Test_lwt_result.suite; - Test_lwt_mvar.suite; - Test_lwt_condition.suite; - Test_lwt_pool.suite; - Test_lwt_sequence.suite; - Test_lwt_seq.suite_base; - Test_lwt_seq.suite_fuzzing; - ]) + (Test_lwt.suites + @ [ + Test_lwt_stream.suite; + Test_lwt_list.suite_primary; + Test_lwt_list.suite_intensive; + Test_lwt_switch.suite; + Test_lwt_mutex.suite; + Test_lwt_result.suite; + Test_lwt_mvar.suite; + Test_lwt_condition.suite; + Test_lwt_pool.suite; + Test_lwt_sequence.suite; + Test_lwt_seq.suite_base; + Test_lwt_seq.suite_fuzzing; + ]) diff --git a/test/core/test_lwt.ml b/test/core/test_lwt.ml index 7c14f5ecd1..8fb8d4dd17 100644 --- a/test/core/test_lwt.ml +++ b/test/core/test_lwt.ml @@ -1,29 +1,23 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] + module Lwt_sequence = Lwt_sequence + [@@@ocaml.warning "+3"] open Test - - -let state_is = - Lwt.debug_state_is +let state_is = Lwt.debug_state_is (* When using JavaScript promises, this runs [f] on the next "tick." *) -let later f = - Lwt.map f Lwt.return_unit - - +let later f = Lwt.map f Lwt.return_unit (* An exception type fresh to this testing module. *) exception Exception @@ -40,4349 +34,3643 @@ let set_async_exception_hook hook = are broken right now, so neither of these is done. *) let add_loc exn = try raise exn with exn -> exn - - (* The list of all the test suites in this file. This name is repeatedly shadowed as more and more test suites are defined. The purpose is to keep the aggregation of test suites local to their definition, instead of having to maintain a list in a separate location in the code. *) let suites : Test.suite list = [] - - (* Tests for promises created with [Lwt.return], [Lwt.fail], and related functions, as well as state query (hard to test one without the other). These tests use assertions instead of relying on the correctness of a final [Lwt.return], not that it's particularly likely to be broken. *) -let trivial_promise_tests = suite "trivial promises" [ - test "return" begin fun () -> - state_is (Lwt.Return "foo") (Lwt.return "foo") - end; - - test "reject" begin fun () -> - state_is (Lwt.Fail Exception) (Lwt.fail Exception) - end; - - test "of_result: fulfilled" begin fun () -> - state_is (Lwt.Return "foo") (Lwt.of_result (Result.Ok "foo")) - end; - - test "of_result: rejected" begin fun () -> - state_is (Lwt.Fail Exception) (Lwt.of_result (Result.Error Exception)) - end; - - test "return_unit" begin fun () -> - state_is (Lwt.Return ()) Lwt.return_unit - end; - - test "return_true" begin fun () -> - state_is (Lwt.Return true) Lwt.return_true - end; - - test "return_false" begin fun () -> - state_is (Lwt.Return false) Lwt.return_false - end; - - test "return_none" begin fun () -> - state_is (Lwt.Return None) Lwt.return_none - end; - - test "return_some" begin fun () -> - state_is (Lwt.Return (Some "foo")) (Lwt.return_some "foo") - end; - - test "return_ok" begin fun () -> - state_is (Lwt.Return (Result.Ok "foo")) (Lwt.return_ok "foo") - end; - - test "return_error" begin fun () -> - state_is (Lwt.Return (Result.Error "foo")) (Lwt.return_error "foo") - end; - - test "fail_with" begin fun () -> - state_is (Lwt.Fail (Failure "foo")) (Lwt.fail_with "foo") - end; - - test "fail_invalid_arg" begin fun () -> - state_is (Lwt.Fail (Invalid_argument "foo")) (Lwt.fail_invalid_arg "foo") - end; -] -let suites = suites @ [trivial_promise_tests] - - +let trivial_promise_tests = + suite "trivial promises" + [ + test "return" (fun () -> state_is (Lwt.Return "foo") (Lwt.return "foo")); + test "reject" (fun () -> + state_is (Lwt.Fail Exception) (Lwt.fail Exception)); + test "of_result: fulfilled" (fun () -> + state_is (Lwt.Return "foo") (Lwt.of_result (Result.Ok "foo"))); + test "of_result: rejected" (fun () -> + state_is (Lwt.Fail Exception) (Lwt.of_result (Result.Error Exception))); + test "return_unit" (fun () -> state_is (Lwt.Return ()) Lwt.return_unit); + test "return_true" (fun () -> state_is (Lwt.Return true) Lwt.return_true); + test "return_false" (fun () -> + state_is (Lwt.Return false) Lwt.return_false); + test "return_none" (fun () -> state_is (Lwt.Return None) Lwt.return_none); + test "return_some" (fun () -> + state_is (Lwt.Return (Some "foo")) (Lwt.return_some "foo")); + test "return_ok" (fun () -> + state_is (Lwt.Return (Result.Ok "foo")) (Lwt.return_ok "foo")); + test "return_error" (fun () -> + state_is (Lwt.Return (Result.Error "foo")) (Lwt.return_error "foo")); + test "fail_with" (fun () -> + state_is (Lwt.Fail (Failure "foo")) (Lwt.fail_with "foo")); + test "fail_invalid_arg" (fun () -> + state_is (Lwt.Fail (Invalid_argument "foo")) + (Lwt.fail_invalid_arg "foo")); + ] + +let suites = suites @ [ trivial_promise_tests ] (* Tests for promises created with [Lwt.wait] and [Lwt.task], not including tests for cancellation of the latter. Tests for double use of [Lwt.wakeup] and related functions are in a separated suite. So are tests for [Lwt.wakeup_later] and related functions. *) -let initial_promise_tests = suite "initial promises" [ - test "wait: pending" begin fun () -> - let p, _ = Lwt.wait () in - state_is Lwt.Sleep p - end; - - test "task: pending" begin fun () -> - let p, _ = Lwt.task () in - state_is Lwt.Sleep p - end; - - test "wait: fulfill" begin fun () -> - let p, r = Lwt.wait () in - Lwt.wakeup r "foo"; - state_is (Lwt.Return "foo") p - end; - - test "task: fulfill" begin fun () -> - let p, r = Lwt.task () in - Lwt.wakeup r "foo"; - state_is (Lwt.Return "foo") p - end; - - test "wait: reject" begin fun () -> - let p, r = Lwt.wait () in - Lwt.wakeup_exn r Exception; - state_is (Lwt.Fail Exception) p - end; - - test "task: reject" begin fun () -> - let p, r = Lwt.task () in - Lwt.wakeup_exn r Exception; - state_is (Lwt.Fail Exception) p - end; - - test "wait: resolve" begin fun () -> - let p, r = Lwt.wait () in - Lwt.wakeup_result r (Result.Ok "foo"); - state_is (Lwt.Return "foo") p - end; - - test "task: resolve" begin fun () -> - let p, r = Lwt.task () in - Lwt.wakeup_result r (Result.Ok "foo"); - state_is (Lwt.Return "foo") p - end; - - test "waiter_of_wakener" begin fun () -> - let p, r = Lwt.wait () in - Lwt.return ((Lwt.waiter_of_wakener [@ocaml.warning "-3"]) r == p) - end; -] -let suites = suites @ [initial_promise_tests] - -let double_resolve_tests = suite "double resolve" [ - test "wakeup: double use on wait" begin fun () -> - let _, r = Lwt.wait () in - Lwt.wakeup r "foo"; - try - Lwt.wakeup r "foo"; - Lwt.return false - with Invalid_argument "Lwt.wakeup" -> - Lwt.return true - end [@ocaml.warning "-52"]; - - test "wakeup: double use on task" begin fun () -> - let _, r = Lwt.task () in - Lwt.wakeup r "foo"; - try - Lwt.wakeup r "foo"; - Lwt.return false - with Invalid_argument "Lwt.wakeup" -> - Lwt.return true - end [@ocaml.warning "-52"]; - - test "wakeup_exn: double use on wait" begin fun () -> - let _, r = Lwt.wait () in - Lwt.wakeup_exn r Exception; - try - Lwt.wakeup_exn r Exception; - Lwt.return false - with Invalid_argument "Lwt.wakeup_exn" -> - Lwt.return true - end [@ocaml.warning "-52"]; - - test "wakeup_exn: double use on task" begin fun () -> - let _, r = Lwt.task () in - Lwt.wakeup_exn r Exception; - try - Lwt.wakeup_exn r Exception; - Lwt.return false - with Invalid_argument "Lwt.wakeup_exn" -> - Lwt.return true - end [@ocaml.warning "-52"]; - - test "wakeup_result: double use on wait" begin fun () -> - let _, r = Lwt.wait () in - Lwt.wakeup_exn r Exception; - try - Lwt.wakeup_result r (Result.Ok ()); - Lwt.return false - with Invalid_argument "Lwt.wakeup_result" -> - Lwt.return true - end [@ocaml.warning "-52"]; - - test "wakeup_result: double use on task" begin fun () -> - let _, r = Lwt.task () in - Lwt.wakeup_exn r Exception; - try - Lwt.wakeup_result r (Result.Ok ()); - Lwt.return false - with Invalid_argument "Lwt.wakeup_result" -> - Lwt.return true - end [@ocaml.warning "-52"]; -] -let suites = suites @ [double_resolve_tests] - - +let initial_promise_tests = + suite "initial promises" + [ + test "wait: pending" (fun () -> + let p, _ = Lwt.wait () in + state_is Lwt.Sleep p); + test "task: pending" (fun () -> + let p, _ = Lwt.task () in + state_is Lwt.Sleep p); + test "wait: fulfill" (fun () -> + let p, r = Lwt.wait () in + Lwt.wakeup r "foo"; + state_is (Lwt.Return "foo") p); + test "task: fulfill" (fun () -> + let p, r = Lwt.task () in + Lwt.wakeup r "foo"; + state_is (Lwt.Return "foo") p); + test "wait: reject" (fun () -> + let p, r = Lwt.wait () in + Lwt.wakeup_exn r Exception; + state_is (Lwt.Fail Exception) p); + test "task: reject" (fun () -> + let p, r = Lwt.task () in + Lwt.wakeup_exn r Exception; + state_is (Lwt.Fail Exception) p); + test "wait: resolve" (fun () -> + let p, r = Lwt.wait () in + Lwt.wakeup_result r (Result.Ok "foo"); + state_is (Lwt.Return "foo") p); + test "task: resolve" (fun () -> + let p, r = Lwt.task () in + Lwt.wakeup_result r (Result.Ok "foo"); + state_is (Lwt.Return "foo") p); + test "waiter_of_wakener" (fun () -> + let p, r = Lwt.wait () in + Lwt.return ((Lwt.waiter_of_wakener [@ocaml.warning "-3"]) r == p)); + ] + +let suites = suites @ [ initial_promise_tests ] + +let double_resolve_tests = + suite "double resolve" + [ + (test "wakeup: double use on wait" (fun () -> + let _, r = Lwt.wait () in + Lwt.wakeup r "foo"; + try + Lwt.wakeup r "foo"; + Lwt.return false + with Invalid_argument "Lwt.wakeup" -> Lwt.return true) + [@ocaml.warning "-52"]); + (test "wakeup: double use on task" (fun () -> + let _, r = Lwt.task () in + Lwt.wakeup r "foo"; + try + Lwt.wakeup r "foo"; + Lwt.return false + with Invalid_argument "Lwt.wakeup" -> Lwt.return true) + [@ocaml.warning "-52"]); + (test "wakeup_exn: double use on wait" (fun () -> + let _, r = Lwt.wait () in + Lwt.wakeup_exn r Exception; + try + Lwt.wakeup_exn r Exception; + Lwt.return false + with Invalid_argument "Lwt.wakeup_exn" -> Lwt.return true) + [@ocaml.warning "-52"]); + (test "wakeup_exn: double use on task" (fun () -> + let _, r = Lwt.task () in + Lwt.wakeup_exn r Exception; + try + Lwt.wakeup_exn r Exception; + Lwt.return false + with Invalid_argument "Lwt.wakeup_exn" -> Lwt.return true) + [@ocaml.warning "-52"]); + (test "wakeup_result: double use on wait" (fun () -> + let _, r = Lwt.wait () in + Lwt.wakeup_exn r Exception; + try + Lwt.wakeup_result r (Result.Ok ()); + Lwt.return false + with Invalid_argument "Lwt.wakeup_result" -> Lwt.return true) + [@ocaml.warning "-52"]); + (test "wakeup_result: double use on task" (fun () -> + let _, r = Lwt.task () in + Lwt.wakeup_exn r Exception; + try + Lwt.wakeup_result r (Result.Ok ()); + Lwt.return false + with Invalid_argument "Lwt.wakeup_result" -> Lwt.return true) + [@ocaml.warning "-52"]); + ] + +let suites = suites @ [ double_resolve_tests ] (* Tests for sequential composition functions, such as [Lwt.bind], but not including testing for interaction with cancellation and sequence-associated storage. Those tests come later. *) -let bind_tests = suite "bind" [ - test "already fulfilled" begin fun () -> - let p = Lwt.return "foo" in - let p = Lwt.bind p (fun s -> Lwt.return (s ^ "bar")) in - state_is (Lwt.Return "foobar") p - end; - - (* A somewhat surprising behavior of native [bind] is that if [p] is fulfilled - and [f] raises before evaluating to a promise, [bind p f] raises, instead - of evaluating to a promise. On the other hand, if [p] is pending, and [f] - raises, the exception is folded into the promise resulting from [bind]. - See - - https://github.com/ocsigen/lwt/issues/329 *) - test "already fulfilled, f raises" begin fun () -> - let p = Lwt.return "foo" in - try - Lwt.bind p (fun _ -> raise Exception) |> ignore; - Lwt.return false - with Exception -> - Lwt.return true - end; - - test "already rejected" begin fun () -> - let p = Lwt.fail Exception in - let p = Lwt.bind p (fun _ -> Lwt.return "foo") in - state_is (Lwt.Fail Exception) p - end; - - test "pending" begin fun () -> - let f_ran = ref false in - let p, _ = Lwt.wait () in - let p = Lwt.bind p (fun _ -> f_ran := true; Lwt.return ()) in - Lwt.bind (state_is Lwt.Sleep p) (fun correct -> - Lwt.return (correct && !f_ran = false)) - end; - - test "pending, fulfilled" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.bind p (fun s -> Lwt.return (s ^ "bar")) in - Lwt.wakeup r "foo"; - state_is (Lwt.Return "foobar") p - end; - - test "pending, fulfilled, f raises" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.bind p (fun _ -> raise Exception) in - Lwt.wakeup r (); - state_is (Lwt.Fail Exception) p - end; - - test "pending, rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.bind p (fun _ -> Lwt.return "foo") in - Lwt.wakeup_exn r Exception; - state_is (Lwt.Fail Exception) p - end; - - test "chain" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2 = Lwt.bind p1 (fun s -> Lwt.return (s ^ "bar")) in - let p3 = Lwt.bind p2 (fun s -> Lwt.return (s ^ "!!1")) in - Lwt.wakeup r1 "foo"; - state_is (Lwt.Return "foobar!!1") p3 - end; - - test "suspended chain" begin fun () -> - let p1, r = Lwt.wait () in - let p2 = Lwt.return "foo" in - let p3 = Lwt.bind p1 (fun () -> p2) in - let p4 = Lwt.bind p1 (fun () -> p3) in - Lwt.wakeup r (); - state_is (Lwt.Return "foo") p4 - end; - - test "fanout" begin fun () -> - let p1, r = Lwt.wait () in - let p2 = Lwt.bind p1 (fun s -> Lwt.return (s ^ "bar")) in - let p3 = Lwt.bind p1 (fun s -> Lwt.return (s ^ "!!1")) in - let p4 = Lwt.bind p1 (fun s -> Lwt.return (s ^ "omg")) in - Lwt.wakeup r "foo"; - Lwt.bind (state_is (Lwt.Return "foobar") p2) (fun p2_correct -> - Lwt.bind (state_is (Lwt.Return "foo!!1") p3) (fun p3_correct -> - Lwt.bind (state_is (Lwt.Return "fooomg") p4) (fun p4_correct -> - Lwt.return (p2_correct && p3_correct && p4_correct)))) - end; - - test "double pending" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p = Lwt.bind p1 (fun _ -> p2) in - Lwt.wakeup r1 "foo"; - assert (Lwt.state p = Lwt.Sleep); - Lwt.wakeup r2 "bar"; - state_is (Lwt.Return "bar") p - end; - - test "same pending" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.bind p (fun _ -> p) in - Lwt.wakeup r "foo"; - state_is (Lwt.Return "foo") p - end; - - test "nested" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p = - Lwt.bind p1 (fun s -> Lwt.bind p2 (fun s' -> Lwt.return (s ^ s'))) in - Lwt.wakeup r1 "foo"; - Lwt.wakeup r2 "bar"; - state_is (Lwt.Return "foobar") p - end; - - (* This tests an implementation detail, namely the construction and flattening - of a chain of proxy promises. *) - test "proxy chain" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p3, r3 = Lwt.wait () in - let p4 = Lwt.bind p1 (fun _ -> p3) in - let p5 = Lwt.bind p2 (fun _ -> p4) in - Lwt.wakeup r1 (); - Lwt.wakeup r2 (); - Lwt.wakeup r3 "bar"; - Lwt.bind (state_is (Lwt.Return "bar") p3) (fun p3_correct -> - Lwt.bind (state_is (Lwt.Return "bar") p4) (fun p4_correct -> - Lwt.bind (state_is (Lwt.Return "bar") p5) (fun p5_correct -> - Lwt.return (p3_correct && p4_correct && p5_correct)))) - end; - - (* This tests an implementation detail, namely that proxy promise chaining - does not form cycles. It's only relevant for the native implementation. *) - test "cycle" begin fun () -> - let p, r = Lwt.wait () in - let p' = ref (Lwt.return ()) in - p' := Lwt.bind p (fun _ -> !p'); - Lwt.wakeup r (); - Lwt.return (Lwt.state !p' = Lwt.Sleep) - end; - - (* This tests the effect of an implementation detail: if a promise is going to - be resolved by a callback, but that promise becomes a proxy synchronously - during that callback, everything still works. *) - test "proxy during callback" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p3 = - Lwt.bind - p1 - (fun () -> - (* Synchronously resolve [p2]. Because of the [bind] below, [p3] will - become a proxy for [p4] while this callback is still running. We - then finish the callback by returning [true]. If [bind] is - implemented correctly, it will follow the [p3] proxy link to [p4] - only after the callback returns. In an earlier incorrect - implementation, this code could cause Lwt to hang forever, or crash - the process. *) - Lwt.wakeup r2 (); - Lwt.return true) - in - let p4 = Lwt.bind p2 (fun () -> p3) in - Lwt.wakeup r1 (); - p4 - end; -] -let suites = suites @ [bind_tests] - -let backtrace_bind_tests = suite "backtrace_bind" [ - test "fulfilled" begin fun () -> - let p = Lwt.return "foo" in - let p = Lwt.backtrace_bind add_loc p (fun s -> Lwt.return @@ s ^ "bar") in - state_is (Lwt.Return "foobar") p - end; - - test "rejected" begin fun () -> - let p = Lwt.fail Exception in - let p = Lwt.backtrace_bind add_loc p (fun _ -> Lwt.return "foo") in - state_is (Lwt.Fail Exception) p - end; - - test "pending, fulfilled" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.backtrace_bind add_loc p (fun s -> Lwt.return (s ^ "bar")) in - Lwt.wakeup r "foo"; - state_is (Lwt.Return "foobar") p - end; - - test "pending, fulfilled, f raises" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.backtrace_bind add_loc p (fun () -> raise Exception) in - Lwt.wakeup r (); - state_is (Lwt.Fail Exception) p - end; - - test "pending, rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.backtrace_bind add_loc p (fun _ -> Lwt.return "foo") in - Lwt.wakeup_exn r Exception; - state_is (Lwt.Fail Exception) p - end; - - (* See "proxy during callback" in [bind] tests. *) - test "proxy during callback" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p3 = - Lwt.backtrace_bind add_loc - p1 - (fun () -> - Lwt.wakeup r2 (); - Lwt.return true) - in - let p4 = Lwt.bind p2 (fun () -> p3) in - Lwt.wakeup r1 (); - p4 - end; -] -let suites = suites @ [backtrace_bind_tests] - -let map_tests = suite "map" [ - test "fulfilled" begin fun () -> - let p = Lwt.return "foo" in - let p = Lwt.map (fun s -> s ^ "bar") p in - state_is (Lwt.Return "foobar") p - end; - - test "fulfilled, f raises" begin fun () -> - let p = Lwt.return "foo" in - let p = Lwt.map (fun _ -> raise Exception) p in - state_is (Lwt.Fail Exception) p - end; - - test "rejected" begin fun () -> - let p = Lwt.fail Exception in - let p = Lwt.map (fun _ -> "foo") p in - state_is (Lwt.Fail Exception) p - end; - - test "pending" begin fun () -> - let f_ran = ref false in - let p, _ = Lwt.wait () in - let p = Lwt.map (fun _ -> f_ran := true) p in - Lwt.bind (state_is Lwt.Sleep p) (fun correct -> - Lwt.return (correct && !f_ran = false)) - end; - - test "pending, fulfilled" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.map (fun s -> s ^ "bar") p in - Lwt.wakeup r "foo"; - state_is (Lwt.Return "foobar") p - end; - - test "pending, fulfilled, f raises" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.map (fun () -> raise Exception) p in - Lwt.wakeup r (); - state_is (Lwt.Fail Exception) p - end; - - test "pending, rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.map (fun _ -> Lwt.return "foo") p in - Lwt.wakeup_exn r Exception; - state_is (Lwt.Fail Exception) p - end; - - (* See "proxy during callback" in [bind] tests. *) - test "proxy during callback" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p3 = - Lwt.map - (fun () -> - Lwt.wakeup r2 (); - true) - p1 - in - let p4 = Lwt.bind p2 (fun () -> p3) in - Lwt.wakeup r1 (); - p4 - end; -] -let suites = suites @ [map_tests] - -let catch_tests = suite "catch" [ - test "fulfilled" begin fun () -> - let p = - Lwt.catch - (fun () -> Lwt.return "foo") - (fun _ -> Lwt.return "bar") - in - state_is (Lwt.Return "foo") p - end; - - test "f raises" begin fun () -> - let p = - Lwt.catch - (fun () -> raise Exception) - (fun exn -> Lwt.return exn) - in - state_is (Lwt.Return Exception) p - end; - - test "rejected" begin fun () -> - let p = - Lwt.catch - (fun () -> Lwt.fail Exception) - (fun exn -> Lwt.return exn) - in - state_is (Lwt.Return Exception) p - end; - - (* This is an analog of the "bind quirk," see - - https://github.com/ocsigen/lwt/issues/329 *) - test "rejected, h raises" begin fun () -> - try - ignore @@ Lwt.catch - (fun () -> Lwt.fail Exit) - (fun _ -> raise Exception); - Lwt.return false - with Exception -> - Lwt.return true - end; - - test "pending" begin fun () -> - let h_ran = ref false in - let p = - Lwt.catch - (fun () -> fst (Lwt.wait ())) - (fun _ -> h_ran := true; Lwt.return ()) - in - Lwt.bind (state_is Lwt.Sleep p) (fun correct -> - Lwt.return (correct && !h_ran = false)) - end; - - test "pending, fulfilled" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.catch - (fun () -> p) - (fun _ -> Lwt.return "bar") - in - Lwt.wakeup r "foo"; - state_is (Lwt.Return "foo") p - end; - - test "pending, rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.catch - (fun () -> p) - (fun exn -> Lwt.return exn) - in - Lwt.wakeup_exn r Exception; - state_is (Lwt.Return Exception) p - end; - - test "pending, rejected, h raises" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.catch - (fun () -> p) - (fun _ -> raise Exception) - in - Lwt.wakeup_exn r Exit; - state_is (Lwt.Fail Exception) p - end; - - test "pending, rejected, h pending" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p = - Lwt.catch - (fun () -> p1) - (fun _ -> p2) - in - Lwt.wakeup_exn r1 Exception; - assert (Lwt.state p = Lwt.Sleep); - Lwt.wakeup r2 "foo"; - state_is (Lwt.Return "foo") p - end; - - (* See "proxy during callback" in [bind] tests. *) - test "proxy during callback" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p3 = - Lwt.catch - (fun () -> p1) - (fun _exn -> - Lwt.wakeup r2 (); - Lwt.return true) - in - let p4 = Lwt.bind p2 (fun () -> p3) in - Lwt.wakeup_exn r1 Exit; - p4 - end; -] -let suites = suites @ [catch_tests] - -let backtrace_catch_tests = suite "backtrace_catch" [ - test "fulfilled" begin fun () -> - let p = - Lwt.backtrace_catch add_loc - (fun () -> Lwt.return "foo") - (fun _ -> Lwt.return "bar") - in - state_is (Lwt.Return "foo") p - end; - - test "f raises" begin fun () -> - let p = - Lwt.backtrace_catch add_loc - (fun () -> raise Exception) - (fun exn -> Lwt.return exn) - in - state_is (Lwt.Return Exception) p - end; - - test "rejected" begin fun () -> - let p = - Lwt.backtrace_catch add_loc - (fun () -> Lwt.fail Exception) - (fun exn -> Lwt.return exn) - in - state_is (Lwt.Return Exception) p - end; - - test "pending" begin fun () -> - let h_ran = ref false in - let p = - Lwt.backtrace_catch add_loc - (fun () -> fst (Lwt.wait ())) - (fun _ -> h_ran := true; Lwt.return ()) - in - state_is Lwt.Sleep p - end; - - test "pending, fulfilled" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.backtrace_catch add_loc - (fun () -> p) - (fun _ -> Lwt.return "bar") - in - Lwt.wakeup r "foo"; - state_is (Lwt.Return "foo") p - end; - - test "pending, rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.backtrace_catch add_loc - (fun () -> p) - (fun exn -> Lwt.return exn) - in - Lwt.wakeup_exn r Exception; - state_is (Lwt.Return Exception) p - end; - - test "pending, rejected, h raises" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.backtrace_catch add_loc - (fun () -> p) - (fun _ -> raise Exception) - in - Lwt.wakeup_exn r Exit; - state_is (Lwt.Fail Exception) p - end; - - (* See "proxy during callback" in [bind] tests. *) - test "proxy during callback" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p3 = - Lwt.backtrace_catch add_loc - (fun () -> p1) - (fun _exn -> +let bind_tests = + suite "bind" + [ + test "already fulfilled" (fun () -> + let p = Lwt.return "foo" in + let p = Lwt.bind p (fun s -> Lwt.return (s ^ "bar")) in + state_is (Lwt.Return "foobar") p); + (* A somewhat surprising behavior of native [bind] is that if [p] is fulfilled + and [f] raises before evaluating to a promise, [bind p f] raises, instead + of evaluating to a promise. On the other hand, if [p] is pending, and [f] + raises, the exception is folded into the promise resulting from [bind]. + See + + https://github.com/ocsigen/lwt/issues/329 *) + test "already fulfilled, f raises" (fun () -> + let p = Lwt.return "foo" in + try + Lwt.bind p (fun _ -> raise Exception) |> ignore; + Lwt.return false + with Exception -> Lwt.return true); + test "already rejected" (fun () -> + let p = Lwt.fail Exception in + let p = Lwt.bind p (fun _ -> Lwt.return "foo") in + state_is (Lwt.Fail Exception) p); + test "pending" (fun () -> + let f_ran = ref false in + let p, _ = Lwt.wait () in + let p = + Lwt.bind p (fun _ -> + f_ran := true; + Lwt.return ()) + in + Lwt.bind (state_is Lwt.Sleep p) (fun correct -> + Lwt.return (correct && !f_ran = false))); + test "pending, fulfilled" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.bind p (fun s -> Lwt.return (s ^ "bar")) in + Lwt.wakeup r "foo"; + state_is (Lwt.Return "foobar") p); + test "pending, fulfilled, f raises" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.bind p (fun _ -> raise Exception) in + Lwt.wakeup r (); + state_is (Lwt.Fail Exception) p); + test "pending, rejected" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.bind p (fun _ -> Lwt.return "foo") in + Lwt.wakeup_exn r Exception; + state_is (Lwt.Fail Exception) p); + test "chain" (fun () -> + let p1, r1 = Lwt.wait () in + let p2 = Lwt.bind p1 (fun s -> Lwt.return (s ^ "bar")) in + let p3 = Lwt.bind p2 (fun s -> Lwt.return (s ^ "!!1")) in + Lwt.wakeup r1 "foo"; + state_is (Lwt.Return "foobar!!1") p3); + test "suspended chain" (fun () -> + let p1, r = Lwt.wait () in + let p2 = Lwt.return "foo" in + let p3 = Lwt.bind p1 (fun () -> p2) in + let p4 = Lwt.bind p1 (fun () -> p3) in + Lwt.wakeup r (); + state_is (Lwt.Return "foo") p4); + test "fanout" (fun () -> + let p1, r = Lwt.wait () in + let p2 = Lwt.bind p1 (fun s -> Lwt.return (s ^ "bar")) in + let p3 = Lwt.bind p1 (fun s -> Lwt.return (s ^ "!!1")) in + let p4 = Lwt.bind p1 (fun s -> Lwt.return (s ^ "omg")) in + Lwt.wakeup r "foo"; + Lwt.bind (state_is (Lwt.Return "foobar") p2) (fun p2_correct -> + Lwt.bind (state_is (Lwt.Return "foo!!1") p3) (fun p3_correct -> + Lwt.bind (state_is (Lwt.Return "fooomg") p4) + (fun p4_correct -> + Lwt.return (p2_correct && p3_correct && p4_correct))))); + test "double pending" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p = Lwt.bind p1 (fun _ -> p2) in + Lwt.wakeup r1 "foo"; + assert (Lwt.state p = Lwt.Sleep); + Lwt.wakeup r2 "bar"; + state_is (Lwt.Return "bar") p); + test "same pending" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.bind p (fun _ -> p) in + Lwt.wakeup r "foo"; + state_is (Lwt.Return "foo") p); + test "nested" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p = + Lwt.bind p1 (fun s -> Lwt.bind p2 (fun s' -> Lwt.return (s ^ s'))) + in + Lwt.wakeup r1 "foo"; + Lwt.wakeup r2 "bar"; + state_is (Lwt.Return "foobar") p); + (* This tests an implementation detail, namely the construction and flattening + of a chain of proxy promises. *) + test "proxy chain" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p3, r3 = Lwt.wait () in + let p4 = Lwt.bind p1 (fun _ -> p3) in + let p5 = Lwt.bind p2 (fun _ -> p4) in + Lwt.wakeup r1 (); Lwt.wakeup r2 (); - Lwt.return true) - in - let p4 = Lwt.bind p2 (fun () -> p3) in - Lwt.wakeup_exn r1 Exit; - p4 - end; -] -let suites = suites @ [backtrace_catch_tests] - -let try_bind_tests = suite "try_bind" [ - test "fulfilled" begin fun () -> - let p = - Lwt.try_bind - (fun () -> Lwt.return "foo") - (fun s -> Lwt.return (s ^ "bar")) - (fun _ -> Lwt.return "!!1") - in - state_is (Lwt.Return "foobar") p - end; - - (* An analog of the bind quirk. *) - test "fulfilled, f' raises" begin fun () -> - try - ignore @@ Lwt.try_bind - (fun () -> Lwt.return ()) - (fun () -> raise Exception) - (fun _ -> Lwt.return ()); - Lwt.return false - with Exception -> - Lwt.return true - end; - - test "rejected" begin fun () -> - let p = - Lwt.try_bind - (fun () -> Lwt.fail Exception) - (fun _ -> Lwt.return Exit) - (fun exn -> Lwt.return exn) - in - state_is (Lwt.Return Exception) p - end; - - test "f raises" begin fun () -> - let p = - Lwt.try_bind - (fun () -> raise Exception) - (fun _ -> Lwt.return Exit) - (fun exn -> Lwt.return exn) - in - state_is (Lwt.Return Exception) p - end; - - (* Another analog of the bind quirk *) - test "rejected, h raises" begin fun () -> - try - ignore @@ Lwt.try_bind - (fun () -> Lwt.fail Exit) - (fun _ -> Lwt.return ()) - (fun _ -> raise Exception); - Lwt.return false - with Exception -> - Lwt.return true - end; - - test "pending" begin fun () -> - let f_ran = ref false in - let p, _ = Lwt.wait () in - let p = - Lwt.try_bind - (fun () -> p) - (fun _ -> f_ran := true; Lwt.return ()) - (fun _ -> f_ran := true; Lwt.return ()) - in - Lwt.bind (state_is Lwt.Sleep p) (fun correct -> - Lwt.return (correct && not !f_ran)) - end; - - test "pending, fulfilled" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.try_bind - (fun () -> p) - (fun s -> Lwt.return (s ^ "bar")) - (fun _ -> Lwt.return "!!1") - in - Lwt.wakeup r "foo"; - state_is (Lwt.Return "foobar") p - end; - - test "pending, fulfilled, f' raises" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.try_bind - (fun () -> p) - (fun _ -> raise Exception) - (fun _ -> Lwt.return ()) - in - Lwt.wakeup r (); - state_is (Lwt.Fail Exception) p - end; - - test "pending, fulfilled, f' pending" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p = - Lwt.try_bind - (fun () -> p1) - (fun () -> p2) - (fun _ -> Lwt.return "bar") - in - Lwt.wakeup r1 (); - assert (Lwt.state p = Lwt.Sleep); - Lwt.wakeup r2 "foo"; - state_is (Lwt.Return "foo") p - end; - - test "pending, rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.try_bind - (fun () -> p) - (fun _ -> Lwt.return Exit) - (fun exn -> Lwt.return exn) - in - Lwt.wakeup_exn r Exception; - state_is (Lwt.Return Exception) p - end; - - test "pending, rejected, h raises" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.try_bind - (fun () -> p) - (fun _ -> Lwt.return ()) - (fun _ -> raise Exception) - in - Lwt.wakeup_exn r Exit; - state_is (Lwt.Fail Exception) p - end; - - test "pending, rejected, h pending" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p = - Lwt.try_bind - (fun () -> p1) - (fun () -> Lwt.return "foo") - (fun _ -> p2) - in - Lwt.wakeup_exn r1 Exception; - assert (Lwt.state p = Lwt.Sleep); - Lwt.wakeup r2 "bar"; - state_is (Lwt.Return "bar") p - end; - - (* See "proxy during callback" in [bind] tests. *) - test "proxy during callback (fulfilled)" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p3 = - Lwt.try_bind - (fun () -> p1) - (fun () -> + Lwt.wakeup r3 "bar"; + Lwt.bind (state_is (Lwt.Return "bar") p3) (fun p3_correct -> + Lwt.bind (state_is (Lwt.Return "bar") p4) (fun p4_correct -> + Lwt.bind (state_is (Lwt.Return "bar") p5) (fun p5_correct -> + Lwt.return (p3_correct && p4_correct && p5_correct))))); + (* This tests an implementation detail, namely that proxy promise chaining + does not form cycles. It's only relevant for the native implementation. *) + test "cycle" (fun () -> + let p, r = Lwt.wait () in + let p' = ref (Lwt.return ()) in + p' := Lwt.bind p (fun _ -> !p'); + Lwt.wakeup r (); + Lwt.return (Lwt.state !p' = Lwt.Sleep)); + (* This tests the effect of an implementation detail: if a promise is going to + be resolved by a callback, but that promise becomes a proxy synchronously + during that callback, everything still works. *) + test "proxy during callback" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p3 = + Lwt.bind p1 (fun () -> + (* Synchronously resolve [p2]. Because of the [bind] below, [p3] will + become a proxy for [p4] while this callback is still running. We + then finish the callback by returning [true]. If [bind] is + implemented correctly, it will follow the [p3] proxy link to [p4] + only after the callback returns. In an earlier incorrect + implementation, this code could cause Lwt to hang forever, or crash + the process. *) + Lwt.wakeup r2 (); + Lwt.return true) + in + let p4 = Lwt.bind p2 (fun () -> p3) in + Lwt.wakeup r1 (); + p4); + ] + +let suites = suites @ [ bind_tests ] + +let backtrace_bind_tests = + suite "backtrace_bind" + [ + test "fulfilled" (fun () -> + let p = Lwt.return "foo" in + let p = + Lwt.backtrace_bind add_loc p (fun s -> Lwt.return @@ s ^ "bar") + in + state_is (Lwt.Return "foobar") p); + test "rejected" (fun () -> + let p = Lwt.fail Exception in + let p = Lwt.backtrace_bind add_loc p (fun _ -> Lwt.return "foo") in + state_is (Lwt.Fail Exception) p); + test "pending, fulfilled" (fun () -> + let p, r = Lwt.wait () in + let p = + Lwt.backtrace_bind add_loc p (fun s -> Lwt.return (s ^ "bar")) + in + Lwt.wakeup r "foo"; + state_is (Lwt.Return "foobar") p); + test "pending, fulfilled, f raises" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.backtrace_bind add_loc p (fun () -> raise Exception) in + Lwt.wakeup r (); + state_is (Lwt.Fail Exception) p); + test "pending, rejected" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.backtrace_bind add_loc p (fun _ -> Lwt.return "foo") in + Lwt.wakeup_exn r Exception; + state_is (Lwt.Fail Exception) p); + (* See "proxy during callback" in [bind] tests. *) + test "proxy during callback" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p3 = + Lwt.backtrace_bind add_loc p1 (fun () -> + Lwt.wakeup r2 (); + Lwt.return true) + in + let p4 = Lwt.bind p2 (fun () -> p3) in + Lwt.wakeup r1 (); + p4); + ] + +let suites = suites @ [ backtrace_bind_tests ] + +let map_tests = + suite "map" + [ + test "fulfilled" (fun () -> + let p = Lwt.return "foo" in + let p = Lwt.map (fun s -> s ^ "bar") p in + state_is (Lwt.Return "foobar") p); + test "fulfilled, f raises" (fun () -> + let p = Lwt.return "foo" in + let p = Lwt.map (fun _ -> raise Exception) p in + state_is (Lwt.Fail Exception) p); + test "rejected" (fun () -> + let p = Lwt.fail Exception in + let p = Lwt.map (fun _ -> "foo") p in + state_is (Lwt.Fail Exception) p); + test "pending" (fun () -> + let f_ran = ref false in + let p, _ = Lwt.wait () in + let p = Lwt.map (fun _ -> f_ran := true) p in + Lwt.bind (state_is Lwt.Sleep p) (fun correct -> + Lwt.return (correct && !f_ran = false))); + test "pending, fulfilled" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.map (fun s -> s ^ "bar") p in + Lwt.wakeup r "foo"; + state_is (Lwt.Return "foobar") p); + test "pending, fulfilled, f raises" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.map (fun () -> raise Exception) p in + Lwt.wakeup r (); + state_is (Lwt.Fail Exception) p); + test "pending, rejected" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.map (fun _ -> Lwt.return "foo") p in + Lwt.wakeup_exn r Exception; + state_is (Lwt.Fail Exception) p); + (* See "proxy during callback" in [bind] tests. *) + test "proxy during callback" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p3 = + Lwt.map + (fun () -> + Lwt.wakeup r2 (); + true) + p1 + in + let p4 = Lwt.bind p2 (fun () -> p3) in + Lwt.wakeup r1 (); + p4); + ] + +let suites = suites @ [ map_tests ] + +let catch_tests = + suite "catch" + [ + test "fulfilled" (fun () -> + let p = + Lwt.catch (fun () -> Lwt.return "foo") (fun _ -> Lwt.return "bar") + in + state_is (Lwt.Return "foo") p); + test "f raises" (fun () -> + let p = + Lwt.catch (fun () -> raise Exception) (fun exn -> Lwt.return exn) + in + state_is (Lwt.Return Exception) p); + test "rejected" (fun () -> + let p = + Lwt.catch (fun () -> Lwt.fail Exception) (fun exn -> Lwt.return exn) + in + state_is (Lwt.Return Exception) p); + (* This is an analog of the "bind quirk," see + + https://github.com/ocsigen/lwt/issues/329 *) + test "rejected, h raises" (fun () -> + try + ignore + @@ Lwt.catch (fun () -> Lwt.fail Exit) (fun _ -> raise Exception); + Lwt.return false + with Exception -> Lwt.return true); + test "pending" (fun () -> + let h_ran = ref false in + let p = + Lwt.catch + (fun () -> fst (Lwt.wait ())) + (fun _ -> + h_ran := true; + Lwt.return ()) + in + Lwt.bind (state_is Lwt.Sleep p) (fun correct -> + Lwt.return (correct && !h_ran = false))); + test "pending, fulfilled" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.catch (fun () -> p) (fun _ -> Lwt.return "bar") in + Lwt.wakeup r "foo"; + state_is (Lwt.Return "foo") p); + test "pending, rejected" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.catch (fun () -> p) (fun exn -> Lwt.return exn) in + Lwt.wakeup_exn r Exception; + state_is (Lwt.Return Exception) p); + test "pending, rejected, h raises" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.catch (fun () -> p) (fun _ -> raise Exception) in + Lwt.wakeup_exn r Exit; + state_is (Lwt.Fail Exception) p); + test "pending, rejected, h pending" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p = Lwt.catch (fun () -> p1) (fun _ -> p2) in + Lwt.wakeup_exn r1 Exception; + assert (Lwt.state p = Lwt.Sleep); + Lwt.wakeup r2 "foo"; + state_is (Lwt.Return "foo") p); + (* See "proxy during callback" in [bind] tests. *) + test "proxy during callback" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p3 = + Lwt.catch + (fun () -> p1) + (fun _exn -> + Lwt.wakeup r2 (); + Lwt.return true) + in + let p4 = Lwt.bind p2 (fun () -> p3) in + Lwt.wakeup_exn r1 Exit; + p4); + ] + +let suites = suites @ [ catch_tests ] + +let backtrace_catch_tests = + suite "backtrace_catch" + [ + test "fulfilled" (fun () -> + let p = + Lwt.backtrace_catch add_loc + (fun () -> Lwt.return "foo") + (fun _ -> Lwt.return "bar") + in + state_is (Lwt.Return "foo") p); + test "f raises" (fun () -> + let p = + Lwt.backtrace_catch add_loc + (fun () -> raise Exception) + (fun exn -> Lwt.return exn) + in + state_is (Lwt.Return Exception) p); + test "rejected" (fun () -> + let p = + Lwt.backtrace_catch add_loc + (fun () -> Lwt.fail Exception) + (fun exn -> Lwt.return exn) + in + state_is (Lwt.Return Exception) p); + test "pending" (fun () -> + let h_ran = ref false in + let p = + Lwt.backtrace_catch add_loc + (fun () -> fst (Lwt.wait ())) + (fun _ -> + h_ran := true; + Lwt.return ()) + in + state_is Lwt.Sleep p); + test "pending, fulfilled" (fun () -> + let p, r = Lwt.wait () in + let p = + Lwt.backtrace_catch add_loc + (fun () -> p) + (fun _ -> Lwt.return "bar") + in + Lwt.wakeup r "foo"; + state_is (Lwt.Return "foo") p); + test "pending, rejected" (fun () -> + let p, r = Lwt.wait () in + let p = + Lwt.backtrace_catch add_loc + (fun () -> p) + (fun exn -> Lwt.return exn) + in + Lwt.wakeup_exn r Exception; + state_is (Lwt.Return Exception) p); + test "pending, rejected, h raises" (fun () -> + let p, r = Lwt.wait () in + let p = + Lwt.backtrace_catch add_loc (fun () -> p) (fun _ -> raise Exception) + in + Lwt.wakeup_exn r Exit; + state_is (Lwt.Fail Exception) p); + (* See "proxy during callback" in [bind] tests. *) + test "proxy during callback" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p3 = + Lwt.backtrace_catch add_loc + (fun () -> p1) + (fun _exn -> + Lwt.wakeup r2 (); + Lwt.return true) + in + let p4 = Lwt.bind p2 (fun () -> p3) in + Lwt.wakeup_exn r1 Exit; + p4); + ] + +let suites = suites @ [ backtrace_catch_tests ] + +let try_bind_tests = + suite "try_bind" + [ + test "fulfilled" (fun () -> + let p = + Lwt.try_bind + (fun () -> Lwt.return "foo") + (fun s -> Lwt.return (s ^ "bar")) + (fun _ -> Lwt.return "!!1") + in + state_is (Lwt.Return "foobar") p); + (* An analog of the bind quirk. *) + test "fulfilled, f' raises" (fun () -> + try + ignore + @@ Lwt.try_bind + (fun () -> Lwt.return ()) + (fun () -> raise Exception) + (fun _ -> Lwt.return ()); + Lwt.return false + with Exception -> Lwt.return true); + test "rejected" (fun () -> + let p = + Lwt.try_bind + (fun () -> Lwt.fail Exception) + (fun _ -> Lwt.return Exit) + (fun exn -> Lwt.return exn) + in + state_is (Lwt.Return Exception) p); + test "f raises" (fun () -> + let p = + Lwt.try_bind + (fun () -> raise Exception) + (fun _ -> Lwt.return Exit) + (fun exn -> Lwt.return exn) + in + state_is (Lwt.Return Exception) p); + (* Another analog of the bind quirk *) + test "rejected, h raises" (fun () -> + try + ignore + @@ Lwt.try_bind + (fun () -> Lwt.fail Exit) + (fun _ -> Lwt.return ()) + (fun _ -> raise Exception); + Lwt.return false + with Exception -> Lwt.return true); + test "pending" (fun () -> + let f_ran = ref false in + let p, _ = Lwt.wait () in + let p = + Lwt.try_bind + (fun () -> p) + (fun _ -> + f_ran := true; + Lwt.return ()) + (fun _ -> + f_ran := true; + Lwt.return ()) + in + Lwt.bind (state_is Lwt.Sleep p) (fun correct -> + Lwt.return (correct && not !f_ran))); + test "pending, fulfilled" (fun () -> + let p, r = Lwt.wait () in + let p = + Lwt.try_bind + (fun () -> p) + (fun s -> Lwt.return (s ^ "bar")) + (fun _ -> Lwt.return "!!1") + in + Lwt.wakeup r "foo"; + state_is (Lwt.Return "foobar") p); + test "pending, fulfilled, f' raises" (fun () -> + let p, r = Lwt.wait () in + let p = + Lwt.try_bind + (fun () -> p) + (fun _ -> raise Exception) + (fun _ -> Lwt.return ()) + in + Lwt.wakeup r (); + state_is (Lwt.Fail Exception) p); + test "pending, fulfilled, f' pending" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p = + Lwt.try_bind + (fun () -> p1) + (fun () -> p2) + (fun _ -> Lwt.return "bar") + in + Lwt.wakeup r1 (); + assert (Lwt.state p = Lwt.Sleep); + Lwt.wakeup r2 "foo"; + state_is (Lwt.Return "foo") p); + test "pending, rejected" (fun () -> + let p, r = Lwt.wait () in + let p = + Lwt.try_bind + (fun () -> p) + (fun _ -> Lwt.return Exit) + (fun exn -> Lwt.return exn) + in + Lwt.wakeup_exn r Exception; + state_is (Lwt.Return Exception) p); + test "pending, rejected, h raises" (fun () -> + let p, r = Lwt.wait () in + let p = + Lwt.try_bind + (fun () -> p) + (fun _ -> Lwt.return ()) + (fun _ -> raise Exception) + in + Lwt.wakeup_exn r Exit; + state_is (Lwt.Fail Exception) p); + test "pending, rejected, h pending" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p = + Lwt.try_bind + (fun () -> p1) + (fun () -> Lwt.return "foo") + (fun _ -> p2) + in + Lwt.wakeup_exn r1 Exception; + assert (Lwt.state p = Lwt.Sleep); + Lwt.wakeup r2 "bar"; + state_is (Lwt.Return "bar") p); + (* See "proxy during callback" in [bind] tests. *) + test "proxy during callback (fulfilled)" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p3 = + Lwt.try_bind + (fun () -> p1) + (fun () -> + Lwt.wakeup r2 (); + Lwt.return true) + (fun _exn -> Lwt.return false) + in + let p4 = Lwt.bind p2 (fun () -> p3) in + Lwt.wakeup r1 (); + p4); + (* See "proxy during callback" in [bind] tests. *) + test "proxy during callback (rejected)" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p3 = + Lwt.try_bind + (fun () -> p1) + (fun () -> Lwt.return false) + (fun _exn -> + Lwt.wakeup r2 (); + Lwt.return true) + in + let p4 = Lwt.bind p2 (fun () -> p3) in + Lwt.wakeup_exn r1 Exit; + p4); + ] + +let suites = suites @ [ try_bind_tests ] + +let backtrace_try_bind_tests = + suite "backtrace_try_bind" + [ + test "fulfilled" (fun () -> + let p = + Lwt.backtrace_try_bind add_loc + (fun () -> Lwt.return "foo") + (fun s -> Lwt.return (s ^ "bar")) + (fun _ -> Lwt.return "!!1") + in + state_is (Lwt.Return "foobar") p); + test "rejected" (fun () -> + let p = + Lwt.backtrace_try_bind add_loc + (fun () -> Lwt.fail Exception) + (fun _ -> Lwt.return Exit) + (fun exn -> Lwt.return exn) + in + state_is (Lwt.Return Exception) p); + test "f raises" (fun () -> + let p = + Lwt.backtrace_try_bind add_loc + (fun () -> raise Exception) + (fun _ -> Lwt.return Exit) + (fun exn -> Lwt.return exn) + in + state_is (Lwt.Return Exception) p); + test "pending" (fun () -> + let f_ran = ref false in + let p, _ = Lwt.wait () in + let p = + Lwt.backtrace_try_bind add_loc + (fun () -> p) + (fun _ -> + f_ran := true; + Lwt.return ()) + (fun _ -> + f_ran := true; + Lwt.return ()) + in + state_is Lwt.Sleep p); + test "pending, fulfilled" (fun () -> + let p, r = Lwt.wait () in + let p = + Lwt.backtrace_try_bind add_loc + (fun () -> p) + (fun s -> Lwt.return (s ^ "bar")) + (fun _ -> Lwt.return "!!1") + in + Lwt.wakeup r "foo"; + state_is (Lwt.Return "foobar") p); + test "pending, fulfilled, f' raises" (fun () -> + let p, r = Lwt.wait () in + let p = + Lwt.backtrace_try_bind add_loc + (fun () -> p) + (fun _ -> raise Exception) + (fun _ -> Lwt.return ()) + in + Lwt.wakeup r (); + state_is (Lwt.Fail Exception) p); + test "pending, rejected" (fun () -> + let p, r = Lwt.wait () in + let p = + Lwt.backtrace_try_bind add_loc + (fun () -> p) + (fun _ -> Lwt.return Exit) + (fun exn -> Lwt.return exn) + in + Lwt.wakeup_exn r Exception; + state_is (Lwt.Return Exception) p); + test "pending, rejected, h raises" (fun () -> + let p, r = Lwt.wait () in + let p = + Lwt.backtrace_try_bind add_loc + (fun () -> p) + (fun _ -> Lwt.return ()) + (fun _ -> raise Exception) + in + Lwt.wakeup_exn r Exit; + state_is (Lwt.Fail Exception) p); + (* See "proxy during callback" in [bind] tests. *) + test "proxy during callback (fulfilled)" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p3 = + Lwt.backtrace_try_bind add_loc + (fun () -> p1) + (fun () -> + Lwt.wakeup r2 (); + Lwt.return true) + (fun _exn -> Lwt.return false) + in + let p4 = Lwt.bind p2 (fun () -> p3) in + Lwt.wakeup r1 (); + p4); + (* See "proxy during callback" in [bind] tests. *) + test "proxy during callback (rejected)" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p3 = + Lwt.backtrace_try_bind add_loc + (fun () -> p1) + (fun () -> Lwt.return false) + (fun _exn -> + Lwt.wakeup r2 (); + Lwt.return true) + in + let p4 = Lwt.bind p2 (fun () -> p3) in + Lwt.wakeup_exn r1 Exit; + p4); + ] + +let suites = suites @ [ backtrace_try_bind_tests ] + +let finalize_tests = + suite "finalize" + [ + test "fulfilled" (fun () -> + let f'_ran = ref false in + let p = + Lwt.finalize + (fun () -> Lwt.return "foo") + (fun () -> + f'_ran := true; + Lwt.return ()) + in + Lwt.bind (state_is (Lwt.Return "foo") p) (fun correct -> + Lwt.return (correct && !f'_ran = true))); + test "fulfilled, f' rejected" (fun () -> + let p = + Lwt.finalize + (fun () -> Lwt.return ()) + (fun () -> Lwt.fail Exception) + in + state_is (Lwt.Fail Exception) p); + (* An instance of the bind quirk. *) + test "fulfilled, f' raises" (fun () -> + try + ignore + @@ Lwt.finalize + (fun () -> Lwt.return ()) + (fun () -> raise Exception); + Lwt.return false + with Exception -> Lwt.return true); + test "rejected" (fun () -> + let f'_ran = ref false in + let p = + Lwt.finalize + (fun () -> Lwt.fail Exception) + (fun () -> + f'_ran := true; + Lwt.return ()) + in + Lwt.bind (state_is (Lwt.Fail Exception) p) (fun correct -> + Lwt.return (correct && !f'_ran = true))); + test "rejected, f' rejected" (fun () -> + let p = + Lwt.finalize + (fun () -> Lwt.fail Exit) + (fun () -> Lwt.fail Exception) + in + state_is (Lwt.Fail Exception) p); + (* An instance of the bind quirk. *) + test "rejected, f' raises" (fun () -> + try + ignore + @@ Lwt.finalize + (fun () -> Lwt.fail Exit) + (fun () -> raise Exception); + Lwt.return false + with Exception -> Lwt.return true); + test "pending" (fun () -> + let f'_ran = ref false in + let p, _ = Lwt.wait () in + let p = + Lwt.finalize + (fun () -> p) + (fun () -> + f'_ran := true; + Lwt.return ()) + in + Lwt.bind (state_is Lwt.Sleep p) (fun correct -> + Lwt.return (correct && !f'_ran = false))); + test "pending, fulfilled" (fun () -> + let f'_ran = ref false in + let p, r = Lwt.wait () in + let p = + Lwt.finalize + (fun () -> p) + (fun () -> + f'_ran := true; + Lwt.return ()) + in + Lwt.wakeup r "foo"; + Lwt.bind (state_is (Lwt.Return "foo") p) (fun correct -> + Lwt.return (correct && !f'_ran = true))); + test "pending, fulfilled, f' rejected" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.finalize (fun () -> p) (fun () -> Lwt.fail Exception) in + Lwt.wakeup r (); + state_is (Lwt.Fail Exception) p); + test "pending, fulfilled, f' raises" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.finalize (fun () -> p) (fun () -> raise Exception) in + Lwt.wakeup r (); + state_is (Lwt.Fail Exception) p); + test "pending, fulfilled, f' pending" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p = Lwt.finalize (fun () -> p1) (fun () -> p2) in + Lwt.wakeup r1 "foo"; + assert (Lwt.state p = Lwt.Sleep); Lwt.wakeup r2 (); - Lwt.return true) - (fun _exn -> - Lwt.return false) - in - let p4 = Lwt.bind p2 (fun () -> p3) in - Lwt.wakeup r1 (); - p4 - end; - - (* See "proxy during callback" in [bind] tests. *) - test "proxy during callback (rejected)" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p3 = - Lwt.try_bind - (fun () -> p1) - (fun () -> - Lwt.return false) - (fun _exn -> + state_is (Lwt.Return "foo") p); + test "pending, fulfilled, f' pending, rejected" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p = Lwt.finalize (fun () -> p1) (fun () -> p2) in + Lwt.wakeup r1 (); + assert (Lwt.state p = Lwt.Sleep); + Lwt.wakeup_exn r2 Exception; + state_is (Lwt.Fail Exception) p); + test "pending, rejected" (fun () -> + let f'_ran = ref false in + let p, r = Lwt.wait () in + let p = + Lwt.finalize + (fun () -> p) + (fun () -> + f'_ran := true; + Lwt.return ()) + in + Lwt.wakeup_exn r Exception; + Lwt.bind (state_is (Lwt.Fail Exception) p) (fun correct -> + Lwt.return (correct && !f'_ran = true))); + test "pending, rejected, f' rejected" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.finalize (fun () -> p) (fun () -> Lwt.fail Exception) in + Lwt.wakeup_exn r Exit; + state_is (Lwt.Fail Exception) p); + test "pending, rejected, f' raises" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.finalize (fun () -> p) (fun () -> raise Exception) in + Lwt.wakeup_exn r Exit; + state_is (Lwt.Fail Exception) p); + test "pending, rejected, f' pending" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p = Lwt.finalize (fun () -> p1) (fun () -> p2) in + Lwt.wakeup_exn r1 Exception; + assert (Lwt.state p = Lwt.Sleep); Lwt.wakeup r2 (); - Lwt.return true) - in - let p4 = Lwt.bind p2 (fun () -> p3) in - Lwt.wakeup_exn r1 Exit; - p4 - end; -] -let suites = suites @ [try_bind_tests] - -let backtrace_try_bind_tests = suite "backtrace_try_bind" [ - test "fulfilled" begin fun () -> - let p = - Lwt.backtrace_try_bind add_loc - (fun () -> Lwt.return "foo") - (fun s -> Lwt.return (s ^ "bar")) - (fun _ -> Lwt.return "!!1") - in - state_is (Lwt.Return "foobar") p - end; - - test "rejected" begin fun () -> - let p = - Lwt.backtrace_try_bind add_loc - (fun () -> Lwt.fail Exception) - (fun _ -> Lwt.return Exit) - (fun exn -> Lwt.return exn) - in - state_is (Lwt.Return Exception) p - end; - - test "f raises" begin fun () -> - let p = - Lwt.backtrace_try_bind add_loc - (fun () -> raise Exception) - (fun _ -> Lwt.return Exit) - (fun exn -> Lwt.return exn) - in - state_is (Lwt.Return Exception) p - end; - - test "pending" begin fun () -> - let f_ran = ref false in - let p, _ = Lwt.wait () in - let p = - Lwt.backtrace_try_bind add_loc - (fun () -> p) - (fun _ -> f_ran := true; Lwt.return ()) - (fun _ -> f_ran := true; Lwt.return ()) - in - state_is Lwt.Sleep p - end; - - test "pending, fulfilled" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.backtrace_try_bind add_loc - (fun () -> p) - (fun s -> Lwt.return (s ^ "bar")) - (fun _ -> Lwt.return "!!1") - in - Lwt.wakeup r "foo"; - state_is (Lwt.Return "foobar") p - end; - - test "pending, fulfilled, f' raises" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.backtrace_try_bind add_loc - (fun () -> p) - (fun _ -> raise Exception) - (fun _ -> Lwt.return ()) - in - Lwt.wakeup r (); - state_is (Lwt.Fail Exception) p - end; - - test "pending, rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.backtrace_try_bind add_loc - (fun () -> p) - (fun _ -> Lwt.return Exit) - (fun exn -> Lwt.return exn) - in - Lwt.wakeup_exn r Exception; - state_is (Lwt.Return Exception) p - end; - - test "pending, rejected, h raises" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.backtrace_try_bind add_loc - (fun () -> p) - (fun _ -> Lwt.return ()) - (fun _ -> raise Exception) - in - Lwt.wakeup_exn r Exit; - state_is (Lwt.Fail Exception) p - end; - - (* See "proxy during callback" in [bind] tests. *) - test "proxy during callback (fulfilled)" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p3 = - Lwt.backtrace_try_bind add_loc - (fun () -> p1) - (fun () -> - Lwt.wakeup r2 (); - Lwt.return true) - (fun _exn -> - Lwt.return false) - in - let p4 = Lwt.bind p2 (fun () -> p3) in - Lwt.wakeup r1 (); - p4 - end; - - (* See "proxy during callback" in [bind] tests. *) - test "proxy during callback (rejected)" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p3 = - Lwt.backtrace_try_bind add_loc - (fun () -> p1) - (fun () -> - Lwt.return false) - (fun _exn -> - Lwt.wakeup r2 (); - Lwt.return true) - in - let p4 = Lwt.bind p2 (fun () -> p3) in - Lwt.wakeup_exn r1 Exit; - p4 - end; -] -let suites = suites @ [backtrace_try_bind_tests] - -let finalize_tests = suite "finalize" [ - test "fulfilled" begin fun () -> - let f'_ran = ref false in - let p = - Lwt.finalize - (fun () -> Lwt.return "foo") - (fun () -> f'_ran := true; Lwt.return ()) - in - Lwt.bind (state_is (Lwt.Return "foo") p) (fun correct -> - Lwt.return (correct && !f'_ran = true)) - end; - - test "fulfilled, f' rejected" begin fun () -> - let p = - Lwt.finalize - (fun () -> Lwt.return ()) - (fun () -> Lwt.fail Exception) - in - state_is (Lwt.Fail Exception) p - end; - - (* An instance of the bind quirk. *) - test "fulfilled, f' raises" begin fun () -> - try - ignore @@ Lwt.finalize - (fun () -> Lwt.return ()) - (fun () -> raise Exception); - Lwt.return false - with Exception -> - Lwt.return true - end; - - test "rejected" begin fun () -> - let f'_ran = ref false in - let p = - Lwt.finalize - (fun () -> Lwt.fail Exception) - (fun () -> f'_ran := true; Lwt.return ()) - in - Lwt.bind (state_is (Lwt.Fail Exception) p) (fun correct -> - Lwt.return (correct && !f'_ran = true)) - end; - - test "rejected, f' rejected" begin fun () -> - let p = - Lwt.finalize - (fun () -> Lwt.fail Exit) - (fun () -> Lwt.fail Exception) - in - state_is (Lwt.Fail Exception) p - end; - - (* An instance of the bind quirk. *) - test "rejected, f' raises" begin fun () -> - try - ignore @@ Lwt.finalize - (fun () -> Lwt.fail Exit) - (fun () -> raise Exception); - Lwt.return false - with Exception -> - Lwt.return true - end; - - test "pending" begin fun () -> - let f'_ran = ref false in - let p, _ = Lwt.wait () in - let p = - Lwt.finalize - (fun () -> p) - (fun () -> f'_ran := true; Lwt.return ()) - in - Lwt.bind (state_is Lwt.Sleep p) (fun correct -> - Lwt.return (correct && !f'_ran = false)) - end; - - test "pending, fulfilled" begin fun () -> - let f'_ran = ref false in - let p, r = Lwt.wait () in - let p = - Lwt.finalize - (fun () -> p) - (fun () -> f'_ran := true; Lwt.return ()) - in - Lwt.wakeup r "foo"; - Lwt.bind (state_is (Lwt.Return "foo") p) (fun correct -> - Lwt.return (correct && !f'_ran = true)) - end; - - test "pending, fulfilled, f' rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.finalize - (fun () -> p) - (fun () -> Lwt.fail Exception) - in - Lwt.wakeup r (); - state_is (Lwt.Fail Exception) p - end; - - test "pending, fulfilled, f' raises" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.finalize - (fun () -> p) - (fun () -> raise Exception) - in - Lwt.wakeup r (); - state_is (Lwt.Fail Exception) p - end; - - test "pending, fulfilled, f' pending" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p = - Lwt.finalize - (fun () -> p1) - (fun () -> p2) - in - Lwt.wakeup r1 "foo"; - assert (Lwt.state p = Lwt.Sleep); - Lwt.wakeup r2 (); - state_is (Lwt.Return "foo") p - end; - - test "pending, fulfilled, f' pending, rejected" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p = - Lwt.finalize - (fun () -> p1) - (fun () -> p2) - in - Lwt.wakeup r1 (); - assert (Lwt.state p = Lwt.Sleep); - Lwt.wakeup_exn r2 Exception; - state_is (Lwt.Fail Exception) p - end; - - test "pending, rejected" begin fun () -> - let f'_ran = ref false in - let p, r = Lwt.wait () in - let p = - Lwt.finalize - (fun () -> p) - (fun () -> f'_ran := true; Lwt.return ()) - in - Lwt.wakeup_exn r Exception; - Lwt.bind (state_is (Lwt.Fail Exception) p) (fun correct -> - Lwt.return (correct && !f'_ran = true)) - end; - - test "pending, rejected, f' rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.finalize - (fun () -> p) - (fun () -> Lwt.fail Exception) - in - Lwt.wakeup_exn r Exit; - state_is (Lwt.Fail Exception) p - end; - - test "pending, rejected, f' raises" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.finalize - (fun () -> p) - (fun () -> raise Exception) - in - Lwt.wakeup_exn r Exit; - state_is (Lwt.Fail Exception) p - end; - - test "pending, rejected, f' pending" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p = - Lwt.finalize - (fun () -> p1) - (fun () -> p2) - in - Lwt.wakeup_exn r1 Exception; - assert (Lwt.state p = Lwt.Sleep); - Lwt.wakeup r2 (); - state_is (Lwt.Fail Exception) p - end; - - test "pending, rejected, f' pending, rejected" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p = - Lwt.finalize - (fun () -> p1) - (fun () -> p2) - in - Lwt.wakeup_exn r1 Exit; - assert (Lwt.state p = Lwt.Sleep); - Lwt.wakeup_exn r2 Exception; - state_is (Lwt.Fail Exception) p - end; - - (* See "proxy during callback" in [bind] tests. *) - test "proxy during callback (fulfilled)" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p3 = - Lwt.finalize - (fun () -> p1) - (fun () -> - Lwt.wakeup r2 (); - Lwt.return ()) - in - let p4 = Lwt.bind p2 (fun () -> p3) in - Lwt.wakeup r1 (); - Lwt.bind p4 (fun () -> Lwt.return true) - end; - - (* See "proxy during callback" in [bind] tests. *) - test "proxy during callback (rejected)" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p3 = - Lwt.finalize - (fun () -> p1) - (fun () -> - Lwt.wakeup r2 (); - Lwt.return ()) - in - let p4 = Lwt.bind p2 (fun () -> p3) in - Lwt.wakeup_exn r1 Exit; - Lwt.catch (fun () -> p4) (fun _exn -> Lwt.return true) - end; -] -let suites = suites @ [finalize_tests] - -let backtrace_finalize_tests = suite "backtrace_finalize" [ - test "fulfilled" begin fun () -> - let f'_ran = ref false in - let p = - Lwt.backtrace_finalize add_loc - (fun () -> Lwt.return "foo") - (fun () -> f'_ran := true; Lwt.return ()) - in - Lwt.bind (state_is (Lwt.Return "foo") p) (fun correct -> - Lwt.return (correct && !f'_ran = true)) - end; - - test "fulfilled, f' rejected" begin fun () -> - let p = - Lwt.backtrace_finalize add_loc - (fun () -> Lwt.return ()) - (fun () -> Lwt.fail Exception) - in - state_is (Lwt.Fail Exception) p - end; - - (* Instance of the bind quirk. *) - test "fulfilled, f' raises" begin fun () -> - try - ignore @@ Lwt.backtrace_finalize add_loc - (fun () -> Lwt.return ()) - (fun () -> raise Exception); - Lwt.return false - with Exception -> - Lwt.return true - end; - - test "rejected" begin fun () -> - let f'_ran = ref false in - let p = - Lwt.backtrace_finalize add_loc - (fun () -> Lwt.fail Exception) - (fun () -> f'_ran := true; Lwt.return ()) - in - Lwt.bind (state_is (Lwt.Fail Exception) p) (fun correct -> - Lwt.return (correct && !f'_ran = true)) - end; - - test "rejected, f' rejected" begin fun () -> - let p = - Lwt.backtrace_finalize add_loc - (fun () -> Lwt.fail Exit) - (fun () -> Lwt.fail Exception) - in - state_is (Lwt.Fail Exception) p - end; - - (* Instance of the bind quirk. *) - test "rejected, f' raises" begin fun () -> - try - ignore @@ Lwt.backtrace_finalize add_loc - (fun () -> Lwt.fail Exit) - (fun () -> raise Exception); - Lwt.return false - with Exception -> - Lwt.return true - end; - - test "pending" begin fun () -> - let f'_ran = ref false in - let p, _ = Lwt.wait () in - let p = - Lwt.backtrace_finalize add_loc - (fun () -> p) - (fun () -> f'_ran := true; Lwt.return ()) - in - Lwt.bind (state_is Lwt.Sleep p) (fun correct -> - Lwt.return (correct && !f'_ran = false)) - end; - - test "pending, fulfilled" begin fun () -> - let f'_ran = ref false in - let p, r = Lwt.wait () in - let p = - Lwt.backtrace_finalize add_loc - (fun () -> p) - (fun () -> f'_ran := true; Lwt.return ()) - in - Lwt.wakeup r "foo"; - Lwt.bind (state_is (Lwt.Return "foo") p) (fun correct -> - Lwt.return (correct && !f'_ran = true)) - end; - - test "pending, fulfilled, f' rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.backtrace_finalize add_loc - (fun () -> p) - (fun () -> Lwt.fail Exception) - in - Lwt.wakeup r (); - state_is (Lwt.Fail Exception) p - end; - - test "pending, fulfilled, f' raises" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.backtrace_finalize add_loc - (fun () -> p) - (fun () -> raise Exception) - in - Lwt.wakeup r (); - state_is (Lwt.Fail Exception) p - end; - - test "pending, rejected" begin fun () -> - let f'_ran = ref false in - let p, r = Lwt.wait () in - let p = - Lwt.backtrace_finalize add_loc - (fun () -> p) - (fun () -> f'_ran := true; Lwt.return ()) - in - Lwt.wakeup_exn r Exception; - Lwt.bind (state_is (Lwt.Fail Exception) p) (fun correct -> - Lwt.return (correct && !f'_ran = true)) - end; - - test "pending, rejected, f' rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.backtrace_finalize add_loc - (fun () -> p) - (fun () -> Lwt.fail Exception) - in - Lwt.wakeup_exn r Exit; - state_is (Lwt.Fail Exception) p - end; - - test "pending, rejected, f' raises" begin fun () -> - let p, r = Lwt.wait () in - let p = - Lwt.backtrace_finalize add_loc - (fun () -> p) - (fun () -> raise Exception) - in - Lwt.wakeup_exn r Exit; - state_is (Lwt.Fail Exception) p - end; - - (* See "proxy during callback" in [bind] tests. *) - test "proxy during callback (fulfilled)" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p3 = - Lwt.backtrace_finalize add_loc - (fun () -> p1) - (fun () -> - Lwt.wakeup r2 (); - Lwt.return ()) - in - let p4 = Lwt.bind p2 (fun () -> p3) in - Lwt.wakeup r1 (); - Lwt.bind p4 (fun () -> Lwt.return true) - end; - - (* See "proxy during callback" in [bind] tests. *) - test "proxy during callback (rejected)" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p3 = - Lwt.backtrace_finalize add_loc - (fun () -> p1) - (fun () -> - Lwt.wakeup r2 (); - Lwt.return ()) - in - let p4 = Lwt.bind p2 (fun () -> p3) in - Lwt.wakeup_exn r1 Exit; - Lwt.catch (fun () -> p4) (fun _exn -> Lwt.return true) - end; -] -let suites = suites @ [backtrace_finalize_tests] - -let on_success_tests = suite "on_success" [ - test "fulfilled" begin fun () -> - let f_ran = ref false in - Lwt.on_success (Lwt.return ()) (fun () -> f_ran := true); - later (fun () -> !f_ran = true) - end; - - test ~sequential:true "fulfilled, f raises" begin fun () -> - let saw = ref None in - let restore = - set_async_exception_hook (fun exn -> saw := Some exn) in - Lwt.on_success (Lwt.return ()) (fun () -> raise Exception); - later (fun () -> - restore (); - !saw = Some Exception) - end; - - test "rejected" begin fun () -> - let f_ran = ref false in - Lwt.on_success (Lwt.fail Exception) (fun () -> f_ran := true); - later (fun () -> !f_ran = false) - end; - - test "pending" begin fun () -> - let f_ran = ref false in - Lwt.on_success (fst (Lwt.wait ())) (fun () -> f_ran := true); - later (fun () -> !f_ran = false) - end; - - test "pending, fulfilled" begin fun () -> - let f_ran = ref false in - let p, r = Lwt.wait () in - Lwt.on_success p (fun () -> f_ran := true); - assert (!f_ran = false); - Lwt.wakeup r (); - later (fun () -> !f_ran = true) - end; - - test ~sequential:true "pending, fulfilled, f raises" begin fun () -> - let saw = ref None in - let p, r = Lwt.wait () in - Lwt.on_success p (fun () -> raise Exception); - let restore = - set_async_exception_hook (fun exn -> saw := Some exn) in - Lwt.wakeup r (); - later (fun () -> - restore (); - !saw = Some Exception) - end; - - test "pending, rejected" begin fun () -> - let f_ran = ref false in - let p, r = Lwt.wait () in - Lwt.on_success p (fun () -> f_ran := true); - Lwt.wakeup_exn r Exception; - later (fun () -> !f_ran = false) - end; -] -let suites = suites @ [on_success_tests] - -let on_failure_tests = suite "on_failure" [ - test "fulfilled" begin fun () -> - let f_ran = ref false in - Lwt.on_failure (Lwt.return ()) (fun _ -> f_ran := true); - later (fun () -> !f_ran = false) - end; - - test "rejected" begin fun () -> - let saw = ref None in - Lwt.on_failure (Lwt.fail Exception) (fun exn -> saw := Some exn); - later (fun () -> !saw = Some Exception) - end; - - test ~sequential:true "rejected, f raises" begin fun () -> - let saw = ref None in - let restore = - set_async_exception_hook (fun exn -> saw := Some exn) in - Lwt.on_failure (Lwt.fail Exit) (fun _ -> raise Exception); - later (fun () -> - restore (); - !saw = Some Exception) - end; - - test "pending" begin fun () -> - let f_ran = ref false in - Lwt.on_failure (fst (Lwt.wait ())) (fun _ -> f_ran := true); - later (fun () -> !f_ran = false) - end; - - test "pending, fulfilled" begin fun () -> - let f_ran = ref false in - let p, r = Lwt.wait () in - Lwt.on_failure p (fun _ -> f_ran := true); - Lwt.wakeup r (); - later (fun () -> !f_ran = false) - end; - - test "pending, rejected" begin fun () -> - let saw = ref None in - let p, r = Lwt.wait () in - Lwt.on_failure p (fun exn -> saw := Some exn); - Lwt.wakeup_exn r Exception; - later (fun () -> !saw = Some Exception) - end; - - test ~sequential:true "pending, rejected, f raises" begin fun () -> - let saw = ref None in - let p, r = Lwt.wait () in - Lwt.on_failure p (fun _ -> raise Exception); - let restore = - set_async_exception_hook (fun exn -> saw := Some exn) in - Lwt.wakeup_exn r Exit; - later (fun () -> - restore (); - !saw = Some Exception) - end; -] -let suites = suites @ [on_failure_tests] - -let on_termination_tests = suite "on_termination" [ - test "fulfilled" begin fun () -> - let f_ran = ref false in - Lwt.on_termination (Lwt.return ()) (fun () -> f_ran := true); - later (fun () -> !f_ran = true) - end; - - test ~sequential:true "fulfilled, f raises" begin fun () -> - let saw = ref None in - let restore = - set_async_exception_hook (fun exn -> saw := Some exn) in - Lwt.on_termination (Lwt.return ()) (fun () -> raise Exception); - later (fun () -> - restore (); - !saw = Some Exception) - end; - - test "rejected" begin fun () -> - let f_ran = ref false in - Lwt.on_termination (Lwt.fail Exception) (fun () -> f_ran := true); - later (fun () -> !f_ran = true) - end; - - test ~sequential:true "rejected, f raises" begin fun () -> - let saw = ref None in - let restore = - set_async_exception_hook (fun exn -> saw := Some exn) in - Lwt.on_termination (Lwt.fail Exit) (fun () -> raise Exception); - later (fun () -> - restore (); - !saw = Some Exception) - end; - - test "pending" begin fun () -> - let f_ran = ref false in - Lwt.on_termination (fst (Lwt.wait ())) (fun () -> f_ran := true); - later (fun () -> !f_ran = false) - end; - - test "pending, fulfilled" begin fun () -> - let f_ran = ref false in - let p, r = Lwt.wait () in - Lwt.on_termination p (fun () -> f_ran := true); - Lwt.wakeup r (); - later (fun () -> !f_ran = true) - end; - - test ~sequential:true "pending, fulfilled, f raises" begin fun () -> - let saw = ref None in - let p, r = Lwt.wait () in - Lwt.on_termination p (fun () -> raise Exception); - let restore = - set_async_exception_hook (fun exn -> saw := Some exn) in - Lwt.wakeup r (); - later (fun () -> - restore (); - !saw = Some Exception) - end; - - test "pending, rejected" begin fun () -> - let f_ran = ref false in - let p, r = Lwt.wait () in - Lwt.on_termination p (fun () -> f_ran := true); - Lwt.wakeup_exn r Exception; - later (fun () -> !f_ran = true) - end; - - test ~sequential:true "pending, rejected, f raises" begin fun () -> - let saw = ref None in - let p, r = Lwt.wait () in - Lwt.on_termination p (fun () -> raise Exception); - let restore = - set_async_exception_hook (fun exn -> saw := Some exn) in - Lwt.wakeup_exn r Exit; - later (fun () -> - restore (); - !saw = Some Exception) - end; -] -let suites = suites @ [on_termination_tests] - -let on_any_tests = suite "on_any" [ - test "fulfilled" begin fun () -> - let f_ran = ref false in - let g_ran = ref false in - Lwt.on_any - (Lwt.return ()) - (fun () -> f_ran := true) - (fun _ -> g_ran := true); - later (fun () -> !f_ran = true && !g_ran = false) - end; - - test ~sequential:true "fulfilled, f raises" begin fun () -> - let saw = ref None in - let restore = - set_async_exception_hook (fun exn -> saw := Some exn) in - Lwt.on_any (Lwt.return ()) (fun () -> raise Exception) ignore; - later (fun () -> - restore (); - !saw = Some Exception) - end; - - test "rejected" begin fun () -> - let saw = ref None in (* f can't run due to parametricity. *) - Lwt.on_any (Lwt.fail Exception) ignore (fun exn -> saw := Some exn); - later (fun () -> !saw = Some Exception) - end; - - test ~sequential:true "rejected, f raises" begin fun () -> - let saw = ref None in - let restore = - set_async_exception_hook (fun exn -> saw := Some exn) in - Lwt.on_any (Lwt.fail Exit) ignore (fun _ -> raise Exception); - later (fun () -> - restore (); - !saw = Some Exception) - end; - - test "pending" begin fun () -> - let g_ran = ref false in (* f can't run due to parametricity. *) - Lwt.on_any (fst (Lwt.wait ())) ignore (fun _ -> g_ran := true); - later (fun () -> !g_ran = false) - end; - - test "pending, fulfilled" begin fun () -> - let f_ran = ref false in - let g_ran = ref false in - let p, r = Lwt.wait () in - Lwt.on_any p (fun () -> f_ran := true) (fun _ -> g_ran := true); - Lwt.wakeup r (); - later (fun () -> !f_ran = true && !g_ran = false) - end; - - test ~sequential:true "pending, fulfilled, f raises" begin fun () -> - let saw = ref None in - let p, r = Lwt.wait () in - Lwt.on_any p (fun () -> raise Exception) ignore; - let restore = - set_async_exception_hook (fun exn -> saw := Some exn) in - Lwt.wakeup r (); - later (fun () -> - restore (); - !saw = Some Exception) - end; - - test "pending, rejected" begin fun () -> - let saw = ref None in (* f can't run due to parametricity. *) - let p, r = Lwt.wait () in - Lwt.on_any p ignore (fun exn -> saw := Some exn); - Lwt.wakeup_exn r Exception; - later (fun () -> !saw = Some Exception) - end; - - test ~sequential:true "pending, rejected, g raises" begin fun () -> - let saw = ref None in - let p, r = Lwt.wait () in - Lwt.on_any p ignore (fun _ -> raise Exception); - let restore = - set_async_exception_hook (fun exn -> saw := Some exn) in - Lwt.wakeup_exn r Exit; - later (fun () -> - restore (); - !saw = Some Exception) - end; -] -let suites = suites @ [on_any_tests] - - + state_is (Lwt.Fail Exception) p); + test "pending, rejected, f' pending, rejected" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p = Lwt.finalize (fun () -> p1) (fun () -> p2) in + Lwt.wakeup_exn r1 Exit; + assert (Lwt.state p = Lwt.Sleep); + Lwt.wakeup_exn r2 Exception; + state_is (Lwt.Fail Exception) p); + (* See "proxy during callback" in [bind] tests. *) + test "proxy during callback (fulfilled)" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p3 = + Lwt.finalize + (fun () -> p1) + (fun () -> + Lwt.wakeup r2 (); + Lwt.return ()) + in + let p4 = Lwt.bind p2 (fun () -> p3) in + Lwt.wakeup r1 (); + Lwt.bind p4 (fun () -> Lwt.return true)); + (* See "proxy during callback" in [bind] tests. *) + test "proxy during callback (rejected)" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p3 = + Lwt.finalize + (fun () -> p1) + (fun () -> + Lwt.wakeup r2 (); + Lwt.return ()) + in + let p4 = Lwt.bind p2 (fun () -> p3) in + Lwt.wakeup_exn r1 Exit; + Lwt.catch (fun () -> p4) (fun _exn -> Lwt.return true)); + ] + +let suites = suites @ [ finalize_tests ] + +let backtrace_finalize_tests = + suite "backtrace_finalize" + [ + test "fulfilled" (fun () -> + let f'_ran = ref false in + let p = + Lwt.backtrace_finalize add_loc + (fun () -> Lwt.return "foo") + (fun () -> + f'_ran := true; + Lwt.return ()) + in + Lwt.bind (state_is (Lwt.Return "foo") p) (fun correct -> + Lwt.return (correct && !f'_ran = true))); + test "fulfilled, f' rejected" (fun () -> + let p = + Lwt.backtrace_finalize add_loc + (fun () -> Lwt.return ()) + (fun () -> Lwt.fail Exception) + in + state_is (Lwt.Fail Exception) p); + (* Instance of the bind quirk. *) + test "fulfilled, f' raises" (fun () -> + try + ignore + @@ Lwt.backtrace_finalize add_loc + (fun () -> Lwt.return ()) + (fun () -> raise Exception); + Lwt.return false + with Exception -> Lwt.return true); + test "rejected" (fun () -> + let f'_ran = ref false in + let p = + Lwt.backtrace_finalize add_loc + (fun () -> Lwt.fail Exception) + (fun () -> + f'_ran := true; + Lwt.return ()) + in + Lwt.bind (state_is (Lwt.Fail Exception) p) (fun correct -> + Lwt.return (correct && !f'_ran = true))); + test "rejected, f' rejected" (fun () -> + let p = + Lwt.backtrace_finalize add_loc + (fun () -> Lwt.fail Exit) + (fun () -> Lwt.fail Exception) + in + state_is (Lwt.Fail Exception) p); + (* Instance of the bind quirk. *) + test "rejected, f' raises" (fun () -> + try + ignore + @@ Lwt.backtrace_finalize add_loc + (fun () -> Lwt.fail Exit) + (fun () -> raise Exception); + Lwt.return false + with Exception -> Lwt.return true); + test "pending" (fun () -> + let f'_ran = ref false in + let p, _ = Lwt.wait () in + let p = + Lwt.backtrace_finalize add_loc + (fun () -> p) + (fun () -> + f'_ran := true; + Lwt.return ()) + in + Lwt.bind (state_is Lwt.Sleep p) (fun correct -> + Lwt.return (correct && !f'_ran = false))); + test "pending, fulfilled" (fun () -> + let f'_ran = ref false in + let p, r = Lwt.wait () in + let p = + Lwt.backtrace_finalize add_loc + (fun () -> p) + (fun () -> + f'_ran := true; + Lwt.return ()) + in + Lwt.wakeup r "foo"; + Lwt.bind (state_is (Lwt.Return "foo") p) (fun correct -> + Lwt.return (correct && !f'_ran = true))); + test "pending, fulfilled, f' rejected" (fun () -> + let p, r = Lwt.wait () in + let p = + Lwt.backtrace_finalize add_loc + (fun () -> p) + (fun () -> Lwt.fail Exception) + in + Lwt.wakeup r (); + state_is (Lwt.Fail Exception) p); + test "pending, fulfilled, f' raises" (fun () -> + let p, r = Lwt.wait () in + let p = + Lwt.backtrace_finalize add_loc + (fun () -> p) + (fun () -> raise Exception) + in + Lwt.wakeup r (); + state_is (Lwt.Fail Exception) p); + test "pending, rejected" (fun () -> + let f'_ran = ref false in + let p, r = Lwt.wait () in + let p = + Lwt.backtrace_finalize add_loc + (fun () -> p) + (fun () -> + f'_ran := true; + Lwt.return ()) + in + Lwt.wakeup_exn r Exception; + Lwt.bind (state_is (Lwt.Fail Exception) p) (fun correct -> + Lwt.return (correct && !f'_ran = true))); + test "pending, rejected, f' rejected" (fun () -> + let p, r = Lwt.wait () in + let p = + Lwt.backtrace_finalize add_loc + (fun () -> p) + (fun () -> Lwt.fail Exception) + in + Lwt.wakeup_exn r Exit; + state_is (Lwt.Fail Exception) p); + test "pending, rejected, f' raises" (fun () -> + let p, r = Lwt.wait () in + let p = + Lwt.backtrace_finalize add_loc + (fun () -> p) + (fun () -> raise Exception) + in + Lwt.wakeup_exn r Exit; + state_is (Lwt.Fail Exception) p); + (* See "proxy during callback" in [bind] tests. *) + test "proxy during callback (fulfilled)" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p3 = + Lwt.backtrace_finalize add_loc + (fun () -> p1) + (fun () -> + Lwt.wakeup r2 (); + Lwt.return ()) + in + let p4 = Lwt.bind p2 (fun () -> p3) in + Lwt.wakeup r1 (); + Lwt.bind p4 (fun () -> Lwt.return true)); + (* See "proxy during callback" in [bind] tests. *) + test "proxy during callback (rejected)" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p3 = + Lwt.backtrace_finalize add_loc + (fun () -> p1) + (fun () -> + Lwt.wakeup r2 (); + Lwt.return ()) + in + let p4 = Lwt.bind p2 (fun () -> p3) in + Lwt.wakeup_exn r1 Exit; + Lwt.catch (fun () -> p4) (fun _exn -> Lwt.return true)); + ] + +let suites = suites @ [ backtrace_finalize_tests ] + +let on_success_tests = + suite "on_success" + [ + test "fulfilled" (fun () -> + let f_ran = ref false in + Lwt.on_success (Lwt.return ()) (fun () -> f_ran := true); + later (fun () -> !f_ran = true)); + test ~sequential:true "fulfilled, f raises" (fun () -> + let saw = ref None in + let restore = set_async_exception_hook (fun exn -> saw := Some exn) in + Lwt.on_success (Lwt.return ()) (fun () -> raise Exception); + later (fun () -> + restore (); + !saw = Some Exception)); + test "rejected" (fun () -> + let f_ran = ref false in + Lwt.on_success (Lwt.fail Exception) (fun () -> f_ran := true); + later (fun () -> !f_ran = false)); + test "pending" (fun () -> + let f_ran = ref false in + Lwt.on_success (fst (Lwt.wait ())) (fun () -> f_ran := true); + later (fun () -> !f_ran = false)); + test "pending, fulfilled" (fun () -> + let f_ran = ref false in + let p, r = Lwt.wait () in + Lwt.on_success p (fun () -> f_ran := true); + assert (!f_ran = false); + Lwt.wakeup r (); + later (fun () -> !f_ran = true)); + test ~sequential:true "pending, fulfilled, f raises" (fun () -> + let saw = ref None in + let p, r = Lwt.wait () in + Lwt.on_success p (fun () -> raise Exception); + let restore = set_async_exception_hook (fun exn -> saw := Some exn) in + Lwt.wakeup r (); + later (fun () -> + restore (); + !saw = Some Exception)); + test "pending, rejected" (fun () -> + let f_ran = ref false in + let p, r = Lwt.wait () in + Lwt.on_success p (fun () -> f_ran := true); + Lwt.wakeup_exn r Exception; + later (fun () -> !f_ran = false)); + ] + +let suites = suites @ [ on_success_tests ] + +let on_failure_tests = + suite "on_failure" + [ + test "fulfilled" (fun () -> + let f_ran = ref false in + Lwt.on_failure (Lwt.return ()) (fun _ -> f_ran := true); + later (fun () -> !f_ran = false)); + test "rejected" (fun () -> + let saw = ref None in + Lwt.on_failure (Lwt.fail Exception) (fun exn -> saw := Some exn); + later (fun () -> !saw = Some Exception)); + test ~sequential:true "rejected, f raises" (fun () -> + let saw = ref None in + let restore = set_async_exception_hook (fun exn -> saw := Some exn) in + Lwt.on_failure (Lwt.fail Exit) (fun _ -> raise Exception); + later (fun () -> + restore (); + !saw = Some Exception)); + test "pending" (fun () -> + let f_ran = ref false in + Lwt.on_failure (fst (Lwt.wait ())) (fun _ -> f_ran := true); + later (fun () -> !f_ran = false)); + test "pending, fulfilled" (fun () -> + let f_ran = ref false in + let p, r = Lwt.wait () in + Lwt.on_failure p (fun _ -> f_ran := true); + Lwt.wakeup r (); + later (fun () -> !f_ran = false)); + test "pending, rejected" (fun () -> + let saw = ref None in + let p, r = Lwt.wait () in + Lwt.on_failure p (fun exn -> saw := Some exn); + Lwt.wakeup_exn r Exception; + later (fun () -> !saw = Some Exception)); + test ~sequential:true "pending, rejected, f raises" (fun () -> + let saw = ref None in + let p, r = Lwt.wait () in + Lwt.on_failure p (fun _ -> raise Exception); + let restore = set_async_exception_hook (fun exn -> saw := Some exn) in + Lwt.wakeup_exn r Exit; + later (fun () -> + restore (); + !saw = Some Exception)); + ] + +let suites = suites @ [ on_failure_tests ] + +let on_termination_tests = + suite "on_termination" + [ + test "fulfilled" (fun () -> + let f_ran = ref false in + Lwt.on_termination (Lwt.return ()) (fun () -> f_ran := true); + later (fun () -> !f_ran = true)); + test ~sequential:true "fulfilled, f raises" (fun () -> + let saw = ref None in + let restore = set_async_exception_hook (fun exn -> saw := Some exn) in + Lwt.on_termination (Lwt.return ()) (fun () -> raise Exception); + later (fun () -> + restore (); + !saw = Some Exception)); + test "rejected" (fun () -> + let f_ran = ref false in + Lwt.on_termination (Lwt.fail Exception) (fun () -> f_ran := true); + later (fun () -> !f_ran = true)); + test ~sequential:true "rejected, f raises" (fun () -> + let saw = ref None in + let restore = set_async_exception_hook (fun exn -> saw := Some exn) in + Lwt.on_termination (Lwt.fail Exit) (fun () -> raise Exception); + later (fun () -> + restore (); + !saw = Some Exception)); + test "pending" (fun () -> + let f_ran = ref false in + Lwt.on_termination (fst (Lwt.wait ())) (fun () -> f_ran := true); + later (fun () -> !f_ran = false)); + test "pending, fulfilled" (fun () -> + let f_ran = ref false in + let p, r = Lwt.wait () in + Lwt.on_termination p (fun () -> f_ran := true); + Lwt.wakeup r (); + later (fun () -> !f_ran = true)); + test ~sequential:true "pending, fulfilled, f raises" (fun () -> + let saw = ref None in + let p, r = Lwt.wait () in + Lwt.on_termination p (fun () -> raise Exception); + let restore = set_async_exception_hook (fun exn -> saw := Some exn) in + Lwt.wakeup r (); + later (fun () -> + restore (); + !saw = Some Exception)); + test "pending, rejected" (fun () -> + let f_ran = ref false in + let p, r = Lwt.wait () in + Lwt.on_termination p (fun () -> f_ran := true); + Lwt.wakeup_exn r Exception; + later (fun () -> !f_ran = true)); + test ~sequential:true "pending, rejected, f raises" (fun () -> + let saw = ref None in + let p, r = Lwt.wait () in + Lwt.on_termination p (fun () -> raise Exception); + let restore = set_async_exception_hook (fun exn -> saw := Some exn) in + Lwt.wakeup_exn r Exit; + later (fun () -> + restore (); + !saw = Some Exception)); + ] + +let suites = suites @ [ on_termination_tests ] + +let on_any_tests = + suite "on_any" + [ + test "fulfilled" (fun () -> + let f_ran = ref false in + let g_ran = ref false in + Lwt.on_any (Lwt.return ()) + (fun () -> f_ran := true) + (fun _ -> g_ran := true); + later (fun () -> !f_ran = true && !g_ran = false)); + test ~sequential:true "fulfilled, f raises" (fun () -> + let saw = ref None in + let restore = set_async_exception_hook (fun exn -> saw := Some exn) in + Lwt.on_any (Lwt.return ()) (fun () -> raise Exception) ignore; + later (fun () -> + restore (); + !saw = Some Exception)); + test "rejected" (fun () -> + let saw = ref None in + (* f can't run due to parametricity. *) + Lwt.on_any (Lwt.fail Exception) ignore (fun exn -> saw := Some exn); + later (fun () -> !saw = Some Exception)); + test ~sequential:true "rejected, f raises" (fun () -> + let saw = ref None in + let restore = set_async_exception_hook (fun exn -> saw := Some exn) in + Lwt.on_any (Lwt.fail Exit) ignore (fun _ -> raise Exception); + later (fun () -> + restore (); + !saw = Some Exception)); + test "pending" (fun () -> + let g_ran = ref false in + (* f can't run due to parametricity. *) + Lwt.on_any (fst (Lwt.wait ())) ignore (fun _ -> g_ran := true); + later (fun () -> !g_ran = false)); + test "pending, fulfilled" (fun () -> + let f_ran = ref false in + let g_ran = ref false in + let p, r = Lwt.wait () in + Lwt.on_any p (fun () -> f_ran := true) (fun _ -> g_ran := true); + Lwt.wakeup r (); + later (fun () -> !f_ran = true && !g_ran = false)); + test ~sequential:true "pending, fulfilled, f raises" (fun () -> + let saw = ref None in + let p, r = Lwt.wait () in + Lwt.on_any p (fun () -> raise Exception) ignore; + let restore = set_async_exception_hook (fun exn -> saw := Some exn) in + Lwt.wakeup r (); + later (fun () -> + restore (); + !saw = Some Exception)); + test "pending, rejected" (fun () -> + let saw = ref None in + (* f can't run due to parametricity. *) + let p, r = Lwt.wait () in + Lwt.on_any p ignore (fun exn -> saw := Some exn); + Lwt.wakeup_exn r Exception; + later (fun () -> !saw = Some Exception)); + test ~sequential:true "pending, rejected, g raises" (fun () -> + let saw = ref None in + let p, r = Lwt.wait () in + Lwt.on_any p ignore (fun _ -> raise Exception); + let restore = set_async_exception_hook (fun exn -> saw := Some exn) in + Lwt.wakeup_exn r Exit; + later (fun () -> + restore (); + !saw = Some Exception)); + ] + +let suites = suites @ [ on_any_tests ] (* Concurrent composition tests, not including cancellation and sequence-associated storage. Also not including [Lwt.pick] and [Lwt.npick], as those interact with cancellation. *) -let async_tests = suite "async" [ - test "fulfilled" begin fun () -> - let f_ran = ref false in - Lwt.async (fun () -> f_ran := true; Lwt.return ()); - later (fun () -> !f_ran = true) - end; - - test ~sequential:true "f raises" begin fun () -> - let saw = ref None in - let restore = - set_async_exception_hook (fun exn -> saw := Some exn) in - Lwt.async (fun () -> raise Exception); - later (fun () -> - restore (); - !saw = Some Exception) - end; - - test ~sequential:true "rejected" begin fun () -> - let saw = ref None in - let restore = - set_async_exception_hook (fun exn -> saw := Some exn) in - Lwt.async (fun () -> Lwt.fail Exception); - later (fun () -> - restore (); - !saw = Some Exception) - end; - - test "pending, fulfilled" begin fun () -> - let resolved = ref false in - let p, r = Lwt.wait () in - Lwt.async (fun () -> - Lwt.bind p (fun () -> - resolved := true; - Lwt.return ())); - Lwt.wakeup r (); - later (fun () -> !resolved = true) - end; - - test ~sequential:true "pending, rejected" begin fun () -> - let saw = ref None in - let p, r = Lwt.wait () in - Lwt.async (fun () -> p); - let restore = - set_async_exception_hook (fun exn -> saw := Some exn) in - Lwt.wakeup_exn r Exception; - later (fun () -> - restore (); - !saw = Some Exception) - end; -] -let suites = suites @ [async_tests] - -let dont_wait_tests = suite "dont_wait" [ - test "fulfilled" begin fun () -> - let f_ran = ref false in - Lwt.dont_wait (fun () -> f_ran := true; Lwt.return ()) (fun _ -> ()); - later (fun () -> !f_ran = true) - end; - - test "f raises" begin fun () -> - let saw = ref None in - Lwt.dont_wait - (fun () -> raise Exception) - (fun exn -> saw := Some exn); - later (fun () -> !saw = Some Exception) - end; - - test "rejected" begin fun () -> - let saw = ref None in - Lwt.dont_wait - (fun () -> Lwt.fail Exception) - (fun exn -> saw := Some exn); - later (fun () -> !saw = Some Exception) - end; - - test "pending, fulfilled" begin fun () -> - let resolved = ref false in - let p, r = Lwt.wait () in - Lwt.dont_wait - (fun () -> - Lwt.bind p (fun () -> - resolved := true; - Lwt.return ())) - (fun _ -> ()); - Lwt.wakeup r (); - later (fun () -> !resolved = true) - end; - - test "pending, rejected" begin fun () -> - let saw = ref None in - let p, r = Lwt.wait () in - Lwt.dont_wait - (fun () -> p) - (fun exn -> saw := Some exn) ; - Lwt.wakeup_exn r Exception; - later (fun () -> !saw = Some Exception) - end; -] -let suites = suites @ [dont_wait_tests] - -let ignore_result_tests = suite "ignore_result" [ - test "fulfilled" begin fun () -> - Lwt.ignore_result (Lwt.return ()); - (* Reaching this without an exception is success. *) - Lwt.return true - end; - - test "rejected" begin fun () -> - try - Lwt.ignore_result (Lwt.fail Exception); - Lwt.return false - with Exception -> - Lwt.return true - end; - - test "pending, fulfilled" begin fun () -> - let p, r = Lwt.wait () in - Lwt.ignore_result p; - Lwt.wakeup r (); - (* Reaching this without process termination is success. *) - Lwt.return true - end; - - test ~sequential:true "pending, rejected" begin fun () -> - let saw = ref None in - let p, r = Lwt.wait () in - Lwt.ignore_result p; - let restore = - set_async_exception_hook (fun exn -> saw := Some exn) in - Lwt.wakeup_exn r Exception; - restore (); - Lwt.return (!saw = Some Exception) - end; -] -let suites = suites @ [ignore_result_tests] - -let join_tests = suite "join" [ - test "empty" begin fun () -> - let p = Lwt.join [] in - state_is (Lwt.Return ()) p - end; - - test "all fulfilled" begin fun () -> - let p = Lwt.join [Lwt.return (); Lwt.return ()] in - state_is (Lwt.Return ()) p - end; - - test "all rejected" begin fun () -> - let p = Lwt.join [Lwt.fail Exception; Lwt.fail Exception] in - state_is (Lwt.Fail Exception) p - end; - - test "fulfilled and pending, fulfilled" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.join [Lwt.return (); p] in - Lwt.wakeup r (); - state_is (Lwt.Return ()) p - end; - - test "rejected and pending, fulfilled" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.join [Lwt.fail Exception; p] in - Lwt.wakeup r (); - state_is (Lwt.Fail Exception) p - end; - - test "fulfilled and pending, rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.join [Lwt.return (); p] in - Lwt.wakeup_exn r Exception; - state_is (Lwt.Fail Exception) p - end; - - test "rejected and pending, rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.join [Lwt.fail Exception; p] in - Lwt.wakeup_exn r Exit; - state_is (Lwt.Fail Exception) p - end; - - test "diamond" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.join [p; p] in - Lwt.wakeup r (); - state_is (Lwt.Return ()) p - end; -] -let suites = suites @ [join_tests] - +let async_tests = + suite "async" + [ + test "fulfilled" (fun () -> + let f_ran = ref false in + Lwt.async (fun () -> + f_ran := true; + Lwt.return ()); + later (fun () -> !f_ran = true)); + test ~sequential:true "f raises" (fun () -> + let saw = ref None in + let restore = set_async_exception_hook (fun exn -> saw := Some exn) in + Lwt.async (fun () -> raise Exception); + later (fun () -> + restore (); + !saw = Some Exception)); + test ~sequential:true "rejected" (fun () -> + let saw = ref None in + let restore = set_async_exception_hook (fun exn -> saw := Some exn) in + Lwt.async (fun () -> Lwt.fail Exception); + later (fun () -> + restore (); + !saw = Some Exception)); + test "pending, fulfilled" (fun () -> + let resolved = ref false in + let p, r = Lwt.wait () in + Lwt.async (fun () -> + Lwt.bind p (fun () -> + resolved := true; + Lwt.return ())); + Lwt.wakeup r (); + later (fun () -> !resolved = true)); + test ~sequential:true "pending, rejected" (fun () -> + let saw = ref None in + let p, r = Lwt.wait () in + Lwt.async (fun () -> p); + let restore = set_async_exception_hook (fun exn -> saw := Some exn) in + Lwt.wakeup_exn r Exception; + later (fun () -> + restore (); + !saw = Some Exception)); + ] + +let suites = suites @ [ async_tests ] + +let dont_wait_tests = + suite "dont_wait" + [ + test "fulfilled" (fun () -> + let f_ran = ref false in + Lwt.dont_wait + (fun () -> + f_ran := true; + Lwt.return ()) + (fun _ -> ()); + later (fun () -> !f_ran = true)); + test "f raises" (fun () -> + let saw = ref None in + Lwt.dont_wait (fun () -> raise Exception) (fun exn -> saw := Some exn); + later (fun () -> !saw = Some Exception)); + test "rejected" (fun () -> + let saw = ref None in + Lwt.dont_wait + (fun () -> Lwt.fail Exception) + (fun exn -> saw := Some exn); + later (fun () -> !saw = Some Exception)); + test "pending, fulfilled" (fun () -> + let resolved = ref false in + let p, r = Lwt.wait () in + Lwt.dont_wait + (fun () -> + Lwt.bind p (fun () -> + resolved := true; + Lwt.return ())) + (fun _ -> ()); + Lwt.wakeup r (); + later (fun () -> !resolved = true)); + test "pending, rejected" (fun () -> + let saw = ref None in + let p, r = Lwt.wait () in + Lwt.dont_wait (fun () -> p) (fun exn -> saw := Some exn); + Lwt.wakeup_exn r Exception; + later (fun () -> !saw = Some Exception)); + ] + +let suites = suites @ [ dont_wait_tests ] + +let ignore_result_tests = + suite "ignore_result" + [ + test "fulfilled" (fun () -> + Lwt.ignore_result (Lwt.return ()); + (* Reaching this without an exception is success. *) + Lwt.return true); + test "rejected" (fun () -> + try + Lwt.ignore_result (Lwt.fail Exception); + Lwt.return false + with Exception -> Lwt.return true); + test "pending, fulfilled" (fun () -> + let p, r = Lwt.wait () in + Lwt.ignore_result p; + Lwt.wakeup r (); + (* Reaching this without process termination is success. *) + Lwt.return true); + test ~sequential:true "pending, rejected" (fun () -> + let saw = ref None in + let p, r = Lwt.wait () in + Lwt.ignore_result p; + let restore = set_async_exception_hook (fun exn -> saw := Some exn) in + Lwt.wakeup_exn r Exception; + restore (); + Lwt.return (!saw = Some Exception)); + ] + +let suites = suites @ [ ignore_result_tests ] + +let join_tests = + suite "join" + [ + test "empty" (fun () -> + let p = Lwt.join [] in + state_is (Lwt.Return ()) p); + test "all fulfilled" (fun () -> + let p = Lwt.join [ Lwt.return (); Lwt.return () ] in + state_is (Lwt.Return ()) p); + test "all rejected" (fun () -> + let p = Lwt.join [ Lwt.fail Exception; Lwt.fail Exception ] in + state_is (Lwt.Fail Exception) p); + test "fulfilled and pending, fulfilled" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.join [ Lwt.return (); p ] in + Lwt.wakeup r (); + state_is (Lwt.Return ()) p); + test "rejected and pending, fulfilled" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.join [ Lwt.fail Exception; p ] in + Lwt.wakeup r (); + state_is (Lwt.Fail Exception) p); + test "fulfilled and pending, rejected" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.join [ Lwt.return (); p ] in + Lwt.wakeup_exn r Exception; + state_is (Lwt.Fail Exception) p); + test "rejected and pending, rejected" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.join [ Lwt.fail Exception; p ] in + Lwt.wakeup_exn r Exit; + state_is (Lwt.Fail Exception) p); + test "diamond" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.join [ p; p ] in + Lwt.wakeup r (); + state_is (Lwt.Return ()) p); + ] + +let suites = suites @ [ join_tests ] let list_init i f = Array.init i f |> Array.to_list -let all_tests = suite "all" [ - test "empty" begin fun () -> - let p = Lwt.all [] in - state_is (Lwt.Return []) p - end; - - test "all fulfilled (one)" begin fun () -> - let p = Lwt.all [Lwt.return 1] in - state_is (Lwt.Return [1]) p - end; - - test "all fulfilled (two)" begin fun () -> - let p = Lwt.all [Lwt.return 1; Lwt.return 2] in - state_is (Lwt.Return [1; 2]) p - end; - - test "all fulfilled (three)" begin fun () -> - let p = Lwt.all [Lwt.return 1; Lwt.return 2; Lwt.return 3] in - state_is (Lwt.Return [1; 2; 3]) p - end; - - test "all fulfilled (long)" begin fun () -> - let p = Lwt.all (list_init 10 Lwt.return) in - state_is (Lwt.Return (list_init 10 (fun i->i))) p - end; - - test "all rejected" begin fun () -> - let p = Lwt.all [Lwt.fail Exception; Lwt.fail Exception] in - state_is (Lwt.Fail Exception) p - end; - - test "fulfilled and pending, fulfilled" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.all [Lwt.return 1; p] in - Lwt.wakeup r 2; - state_is (Lwt.Return [1; 2]) p - end; - - test "pending twice physically equal, fulfilled" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.all [p; p] in - Lwt.wakeup r 2; - state_is (Lwt.Return [2; 2]) p - end; - - test "pending twice physically equal twice, fulfilled" begin fun () -> - let p, r = Lwt.wait () in - let q, s = Lwt.wait () in - let p = Lwt.all [p; p; q; q] in - Lwt.wakeup r 2; - Lwt.wakeup s 4; - state_is (Lwt.Return [2; 2; 4; 4]) p - end; - - test "fulfilled and pending and fulfilled, fulfilled" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.all [Lwt.return 1; p; Lwt.return 3] in - Lwt.wakeup r 2; - state_is (Lwt.Return [1; 2; 3]) p - end; - - test "fulfilled and pending, fulfilled (long)" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.all (list_init 10 Lwt.return @ [p]) in - Lwt.wakeup r 10; - state_is (Lwt.Return (list_init 11 (fun x->x))) p - end; - - test "rejected and pending, fulfilled" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.all [Lwt.fail Exception; p] in - Lwt.wakeup r 2; - state_is (Lwt.Fail Exception) p - end; - - test "fulfilled and pending, rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.all [Lwt.return 1; p] in - Lwt.wakeup_exn r Exception; - state_is (Lwt.Fail Exception) p - end; - - test "rejected and pending, rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.all [Lwt.fail Exception; p] in - Lwt.wakeup_exn r Exit; - state_is (Lwt.Fail Exception) p - end; - - test "diamond" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.all [p; p] in - Lwt.wakeup r 1; - state_is (Lwt.Return [1; 1]) p - end; -] -let suites = suites @ [all_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 "both 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 () -> - try - ignore (Lwt.choose []); - Lwt.return false - with Invalid_argument "Lwt.choose [] would return a \ - promise that is pending forever" -> - Lwt.return true - end [@ocaml.warning "-52"]; - - test "fulfilled" begin fun () -> - let p = Lwt.choose [fst (Lwt.wait ()); Lwt.return "foo"] in - state_is (Lwt.Return "foo") p - end; - - test "rejected" begin fun () -> - let p = Lwt.choose [fst (Lwt.wait ()); Lwt.fail Exception] in - state_is (Lwt.Fail Exception) p - end; - - test "multiple resolved" begin fun () -> - (* This is run in a loop to exercise the internal PRNG. *) - let outcomes = Array.make 3 0 in - let rec repeat n = - if n <= 0 then () - else - let p = - Lwt.choose - [fst (Lwt.wait ()); - Lwt.return "foo"; - Lwt.fail Exception; - Lwt.return "bar"] - in - begin match Lwt.state p with - | Lwt.Return "foo" -> outcomes.(0) <- outcomes.(0) + 1 - | Lwt.Fail Exception -> outcomes.(1) <- outcomes.(1) + 1 - | Lwt.Return "bar" -> outcomes.(2) <- outcomes.(2) + 1 - | _ -> assert false - end [@ocaml.warning "-4"]; - repeat (n - 1) - in - let count = 1000 in - repeat count; - Lwt.return - (outcomes.(0) > 0 && outcomes.(1) > 0 && outcomes.(2) > 0 && - outcomes.(0) + outcomes.(1) + outcomes.(2) = count) - end; - - test "pending" begin fun () -> - let p = Lwt.choose [fst (Lwt.wait ()); fst (Lwt.wait ())] in - state_is Lwt.Sleep p - end; - - test "pending, fulfilled" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p = Lwt.choose [p1; p2] in - Lwt.wakeup r1 "foo"; - Lwt.wakeup r2 "bar"; - state_is (Lwt.Return "foo") p - end; - - test "diamond" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.choose [p; p] in - Lwt.wakeup r "foo"; - state_is (Lwt.Return "foo") p - end; -] -let suites = suites @ [choose_tests] - -let nchoose_tests = suite "nchoose" [ - test "empty" begin fun () -> - try - ignore (Lwt.nchoose []); - Lwt.return false - with Invalid_argument "Lwt.nchoose [] would return a \ - promise that is pending forever" -> - Lwt.return true - end [@ocaml.warning "-52"]; - - test "all fulfilled" begin fun () -> - let p = Lwt.nchoose [Lwt.return "foo"; Lwt.return "bar"] in - Lwt.return (Lwt.state p = Lwt.Return ["foo"; "bar"]) - end; - - test "fulfilled, rejected" begin fun () -> - let p = Lwt.nchoose [Lwt.return "foo"; Lwt.fail Exception] in - Lwt.return (Lwt.state p = Lwt.Fail Exception) - end; - - test "rejected, fulfilled" begin fun () -> - let p = Lwt.nchoose [Lwt.fail Exception; Lwt.return "foo"] in - Lwt.return (Lwt.state p = Lwt.Fail Exception) - end; - - test "some pending" begin fun () -> - let p = - Lwt.nchoose [Lwt.return "foo"; fst (Lwt.wait ()); Lwt.return "bar"] in - Lwt.return (Lwt.state p = Lwt.Return ["foo"; "bar"]) - end; - - test "pending, fulfilled" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.nchoose [fst (Lwt.wait ()); p] in - assert (Lwt.state p = Lwt.Sleep); - Lwt.wakeup r "foo"; - Lwt.return (Lwt.state p = Lwt.Return ["foo"]) - end; - - test "pending, rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.nchoose [fst (Lwt.wait ()); p] in - Lwt.wakeup_exn r Exception; - Lwt.return (Lwt.state p = Lwt.Fail Exception) - end; - - test "diamond" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.nchoose [p; p] in - Lwt.wakeup r "foo"; - Lwt.return (Lwt.state p = Lwt.Return ["foo"; "foo"]) - end; - - test "diamond, rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.nchoose [p; p] in - Lwt.wakeup_exn r Exception; - Lwt.return (Lwt.state p = Lwt.Fail Exception) - end; -] -let suites = suites @ [nchoose_tests] - -let nchoose_split_tests = suite "nchoose_split" [ - test "empty" begin fun () -> - try - ignore (Lwt.nchoose_split []); - Lwt.return false - with Invalid_argument "Lwt.nchoose_split [] would return a \ - promise that is pending forever" -> - Lwt.return true - end [@ocaml.warning "-52"]; - - test "some fulfilled" begin fun () -> - let p = - Lwt.nchoose_split - [Lwt.return "foo"; fst (Lwt.wait ()); Lwt.return "bar"] - in - begin match Lwt.state p with - | Lwt.Return (["foo"; "bar"], [_]) -> Lwt.return true - | _ -> Lwt.return false - end [@ocaml.warning "-4"] - end; - - test "fulfilled, rejected" begin fun () -> - let p = Lwt.nchoose_split [Lwt.return (); Lwt.fail Exception] in - Lwt.return (Lwt.state p = Lwt.Fail Exception) - end; - - test "rejected, fulfilled" begin fun () -> - let p = Lwt.nchoose_split [Lwt.fail Exception; Lwt.return ()] in - Lwt.return (Lwt.state p = Lwt.Fail Exception) - end; - - test "pending, rejected" begin fun () -> - let p = Lwt.nchoose_split [fst (Lwt.wait ()); Lwt.fail Exception] in - Lwt.return (Lwt.state p = Lwt.Fail Exception) - end; - - test "pending, fulfilled" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.nchoose_split [p; fst (Lwt.wait ())] in - assert (Lwt.state p = Lwt.Sleep); - Lwt.wakeup r "foo"; - begin match Lwt.state p with - | Lwt.Return (["foo"], [_]) -> Lwt.return true - | _ -> Lwt.return false - end [@ocaml.warning "-4"] - end; - - test "pending, rejected 2" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.nchoose_split [p; fst (Lwt.wait ())] in - Lwt.wakeup_exn r Exception; - Lwt.return (Lwt.state p = Lwt.Fail Exception) - end; - - test "diamond" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.nchoose_split [p; p; fst (Lwt.wait ())] in - Lwt.wakeup r (); - begin match Lwt.state p with - | Lwt.Return ([(); ()], [_]) -> Lwt.return true - | _ -> Lwt.return false - end [@ocaml.warning "-4"] - end; - - test "diamond, rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.nchoose_split [p; p; fst (Lwt.wait ())] in - Lwt.wakeup_exn r Exception; - Lwt.return (Lwt.state p = Lwt.Fail Exception) - end; -] -let suites = suites @ [nchoose_split_tests] - - +let all_tests = + suite "all" + [ + test "empty" (fun () -> + let p = Lwt.all [] in + state_is (Lwt.Return []) p); + test "all fulfilled (one)" (fun () -> + let p = Lwt.all [ Lwt.return 1 ] in + state_is (Lwt.Return [ 1 ]) p); + test "all fulfilled (two)" (fun () -> + let p = Lwt.all [ Lwt.return 1; Lwt.return 2 ] in + state_is (Lwt.Return [ 1; 2 ]) p); + test "all fulfilled (three)" (fun () -> + let p = Lwt.all [ Lwt.return 1; Lwt.return 2; Lwt.return 3 ] in + state_is (Lwt.Return [ 1; 2; 3 ]) p); + test "all fulfilled (long)" (fun () -> + let p = Lwt.all (list_init 10 Lwt.return) in + state_is (Lwt.Return (list_init 10 (fun i -> i))) p); + test "all rejected" (fun () -> + let p = Lwt.all [ Lwt.fail Exception; Lwt.fail Exception ] in + state_is (Lwt.Fail Exception) p); + test "fulfilled and pending, fulfilled" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.all [ Lwt.return 1; p ] in + Lwt.wakeup r 2; + state_is (Lwt.Return [ 1; 2 ]) p); + test "pending twice physically equal, fulfilled" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.all [ p; p ] in + Lwt.wakeup r 2; + state_is (Lwt.Return [ 2; 2 ]) p); + test "pending twice physically equal twice, fulfilled" (fun () -> + let p, r = Lwt.wait () in + let q, s = Lwt.wait () in + let p = Lwt.all [ p; p; q; q ] in + Lwt.wakeup r 2; + Lwt.wakeup s 4; + state_is (Lwt.Return [ 2; 2; 4; 4 ]) p); + test "fulfilled and pending and fulfilled, fulfilled" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.all [ Lwt.return 1; p; Lwt.return 3 ] in + Lwt.wakeup r 2; + state_is (Lwt.Return [ 1; 2; 3 ]) p); + test "fulfilled and pending, fulfilled (long)" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.all (list_init 10 Lwt.return @ [ p ]) in + Lwt.wakeup r 10; + state_is (Lwt.Return (list_init 11 (fun x -> x))) p); + test "rejected and pending, fulfilled" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.all [ Lwt.fail Exception; p ] in + Lwt.wakeup r 2; + state_is (Lwt.Fail Exception) p); + test "fulfilled and pending, rejected" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.all [ Lwt.return 1; p ] in + Lwt.wakeup_exn r Exception; + state_is (Lwt.Fail Exception) p); + test "rejected and pending, rejected" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.all [ Lwt.fail Exception; p ] in + Lwt.wakeup_exn r Exit; + state_is (Lwt.Fail Exception) p); + test "diamond" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.all [ p; p ] in + Lwt.wakeup r 1; + state_is (Lwt.Return [ 1; 1 ]) p); + ] + +let suites = suites @ [ all_tests ] + +let both_tests = + suite "both" + [ + test "both fulfilled" (fun () -> + let p = Lwt.both (Lwt.return 1) (Lwt.return 2) in + state_is (Lwt.Return (1, 2)) p); + test "both rejected" (fun () -> + let p = Lwt.both (Lwt.fail Exception) (Lwt.fail Exit) in + state_is (Lwt.Fail Exception) p); + test "rejected, fulfilled" (fun () -> + let p = Lwt.both (Lwt.fail Exception) (Lwt.return 2) in + state_is (Lwt.Fail Exception) p); + test "fulfilled, rejected" (fun () -> + let p = Lwt.both (Lwt.return 1) (Lwt.fail Exception) in + state_is (Lwt.Fail Exception) p); + test "both pending" (fun () -> + let p = Lwt.both (fst (Lwt.wait ())) (fst (Lwt.wait ())) in + state_is Lwt.Sleep p); + test "pending, fulfilled" (fun () -> + let p = Lwt.both (fst (Lwt.wait ())) (Lwt.return 2) in + state_is Lwt.Sleep p); + test "pending, rejected" (fun () -> + let p = Lwt.both (fst (Lwt.wait ())) (Lwt.fail Exception) in + state_is Lwt.Sleep p); + test "fulfilled, pending" (fun () -> + let p = Lwt.both (Lwt.return 1) (fst (Lwt.wait ())) in + state_is Lwt.Sleep p); + test "rejected, pending" (fun () -> + let p = Lwt.both (Lwt.fail Exception) (fst (Lwt.wait ())) in + state_is Lwt.Sleep p); + test "pending, fulfilled, then fulfilled" (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); + test "pending, rejected, then fulfilled" (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); + test "pending, fulfilled, then rejected" (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); + test "pending, rejected, then rejected" (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); + test "fulfilled, pending, then fulfilled" (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); + test "rejected, pending, then fulfilled" (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); + test "fulfilled, pending, then rejected" (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); + test "rejected, pending, then rejected" (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); + test "pending, then first fulfilled" (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); + test "pending, then first rejected" (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); + test "pending, then second fulfilled" (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); + test "pending, then second rejected" (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); + test "pending, then first fulfilled, then fulfilled" (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); + test "pending, then first fulfilled, then rejected" (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); + test "pending, then first rejected, then fulfilled" (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); + test "pending, then first rejected, then rejected" (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); + test "pending, then second fulfilled, then fulfilled" (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); + test "pending, then second fulfilled, then rejected" (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); + test "pending, then second rejected, then fulfilled" (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); + test "pending, then second rejected, then rejected" (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); + test "diamond" (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)))); + ] + +let suites = suites @ [ both_tests ] + +let choose_tests = + suite "choose" + [ + (test "empty" (fun () -> + try + ignore (Lwt.choose []); + Lwt.return false + with + | Invalid_argument + "Lwt.choose [] would return a promise that is pending forever" + -> + Lwt.return true) [@ocaml.warning "-52"]); + test "fulfilled" (fun () -> + let p = Lwt.choose [ fst (Lwt.wait ()); Lwt.return "foo" ] in + state_is (Lwt.Return "foo") p); + test "rejected" (fun () -> + let p = Lwt.choose [ fst (Lwt.wait ()); Lwt.fail Exception ] in + state_is (Lwt.Fail Exception) p); + test "multiple resolved" (fun () -> + (* This is run in a loop to exercise the internal PRNG. *) + let outcomes = Array.make 3 0 in + let rec repeat n = + if n <= 0 then () + else + let p = + Lwt.choose + [ + fst (Lwt.wait ()); + Lwt.return "foo"; + Lwt.fail Exception; + Lwt.return "bar"; + ] + in + (match[@ocaml.warning "-4"] Lwt.state p with + | Lwt.Return "foo" -> outcomes.(0) <- outcomes.(0) + 1 + | Lwt.Fail Exception -> outcomes.(1) <- outcomes.(1) + 1 + | Lwt.Return "bar" -> outcomes.(2) <- outcomes.(2) + 1 + | _ -> assert false); + repeat (n - 1) + in + let count = 1000 in + repeat count; + Lwt.return + (outcomes.(0) > 0 + && outcomes.(1) > 0 + && outcomes.(2) > 0 + && outcomes.(0) + outcomes.(1) + outcomes.(2) = count)); + test "pending" (fun () -> + let p = Lwt.choose [ fst (Lwt.wait ()); fst (Lwt.wait ()) ] in + state_is Lwt.Sleep p); + test "pending, fulfilled" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p = Lwt.choose [ p1; p2 ] in + Lwt.wakeup r1 "foo"; + Lwt.wakeup r2 "bar"; + state_is (Lwt.Return "foo") p); + test "diamond" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.choose [ p; p ] in + Lwt.wakeup r "foo"; + state_is (Lwt.Return "foo") p); + ] + +let suites = suites @ [ choose_tests ] + +let nchoose_tests = + suite "nchoose" + [ + (test "empty" (fun () -> + try + ignore (Lwt.nchoose []); + Lwt.return false + with + | Invalid_argument + "Lwt.nchoose [] would return a promise that is pending forever" + -> + Lwt.return true) [@ocaml.warning "-52"]); + test "all fulfilled" (fun () -> + let p = Lwt.nchoose [ Lwt.return "foo"; Lwt.return "bar" ] in + Lwt.return (Lwt.state p = Lwt.Return [ "foo"; "bar" ])); + test "fulfilled, rejected" (fun () -> + let p = Lwt.nchoose [ Lwt.return "foo"; Lwt.fail Exception ] in + Lwt.return (Lwt.state p = Lwt.Fail Exception)); + test "rejected, fulfilled" (fun () -> + let p = Lwt.nchoose [ Lwt.fail Exception; Lwt.return "foo" ] in + Lwt.return (Lwt.state p = Lwt.Fail Exception)); + test "some pending" (fun () -> + let p = + Lwt.nchoose + [ Lwt.return "foo"; fst (Lwt.wait ()); Lwt.return "bar" ] + in + Lwt.return (Lwt.state p = Lwt.Return [ "foo"; "bar" ])); + test "pending, fulfilled" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.nchoose [ fst (Lwt.wait ()); p ] in + assert (Lwt.state p = Lwt.Sleep); + Lwt.wakeup r "foo"; + Lwt.return (Lwt.state p = Lwt.Return [ "foo" ])); + test "pending, rejected" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.nchoose [ fst (Lwt.wait ()); p ] in + Lwt.wakeup_exn r Exception; + Lwt.return (Lwt.state p = Lwt.Fail Exception)); + test "diamond" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.nchoose [ p; p ] in + Lwt.wakeup r "foo"; + Lwt.return (Lwt.state p = Lwt.Return [ "foo"; "foo" ])); + test "diamond, rejected" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.nchoose [ p; p ] in + Lwt.wakeup_exn r Exception; + Lwt.return (Lwt.state p = Lwt.Fail Exception)); + ] + +let suites = suites @ [ nchoose_tests ] + +let nchoose_split_tests = + suite "nchoose_split" + [ + (test "empty" (fun () -> + try + ignore (Lwt.nchoose_split []); + Lwt.return false + with + | Invalid_argument + "Lwt.nchoose_split [] would return a promise that is pending \ + forever" + -> + Lwt.return true) [@ocaml.warning "-52"]); + test "some fulfilled" (fun () -> + let p = + Lwt.nchoose_split + [ Lwt.return "foo"; fst (Lwt.wait ()); Lwt.return "bar" ] + in + match[@ocaml.warning "-4"] Lwt.state p with + | Lwt.Return ([ "foo"; "bar" ], [ _ ]) -> Lwt.return true + | _ -> Lwt.return false); + test "fulfilled, rejected" (fun () -> + let p = Lwt.nchoose_split [ Lwt.return (); Lwt.fail Exception ] in + Lwt.return (Lwt.state p = Lwt.Fail Exception)); + test "rejected, fulfilled" (fun () -> + let p = Lwt.nchoose_split [ Lwt.fail Exception; Lwt.return () ] in + Lwt.return (Lwt.state p = Lwt.Fail Exception)); + test "pending, rejected" (fun () -> + let p = Lwt.nchoose_split [ fst (Lwt.wait ()); Lwt.fail Exception ] in + Lwt.return (Lwt.state p = Lwt.Fail Exception)); + test "pending, fulfilled" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.nchoose_split [ p; fst (Lwt.wait ()) ] in + assert (Lwt.state p = Lwt.Sleep); + Lwt.wakeup r "foo"; + match[@ocaml.warning "-4"] Lwt.state p with + | Lwt.Return ([ "foo" ], [ _ ]) -> Lwt.return true + | _ -> Lwt.return false); + test "pending, rejected 2" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.nchoose_split [ p; fst (Lwt.wait ()) ] in + Lwt.wakeup_exn r Exception; + Lwt.return (Lwt.state p = Lwt.Fail Exception)); + test "diamond" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.nchoose_split [ p; p; fst (Lwt.wait ()) ] in + Lwt.wakeup r (); + match[@ocaml.warning "-4"] Lwt.state p with + | Lwt.Return ([ (); () ], [ _ ]) -> Lwt.return true + | _ -> Lwt.return false); + test "diamond, rejected" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.nchoose_split [ p; p; fst (Lwt.wait ()) ] in + Lwt.wakeup_exn r Exception; + Lwt.return (Lwt.state p = Lwt.Fail Exception)); + ] + +let suites = suites @ [ nchoose_split_tests ] (* Tests functions related to [Lwt.state]; [Lwt.state] itself is tested in the preceding sections. *) -let state_query_tests = suite "state query" [ - test "is_sleeping: fulfilled" begin fun () -> - Lwt.return (not @@ Lwt.is_sleeping (Lwt.return ())) - end; - - test "is_sleeping: rejected" begin fun () -> - Lwt.return (not @@ Lwt.is_sleeping (Lwt.fail Exception)) - end; - - test "is_sleeping: pending" begin fun () -> - Lwt.return (Lwt.is_sleeping (fst (Lwt.wait ()))) - end; - - (* This tests an implementation detail. *) - test "is_sleeping: proxy" begin fun () -> - let p1, r = Lwt.wait () in - let p2, _ = Lwt.wait () in - Lwt.bind p1 (fun () -> p2) |> ignore; - Lwt.wakeup r (); - Lwt.return (Lwt.is_sleeping p2) - end; - - (* This tests an internal API. *) - test "poll: fulfilled" begin fun () -> - Lwt.return (Lwt.poll (Lwt.return "foo") = Some "foo") - end; - - test "poll: rejected" begin fun () -> - try - Lwt.poll (Lwt.fail Exception) |> ignore; - Lwt.return false - with Exception -> - Lwt.return true - end; - - test "poll: pending" begin fun () -> - Lwt.return (Lwt.poll (fst (Lwt.wait ())) = None) - end; - - (* This tests an internal API on an implementation detail... *) - test "poll: proxy" begin fun () -> - let p1, r = Lwt.wait () in - let p2, _ = Lwt.wait () in - Lwt.bind p1 (fun () -> p2) |> ignore; - Lwt.wakeup r (); - Lwt.return (Lwt.poll p2 = None) - end; -] -let suites = suites @ [state_query_tests] - - +let state_query_tests = + suite "state query" + [ + test "is_sleeping: fulfilled" (fun () -> + Lwt.return (not @@ Lwt.is_sleeping (Lwt.return ()))); + test "is_sleeping: rejected" (fun () -> + Lwt.return (not @@ Lwt.is_sleeping (Lwt.fail Exception))); + test "is_sleeping: pending" (fun () -> + Lwt.return (Lwt.is_sleeping (fst (Lwt.wait ())))); + (* This tests an implementation detail. *) + test "is_sleeping: proxy" (fun () -> + let p1, r = Lwt.wait () in + let p2, _ = Lwt.wait () in + Lwt.bind p1 (fun () -> p2) |> ignore; + Lwt.wakeup r (); + Lwt.return (Lwt.is_sleeping p2)); + (* This tests an internal API. *) + test "poll: fulfilled" (fun () -> + Lwt.return (Lwt.poll (Lwt.return "foo") = Some "foo")); + test "poll: rejected" (fun () -> + try + Lwt.poll (Lwt.fail Exception) |> ignore; + Lwt.return false + with Exception -> Lwt.return true); + test "poll: pending" (fun () -> + Lwt.return (Lwt.poll (fst (Lwt.wait ())) = None)); + (* This tests an internal API on an implementation detail... *) + test "poll: proxy" (fun () -> + let p1, r = Lwt.wait () in + let p2, _ = Lwt.wait () in + Lwt.bind p1 (fun () -> p2) |> ignore; + Lwt.wakeup r (); + Lwt.return (Lwt.poll p2 = None)); + ] + +let suites = suites @ [ state_query_tests ] (* Preceding tests exercised most of [Lwt.wakeup], but here are more checks. *) -let wakeup_tests = suite "wakeup" [ - test "wakeup_result: nested" begin fun () -> - let f_ran = ref false in - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - Lwt.on_success p2 (fun _ -> f_ran := true); - Lwt.on_success p1 (fun s -> - Lwt.wakeup_result r2 (Result.Ok (s ^ "bar")); - assert (Lwt.state p2 = Lwt.Return "foobar"); - assert (!f_ran = true)); - Lwt.wakeup_result r1 (Result.Ok "foo"); - Lwt.return (!f_ran = true && Lwt.state p2 = Lwt.Return "foobar") - end; -] -let suites = suites @ [wakeup_tests] - -let wakeup_later_tests = suite "wakeup_later" [ - test "wakeup_later_result: immediate" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.bind p (fun s -> Lwt.return (s ^ "bar")) in - Lwt.wakeup_later_result r (Result.Ok "foo"); - state_is (Lwt.Return "foobar") p - end; - - test "wakeup_later: double use on wait" begin fun () -> - let _, r = Lwt.wait () in - Lwt.wakeup r (); - try - Lwt.wakeup_later r (); - Lwt.return false - with Invalid_argument "Lwt.wakeup_later" -> - Lwt.return true - end [@ocaml.warning "-52"]; - - test "wakeup_later: double use on task" begin fun () -> - let _, r = Lwt.task () in - Lwt.wakeup r (); - try - Lwt.wakeup_later r (); - Lwt.return false - with Invalid_argument "Lwt.wakeup_later" -> - Lwt.return true - end [@ocaml.warning "-52"]; - - test "wakeup_later_result: double use on wait" begin fun () -> - let _, r = Lwt.wait () in - Lwt.wakeup r (); - try - Lwt.wakeup_later_result r (Result.Ok ()); - Lwt.return false - with Invalid_argument "Lwt.wakeup_later_result" -> - Lwt.return true - end [@ocaml.warning "-52"]; - - test "wakeup_later_result: double use on task" begin fun () -> - let _, r = Lwt.task () in - Lwt.wakeup r (); - try - Lwt.wakeup_later_result r (Result.Ok ()); - Lwt.return false - with Invalid_argument "Lwt.wakeup_later_result" -> - Lwt.return true - end [@ocaml.warning "-52"]; - - test "wakeup_later_exn: double use on wait" begin fun () -> - let _, r = Lwt.wait () in - Lwt.wakeup r (); - try - Lwt.wakeup_later_exn r Exception; - Lwt.return false - with Invalid_argument "Lwt.wakeup_later_exn" -> - Lwt.return true - end [@ocaml.warning "-52"]; - - test "wakeup_later_exn: double use on task" begin fun () -> - let _, r = Lwt.task () in - Lwt.wakeup r (); - try - Lwt.wakeup_later_exn r Exception; - Lwt.return false - with Invalid_argument "Lwt.wakeup_later_exn" -> - Lwt.return true - end [@ocaml.warning "-52"]; - - test "wakeup_later_result: nested" begin fun () -> - let f_ran = ref false in - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - Lwt.on_success p2 (fun _ -> f_ran := true); - Lwt.on_success p1 (fun s -> - Lwt.wakeup_later_result r2 (Result.Ok (s ^ "bar")); - assert (Lwt.state p2 = Lwt.Return "foobar"); - assert (!f_ran = false)); - Lwt.wakeup_later_result r1 (Result.Ok "foo"); - Lwt.return (!f_ran = true && Lwt.state p2 = Lwt.Return "foobar") - end; - - (* Only basic tests for wakeup_later and wakeup_later_exn, as they are - implemented in terms of wakeup_later_result. This isn't fully legitimate as - a reason, but oh well. *) - test "wakeup_later: basic" begin fun () -> - let p, r = Lwt.wait () in - Lwt.wakeup_later r "foo"; - state_is (Lwt.Return "foo") p - end; - - test "wakeup_later_exn: basic" begin fun () -> - let p, r = Lwt.wait () in - Lwt.wakeup_later_exn r Exception; - state_is (Lwt.Fail Exception) p - end; -] -let suites = suites @ [wakeup_later_tests] - - +let wakeup_tests = + suite "wakeup" + [ + test "wakeup_result: nested" (fun () -> + let f_ran = ref false in + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + Lwt.on_success p2 (fun _ -> f_ran := true); + Lwt.on_success p1 (fun s -> + Lwt.wakeup_result r2 (Result.Ok (s ^ "bar")); + assert (Lwt.state p2 = Lwt.Return "foobar"); + assert (!f_ran = true)); + Lwt.wakeup_result r1 (Result.Ok "foo"); + Lwt.return (!f_ran = true && Lwt.state p2 = Lwt.Return "foobar")); + ] + +let suites = suites @ [ wakeup_tests ] + +let wakeup_later_tests = + suite "wakeup_later" + [ + test "wakeup_later_result: immediate" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.bind p (fun s -> Lwt.return (s ^ "bar")) in + Lwt.wakeup_later_result r (Result.Ok "foo"); + state_is (Lwt.Return "foobar") p); + (test "wakeup_later: double use on wait" (fun () -> + let _, r = Lwt.wait () in + Lwt.wakeup r (); + try + Lwt.wakeup_later r (); + Lwt.return false + with Invalid_argument "Lwt.wakeup_later" -> Lwt.return true) + [@ocaml.warning "-52"]); + (test "wakeup_later: double use on task" (fun () -> + let _, r = Lwt.task () in + Lwt.wakeup r (); + try + Lwt.wakeup_later r (); + Lwt.return false + with Invalid_argument "Lwt.wakeup_later" -> Lwt.return true) + [@ocaml.warning "-52"]); + (test "wakeup_later_result: double use on wait" (fun () -> + let _, r = Lwt.wait () in + Lwt.wakeup r (); + try + Lwt.wakeup_later_result r (Result.Ok ()); + Lwt.return false + with Invalid_argument "Lwt.wakeup_later_result" -> Lwt.return true) + [@ocaml.warning "-52"]); + (test "wakeup_later_result: double use on task" (fun () -> + let _, r = Lwt.task () in + Lwt.wakeup r (); + try + Lwt.wakeup_later_result r (Result.Ok ()); + Lwt.return false + with Invalid_argument "Lwt.wakeup_later_result" -> Lwt.return true) + [@ocaml.warning "-52"]); + (test "wakeup_later_exn: double use on wait" (fun () -> + let _, r = Lwt.wait () in + Lwt.wakeup r (); + try + Lwt.wakeup_later_exn r Exception; + Lwt.return false + with Invalid_argument "Lwt.wakeup_later_exn" -> Lwt.return true) + [@ocaml.warning "-52"]); + (test "wakeup_later_exn: double use on task" (fun () -> + let _, r = Lwt.task () in + Lwt.wakeup r (); + try + Lwt.wakeup_later_exn r Exception; + Lwt.return false + with Invalid_argument "Lwt.wakeup_later_exn" -> Lwt.return true) + [@ocaml.warning "-52"]); + test "wakeup_later_result: nested" (fun () -> + let f_ran = ref false in + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + Lwt.on_success p2 (fun _ -> f_ran := true); + Lwt.on_success p1 (fun s -> + Lwt.wakeup_later_result r2 (Result.Ok (s ^ "bar")); + assert (Lwt.state p2 = Lwt.Return "foobar"); + assert (!f_ran = false)); + Lwt.wakeup_later_result r1 (Result.Ok "foo"); + Lwt.return (!f_ran = true && Lwt.state p2 = Lwt.Return "foobar")); + (* Only basic tests for wakeup_later and wakeup_later_exn, as they are + implemented in terms of wakeup_later_result. This isn't fully legitimate as + a reason, but oh well. *) + test "wakeup_later: basic" (fun () -> + let p, r = Lwt.wait () in + Lwt.wakeup_later r "foo"; + state_is (Lwt.Return "foo") p); + test "wakeup_later_exn: basic" (fun () -> + let p, r = Lwt.wait () in + Lwt.wakeup_later_exn r Exception; + state_is (Lwt.Fail Exception) p); + ] + +let suites = suites @ [ wakeup_later_tests ] (* Cancellation and its interaction with the rest of the API. *) -let cancel_tests = suite "cancel" [ - test "fulfilled" begin fun () -> - let p = Lwt.return () in - Lwt.cancel p; - Lwt.return (Lwt.state p = Lwt.Return ()) - end; - - test "rejected" begin fun () -> - let p = Lwt.fail Exception in - Lwt.cancel p; - Lwt.return (Lwt.state p = Lwt.Fail Exception) - end; - - test "wait" begin fun () -> - let p, _ = Lwt.wait () in - Lwt.cancel p; - Lwt.return (Lwt.state p = Lwt.Sleep) - end; - - test "task" begin fun () -> - let p, _ = Lwt.task () in - Lwt.cancel p; - Lwt.return (Lwt.state p = Lwt.Fail Lwt.Canceled) - end; - - test "callback" begin fun () -> - let saw = ref None in - let p, _ = Lwt.task () in - Lwt.on_failure p (fun exn -> saw := Some exn); - Lwt.cancel p; - Lwt.return (!saw = Some Lwt.Canceled) - end; - - (* Behaves like wakeup rather than wakeup_later, even though that's probably - wrong. Calling cancel in a (functional) loop will cause stack overflow. *) - test "nested" begin fun () -> - let f_ran = ref false in - let p1, _ = Lwt.task () in - let p2, _ = Lwt.task () in - Lwt.on_failure p2 (fun _ -> f_ran := true); - Lwt.on_failure p1 (fun _ -> - Lwt.cancel p2; - assert (Lwt.state p2 = Lwt.Fail Lwt.Canceled); - assert (!f_ran = true)); - Lwt.cancel p1; - Lwt.return (!f_ran = true && Lwt.state p2 = Lwt.Fail Lwt.Canceled) - end; -] -let suites = suites @ [cancel_tests] - -let on_cancel_tests = suite "on_cancel" [ - test "pending" begin fun () -> - let f_ran = ref false in - let p, _ = Lwt.task () in - Lwt.on_cancel p (fun () -> f_ran := true); - assert (!f_ran = false); - Lwt.cancel p; - Lwt.return (!f_ran = true) - end; - - test "multiple" begin fun () -> - let f_ran = ref false in - let g_ran = ref false in - let h_ran = ref false in - let p, _ = Lwt.task () in - Lwt.on_cancel p (fun () -> f_ran := true); - Lwt.on_cancel p (fun () -> g_ran := true); - Lwt.on_cancel p (fun () -> h_ran := true); - Lwt.cancel p; - Lwt.return (!f_ran = true && !g_ran = true && !h_ran = true) - end; - - test "ordering" begin fun () -> - (* Two cancel callbacks to make sure they both run before the ordinary - callback. *) - let on_cancel_1_ran = ref false in - let on_cancel_2_ran = ref false in - let callback_ran = ref false in - let p, _ = Lwt.task () in - Lwt.on_cancel p (fun () -> on_cancel_1_ran := true); - Lwt.on_failure p (fun _ -> - assert (!on_cancel_1_ran = true); - assert (!on_cancel_2_ran = true); - callback_ran := true); - Lwt.on_cancel p (fun () -> on_cancel_2_ran := true); - Lwt.cancel p; - Lwt.return (!callback_ran = true) - end; - - test "fulfilled" begin fun () -> - let f_ran = ref false in - Lwt.on_cancel (Lwt.return ()) (fun () -> f_ran := true); - Lwt.return (!f_ran = false) - end; - - test "rejected" begin fun () -> - let f_ran = ref false in - Lwt.on_cancel (Lwt.fail Exception) (fun () -> f_ran := true); - Lwt.return (!f_ran = false) - end; - - test "already canceled" begin fun () -> - let f_ran = ref false in - Lwt.on_cancel (Lwt.fail Lwt.Canceled) (fun () -> f_ran := true); - Lwt.return (!f_ran = true) - end; - - (* More generally, this tests that rejecting with [Lwt.Canceled] is equivalent - to calling [Lwt.cancel]. The difference is that [Lwt.cancel] can be called - on promises without the need of a resolver. *) - test "reject with Canceled" begin fun () -> - let f_ran = ref false in - let p, r = Lwt.wait () in - Lwt.on_cancel p (fun () -> f_ran := true); - Lwt.wakeup_exn r Lwt.Canceled; - Lwt.return (!f_ran = true) - end; -] -let suites = suites @ [on_cancel_tests] - -let protected_tests = suite "protected" [ - test "fulfilled" begin fun () -> - let p = Lwt.protected (Lwt.return ()) in - (* If [p] starts fulfilled, it can't be canceled. *) - Lwt.return (Lwt.state p = Lwt.Return ()) - end; - - test "rejected" begin fun () -> - let p = Lwt.protected (Lwt.fail Exception) in - Lwt.return (Lwt.state p = Lwt.Fail Exception) - end; - - test "pending" begin fun () -> - let p, _ = Lwt.task () in - let p' = Lwt.protected p in - Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) - end; - - test "pending, fulfilled" begin fun () -> - let p, r = Lwt.task () in - let p' = Lwt.protected p in - Lwt.wakeup r "foo"; - Lwt.return (Lwt.state p' = Lwt.Return "foo") - end; - - test "pending, canceled" begin fun () -> - let p, _ = Lwt.task () in - let p' = Lwt.protected p in - Lwt.cancel p'; - Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Fail Lwt.Canceled) - end; - - test "pending, canceled, fulfilled" begin fun () -> - let p, r = Lwt.task () in - let p' = Lwt.protected p in - Lwt.cancel p'; - Lwt.wakeup r "foo"; - Lwt.return - (Lwt.state p = Lwt.Return "foo" && Lwt.state p' = Lwt.Fail Lwt.Canceled) - end; - - (* Implementation detail: [p' = Lwt.protected _] can still be resolved if it - becomes a proxy. *) - test "pending, proxy" begin fun () -> - let p1, r1 = Lwt.task () in - let p2 = Lwt.protected p1 in - - (* Make p2 a proxy for p4; p3 is just needed to suspend the bind, in order - to callback the code that makes p2 a proxy. *) - let p3, r3 = Lwt.wait () in - let _ = Lwt.bind p3 (fun () -> p2) in - Lwt.wakeup r3 (); - - (* It should now be possible to resolve p2 by resolving p1. *) - Lwt.wakeup r1 "foo"; - Lwt.return (Lwt.state p2 = Lwt.Return "foo") - end; -] -let suites = suites @ [protected_tests] - -let cancelable_tests = suite "wrap_in_cancelable" [ - test "fulfilled" begin fun () -> - let p = Lwt.wrap_in_cancelable (Lwt.return ()) in - Lwt.return (Lwt.state p = Lwt.Return ()) - end; - - test "rejected" begin fun () -> - let p = Lwt.wrap_in_cancelable (Lwt.fail Exception) in - Lwt.return (Lwt.state p = Lwt.Fail Exception) - end; - - test "pending(task)" begin fun () -> - let p, _ = Lwt.task () in - let p' = Lwt.wrap_in_cancelable p in - Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) - end; - - test "pending(task), fulfilled" begin fun () -> - let p, r = Lwt.task () in - let p' = Lwt.wrap_in_cancelable p in - Lwt.wakeup r "foo"; - Lwt.return (Lwt.state p = Lwt.Return "foo" && Lwt.state p' = Lwt.Return "foo") - end; - - test "pending(task), canceled" begin fun () -> - let p, _ = Lwt.task () in - let p' = Lwt.wrap_in_cancelable p in - Lwt.cancel p'; - Lwt.return (Lwt.state p = Lwt.Fail Lwt.Canceled && Lwt.state p' = Lwt.Fail Lwt.Canceled) - end; - - test "pending(wait)" begin fun () -> - let p, _ = Lwt.wait () in - let p' = Lwt.wrap_in_cancelable p in - Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) - end; - - test "pending(wait), fulfilled" begin fun () -> - let p, r = Lwt.wait () in - let p' = Lwt.wrap_in_cancelable p in - Lwt.wakeup r "foo"; - Lwt.return (Lwt.state p = Lwt.Return "foo" && Lwt.state p' = Lwt.Return "foo") - end; - - test "pending(wait), canceled" begin fun () -> - let p, _ = Lwt.wait () in - let p' = Lwt.wrap_in_cancelable p in - Lwt.cancel p'; - Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Fail Lwt.Canceled) - end; - - test "pending(task), canceled, fulfilled" begin fun () -> - let p, r = Lwt.task () in - let p' = Lwt.wrap_in_cancelable p in - Lwt.cancel p'; - Lwt.wakeup r "foo"; - Lwt.return - (Lwt.state p = Lwt.Fail Lwt.Canceled && Lwt.state p' = Lwt.Fail Lwt.Canceled) - end; - - test "pending(wait), canceled, fulfilled" begin fun () -> - let p, r = Lwt.wait () in - let p' = Lwt.wrap_in_cancelable p in - Lwt.cancel p'; - Lwt.wakeup r "foo"; - Lwt.return - (Lwt.state p = Lwt.Return "foo" && Lwt.state p' = Lwt.Fail Lwt.Canceled) - end; - - (* Implementation detail: [p' = Lwt.wrap_in_cancelable _] can still be - resolved if it becomes a proxy. *) - test "pending, proxy" begin fun () -> - let p1, r1 = Lwt.task () in - let p2 = Lwt.wrap_in_cancelable p1 in - - (* Make p2 a proxy for p4; p3 is just needed to suspend the bind, in order - to callback the code that makes p2 a proxy. *) - let p3, r3 = Lwt.wait () in - let _ = Lwt.bind p3 (fun () -> p2) in - Lwt.wakeup r3 (); - - (* It should now be possible to resolve p2 by resolving p1. *) - Lwt.wakeup r1 "foo"; - Lwt.return (Lwt.state p2 = Lwt.Return "foo") - end; -] -let suites = suites @ [cancelable_tests] - -let no_cancel_tests = suite "no_cancel" [ - test "fulfilled" begin fun () -> - let p = Lwt.no_cancel (Lwt.return ()) in - (* [p] starts fulfilled, so it can't be canceled. *) - Lwt.return (Lwt.state p = Lwt.Return ()) - end; - - test "rejected" begin fun () -> - let p = Lwt.no_cancel (Lwt.fail Exception) in - Lwt.return (Lwt.state p = Lwt.Fail Exception) - end; - - test "pending" begin fun () -> - let p, _ = Lwt.task () in - let p' = Lwt.no_cancel p in - Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) - end; - - test "pending, fulfilled" begin fun () -> - let p, r = Lwt.task () in - let p = Lwt.no_cancel p in - Lwt.wakeup r "foo"; - Lwt.return (Lwt.state p = Lwt.Return "foo") - end; - - test "pending, cancel attempt" begin fun () -> - let p, _ = Lwt.task () in - let p' = Lwt.no_cancel p in - Lwt.cancel p'; - Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) - end; -] -let suites = suites @ [no_cancel_tests] - -let resolve_already_canceled_promise_tests = suite "resolve canceled" [ - test "wakeup: canceled" begin fun () -> - let p, r = Lwt.task () in - Lwt.cancel p; - Lwt.wakeup r (); - Lwt.return (Lwt.state p = Lwt.Fail Lwt.Canceled) - end; - - (* This test can start falsely passing if the entire test is run inside an - Lwt promise resolution phase, e.g. inside an outer [Lwt.wakeup_later]. *) - test "wakeup_later: canceled" begin fun () -> - let p, r = Lwt.task () in - Lwt.cancel p; - Lwt.wakeup_later r (); - Lwt.return (Lwt.state p = Lwt.Fail Lwt.Canceled) - end; -] -let suites = suites @ [resolve_already_canceled_promise_tests] - -let pick_tests = suite "pick" [ - test "empty" begin fun () -> - try - ignore (Lwt.pick []); - Lwt.return false - with Invalid_argument "Lwt.pick [] would return a \ - promise that is pending forever" -> - Lwt.return true - end [@ocaml.warning "-52"]; - - test "fulfilled" begin fun () -> - let p1, _ = Lwt.task () in - let p2 = Lwt.pick [p1; Lwt.return "foo"] in - Lwt.return - (Lwt.state p1 = Lwt.Fail Lwt.Canceled && Lwt.state p2 = Lwt.Return "foo") - end; - - test "rejected" begin fun () -> - let p1, _ = Lwt.task () in - let p2 = Lwt.pick [p1; Lwt.fail Exception] in - Lwt.return - (Lwt.state p1 = Lwt.Fail Lwt.Canceled && - Lwt.state p2 = Lwt.Fail Exception) - end; - - test "multiple resolved" begin fun () -> - (* This is run in a loop to exercise the internal PRNG. *) - let outcomes = Array.make 3 0 in - let rec repeat n = - if n <= 0 then () - else - let p = - Lwt.pick - [fst (Lwt.wait ()); - Lwt.return "foo"; - Lwt.fail Exception; - Lwt.return "bar"] - in - begin match Lwt.state p with - | Lwt.Return "foo" -> outcomes.(0) <- outcomes.(0) + 1 - | Lwt.Fail Exception -> outcomes.(1) <- outcomes.(1) + 1 - | Lwt.Return "bar" -> outcomes.(2) <- outcomes.(2) + 1 - | _ -> assert false - end [@ocaml.warning "-4"]; - repeat (n - 1) - in - let count = 1000 in - repeat count; - Lwt.return - (outcomes.(0) > 0 && outcomes.(1) > 0 && outcomes.(2) > 0 && - outcomes.(0) + outcomes.(1) + outcomes.(2) = count) - end; - - test "pending" begin fun () -> - let p = Lwt.pick [fst (Lwt.wait ()); fst (Lwt.wait ())] in - Lwt.return (Lwt.state p = Lwt.Sleep) - end; - - test "pending, fulfilled" begin fun () -> - let p1, r1 = Lwt.task () in - let p2, _ = Lwt.task () in - let p = Lwt.pick [p1; p2] in - Lwt.wakeup r1 "foo"; - Lwt.return - (Lwt.state p2 = Lwt.Fail Lwt.Canceled && Lwt.state p = Lwt.Return "foo") - end; - - test "diamond" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.pick [p; p] in - Lwt.wakeup r "foo"; - Lwt.return (Lwt.state p = Lwt.Return "foo") - end; - - test "pending, canceled" begin fun () -> - let p1, _ = Lwt.task () in - let p2, _ = Lwt.task () in - let p = Lwt.pick [p1; p2] in - Lwt.cancel p; - Lwt.return - (Lwt.state p1 = Lwt.Fail Lwt.Canceled && - Lwt.state p2 = Lwt.Fail Lwt.Canceled) - end; - - test "cancellation/resolution order" begin fun () -> - let a = [|0; 0|] in - let i = ref 0 in - let p1, r1 = Lwt.task () in - let p2, _ = Lwt.task () in - let p3 = Lwt.pick [p1; p2] in - let _ = - Lwt.catch - (fun () -> p2) - (fun _ -> - a.(!i) <- 1; - i := 1; - Lwt.return ()) - in - let _ = - Lwt.bind p3 (fun _ -> - a.(!i) <- 2; - i := 1; - Lwt.return ()) - in - Lwt.wakeup_later r1 (); - Lwt.return (a.(0) = 1 && a.(1) = 2) - end; -] -let suites = suites @ [pick_tests] - -let npick_tests = suite "npick" [ - test "empty" begin fun () -> - try - ignore (Lwt.npick []); - Lwt.return false - with Invalid_argument "Lwt.npick [] would return a \ - promise that is pending forever" -> - Lwt.return true - end [@ocaml.warning "-52"]; - - test "all fulfilled" begin fun () -> - let p = Lwt.npick [Lwt.return "foo"; Lwt.return "bar"] in - Lwt.return (Lwt.state p = Lwt.Return ["foo"; "bar"]) - end; - - test "fulfilled, rejected" begin fun () -> - let p = Lwt.npick [Lwt.return "foo"; Lwt.fail Exception] in - Lwt.return (Lwt.state p = Lwt.Fail Exception) - end; - - test "rejected, fulfilled" begin fun () -> - let p = Lwt.npick [Lwt.fail Exception; Lwt.return "foo"] in - Lwt.return (Lwt.state p = Lwt.Fail Exception) - end; - - test "some pending" begin fun () -> - let p1, _ = Lwt.task () in - let p2 = Lwt.npick [Lwt.return "foo"; p1; Lwt.return "bar"] in - Lwt.return - (Lwt.state p1 = Lwt.Fail Lwt.Canceled && - Lwt.state p2 = Lwt.Return ["foo"; "bar"]) - end; - - test "pending" begin fun () -> - let p = Lwt.npick [fst (Lwt.task ()); fst (Lwt.task ())] in - Lwt.return (Lwt.state p = Lwt.Sleep) - end; - - test "pending, fulfilled" begin fun () -> - let p1, _ = Lwt.task () in - let p2, r = Lwt.task () in - let p = Lwt.npick [p1; p2] in - Lwt.wakeup r "foo"; - Lwt.return - (Lwt.state p1 = Lwt.Fail Lwt.Canceled && - Lwt.state p = Lwt.Return ["foo"]) - end; - - test "pending, rejected" begin fun () -> - let p1, _ = Lwt.task () in - let p2, r = Lwt.task () in - let p = Lwt.npick [p1; p2] in - Lwt.wakeup_exn r Exception; - Lwt.return - (Lwt.state p1 = Lwt.Fail Lwt.Canceled && - Lwt.state p = Lwt.Fail Exception) - end; - - test "diamond" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.npick [p; p] in - Lwt.wakeup r "foo"; - Lwt.return (Lwt.state p = Lwt.Return ["foo"; "foo"]) - end; - - test "diamond, rejected" begin fun () -> - let p, r = Lwt.wait () in - let p = Lwt.npick [p; p] in - Lwt.wakeup_exn r Exception; - Lwt.return (Lwt.state p = Lwt.Fail Exception) - end; - - test "pending, canceled" begin fun () -> - let p1, _ = Lwt.task () in - let p2, _ = Lwt.task () in - let p = Lwt.npick [p1; p2] in - Lwt.cancel p; - Lwt.return - (Lwt.state p1 = Lwt.Fail Lwt.Canceled && - Lwt.state p2 = Lwt.Fail Lwt.Canceled) - end; - - test "cancellation/resolution order" begin fun () -> - let a = [|0; 0|] in - let i = ref 0 in - let p1, r1 = Lwt.task () in - let p2, _ = Lwt.task () in - let p3 = Lwt.npick [p1; p2] in - let _ = - Lwt.catch - (fun () -> p2) - (fun _ -> - a.(!i) <- 1; - i := 1; - Lwt.return ()) - in - let _ = - Lwt.bind p3 (fun _ -> - a.(!i) <- 2; - i := 1; - Lwt.return ()) - in - Lwt.wakeup_later r1 (); - Lwt.return (a.(0) = 1 && a.(1) = 2) - end; -] -let suites = suites @ [npick_tests] - -let cancel_bind_tests = suite "cancel bind" [ - test "wait, pending, canceled" begin fun () -> - let f_ran = ref false in - let p, _ = Lwt.wait () in - let p' = Lwt.bind p (fun () -> f_ran := true; Lwt.return ()) in - Lwt.cancel p'; - Lwt.return - (!f_ran = false && Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) - end; - - test "task, pending, canceled" begin fun () -> - let f_ran = ref false in - let p, _ = Lwt.task () in - let p' = Lwt.bind p (fun () -> f_ran := true; Lwt.return ()) in - Lwt.cancel p'; - Lwt.return - (!f_ran = false && - Lwt.state p = Lwt.Fail Lwt.Canceled && - Lwt.state p' = Lwt.Fail Lwt.Canceled) - end; - - test "pending, wait, canceled" begin fun () -> - let p, r = Lwt.wait () in - let p', _ = Lwt.wait () in - let p'' = Lwt.bind p (fun () -> p') in - Lwt.wakeup r (); - (* [bind]'s [f] ran, and now [p'] and [p''] should share the same state. *) - Lwt.cancel p''; - Lwt.return (Lwt.state p' = Lwt.Sleep && Lwt.state p'' = Lwt.Sleep) - end; - - test "pending, task, canceled" begin fun () -> - let p1, r = Lwt.wait () in - let p2, _ = Lwt.task () in - let p3 = Lwt.bind p1 (fun () -> p2) in - Lwt.wakeup r (); - Lwt.cancel p3; - Lwt.return - (Lwt.state p2 = Lwt.Fail Lwt.Canceled && - Lwt.state p3 = Lwt.Fail Lwt.Canceled && - p2 != p3) - end; - - test "pending, task, canceled, chain" begin fun () -> - let p1, r = Lwt.wait () in - let p2, _ = Lwt.task () in - let p3 = Lwt.bind p1 (fun () -> p2) in - let p4 = Lwt.bind p1 (fun () -> p3) in - Lwt.wakeup r (); - (* At this point, [p4] and [p3] share the same state, and canceling [p4] - should chain to [p2], because [p3] is obtained by binding on [p2]. *) - Lwt.cancel p4; - Lwt.return - (Lwt.state p2 = Lwt.Fail Lwt.Canceled && - Lwt.state p3 = Lwt.Fail Lwt.Canceled && - Lwt.state p4 = Lwt.Fail Lwt.Canceled) - end; - - test "pending, on_cancel callbacks" begin fun () -> - let f_ran = ref false in - let g_ran = ref false in - let p1, _ = Lwt.task () in - let p2 = Lwt.bind (fst (Lwt.task ())) (fun () -> p1) in - Lwt.on_cancel p1 (fun () -> f_ran := true); - Lwt.on_cancel p2 (fun () -> g_ran := true); - Lwt.cancel p2; - (* Canceling [p2] doesn't cancel [p1], because the function passed to - [Lwt.bind] never ran. *) - Lwt.return (!f_ran = false && !g_ran = true) - end; - - test "pending, fulfilled, on_cancel callbacks" begin fun () -> - let f_ran = ref false in - let g_ran = ref false in - let p1, r = Lwt.task () in - let p2, _ = Lwt.task () in - let p3 = Lwt.bind p1 (fun () -> p2) in - Lwt.on_cancel p2 (fun () -> f_ran := true); - Lwt.on_cancel p3 (fun () -> g_ran := true); - Lwt.wakeup r (); - Lwt.cancel p3; - (* Canceling [p3] cancels [p2], because the function passed to [Lwt.bind] - did run, and evaluated to [p2]. *) - Lwt.return (!f_ran = true && !g_ran = true) - end; -] -let suites = suites @ [cancel_bind_tests] - -let cancel_map_tests = suite "cancel map" [ - test "wait, pending, canceled" begin fun () -> - let f_ran = ref false in - let p, _ = Lwt.wait () in - let p' = Lwt.map (fun () -> f_ran := true) p in - Lwt.cancel p'; - Lwt.return - (!f_ran = false && Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) - end; - - test "task, pending, canceled" begin fun () -> - let f_ran = ref false in - let p, _ = Lwt.task () in - let p' = Lwt.map (fun () -> f_ran := true) p in - Lwt.cancel p'; - Lwt.return - (!f_ran = false && - Lwt.state p = Lwt.Fail Lwt.Canceled && - Lwt.state p' = Lwt.Fail Lwt.Canceled) - end; -] -let suites = suites @ [cancel_map_tests] - -let cancel_catch_tests = suite "cancel catch" [ - (* In [p' = Lwt.catch (fun () -> p) f], if [p] is not cancelable, [p'] is also - not cancelable. *) - test "wait, pending, canceled" begin fun () -> - let f_ran = ref false in - let p, _ = Lwt.wait () in - let p' = - Lwt.catch - (fun () -> p) - (fun _ -> f_ran := true; Lwt.return ()) - in - Lwt.cancel p'; - Lwt.return - (!f_ran = false && Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) - end; - - (* In [p' = Lwt.catch (fun () -> p) f], if [p] is cancelable, canceling [p'] - propagates to [p], and then the cancellation exception can be "intercepted" - by [f], which can resolve [p'] in an arbitrary way. *) - test "task, pending, canceled" begin fun () -> - let saw = ref None in - let p, _ = Lwt.task () in - let p' = - Lwt.catch - (fun () -> p) - (fun exn -> saw := Some exn; Lwt.return "foo") - in - Lwt.cancel p'; - Lwt.return - (!saw = Some Lwt.Canceled && - Lwt.state p = Lwt.Fail Lwt.Canceled && - Lwt.state p' = Lwt.Return "foo") - end; - - (* In [p' = Lwt.catch (fun () -> p) f], if [p] is cancelable, and cancel - callbacks are added to both [p] and [p'], and [f] does not resolve [p'] - with [Lwt.Fail Lwt.Canceled], only the callback on [p] runs. *) - test "task, pending, canceled, on_cancel, intercepted" begin fun () -> - let on_cancel_1_ran = ref false in - let on_cancel_2_ran = ref false in - let p, _ = Lwt.task () in - let p' = - Lwt.catch - (fun () -> p) - (fun _ -> - assert (!on_cancel_1_ran = true && !on_cancel_2_ran = false); - Lwt.return "foo") - in - Lwt.on_cancel p (fun () -> on_cancel_1_ran := true); - Lwt.on_cancel p' (fun () -> on_cancel_2_ran := true); - Lwt.cancel p'; - Lwt.return - (Lwt.state p = Lwt.Fail Lwt.Canceled && - Lwt.state p' = Lwt.Return "foo" && - !on_cancel_2_ran = false) - end; - - (* Same as above, except this time, cancellation is passed on to the outer - promise, so we can expect both cancel callbacks to run. *) - test "task, pending, canceled, on_cancel, forwarded" begin fun () -> - let on_cancel_2_ran = ref false in - let p, _ = Lwt.task () in - let p' = Lwt.catch (fun () -> p) Lwt.fail in - Lwt.on_cancel p' (fun () -> on_cancel_2_ran := true); - Lwt.cancel p'; - Lwt.return - (Lwt.state p = Lwt.Fail Lwt.Canceled && - Lwt.state p' = Lwt.Fail Lwt.Canceled && - !on_cancel_2_ran = true) - end; - - (* (2 tests) If the handler passed to [Lwt.catch] already ran, canceling the - outer promise is the same as canceling the promise returned by the - handler. *) - test "pending, wait, canceled" begin fun () -> - let p1, r = Lwt.wait () in - let p2, _ = Lwt.wait () in - let p3 = - Lwt.catch - (fun () -> p1) - (fun _ -> p2) - in - Lwt.wakeup_exn r Exception; - Lwt.cancel p3; - Lwt.return (Lwt.state p2 = Lwt.Sleep && Lwt.state p3 = Lwt.Sleep) - end; - - test "pending, task, canceled" begin fun () -> - let p1, r = Lwt.wait () in - let p2, _ = Lwt.task () in - let p3 = - Lwt.catch - (fun () -> p1) - (fun _ -> p2) - in - Lwt.wakeup_exn r Exception; - Lwt.cancel p3; - Lwt.return - (Lwt.state p2 = Lwt.Fail Lwt.Canceled && - Lwt.state p3 = Lwt.Fail Lwt.Canceled) - end; -] -let suites = suites @ [cancel_catch_tests] - -let cancel_try_bind_tests = suite "cancel try_bind" [ - test "wait, pending, canceled" begin fun () -> - let f_or_g_ran = ref false in - let p, _ = Lwt.wait () in - let p' = - Lwt.try_bind - (fun () -> p) - (fun () -> f_or_g_ran := true; Lwt.return ()) - (fun _ -> f_or_g_ran := true; Lwt.return ()) - in - Lwt.cancel p'; - Lwt.return - (!f_or_g_ran = false && - Lwt.state p = Lwt.Sleep && - Lwt.state p' = Lwt.Sleep) - end; - - test "task, pending, canceled" begin fun () -> - let f_ran = ref false in - let saw = ref None in - let p, _ = Lwt.task () in - let p' = - Lwt.try_bind - (fun () -> p) - (fun () -> f_ran := true; Lwt.return "foo") - (fun exn -> saw := Some exn; Lwt.return "bar") - in - Lwt.cancel p'; - Lwt.return - (!f_ran = false && - !saw = Some Lwt.Canceled && - Lwt.state p = Lwt.Fail Lwt.Canceled && - Lwt.state p' = Lwt.Return "bar") - end; - - test "pending, fulfilled, wait, canceled" begin fun () -> - let p1, r = Lwt.wait () in - let p2, _ = Lwt.wait () in - let p3 = - Lwt.try_bind - (fun () -> p1) - (fun () -> p2) - (fun _ -> Lwt.return "foo") - in - Lwt.wakeup r (); - Lwt.cancel p3; - Lwt.return (Lwt.state p2 = Lwt.Sleep && Lwt.state p3 = Lwt.Sleep) - end; - - test "pending, fulfilled, task, canceled" begin fun () -> - let p1, r = Lwt.wait () in - let p2, _ = Lwt.task () in - let p3 = - Lwt.try_bind - (fun () -> p1) - (fun () -> p2) - (fun _ -> Lwt.return "foo") - in - Lwt.wakeup r (); - Lwt.cancel p3; - Lwt.return - (Lwt.state p2 = Lwt.Fail Lwt.Canceled && - Lwt.state p3 = Lwt.Fail Lwt.Canceled) - end; - - test "pending, rejected, wait, canceled" begin fun () -> - let p1, r = Lwt.wait () in - let p2, _ = Lwt.wait () in - let p3 = - Lwt.try_bind - (fun () -> p1) - (fun () -> Lwt.return "foo") - (fun _ -> p2) - in - Lwt.wakeup_exn r Exception; - Lwt.cancel p3; - Lwt.return (Lwt.state p2 = Lwt.Sleep && Lwt.state p3 = Lwt.Sleep) - end; - - test "pending, rejected, task, canceled" begin fun () -> - let p1, r = Lwt.wait () in - let p2, _ = Lwt.task () in - let p3 = - Lwt.try_bind - (fun () -> p1) - (fun () -> Lwt.return "foo") - (fun _ -> p2) - in - Lwt.wakeup_exn r Exception; - Lwt.cancel p3; - Lwt.return - (Lwt.state p2 = Lwt.Fail Lwt.Canceled && - Lwt.state p3 = Lwt.Fail Lwt.Canceled) - end; -] -let suites = suites @ [cancel_try_bind_tests] - -let cancel_finalize_tests = suite "cancel finalize" [ - test "wait, pending, canceled" begin fun () -> - let f_ran = ref false in - let p, _ = Lwt.wait () in - let p' = - Lwt.finalize - (fun () -> p) - (fun () -> f_ran := true; Lwt.return ()) - in - Lwt.cancel p'; - Lwt.return - (!f_ran = false && Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) - end; - - test "task, pending, canceled" begin fun () -> - let f_ran = ref false in - let p, _ = Lwt.task () in - let p' = - Lwt.finalize - (fun () -> p) - (fun () -> f_ran := true; Lwt.return ()) - in - Lwt.cancel p'; - Lwt.return - (!f_ran = true && - Lwt.state p = Lwt.Fail Lwt.Canceled && - Lwt.state p' = Lwt.Fail Lwt.Canceled) - end; - - test "task, canceled, cancel exception replaced" begin fun () -> - let p, _ = Lwt.task () in - let p' = - Lwt.finalize - (fun () -> p) - (fun () -> Lwt.fail Exception) - in - Lwt.cancel p; - Lwt.return (Lwt.state p' = Lwt.Fail Exception) - end; - - test "pending, wait, canceled" begin fun () -> - let p1, r = Lwt.wait () in - let p2, _ = Lwt.wait () in - let p3 = - Lwt.finalize - (fun () -> p1) - (fun () -> p2) - in - Lwt.wakeup r (); - Lwt.cancel p3; - Lwt.return (Lwt.state p2 = Lwt.Sleep && Lwt.state p3 = Lwt.Sleep) - end; - - test "pending, task, canceled" begin fun () -> - let p1, r = Lwt.wait () in - let p2, _ = Lwt.task () in - let p3 = - Lwt.finalize - (fun () -> p1) - (fun () -> p2) - in - Lwt.wakeup r (); - Lwt.cancel p3; - Lwt.return - (Lwt.state p2 = Lwt.Fail Lwt.Canceled && - Lwt.state p3 = Lwt.Fail Lwt.Canceled) - end; -] -let suites = suites @ [cancel_finalize_tests] - -let cancel_direct_handler_tests = suite "cancel with direct handler" [ - test "on_success: pending, canceled" begin fun () -> - let f_ran = ref false in - let p, _ = Lwt.task () in - Lwt.on_success p (fun () -> f_ran := true); - Lwt.cancel p; - Lwt.return (!f_ran = false) - end; - - test "on_failure: pending, canceled" begin fun () -> - let saw = ref None in - let p, _ = Lwt.task () in - Lwt.on_failure p (fun exn -> saw := Some exn); - Lwt.cancel p; - Lwt.return (!saw = Some Lwt.Canceled) - end; - - test "on_termination: pending, canceled" begin fun () -> - let f_ran = ref false in - let p, _ = Lwt.task () in - Lwt.on_termination p (fun () -> f_ran := true); - Lwt.cancel p; - Lwt.return (!f_ran = true) - end; - - test "on_any: pending, canceled" begin fun () -> - let f_ran = ref false in - let saw = ref None in - let p, _ = Lwt.task () in - Lwt.on_any p (fun () -> f_ran := true) (fun exn -> saw := Some exn); - Lwt.cancel p; - Lwt.return (!f_ran = false && !saw = Some Lwt.Canceled) - end; -] -let suites = suites @ [cancel_direct_handler_tests] - -let cancel_join_tests = suite "cancel join" [ - test "wait, pending, cancel" begin fun () -> - let p1, _ = Lwt.wait () in - let p2, _ = Lwt.wait () in - let p3 = Lwt.join [p1; p2] in - Lwt.cancel p3; - Lwt.return - (Lwt.state p1 = Lwt.Sleep && - Lwt.state p2 = Lwt.Sleep && - Lwt.state p3 = Lwt.Sleep) - end; - - test "task, pending, cancel" begin fun () -> - let p1, _ = Lwt.task () in - let p2, _ = Lwt.task () in - let p3 = Lwt.join [p1; p2] in - Lwt.cancel p3; - Lwt.return - (Lwt.state p1 = Lwt.Fail Lwt.Canceled && - Lwt.state p2 = Lwt.Fail Lwt.Canceled && - Lwt.state p3 = Lwt.Fail Lwt.Canceled) - end; - - test "wait and task, pending, cancel" begin fun () -> - let p1, r = Lwt.wait () in - let p2, _ = Lwt.task () in - let p3 = Lwt.join [p1; p2] in - Lwt.cancel p3; - assert (Lwt.state p1 = Lwt.Sleep); - assert (Lwt.state p2 = Lwt.Fail Lwt.Canceled); - assert (Lwt.state p3 = Lwt.Sleep); - Lwt.wakeup r (); - Lwt.return - (Lwt.state p1 = Lwt.Return () && Lwt.state p3 = Lwt.Fail Lwt.Canceled) - end; - - (* In [p' = Lwt.join [p; p]], if [p'] is canceled, the cancel handler on [p] - is called only once, even though it is reachable by two paths in the - cancellation graph. *) - test "cancel diamond" begin fun () -> - let ran = ref 0 in - let p, _ = Lwt.task () in - let p' = Lwt.join [p; p] in - Lwt.on_cancel p (fun () -> ran := !ran + 1); - Lwt.cancel p'; - Lwt.return (!ran = 1) - end; -] -let suites = suites @ [cancel_join_tests] - -let cancel_choose_tests = suite "cancel choose" [ - test "wait, pending, cancel" begin fun () -> - let p1, _ = Lwt.wait () in - let p2, _ = Lwt.wait () in - let p3 = Lwt.choose [p1; p2] in - Lwt.cancel p3; - Lwt.return - (Lwt.state p1 = Lwt.Sleep && - Lwt.state p2 = Lwt.Sleep && - Lwt.state p3 = Lwt.Sleep) - end; - - test "wait and task, pending, cancel" begin fun () -> - let p1, _ = Lwt.wait () in - let p2, _ = Lwt.task () in - let p3 = Lwt.choose [p1; p2] in - Lwt.cancel p3; - Lwt.return - (Lwt.state p1 = Lwt.Sleep && - Lwt.state p2 = Lwt.Fail Lwt.Canceled && - Lwt.state p3 = Lwt.Fail Lwt.Canceled) - end; -] -let suites = suites @ [cancel_choose_tests] - -let cancel_pick_tests = suite "cancel pick" [ - test "wait, pending, cancel" begin fun () -> - let p1, _ = Lwt.wait () in - let p2, _ = Lwt.wait () in - let p3 = Lwt.pick [p1; p2] in - Lwt.cancel p3; - Lwt.return - (Lwt.state p1 = Lwt.Sleep && - Lwt.state p2 = Lwt.Sleep && - Lwt.state p3 = Lwt.Sleep) - end; - - test "wait and task, pending, cancel" begin fun () -> - let p1, _ = Lwt.wait () in - let p2, _ = Lwt.task () in - let p3 = Lwt.pick [p1; p2] in - Lwt.cancel p3; - Lwt.return - (Lwt.state p1 = Lwt.Sleep && - Lwt.state p2 = Lwt.Fail Lwt.Canceled && - Lwt.state p3 = Lwt.Fail Lwt.Canceled) - end; -] -let suites = suites @ [cancel_pick_tests] - -let cancel_nchoose_tests = suite "cancel nchoose" [ - test "wait, pending, cancel" begin fun () -> - let p1, _ = Lwt.wait () in - let p2, _ = Lwt.wait () in - let p3 = Lwt.nchoose [p1; p2] in - Lwt.cancel p3; - Lwt.return - (Lwt.state p1 = Lwt.Sleep && - Lwt.state p2 = Lwt.Sleep && - Lwt.state p3 = Lwt.Sleep) - end; - - test "wait and task, pending, cancel" begin fun () -> - let p1, _ = Lwt.wait () in - let p2, _ = Lwt.task () in - let p3 = Lwt.nchoose [p1; p2] in - Lwt.cancel p3; - Lwt.return - (Lwt.state p1 = Lwt.Sleep && - Lwt.state p2 = Lwt.Fail Lwt.Canceled && - Lwt.state p3 = Lwt.Fail Lwt.Canceled) - end; -] -let suites = suites @ [cancel_nchoose_tests] - -let cancel_npick_tests = suite "cancel npick" [ - test "wait, pending, cancel" begin fun () -> - let p1, _ = Lwt.wait () in - let p2, _ = Lwt.wait () in - let p3 = Lwt.npick [p1; p2] in - Lwt.cancel p3; - Lwt.return - (Lwt.state p1 = Lwt.Sleep && - Lwt.state p2 = Lwt.Sleep && - Lwt.state p3 = Lwt.Sleep) - end; - - test "wait and task, pending, cancel" begin fun () -> - let p1, _ = Lwt.wait () in - let p2, _ = Lwt.task () in - let p3 = Lwt.npick [p1; p2] in - Lwt.cancel p3; - Lwt.return - (Lwt.state p1 = Lwt.Sleep && - Lwt.state p2 = Lwt.Fail Lwt.Canceled && - Lwt.state p3 = Lwt.Fail Lwt.Canceled) - end; -] -let suites = suites @ [cancel_npick_tests] - -let cancel_nchoose_split_tests = suite "cancel nchoose_split" [ - test "wait, pending, cancel" begin fun () -> - let p1, _ = Lwt.wait () in - let p2, _ = Lwt.wait () in - let p3 = Lwt.nchoose_split [p1; p2] in - Lwt.cancel p3; - Lwt.return - (Lwt.state p1 = Lwt.Sleep && - Lwt.state p2 = Lwt.Sleep && - Lwt.state p3 = Lwt.Sleep) - end; - - test "wait and task, pending, cancel" begin fun () -> - let p1, _ = Lwt.wait () in - let p2, _ = Lwt.task () in - let p3 = Lwt.nchoose_split [p1; p2] in - Lwt.cancel p3; - Lwt.return - (Lwt.state p1 = Lwt.Sleep && - Lwt.state p2 = Lwt.Fail Lwt.Canceled && - Lwt.state p3 = Lwt.Fail Lwt.Canceled) - end; -] -let suites = suites @ [cancel_nchoose_split_tests] - - +let cancel_tests = + suite "cancel" + [ + test "fulfilled" (fun () -> + let p = Lwt.return () in + Lwt.cancel p; + Lwt.return (Lwt.state p = Lwt.Return ())); + test "rejected" (fun () -> + let p = Lwt.fail Exception in + Lwt.cancel p; + Lwt.return (Lwt.state p = Lwt.Fail Exception)); + test "wait" (fun () -> + let p, _ = Lwt.wait () in + Lwt.cancel p; + Lwt.return (Lwt.state p = Lwt.Sleep)); + test "task" (fun () -> + let p, _ = Lwt.task () in + Lwt.cancel p; + Lwt.return (Lwt.state p = Lwt.Fail Lwt.Canceled)); + test "callback" (fun () -> + let saw = ref None in + let p, _ = Lwt.task () in + Lwt.on_failure p (fun exn -> saw := Some exn); + Lwt.cancel p; + Lwt.return (!saw = Some Lwt.Canceled)); + (* Behaves like wakeup rather than wakeup_later, even though that's probably + wrong. Calling cancel in a (functional) loop will cause stack overflow. *) + test "nested" (fun () -> + let f_ran = ref false in + let p1, _ = Lwt.task () in + let p2, _ = Lwt.task () in + Lwt.on_failure p2 (fun _ -> f_ran := true); + Lwt.on_failure p1 (fun _ -> + Lwt.cancel p2; + assert (Lwt.state p2 = Lwt.Fail Lwt.Canceled); + assert (!f_ran = true)); + Lwt.cancel p1; + Lwt.return (!f_ran = true && Lwt.state p2 = Lwt.Fail Lwt.Canceled)); + ] + +let suites = suites @ [ cancel_tests ] + +let on_cancel_tests = + suite "on_cancel" + [ + test "pending" (fun () -> + let f_ran = ref false in + let p, _ = Lwt.task () in + Lwt.on_cancel p (fun () -> f_ran := true); + assert (!f_ran = false); + Lwt.cancel p; + Lwt.return (!f_ran = true)); + test "multiple" (fun () -> + let f_ran = ref false in + let g_ran = ref false in + let h_ran = ref false in + let p, _ = Lwt.task () in + Lwt.on_cancel p (fun () -> f_ran := true); + Lwt.on_cancel p (fun () -> g_ran := true); + Lwt.on_cancel p (fun () -> h_ran := true); + Lwt.cancel p; + Lwt.return (!f_ran = true && !g_ran = true && !h_ran = true)); + test "ordering" (fun () -> + (* Two cancel callbacks to make sure they both run before the ordinary + callback. *) + let on_cancel_1_ran = ref false in + let on_cancel_2_ran = ref false in + let callback_ran = ref false in + let p, _ = Lwt.task () in + Lwt.on_cancel p (fun () -> on_cancel_1_ran := true); + Lwt.on_failure p (fun _ -> + assert (!on_cancel_1_ran = true); + assert (!on_cancel_2_ran = true); + callback_ran := true); + Lwt.on_cancel p (fun () -> on_cancel_2_ran := true); + Lwt.cancel p; + Lwt.return (!callback_ran = true)); + test "fulfilled" (fun () -> + let f_ran = ref false in + Lwt.on_cancel (Lwt.return ()) (fun () -> f_ran := true); + Lwt.return (!f_ran = false)); + test "rejected" (fun () -> + let f_ran = ref false in + Lwt.on_cancel (Lwt.fail Exception) (fun () -> f_ran := true); + Lwt.return (!f_ran = false)); + test "already canceled" (fun () -> + let f_ran = ref false in + Lwt.on_cancel (Lwt.fail Lwt.Canceled) (fun () -> f_ran := true); + Lwt.return (!f_ran = true)); + (* More generally, this tests that rejecting with [Lwt.Canceled] is equivalent + to calling [Lwt.cancel]. The difference is that [Lwt.cancel] can be called + on promises without the need of a resolver. *) + test "reject with Canceled" (fun () -> + let f_ran = ref false in + let p, r = Lwt.wait () in + Lwt.on_cancel p (fun () -> f_ran := true); + Lwt.wakeup_exn r Lwt.Canceled; + Lwt.return (!f_ran = true)); + ] + +let suites = suites @ [ on_cancel_tests ] + +let protected_tests = + suite "protected" + [ + test "fulfilled" (fun () -> + let p = Lwt.protected (Lwt.return ()) in + (* If [p] starts fulfilled, it can't be canceled. *) + Lwt.return (Lwt.state p = Lwt.Return ())); + test "rejected" (fun () -> + let p = Lwt.protected (Lwt.fail Exception) in + Lwt.return (Lwt.state p = Lwt.Fail Exception)); + test "pending" (fun () -> + let p, _ = Lwt.task () in + let p' = Lwt.protected p in + Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep)); + test "pending, fulfilled" (fun () -> + let p, r = Lwt.task () in + let p' = Lwt.protected p in + Lwt.wakeup r "foo"; + Lwt.return (Lwt.state p' = Lwt.Return "foo")); + test "pending, canceled" (fun () -> + let p, _ = Lwt.task () in + let p' = Lwt.protected p in + Lwt.cancel p'; + Lwt.return + (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Fail Lwt.Canceled)); + test "pending, canceled, fulfilled" (fun () -> + let p, r = Lwt.task () in + let p' = Lwt.protected p in + Lwt.cancel p'; + Lwt.wakeup r "foo"; + Lwt.return + (Lwt.state p = Lwt.Return "foo" + && Lwt.state p' = Lwt.Fail Lwt.Canceled)); + (* Implementation detail: [p' = Lwt.protected _] can still be resolved if it + becomes a proxy. *) + test "pending, proxy" (fun () -> + let p1, r1 = Lwt.task () in + let p2 = Lwt.protected p1 in + + (* Make p2 a proxy for p4; p3 is just needed to suspend the bind, in order + to callback the code that makes p2 a proxy. *) + let p3, r3 = Lwt.wait () in + let _ = Lwt.bind p3 (fun () -> p2) in + Lwt.wakeup r3 (); + + (* It should now be possible to resolve p2 by resolving p1. *) + Lwt.wakeup r1 "foo"; + Lwt.return (Lwt.state p2 = Lwt.Return "foo")); + ] + +let suites = suites @ [ protected_tests ] + +let cancelable_tests = + suite "wrap_in_cancelable" + [ + test "fulfilled" (fun () -> + let p = Lwt.wrap_in_cancelable (Lwt.return ()) in + Lwt.return (Lwt.state p = Lwt.Return ())); + test "rejected" (fun () -> + let p = Lwt.wrap_in_cancelable (Lwt.fail Exception) in + Lwt.return (Lwt.state p = Lwt.Fail Exception)); + test "pending(task)" (fun () -> + let p, _ = Lwt.task () in + let p' = Lwt.wrap_in_cancelable p in + Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep)); + test "pending(task), fulfilled" (fun () -> + let p, r = Lwt.task () in + let p' = Lwt.wrap_in_cancelable p in + Lwt.wakeup r "foo"; + Lwt.return + (Lwt.state p = Lwt.Return "foo" && Lwt.state p' = Lwt.Return "foo")); + test "pending(task), canceled" (fun () -> + let p, _ = Lwt.task () in + let p' = Lwt.wrap_in_cancelable p in + Lwt.cancel p'; + Lwt.return + (Lwt.state p = Lwt.Fail Lwt.Canceled + && Lwt.state p' = Lwt.Fail Lwt.Canceled)); + test "pending(wait)" (fun () -> + let p, _ = Lwt.wait () in + let p' = Lwt.wrap_in_cancelable p in + Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep)); + test "pending(wait), fulfilled" (fun () -> + let p, r = Lwt.wait () in + let p' = Lwt.wrap_in_cancelable p in + Lwt.wakeup r "foo"; + Lwt.return + (Lwt.state p = Lwt.Return "foo" && Lwt.state p' = Lwt.Return "foo")); + test "pending(wait), canceled" (fun () -> + let p, _ = Lwt.wait () in + let p' = Lwt.wrap_in_cancelable p in + Lwt.cancel p'; + Lwt.return + (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Fail Lwt.Canceled)); + test "pending(task), canceled, fulfilled" (fun () -> + let p, r = Lwt.task () in + let p' = Lwt.wrap_in_cancelable p in + Lwt.cancel p'; + Lwt.wakeup r "foo"; + Lwt.return + (Lwt.state p = Lwt.Fail Lwt.Canceled + && Lwt.state p' = Lwt.Fail Lwt.Canceled)); + test "pending(wait), canceled, fulfilled" (fun () -> + let p, r = Lwt.wait () in + let p' = Lwt.wrap_in_cancelable p in + Lwt.cancel p'; + Lwt.wakeup r "foo"; + Lwt.return + (Lwt.state p = Lwt.Return "foo" + && Lwt.state p' = Lwt.Fail Lwt.Canceled)); + (* Implementation detail: [p' = Lwt.wrap_in_cancelable _] can still be + resolved if it becomes a proxy. *) + test "pending, proxy" (fun () -> + let p1, r1 = Lwt.task () in + let p2 = Lwt.wrap_in_cancelable p1 in + + (* Make p2 a proxy for p4; p3 is just needed to suspend the bind, in order + to callback the code that makes p2 a proxy. *) + let p3, r3 = Lwt.wait () in + let _ = Lwt.bind p3 (fun () -> p2) in + Lwt.wakeup r3 (); + + (* It should now be possible to resolve p2 by resolving p1. *) + Lwt.wakeup r1 "foo"; + Lwt.return (Lwt.state p2 = Lwt.Return "foo")); + ] + +let suites = suites @ [ cancelable_tests ] + +let no_cancel_tests = + suite "no_cancel" + [ + test "fulfilled" (fun () -> + let p = Lwt.no_cancel (Lwt.return ()) in + (* [p] starts fulfilled, so it can't be canceled. *) + Lwt.return (Lwt.state p = Lwt.Return ())); + test "rejected" (fun () -> + let p = Lwt.no_cancel (Lwt.fail Exception) in + Lwt.return (Lwt.state p = Lwt.Fail Exception)); + test "pending" (fun () -> + let p, _ = Lwt.task () in + let p' = Lwt.no_cancel p in + Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep)); + test "pending, fulfilled" (fun () -> + let p, r = Lwt.task () in + let p = Lwt.no_cancel p in + Lwt.wakeup r "foo"; + Lwt.return (Lwt.state p = Lwt.Return "foo")); + test "pending, cancel attempt" (fun () -> + let p, _ = Lwt.task () in + let p' = Lwt.no_cancel p in + Lwt.cancel p'; + Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep)); + ] + +let suites = suites @ [ no_cancel_tests ] + +let resolve_already_canceled_promise_tests = + suite "resolve canceled" + [ + test "wakeup: canceled" (fun () -> + let p, r = Lwt.task () in + Lwt.cancel p; + Lwt.wakeup r (); + Lwt.return (Lwt.state p = Lwt.Fail Lwt.Canceled)); + (* This test can start falsely passing if the entire test is run inside an + Lwt promise resolution phase, e.g. inside an outer [Lwt.wakeup_later]. *) + test "wakeup_later: canceled" (fun () -> + let p, r = Lwt.task () in + Lwt.cancel p; + Lwt.wakeup_later r (); + Lwt.return (Lwt.state p = Lwt.Fail Lwt.Canceled)); + ] + +let suites = suites @ [ resolve_already_canceled_promise_tests ] + +let pick_tests = + suite "pick" + [ + (test "empty" (fun () -> + try + ignore (Lwt.pick []); + Lwt.return false + with + | Invalid_argument + "Lwt.pick [] would return a promise that is pending forever" + -> + Lwt.return true) [@ocaml.warning "-52"]); + test "fulfilled" (fun () -> + let p1, _ = Lwt.task () in + let p2 = Lwt.pick [ p1; Lwt.return "foo" ] in + Lwt.return + (Lwt.state p1 = Lwt.Fail Lwt.Canceled + && Lwt.state p2 = Lwt.Return "foo")); + test "rejected" (fun () -> + let p1, _ = Lwt.task () in + let p2 = Lwt.pick [ p1; Lwt.fail Exception ] in + Lwt.return + (Lwt.state p1 = Lwt.Fail Lwt.Canceled + && Lwt.state p2 = Lwt.Fail Exception)); + test "multiple resolved" (fun () -> + (* This is run in a loop to exercise the internal PRNG. *) + let outcomes = Array.make 3 0 in + let rec repeat n = + if n <= 0 then () + else + let p = + Lwt.pick + [ + fst (Lwt.wait ()); + Lwt.return "foo"; + Lwt.fail Exception; + Lwt.return "bar"; + ] + in + (match[@ocaml.warning "-4"] Lwt.state p with + | Lwt.Return "foo" -> outcomes.(0) <- outcomes.(0) + 1 + | Lwt.Fail Exception -> outcomes.(1) <- outcomes.(1) + 1 + | Lwt.Return "bar" -> outcomes.(2) <- outcomes.(2) + 1 + | _ -> assert false); + repeat (n - 1) + in + let count = 1000 in + repeat count; + Lwt.return + (outcomes.(0) > 0 + && outcomes.(1) > 0 + && outcomes.(2) > 0 + && outcomes.(0) + outcomes.(1) + outcomes.(2) = count)); + test "pending" (fun () -> + let p = Lwt.pick [ fst (Lwt.wait ()); fst (Lwt.wait ()) ] in + Lwt.return (Lwt.state p = Lwt.Sleep)); + test "pending, fulfilled" (fun () -> + let p1, r1 = Lwt.task () in + let p2, _ = Lwt.task () in + let p = Lwt.pick [ p1; p2 ] in + Lwt.wakeup r1 "foo"; + Lwt.return + (Lwt.state p2 = Lwt.Fail Lwt.Canceled + && Lwt.state p = Lwt.Return "foo")); + test "diamond" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.pick [ p; p ] in + Lwt.wakeup r "foo"; + Lwt.return (Lwt.state p = Lwt.Return "foo")); + test "pending, canceled" (fun () -> + let p1, _ = Lwt.task () in + let p2, _ = Lwt.task () in + let p = Lwt.pick [ p1; p2 ] in + Lwt.cancel p; + Lwt.return + (Lwt.state p1 = Lwt.Fail Lwt.Canceled + && Lwt.state p2 = Lwt.Fail Lwt.Canceled)); + test "cancellation/resolution order" (fun () -> + let a = [| 0; 0 |] in + let i = ref 0 in + let p1, r1 = Lwt.task () in + let p2, _ = Lwt.task () in + let p3 = Lwt.pick [ p1; p2 ] in + let _ = + Lwt.catch + (fun () -> p2) + (fun _ -> + a.(!i) <- 1; + i := 1; + Lwt.return ()) + in + let _ = + Lwt.bind p3 (fun _ -> + a.(!i) <- 2; + i := 1; + Lwt.return ()) + in + Lwt.wakeup_later r1 (); + Lwt.return (a.(0) = 1 && a.(1) = 2)); + ] + +let suites = suites @ [ pick_tests ] + +let npick_tests = + suite "npick" + [ + (test "empty" (fun () -> + try + ignore (Lwt.npick []); + Lwt.return false + with + | Invalid_argument + "Lwt.npick [] would return a promise that is pending forever" + -> + Lwt.return true) [@ocaml.warning "-52"]); + test "all fulfilled" (fun () -> + let p = Lwt.npick [ Lwt.return "foo"; Lwt.return "bar" ] in + Lwt.return (Lwt.state p = Lwt.Return [ "foo"; "bar" ])); + test "fulfilled, rejected" (fun () -> + let p = Lwt.npick [ Lwt.return "foo"; Lwt.fail Exception ] in + Lwt.return (Lwt.state p = Lwt.Fail Exception)); + test "rejected, fulfilled" (fun () -> + let p = Lwt.npick [ Lwt.fail Exception; Lwt.return "foo" ] in + Lwt.return (Lwt.state p = Lwt.Fail Exception)); + test "some pending" (fun () -> + let p1, _ = Lwt.task () in + let p2 = Lwt.npick [ Lwt.return "foo"; p1; Lwt.return "bar" ] in + Lwt.return + (Lwt.state p1 = Lwt.Fail Lwt.Canceled + && Lwt.state p2 = Lwt.Return [ "foo"; "bar" ])); + test "pending" (fun () -> + let p = Lwt.npick [ fst (Lwt.task ()); fst (Lwt.task ()) ] in + Lwt.return (Lwt.state p = Lwt.Sleep)); + test "pending, fulfilled" (fun () -> + let p1, _ = Lwt.task () in + let p2, r = Lwt.task () in + let p = Lwt.npick [ p1; p2 ] in + Lwt.wakeup r "foo"; + Lwt.return + (Lwt.state p1 = Lwt.Fail Lwt.Canceled + && Lwt.state p = Lwt.Return [ "foo" ])); + test "pending, rejected" (fun () -> + let p1, _ = Lwt.task () in + let p2, r = Lwt.task () in + let p = Lwt.npick [ p1; p2 ] in + Lwt.wakeup_exn r Exception; + Lwt.return + (Lwt.state p1 = Lwt.Fail Lwt.Canceled + && Lwt.state p = Lwt.Fail Exception)); + test "diamond" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.npick [ p; p ] in + Lwt.wakeup r "foo"; + Lwt.return (Lwt.state p = Lwt.Return [ "foo"; "foo" ])); + test "diamond, rejected" (fun () -> + let p, r = Lwt.wait () in + let p = Lwt.npick [ p; p ] in + Lwt.wakeup_exn r Exception; + Lwt.return (Lwt.state p = Lwt.Fail Exception)); + test "pending, canceled" (fun () -> + let p1, _ = Lwt.task () in + let p2, _ = Lwt.task () in + let p = Lwt.npick [ p1; p2 ] in + Lwt.cancel p; + Lwt.return + (Lwt.state p1 = Lwt.Fail Lwt.Canceled + && Lwt.state p2 = Lwt.Fail Lwt.Canceled)); + test "cancellation/resolution order" (fun () -> + let a = [| 0; 0 |] in + let i = ref 0 in + let p1, r1 = Lwt.task () in + let p2, _ = Lwt.task () in + let p3 = Lwt.npick [ p1; p2 ] in + let _ = + Lwt.catch + (fun () -> p2) + (fun _ -> + a.(!i) <- 1; + i := 1; + Lwt.return ()) + in + let _ = + Lwt.bind p3 (fun _ -> + a.(!i) <- 2; + i := 1; + Lwt.return ()) + in + Lwt.wakeup_later r1 (); + Lwt.return (a.(0) = 1 && a.(1) = 2)); + ] + +let suites = suites @ [ npick_tests ] + +let cancel_bind_tests = + suite "cancel bind" + [ + test "wait, pending, canceled" (fun () -> + let f_ran = ref false in + let p, _ = Lwt.wait () in + let p' = + Lwt.bind p (fun () -> + f_ran := true; + Lwt.return ()) + in + Lwt.cancel p'; + Lwt.return + (!f_ran = false + && Lwt.state p = Lwt.Sleep + && Lwt.state p' = Lwt.Sleep)); + test "task, pending, canceled" (fun () -> + let f_ran = ref false in + let p, _ = Lwt.task () in + let p' = + Lwt.bind p (fun () -> + f_ran := true; + Lwt.return ()) + in + Lwt.cancel p'; + Lwt.return + (!f_ran = false + && Lwt.state p = Lwt.Fail Lwt.Canceled + && Lwt.state p' = Lwt.Fail Lwt.Canceled)); + test "pending, wait, canceled" (fun () -> + let p, r = Lwt.wait () in + let p', _ = Lwt.wait () in + let p'' = Lwt.bind p (fun () -> p') in + Lwt.wakeup r (); + (* [bind]'s [f] ran, and now [p'] and [p''] should share the same state. *) + Lwt.cancel p''; + Lwt.return (Lwt.state p' = Lwt.Sleep && Lwt.state p'' = Lwt.Sleep)); + test "pending, task, canceled" (fun () -> + let p1, r = Lwt.wait () in + let p2, _ = Lwt.task () in + let p3 = Lwt.bind p1 (fun () -> p2) in + Lwt.wakeup r (); + Lwt.cancel p3; + Lwt.return + (Lwt.state p2 = Lwt.Fail Lwt.Canceled + && Lwt.state p3 = Lwt.Fail Lwt.Canceled + && p2 != p3)); + test "pending, task, canceled, chain" (fun () -> + let p1, r = Lwt.wait () in + let p2, _ = Lwt.task () in + let p3 = Lwt.bind p1 (fun () -> p2) in + let p4 = Lwt.bind p1 (fun () -> p3) in + Lwt.wakeup r (); + (* At this point, [p4] and [p3] share the same state, and canceling [p4] + should chain to [p2], because [p3] is obtained by binding on [p2]. *) + Lwt.cancel p4; + Lwt.return + (Lwt.state p2 = Lwt.Fail Lwt.Canceled + && Lwt.state p3 = Lwt.Fail Lwt.Canceled + && Lwt.state p4 = Lwt.Fail Lwt.Canceled)); + test "pending, on_cancel callbacks" (fun () -> + let f_ran = ref false in + let g_ran = ref false in + let p1, _ = Lwt.task () in + let p2 = Lwt.bind (fst (Lwt.task ())) (fun () -> p1) in + Lwt.on_cancel p1 (fun () -> f_ran := true); + Lwt.on_cancel p2 (fun () -> g_ran := true); + Lwt.cancel p2; + (* Canceling [p2] doesn't cancel [p1], because the function passed to + [Lwt.bind] never ran. *) + Lwt.return (!f_ran = false && !g_ran = true)); + test "pending, fulfilled, on_cancel callbacks" (fun () -> + let f_ran = ref false in + let g_ran = ref false in + let p1, r = Lwt.task () in + let p2, _ = Lwt.task () in + let p3 = Lwt.bind p1 (fun () -> p2) in + Lwt.on_cancel p2 (fun () -> f_ran := true); + Lwt.on_cancel p3 (fun () -> g_ran := true); + Lwt.wakeup r (); + Lwt.cancel p3; + (* Canceling [p3] cancels [p2], because the function passed to [Lwt.bind] + did run, and evaluated to [p2]. *) + Lwt.return (!f_ran = true && !g_ran = true)); + ] + +let suites = suites @ [ cancel_bind_tests ] + +let cancel_map_tests = + suite "cancel map" + [ + test "wait, pending, canceled" (fun () -> + let f_ran = ref false in + let p, _ = Lwt.wait () in + let p' = Lwt.map (fun () -> f_ran := true) p in + Lwt.cancel p'; + Lwt.return + (!f_ran = false + && Lwt.state p = Lwt.Sleep + && Lwt.state p' = Lwt.Sleep)); + test "task, pending, canceled" (fun () -> + let f_ran = ref false in + let p, _ = Lwt.task () in + let p' = Lwt.map (fun () -> f_ran := true) p in + Lwt.cancel p'; + Lwt.return + (!f_ran = false + && Lwt.state p = Lwt.Fail Lwt.Canceled + && Lwt.state p' = Lwt.Fail Lwt.Canceled)); + ] + +let suites = suites @ [ cancel_map_tests ] + +let cancel_catch_tests = + suite "cancel catch" + [ + (* In [p' = Lwt.catch (fun () -> p) f], if [p] is not cancelable, [p'] is also + not cancelable. *) + test "wait, pending, canceled" (fun () -> + let f_ran = ref false in + let p, _ = Lwt.wait () in + let p' = + Lwt.catch + (fun () -> p) + (fun _ -> + f_ran := true; + Lwt.return ()) + in + Lwt.cancel p'; + Lwt.return + (!f_ran = false + && Lwt.state p = Lwt.Sleep + && Lwt.state p' = Lwt.Sleep)); + (* In [p' = Lwt.catch (fun () -> p) f], if [p] is cancelable, canceling [p'] + propagates to [p], and then the cancellation exception can be "intercepted" + by [f], which can resolve [p'] in an arbitrary way. *) + test "task, pending, canceled" (fun () -> + let saw = ref None in + let p, _ = Lwt.task () in + let p' = + Lwt.catch + (fun () -> p) + (fun exn -> + saw := Some exn; + Lwt.return "foo") + in + Lwt.cancel p'; + Lwt.return + (!saw = Some Lwt.Canceled + && Lwt.state p = Lwt.Fail Lwt.Canceled + && Lwt.state p' = Lwt.Return "foo")); + (* In [p' = Lwt.catch (fun () -> p) f], if [p] is cancelable, and cancel + callbacks are added to both [p] and [p'], and [f] does not resolve [p'] + with [Lwt.Fail Lwt.Canceled], only the callback on [p] runs. *) + test "task, pending, canceled, on_cancel, intercepted" (fun () -> + let on_cancel_1_ran = ref false in + let on_cancel_2_ran = ref false in + let p, _ = Lwt.task () in + let p' = + Lwt.catch + (fun () -> p) + (fun _ -> + assert (!on_cancel_1_ran = true && !on_cancel_2_ran = false); + Lwt.return "foo") + in + Lwt.on_cancel p (fun () -> on_cancel_1_ran := true); + Lwt.on_cancel p' (fun () -> on_cancel_2_ran := true); + Lwt.cancel p'; + Lwt.return + (Lwt.state p = Lwt.Fail Lwt.Canceled + && Lwt.state p' = Lwt.Return "foo" + && !on_cancel_2_ran = false)); + (* Same as above, except this time, cancellation is passed on to the outer + promise, so we can expect both cancel callbacks to run. *) + test "task, pending, canceled, on_cancel, forwarded" (fun () -> + let on_cancel_2_ran = ref false in + let p, _ = Lwt.task () in + let p' = Lwt.catch (fun () -> p) Lwt.fail in + Lwt.on_cancel p' (fun () -> on_cancel_2_ran := true); + Lwt.cancel p'; + Lwt.return + (Lwt.state p = Lwt.Fail Lwt.Canceled + && Lwt.state p' = Lwt.Fail Lwt.Canceled + && !on_cancel_2_ran = true)); + (* (2 tests) If the handler passed to [Lwt.catch] already ran, canceling the + outer promise is the same as canceling the promise returned by the + handler. *) + test "pending, wait, canceled" (fun () -> + let p1, r = Lwt.wait () in + let p2, _ = Lwt.wait () in + let p3 = Lwt.catch (fun () -> p1) (fun _ -> p2) in + Lwt.wakeup_exn r Exception; + Lwt.cancel p3; + Lwt.return (Lwt.state p2 = Lwt.Sleep && Lwt.state p3 = Lwt.Sleep)); + test "pending, task, canceled" (fun () -> + let p1, r = Lwt.wait () in + let p2, _ = Lwt.task () in + let p3 = Lwt.catch (fun () -> p1) (fun _ -> p2) in + Lwt.wakeup_exn r Exception; + Lwt.cancel p3; + Lwt.return + (Lwt.state p2 = Lwt.Fail Lwt.Canceled + && Lwt.state p3 = Lwt.Fail Lwt.Canceled)); + ] + +let suites = suites @ [ cancel_catch_tests ] + +let cancel_try_bind_tests = + suite "cancel try_bind" + [ + test "wait, pending, canceled" (fun () -> + let f_or_g_ran = ref false in + let p, _ = Lwt.wait () in + let p' = + Lwt.try_bind + (fun () -> p) + (fun () -> + f_or_g_ran := true; + Lwt.return ()) + (fun _ -> + f_or_g_ran := true; + Lwt.return ()) + in + Lwt.cancel p'; + Lwt.return + (!f_or_g_ran = false + && Lwt.state p = Lwt.Sleep + && Lwt.state p' = Lwt.Sleep)); + test "task, pending, canceled" (fun () -> + let f_ran = ref false in + let saw = ref None in + let p, _ = Lwt.task () in + let p' = + Lwt.try_bind + (fun () -> p) + (fun () -> + f_ran := true; + Lwt.return "foo") + (fun exn -> + saw := Some exn; + Lwt.return "bar") + in + Lwt.cancel p'; + Lwt.return + (!f_ran = false + && !saw = Some Lwt.Canceled + && Lwt.state p = Lwt.Fail Lwt.Canceled + && Lwt.state p' = Lwt.Return "bar")); + test "pending, fulfilled, wait, canceled" (fun () -> + let p1, r = Lwt.wait () in + let p2, _ = Lwt.wait () in + let p3 = + Lwt.try_bind + (fun () -> p1) + (fun () -> p2) + (fun _ -> Lwt.return "foo") + in + Lwt.wakeup r (); + Lwt.cancel p3; + Lwt.return (Lwt.state p2 = Lwt.Sleep && Lwt.state p3 = Lwt.Sleep)); + test "pending, fulfilled, task, canceled" (fun () -> + let p1, r = Lwt.wait () in + let p2, _ = Lwt.task () in + let p3 = + Lwt.try_bind + (fun () -> p1) + (fun () -> p2) + (fun _ -> Lwt.return "foo") + in + Lwt.wakeup r (); + Lwt.cancel p3; + Lwt.return + (Lwt.state p2 = Lwt.Fail Lwt.Canceled + && Lwt.state p3 = Lwt.Fail Lwt.Canceled)); + test "pending, rejected, wait, canceled" (fun () -> + let p1, r = Lwt.wait () in + let p2, _ = Lwt.wait () in + let p3 = + Lwt.try_bind + (fun () -> p1) + (fun () -> Lwt.return "foo") + (fun _ -> p2) + in + Lwt.wakeup_exn r Exception; + Lwt.cancel p3; + Lwt.return (Lwt.state p2 = Lwt.Sleep && Lwt.state p3 = Lwt.Sleep)); + test "pending, rejected, task, canceled" (fun () -> + let p1, r = Lwt.wait () in + let p2, _ = Lwt.task () in + let p3 = + Lwt.try_bind + (fun () -> p1) + (fun () -> Lwt.return "foo") + (fun _ -> p2) + in + Lwt.wakeup_exn r Exception; + Lwt.cancel p3; + Lwt.return + (Lwt.state p2 = Lwt.Fail Lwt.Canceled + && Lwt.state p3 = Lwt.Fail Lwt.Canceled)); + ] + +let suites = suites @ [ cancel_try_bind_tests ] + +let cancel_finalize_tests = + suite "cancel finalize" + [ + test "wait, pending, canceled" (fun () -> + let f_ran = ref false in + let p, _ = Lwt.wait () in + let p' = + Lwt.finalize + (fun () -> p) + (fun () -> + f_ran := true; + Lwt.return ()) + in + Lwt.cancel p'; + Lwt.return + (!f_ran = false + && Lwt.state p = Lwt.Sleep + && Lwt.state p' = Lwt.Sleep)); + test "task, pending, canceled" (fun () -> + let f_ran = ref false in + let p, _ = Lwt.task () in + let p' = + Lwt.finalize + (fun () -> p) + (fun () -> + f_ran := true; + Lwt.return ()) + in + Lwt.cancel p'; + Lwt.return + (!f_ran = true + && Lwt.state p = Lwt.Fail Lwt.Canceled + && Lwt.state p' = Lwt.Fail Lwt.Canceled)); + test "task, canceled, cancel exception replaced" (fun () -> + let p, _ = Lwt.task () in + let p' = Lwt.finalize (fun () -> p) (fun () -> Lwt.fail Exception) in + Lwt.cancel p; + Lwt.return (Lwt.state p' = Lwt.Fail Exception)); + test "pending, wait, canceled" (fun () -> + let p1, r = Lwt.wait () in + let p2, _ = Lwt.wait () in + let p3 = Lwt.finalize (fun () -> p1) (fun () -> p2) in + Lwt.wakeup r (); + Lwt.cancel p3; + Lwt.return (Lwt.state p2 = Lwt.Sleep && Lwt.state p3 = Lwt.Sleep)); + test "pending, task, canceled" (fun () -> + let p1, r = Lwt.wait () in + let p2, _ = Lwt.task () in + let p3 = Lwt.finalize (fun () -> p1) (fun () -> p2) in + Lwt.wakeup r (); + Lwt.cancel p3; + Lwt.return + (Lwt.state p2 = Lwt.Fail Lwt.Canceled + && Lwt.state p3 = Lwt.Fail Lwt.Canceled)); + ] + +let suites = suites @ [ cancel_finalize_tests ] + +let cancel_direct_handler_tests = + suite "cancel with direct handler" + [ + test "on_success: pending, canceled" (fun () -> + let f_ran = ref false in + let p, _ = Lwt.task () in + Lwt.on_success p (fun () -> f_ran := true); + Lwt.cancel p; + Lwt.return (!f_ran = false)); + test "on_failure: pending, canceled" (fun () -> + let saw = ref None in + let p, _ = Lwt.task () in + Lwt.on_failure p (fun exn -> saw := Some exn); + Lwt.cancel p; + Lwt.return (!saw = Some Lwt.Canceled)); + test "on_termination: pending, canceled" (fun () -> + let f_ran = ref false in + let p, _ = Lwt.task () in + Lwt.on_termination p (fun () -> f_ran := true); + Lwt.cancel p; + Lwt.return (!f_ran = true)); + test "on_any: pending, canceled" (fun () -> + let f_ran = ref false in + let saw = ref None in + let p, _ = Lwt.task () in + Lwt.on_any p (fun () -> f_ran := true) (fun exn -> saw := Some exn); + Lwt.cancel p; + Lwt.return (!f_ran = false && !saw = Some Lwt.Canceled)); + ] + +let suites = suites @ [ cancel_direct_handler_tests ] + +let cancel_join_tests = + suite "cancel join" + [ + test "wait, pending, cancel" (fun () -> + let p1, _ = Lwt.wait () in + let p2, _ = Lwt.wait () in + let p3 = Lwt.join [ p1; p2 ] in + Lwt.cancel p3; + Lwt.return + (Lwt.state p1 = Lwt.Sleep + && Lwt.state p2 = Lwt.Sleep + && Lwt.state p3 = Lwt.Sleep)); + test "task, pending, cancel" (fun () -> + let p1, _ = Lwt.task () in + let p2, _ = Lwt.task () in + let p3 = Lwt.join [ p1; p2 ] in + Lwt.cancel p3; + Lwt.return + (Lwt.state p1 = Lwt.Fail Lwt.Canceled + && Lwt.state p2 = Lwt.Fail Lwt.Canceled + && Lwt.state p3 = Lwt.Fail Lwt.Canceled)); + test "wait and task, pending, cancel" (fun () -> + let p1, r = Lwt.wait () in + let p2, _ = Lwt.task () in + let p3 = Lwt.join [ p1; p2 ] in + Lwt.cancel p3; + assert (Lwt.state p1 = Lwt.Sleep); + assert (Lwt.state p2 = Lwt.Fail Lwt.Canceled); + assert (Lwt.state p3 = Lwt.Sleep); + Lwt.wakeup r (); + Lwt.return + (Lwt.state p1 = Lwt.Return () + && Lwt.state p3 = Lwt.Fail Lwt.Canceled)); + (* In [p' = Lwt.join [p; p]], if [p'] is canceled, the cancel handler on [p] + is called only once, even though it is reachable by two paths in the + cancellation graph. *) + test "cancel diamond" (fun () -> + let ran = ref 0 in + let p, _ = Lwt.task () in + let p' = Lwt.join [ p; p ] in + Lwt.on_cancel p (fun () -> ran := !ran + 1); + Lwt.cancel p'; + Lwt.return (!ran = 1)); + ] + +let suites = suites @ [ cancel_join_tests ] + +let cancel_choose_tests = + suite "cancel choose" + [ + test "wait, pending, cancel" (fun () -> + let p1, _ = Lwt.wait () in + let p2, _ = Lwt.wait () in + let p3 = Lwt.choose [ p1; p2 ] in + Lwt.cancel p3; + Lwt.return + (Lwt.state p1 = Lwt.Sleep + && Lwt.state p2 = Lwt.Sleep + && Lwt.state p3 = Lwt.Sleep)); + test "wait and task, pending, cancel" (fun () -> + let p1, _ = Lwt.wait () in + let p2, _ = Lwt.task () in + let p3 = Lwt.choose [ p1; p2 ] in + Lwt.cancel p3; + Lwt.return + (Lwt.state p1 = Lwt.Sleep + && Lwt.state p2 = Lwt.Fail Lwt.Canceled + && Lwt.state p3 = Lwt.Fail Lwt.Canceled)); + ] + +let suites = suites @ [ cancel_choose_tests ] + +let cancel_pick_tests = + suite "cancel pick" + [ + test "wait, pending, cancel" (fun () -> + let p1, _ = Lwt.wait () in + let p2, _ = Lwt.wait () in + let p3 = Lwt.pick [ p1; p2 ] in + Lwt.cancel p3; + Lwt.return + (Lwt.state p1 = Lwt.Sleep + && Lwt.state p2 = Lwt.Sleep + && Lwt.state p3 = Lwt.Sleep)); + test "wait and task, pending, cancel" (fun () -> + let p1, _ = Lwt.wait () in + let p2, _ = Lwt.task () in + let p3 = Lwt.pick [ p1; p2 ] in + Lwt.cancel p3; + Lwt.return + (Lwt.state p1 = Lwt.Sleep + && Lwt.state p2 = Lwt.Fail Lwt.Canceled + && Lwt.state p3 = Lwt.Fail Lwt.Canceled)); + ] + +let suites = suites @ [ cancel_pick_tests ] + +let cancel_nchoose_tests = + suite "cancel nchoose" + [ + test "wait, pending, cancel" (fun () -> + let p1, _ = Lwt.wait () in + let p2, _ = Lwt.wait () in + let p3 = Lwt.nchoose [ p1; p2 ] in + Lwt.cancel p3; + Lwt.return + (Lwt.state p1 = Lwt.Sleep + && Lwt.state p2 = Lwt.Sleep + && Lwt.state p3 = Lwt.Sleep)); + test "wait and task, pending, cancel" (fun () -> + let p1, _ = Lwt.wait () in + let p2, _ = Lwt.task () in + let p3 = Lwt.nchoose [ p1; p2 ] in + Lwt.cancel p3; + Lwt.return + (Lwt.state p1 = Lwt.Sleep + && Lwt.state p2 = Lwt.Fail Lwt.Canceled + && Lwt.state p3 = Lwt.Fail Lwt.Canceled)); + ] + +let suites = suites @ [ cancel_nchoose_tests ] + +let cancel_npick_tests = + suite "cancel npick" + [ + test "wait, pending, cancel" (fun () -> + let p1, _ = Lwt.wait () in + let p2, _ = Lwt.wait () in + let p3 = Lwt.npick [ p1; p2 ] in + Lwt.cancel p3; + Lwt.return + (Lwt.state p1 = Lwt.Sleep + && Lwt.state p2 = Lwt.Sleep + && Lwt.state p3 = Lwt.Sleep)); + test "wait and task, pending, cancel" (fun () -> + let p1, _ = Lwt.wait () in + let p2, _ = Lwt.task () in + let p3 = Lwt.npick [ p1; p2 ] in + Lwt.cancel p3; + Lwt.return + (Lwt.state p1 = Lwt.Sleep + && Lwt.state p2 = Lwt.Fail Lwt.Canceled + && Lwt.state p3 = Lwt.Fail Lwt.Canceled)); + ] + +let suites = suites @ [ cancel_npick_tests ] + +let cancel_nchoose_split_tests = + suite "cancel nchoose_split" + [ + test "wait, pending, cancel" (fun () -> + let p1, _ = Lwt.wait () in + let p2, _ = Lwt.wait () in + let p3 = Lwt.nchoose_split [ p1; p2 ] in + Lwt.cancel p3; + Lwt.return + (Lwt.state p1 = Lwt.Sleep + && Lwt.state p2 = Lwt.Sleep + && Lwt.state p3 = Lwt.Sleep)); + test "wait and task, pending, cancel" (fun () -> + let p1, _ = Lwt.wait () in + let p2, _ = Lwt.task () in + let p3 = Lwt.nchoose_split [ p1; p2 ] in + Lwt.cancel p3; + Lwt.return + (Lwt.state p1 = Lwt.Sleep + && Lwt.state p2 = Lwt.Fail Lwt.Canceled + && Lwt.state p3 = Lwt.Fail Lwt.Canceled)); + ] + +let suites = suites @ [ cancel_nchoose_split_tests ] (* Sequence-associated storage, and its interaction with the rest of the API. *) -let storage_tests = suite "storage" [ - test "initial" begin fun () -> - let key = Lwt.new_key () in - Lwt.return (Lwt.get key = None) - end; - - test "store, retrieve" begin fun () -> - let key = Lwt.new_key () in - Lwt.with_value key (Some 42) (fun () -> - Lwt.return (Lwt.get key = Some 42)) - end; - - test "store, restore" begin fun () -> - let key = Lwt.new_key () in - Lwt.with_value key (Some 42) ignore; - Lwt.return (Lwt.get key = None) - end; - - test "store, f raises, restore" begin fun () -> - let key = Lwt.new_key () in - try - Lwt.with_value key (Some 42) (fun () -> raise Exception) |> ignore; - Lwt.return false - with Exception -> - Lwt.return (Lwt.get key = None) - end; - - test "store, overwrite, retrieve" begin fun () -> - let key = Lwt.new_key () in - Lwt.with_value key (Some 42) (fun () -> - Lwt.with_value key (Some 1337) (fun () -> - Lwt.return (Lwt.get key = Some 1337))) - end; - - test "store, blank, retrieve" begin fun () -> - let key = Lwt.new_key () in - Lwt.with_value key (Some 42) (fun () -> - Lwt.with_value key None (fun () -> - Lwt.return (Lwt.get key = None))) - end; - - test "distinct keys" begin fun () -> - let key1 = Lwt.new_key () in - let key2 = Lwt.new_key () in - Lwt.with_value key1 (Some 42) (fun () -> - Lwt.return (Lwt.get key2 = None)) - end; - - test "bind" begin fun () -> - let key = Lwt.new_key () in - let f = fun () -> Lwt.return (Lwt.get key) in - let p, r = Lwt.wait () in - Lwt.with_value key (Some 42) (fun () -> - let p' = - Lwt.with_value key (Some 1337) (fun () -> - Lwt.bind p f) - in - Lwt.wakeup r (); - Lwt.return - (Lwt.state p' = Lwt.Return (Some 1337) && - Lwt.get key = Some 42)) - end; - - test "map" begin fun () -> - let key = Lwt.new_key () in - let f = fun () -> Lwt.get key in - let p, r = Lwt.wait () in - Lwt.with_value key (Some 42) (fun () -> - let p' = - Lwt.with_value key (Some 1337) (fun () -> - Lwt.map f p) - in - Lwt.wakeup r (); - Lwt.return - (Lwt.state p' = Lwt.Return (Some 1337) && - Lwt.get key = Some 42)) - end; - - test "catch" begin fun () -> - let key = Lwt.new_key () in - let f = fun _ -> Lwt.return (Lwt.get key) in - let p, r = Lwt.wait () in - Lwt.with_value key (Some 42) (fun () -> - let p' = - Lwt.with_value key (Some 1337) (fun () -> - Lwt.catch (fun () -> p) f) - in - Lwt.wakeup_exn r Exception; - Lwt.return - (Lwt.state p' = Lwt.Return (Some 1337) && - Lwt.get key = Some 42)) - end; - - test "try_bind, fulfilled" begin fun () -> - let key = Lwt.new_key () in - let f = fun () -> Lwt.return (Lwt.get key) in - let p, r = Lwt.wait () in - Lwt.with_value key (Some 42) (fun () -> - let p' = - Lwt.with_value key (Some 1337) (fun () -> - Lwt.try_bind (fun () -> p) f Lwt.fail) - in - Lwt.wakeup r (); - Lwt.return - (Lwt.state p' = Lwt.Return (Some 1337) && - Lwt.get key = Some 42)) - end; - - test "try_bind, rejected" begin fun () -> - let key = Lwt.new_key () in - let f = fun _ -> Lwt.return (Lwt.get key) in - let p, r = Lwt.wait () in - Lwt.with_value key (Some 42) (fun () -> - let p' = - Lwt.with_value key (Some 1337) (fun () -> - Lwt.try_bind (fun () -> p) Lwt.return f) - in - Lwt.wakeup_exn r Exception; - Lwt.return - (Lwt.state p' = Lwt.Return (Some 1337) && - Lwt.get key = Some 42)) - end; - - test "finalize" begin fun () -> - let key = Lwt.new_key () in - let f = fun () -> assert (Lwt.get key = Some 1337); Lwt.return () in - let p, r = Lwt.wait () in - Lwt.with_value key (Some 42) (fun () -> - Lwt.with_value key (Some 1337) (fun () -> - Lwt.finalize (fun () -> p) f) |> ignore; - Lwt.wakeup r (); - Lwt.return (Lwt.get key = Some 42)) - end; - - test "on_success" begin fun () -> - let key = Lwt.new_key () in - let f = fun () -> assert (Lwt.get key = Some 1337) in - let p, r = Lwt.wait () in - Lwt.with_value key (Some 42) (fun () -> - Lwt.with_value key (Some 1337) (fun () -> - Lwt.on_success p f); - Lwt.wakeup r (); - Lwt.return (Lwt.get key = Some 42)) - end; - - test "on_failure" begin fun () -> - let key = Lwt.new_key () in - let f = fun _ -> assert (Lwt.get key = Some 1337) in - let p, r = Lwt.wait () in - Lwt.with_value key (Some 42) (fun () -> - Lwt.with_value key (Some 1337) (fun () -> - Lwt.on_failure p f); - Lwt.wakeup_exn r Exception; - Lwt.return (Lwt.get key = Some 42)) - end; - - test "on_termination, fulfilled" begin fun () -> - let key = Lwt.new_key () in - let f = fun () -> assert (Lwt.get key = Some 1337) in - let p, r = Lwt.wait () in - Lwt.with_value key (Some 42) (fun () -> - Lwt.with_value key (Some 1337) (fun () -> - Lwt.on_termination p f); - Lwt.wakeup r (); - Lwt.return (Lwt.get key = Some 42)) - end; - - test "on_termination, rejected" begin fun () -> - let key = Lwt.new_key () in - let f = fun () -> assert (Lwt.get key = Some 1337) in - let p, r = Lwt.wait () in - Lwt.with_value key (Some 42) (fun () -> - Lwt.with_value key (Some 1337) (fun () -> - Lwt.on_termination p f); - Lwt.wakeup_exn r Exception; - Lwt.return (Lwt.get key = Some 42)) - end; - - test "on_any, fulfilled" begin fun () -> - let key = Lwt.new_key () in - let f = fun () -> assert (Lwt.get key = Some 1337) in - let p, r = Lwt.wait () in - Lwt.with_value key (Some 42) (fun () -> - Lwt.with_value key (Some 1337) (fun () -> - Lwt.on_any p f ignore); - Lwt.wakeup r (); - Lwt.return (Lwt.get key = Some 42)) - end; - - test "on_any, rejected" begin fun () -> - let key = Lwt.new_key () in - let f = fun _ -> assert (Lwt.get key = Some 1337) in - let p, r = Lwt.wait () in - Lwt.with_value key (Some 42) (fun () -> - Lwt.with_value key (Some 1337) (fun () -> - Lwt.on_any p ignore f); - Lwt.wakeup r (); - Lwt.return (Lwt.get key = Some 42)) - end; - - test "on_cancel" begin fun () -> - let key = Lwt.new_key () in - let f = fun () -> assert (Lwt.get key = Some 1337) in - let p, _ = Lwt.task () in - Lwt.with_value key (Some 42) (fun () -> - Lwt.with_value key (Some 1337) (fun () -> - Lwt.on_cancel p f); - Lwt.cancel p; - Lwt.return (Lwt.get key = Some 42)) - end; -] -let suites = suites @ [storage_tests] - - +let storage_tests = + suite "storage" + [ + test "initial" (fun () -> + let key = Lwt.new_key () in + Lwt.return (Lwt.get key = None)); + test "store, retrieve" (fun () -> + let key = Lwt.new_key () in + Lwt.with_value key (Some 42) (fun () -> + Lwt.return (Lwt.get key = Some 42))); + test "store, restore" (fun () -> + let key = Lwt.new_key () in + Lwt.with_value key (Some 42) ignore; + Lwt.return (Lwt.get key = None)); + test "store, f raises, restore" (fun () -> + let key = Lwt.new_key () in + try + Lwt.with_value key (Some 42) (fun () -> raise Exception) |> ignore; + Lwt.return false + with Exception -> Lwt.return (Lwt.get key = None)); + test "store, overwrite, retrieve" (fun () -> + let key = Lwt.new_key () in + Lwt.with_value key (Some 42) (fun () -> + Lwt.with_value key (Some 1337) (fun () -> + Lwt.return (Lwt.get key = Some 1337)))); + test "store, blank, retrieve" (fun () -> + let key = Lwt.new_key () in + Lwt.with_value key (Some 42) (fun () -> + Lwt.with_value key None (fun () -> + Lwt.return (Lwt.get key = None)))); + test "distinct keys" (fun () -> + let key1 = Lwt.new_key () in + let key2 = Lwt.new_key () in + Lwt.with_value key1 (Some 42) (fun () -> + Lwt.return (Lwt.get key2 = None))); + test "bind" (fun () -> + let key = Lwt.new_key () in + let f () = Lwt.return (Lwt.get key) in + let p, r = Lwt.wait () in + Lwt.with_value key (Some 42) (fun () -> + let p' = + Lwt.with_value key (Some 1337) (fun () -> Lwt.bind p f) + in + Lwt.wakeup r (); + Lwt.return + (Lwt.state p' = Lwt.Return (Some 1337) && Lwt.get key = Some 42))); + test "map" (fun () -> + let key = Lwt.new_key () in + let f () = Lwt.get key in + let p, r = Lwt.wait () in + Lwt.with_value key (Some 42) (fun () -> + let p' = Lwt.with_value key (Some 1337) (fun () -> Lwt.map f p) in + Lwt.wakeup r (); + Lwt.return + (Lwt.state p' = Lwt.Return (Some 1337) && Lwt.get key = Some 42))); + test "catch" (fun () -> + let key = Lwt.new_key () in + let f _ = Lwt.return (Lwt.get key) in + let p, r = Lwt.wait () in + Lwt.with_value key (Some 42) (fun () -> + let p' = + Lwt.with_value key (Some 1337) (fun () -> + Lwt.catch (fun () -> p) f) + in + Lwt.wakeup_exn r Exception; + Lwt.return + (Lwt.state p' = Lwt.Return (Some 1337) && Lwt.get key = Some 42))); + test "try_bind, fulfilled" (fun () -> + let key = Lwt.new_key () in + let f () = Lwt.return (Lwt.get key) in + let p, r = Lwt.wait () in + Lwt.with_value key (Some 42) (fun () -> + let p' = + Lwt.with_value key (Some 1337) (fun () -> + Lwt.try_bind (fun () -> p) f Lwt.fail) + in + Lwt.wakeup r (); + Lwt.return + (Lwt.state p' = Lwt.Return (Some 1337) && Lwt.get key = Some 42))); + test "try_bind, rejected" (fun () -> + let key = Lwt.new_key () in + let f _ = Lwt.return (Lwt.get key) in + let p, r = Lwt.wait () in + Lwt.with_value key (Some 42) (fun () -> + let p' = + Lwt.with_value key (Some 1337) (fun () -> + Lwt.try_bind (fun () -> p) Lwt.return f) + in + Lwt.wakeup_exn r Exception; + Lwt.return + (Lwt.state p' = Lwt.Return (Some 1337) && Lwt.get key = Some 42))); + test "finalize" (fun () -> + let key = Lwt.new_key () in + let f () = + assert (Lwt.get key = Some 1337); + Lwt.return () + in + let p, r = Lwt.wait () in + Lwt.with_value key (Some 42) (fun () -> + Lwt.with_value key (Some 1337) (fun () -> + Lwt.finalize (fun () -> p) f) + |> ignore; + Lwt.wakeup r (); + Lwt.return (Lwt.get key = Some 42))); + test "on_success" (fun () -> + let key = Lwt.new_key () in + let f () = assert (Lwt.get key = Some 1337) in + let p, r = Lwt.wait () in + Lwt.with_value key (Some 42) (fun () -> + Lwt.with_value key (Some 1337) (fun () -> Lwt.on_success p f); + Lwt.wakeup r (); + Lwt.return (Lwt.get key = Some 42))); + test "on_failure" (fun () -> + let key = Lwt.new_key () in + let f _ = assert (Lwt.get key = Some 1337) in + let p, r = Lwt.wait () in + Lwt.with_value key (Some 42) (fun () -> + Lwt.with_value key (Some 1337) (fun () -> Lwt.on_failure p f); + Lwt.wakeup_exn r Exception; + Lwt.return (Lwt.get key = Some 42))); + test "on_termination, fulfilled" (fun () -> + let key = Lwt.new_key () in + let f () = assert (Lwt.get key = Some 1337) in + let p, r = Lwt.wait () in + Lwt.with_value key (Some 42) (fun () -> + Lwt.with_value key (Some 1337) (fun () -> Lwt.on_termination p f); + Lwt.wakeup r (); + Lwt.return (Lwt.get key = Some 42))); + test "on_termination, rejected" (fun () -> + let key = Lwt.new_key () in + let f () = assert (Lwt.get key = Some 1337) in + let p, r = Lwt.wait () in + Lwt.with_value key (Some 42) (fun () -> + Lwt.with_value key (Some 1337) (fun () -> Lwt.on_termination p f); + Lwt.wakeup_exn r Exception; + Lwt.return (Lwt.get key = Some 42))); + test "on_any, fulfilled" (fun () -> + let key = Lwt.new_key () in + let f () = assert (Lwt.get key = Some 1337) in + let p, r = Lwt.wait () in + Lwt.with_value key (Some 42) (fun () -> + Lwt.with_value key (Some 1337) (fun () -> Lwt.on_any p f ignore); + Lwt.wakeup r (); + Lwt.return (Lwt.get key = Some 42))); + test "on_any, rejected" (fun () -> + let key = Lwt.new_key () in + let f _ = assert (Lwt.get key = Some 1337) in + let p, r = Lwt.wait () in + Lwt.with_value key (Some 42) (fun () -> + Lwt.with_value key (Some 1337) (fun () -> Lwt.on_any p ignore f); + Lwt.wakeup r (); + Lwt.return (Lwt.get key = Some 42))); + test "on_cancel" (fun () -> + let key = Lwt.new_key () in + let f () = assert (Lwt.get key = Some 1337) in + let p, _ = Lwt.task () in + Lwt.with_value key (Some 42) (fun () -> + Lwt.with_value key (Some 1337) (fun () -> Lwt.on_cancel p f); + Lwt.cancel p; + Lwt.return (Lwt.get key = Some 42))); + ] + +let suites = suites @ [ storage_tests ] (* These basically just test that the infix operators are exposed in the API, and are defined "more or less" as they should be. *) -let infix_operator_tests = suite "infix operators" [ - test ">>=" begin fun () -> - let open Lwt.Infix in - let p, r = Lwt.wait () in - let p' = p >>= (fun s -> Lwt.return (s ^ "bar")) in - Lwt.wakeup r "foo"; - state_is (Lwt.Return "foobar") p' - end; - - test "=<<" begin fun () -> - let open Lwt.Infix in - let p, r = Lwt.wait () in - let p' = (fun s -> Lwt.return (s ^ "bar")) =<< p in - Lwt.wakeup r "foo"; - state_is (Lwt.Return "foobar") p' - end; - - test ">|=" begin fun () -> - let open Lwt.Infix in - let p, r = Lwt.wait () in - let p' = p >|= (fun s -> s ^ "bar") in - Lwt.wakeup r "foo"; - state_is (Lwt.Return "foobar") p' - end; - - test "=|<" begin fun () -> - let open Lwt.Infix in - let p, r = Lwt.wait () in - let p' = (fun s -> s ^ "bar") =|< p in - Lwt.wakeup r "foo"; - state_is (Lwt.Return "foobar") p' - end; - - test "<&>" begin fun () -> - let open Lwt.Infix in - let p, r = Lwt.wait () in - let p' = p <&> Lwt.return () in - Lwt.wakeup r (); - state_is (Lwt.Return ()) p' - end; - - test "" begin fun () -> - let open Lwt.Infix in - let p1, r = Lwt.wait () in - let p2, _ = Lwt.wait () in - let p3 = p1 p2 in - Lwt.wakeup r (); - state_is (Lwt.Return ()) p3 - end; -] -let suites = suites @ [infix_operator_tests] - - +let infix_operator_tests = + suite "infix operators" + [ + test ">>=" (fun () -> + let open Lwt.Infix in + let p, r = Lwt.wait () in + let p' = p >>= fun s -> Lwt.return (s ^ "bar") in + Lwt.wakeup r "foo"; + state_is (Lwt.Return "foobar") p'); + test "=<<" (fun () -> + let open Lwt.Infix in + let p, r = Lwt.wait () in + let p' = (fun s -> Lwt.return (s ^ "bar")) =<< p in + Lwt.wakeup r "foo"; + state_is (Lwt.Return "foobar") p'); + test ">|=" (fun () -> + let open Lwt.Infix in + let p, r = Lwt.wait () in + let p' = p >|= fun s -> s ^ "bar" in + Lwt.wakeup r "foo"; + state_is (Lwt.Return "foobar") p'); + test "=|<" (fun () -> + let open Lwt.Infix in + let p, r = Lwt.wait () in + let p' = (fun s -> s ^ "bar") =|< p in + Lwt.wakeup r "foo"; + state_is (Lwt.Return "foobar") p'); + test "<&>" (fun () -> + let open Lwt.Infix in + let p, r = Lwt.wait () in + let p' = p <&> Lwt.return () in + Lwt.wakeup r (); + state_is (Lwt.Return ()) p'); + test "" (fun () -> + let open Lwt.Infix in + let p1, r = Lwt.wait () in + let p2, _ = Lwt.wait () in + let p3 = p1 p2 in + Lwt.wakeup r (); + state_is (Lwt.Return ()) p3); + ] + +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.Let_syntax.Let_syntax.return () in - state_is (Lwt.Return ()) p - end; - - test "map" begin fun () -> - let p = Lwt.Let_syntax.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.Let_syntax.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.Let_syntax.Let_syntax.Open_on_rhs) in - ignore x; - Lwt.return true - end; -] -let suites = suites @ [ppx_let_tests] - - - -let let_syntax_tests = suite "let syntax" [ - test "let*" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p' = - let open Lwt.Syntax in - let* s1 = p1 in - let* s2 = p2 in - Lwt.return (s1 ^ s2) - in - Lwt.wakeup r1 "foo"; - Lwt.wakeup r2 "bar"; - state_is (Lwt.Return "foobar") p' - end; - - test "and*" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p' = - let open Lwt.Syntax in - let* s1 = p1 - and* s2 = p2 in - Lwt.return (s1 ^ s2) - in - Lwt.wakeup r1 "foo"; - Lwt.wakeup r2 "bar"; - state_is (Lwt.Return "foobar") p' - end; - - test "let+/and+" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p' = - let open Lwt.Syntax in - let+ s1 = p1 - and+ s2 = p2 in - (s1 ^ s2) - in - Lwt.wakeup r1 "foo"; - Lwt.wakeup r2 "bar"; - state_is (Lwt.Return "foobar") p' - end; -] -let suites = suites @ [let_syntax_tests] - - +let ppx_let_tests = + suite "ppx_let" + [ + test "return" (fun () -> + let p = Lwt.Let_syntax.Let_syntax.return () in + state_is (Lwt.Return ()) p); + test "map" (fun () -> + let p = + Lwt.Let_syntax.Let_syntax.map (Lwt.return 1) ~f:(fun x -> x + 1) + in + state_is (Lwt.Return 2) p); + test "bind" (fun () -> + let p = + Lwt.Let_syntax.Let_syntax.bind (Lwt.return 1) ~f:(fun x -> + Lwt.return (x + 1)) + in + state_is (Lwt.Return 2) p); + test "both" (fun () -> + let p = Lwt.both (Lwt.return 1) (Lwt.return 2) in + state_is (Lwt.Return (1, 2)) p); + test "Open_on_rhs" (fun () -> + let module Local = struct + module type Empty = sig end + end in + let x : (module Local.Empty) = + (module Lwt.Let_syntax.Let_syntax.Open_on_rhs) + in + ignore x; + Lwt.return true); + ] + +let suites = suites @ [ ppx_let_tests ] + +let let_syntax_tests = + suite "let syntax" + [ + test "let*" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p' = + let open Lwt.Syntax in + let* s1 = p1 in + let* s2 = p2 in + Lwt.return (s1 ^ s2) + in + Lwt.wakeup r1 "foo"; + Lwt.wakeup r2 "bar"; + state_is (Lwt.Return "foobar") p'); + test "and*" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p' = + let open Lwt.Syntax in + let* s1 = p1 and* s2 = p2 in + Lwt.return (s1 ^ s2) + in + Lwt.wakeup r1 "foo"; + Lwt.wakeup r2 "bar"; + state_is (Lwt.Return "foobar") p'); + test "let+/and+" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p' = + let open Lwt.Syntax in + let+ s1 = p1 and+ s2 = p2 in + s1 ^ s2 + in + Lwt.wakeup r1 "foo"; + Lwt.wakeup r2 "bar"; + state_is (Lwt.Return "foobar") p'); + ] + +let suites = suites @ [ let_syntax_tests ] (* Tests for [Lwt.add_task_l] and [Lwt.add_task_r]. *) let lwt_sequence_contains sequence list = let step item ((contains_so_far, list_tail) as state) = - if not contains_so_far then - state + if not contains_so_far then state else match list_tail with - | item'::rest -> item == item', rest + | item' :: rest -> (item == item', rest) | [] -> failwith "Sequence and list not of the same length" in fst (Lwt_sequence.fold_l step sequence (true, list)) -let lwt_sequence_tests = suite "add_task_l and add_task_r" [ - test "add_task_r" begin fun () -> - let sequence = Lwt_sequence.create () in - let p = (Lwt.add_task_r [@ocaml.warning "-3"]) sequence in - let p' = (Lwt.add_task_r [@ocaml.warning "-3"]) sequence in - assert (Lwt.state p = Lwt.Sleep); - assert (lwt_sequence_contains sequence [Obj.magic p; Obj.magic p']); - Lwt.cancel p; - Lwt.return - (Lwt.state p = Lwt.Fail Lwt.Canceled && - lwt_sequence_contains sequence [Obj.magic p']) - end; - - test "add_task_l" begin fun () -> - let sequence = Lwt_sequence.create () in - let p = (Lwt.add_task_l [@ocaml.warning "-3"]) sequence in - let p' = (Lwt.add_task_l [@ocaml.warning "-3"]) sequence in - assert (Lwt.state p = Lwt.Sleep); - assert (lwt_sequence_contains sequence [Obj.magic p'; Obj.magic p]); - Lwt.cancel p; - Lwt.return - (Lwt.state p = Lwt.Fail Lwt.Canceled && - lwt_sequence_contains sequence [Obj.magic p']) - end; -] -let suites = suites @ [lwt_sequence_tests] - - - -let pause_tests = suite "pause" [ - test "initial state" begin fun () -> - Lwt.return (Lwt.paused_count () = 0) - end; - - test "one promise" begin fun () -> - let p = Lwt.pause () in - assert (Lwt.paused_count () = 1); - Lwt.bind (state_is Lwt.Sleep p) (fun initial_state_correct -> - Lwt.wakeup_paused (); - assert (Lwt.paused_count () = 0); - Lwt.bind (state_is (Lwt.Return ()) p) (fun final_state_correct -> - Lwt.return (initial_state_correct && final_state_correct))) - end; - - test "multiple promises" begin fun () -> - let p1 = Lwt.pause () in - let p2 = Lwt.pause () in - assert (Lwt.paused_count () = 2); - Lwt.bind (state_is Lwt.Sleep p1) (fun initial_state_correct_1 -> - Lwt.bind (state_is Lwt.Sleep p2) (fun initial_state_correct_2 -> - Lwt.wakeup_paused (); - assert (Lwt.paused_count () = 0); - Lwt.bind (state_is (Lwt.Return ()) p1) (fun final_state_correct_1 -> - Lwt.bind (state_is (Lwt.Return ()) p2) (fun final_state_correct_2 -> - Lwt.return - (initial_state_correct_1 && initial_state_correct_2 && - final_state_correct_1 && final_state_correct_2))))) - end; - - test "wakeup with no promises" begin fun () -> - assert (Lwt.paused_count () = 0); - Lwt.wakeup_paused (); - assert (Lwt.paused_count () = 0); - Lwt.return true - end; - - test "pause notifier" begin fun () -> - let seen = ref None in - Lwt.register_pause_notifier (fun count -> seen := Some count); - Lwt.pause () |> ignore; - assert (Lwt.paused_count () = 1); - assert (!seen = Some 1); - Lwt.wakeup_paused (); - Lwt.register_pause_notifier ignore; - Lwt.return true - end; - - test "pause in unpause" begin fun () -> - let p1 = Lwt.pause () in - (* let p2 = ref return_unit in *) - Lwt.bind p1 (fun () -> Lwt.pause ()) |> ignore; - assert (Lwt.paused_count () = 1); - Lwt.wakeup_paused (); - later (fun () -> - assert (Lwt.paused_count () = 1); - Lwt.wakeup_paused (); - true) - end; - - test "recursive pause in notifier" begin fun () -> - Lwt.register_pause_notifier (fun _count -> - (* This will be called in response to a call to [Lwt.pause ()], so we can - expect one paused promise to already be in the queue. *) - assert (Lwt.paused_count () = 1); - Lwt.register_pause_notifier ignore; - Lwt.pause () |> ignore); - Lwt.pause () |> ignore; - assert (Lwt.paused_count () = 2); - Lwt.wakeup_paused (); - Lwt.return true - end; - - test "unpause in pause" begin fun () -> - Lwt.register_pause_notifier (fun _count -> - assert (Lwt.paused_count () = 1); - Lwt.wakeup_paused ()); - Lwt.pause () |> ignore; - assert (Lwt.paused_count () = 0); - Lwt.register_pause_notifier ignore; - Lwt.return true - end; -] -let suites = suites @ [pause_tests] - - +let lwt_sequence_tests = + suite "add_task_l and add_task_r" + [ + test "add_task_r" (fun () -> + let sequence = Lwt_sequence.create () in + let p = (Lwt.add_task_r [@ocaml.warning "-3"]) sequence in + let p' = (Lwt.add_task_r [@ocaml.warning "-3"]) sequence in + assert (Lwt.state p = Lwt.Sleep); + assert (lwt_sequence_contains sequence [ Obj.magic p; Obj.magic p' ]); + Lwt.cancel p; + Lwt.return + (Lwt.state p = Lwt.Fail Lwt.Canceled + && lwt_sequence_contains sequence [ Obj.magic p' ])); + test "add_task_l" (fun () -> + let sequence = Lwt_sequence.create () in + let p = (Lwt.add_task_l [@ocaml.warning "-3"]) sequence in + let p' = (Lwt.add_task_l [@ocaml.warning "-3"]) sequence in + assert (Lwt.state p = Lwt.Sleep); + assert (lwt_sequence_contains sequence [ Obj.magic p'; Obj.magic p ]); + Lwt.cancel p; + Lwt.return + (Lwt.state p = Lwt.Fail Lwt.Canceled + && lwt_sequence_contains sequence [ Obj.magic p' ])); + ] + +let suites = suites @ [ lwt_sequence_tests ] + +let pause_tests = + suite "pause" + [ + test "initial state" (fun () -> Lwt.return (Lwt.paused_count () = 0)); + test "one promise" (fun () -> + let p = Lwt.pause () in + assert (Lwt.paused_count () = 1); + Lwt.bind (state_is Lwt.Sleep p) (fun initial_state_correct -> + Lwt.wakeup_paused (); + assert (Lwt.paused_count () = 0); + Lwt.bind (state_is (Lwt.Return ()) p) (fun final_state_correct -> + Lwt.return (initial_state_correct && final_state_correct)))); + test "multiple promises" (fun () -> + let p1 = Lwt.pause () in + let p2 = Lwt.pause () in + assert (Lwt.paused_count () = 2); + Lwt.bind (state_is Lwt.Sleep p1) (fun initial_state_correct_1 -> + Lwt.bind (state_is Lwt.Sleep p2) (fun initial_state_correct_2 -> + Lwt.wakeup_paused (); + assert (Lwt.paused_count () = 0); + Lwt.bind (state_is (Lwt.Return ()) p1) + (fun final_state_correct_1 -> + Lwt.bind (state_is (Lwt.Return ()) p2) + (fun final_state_correct_2 -> + Lwt.return + (initial_state_correct_1 + && initial_state_correct_2 + && final_state_correct_1 + && final_state_correct_2)))))); + test "wakeup with no promises" (fun () -> + assert (Lwt.paused_count () = 0); + Lwt.wakeup_paused (); + assert (Lwt.paused_count () = 0); + Lwt.return true); + test "pause notifier" (fun () -> + let seen = ref None in + Lwt.register_pause_notifier (fun count -> seen := Some count); + Lwt.pause () |> ignore; + assert (Lwt.paused_count () = 1); + assert (!seen = Some 1); + Lwt.wakeup_paused (); + Lwt.register_pause_notifier ignore; + Lwt.return true); + test "pause in unpause" (fun () -> + let p1 = Lwt.pause () in + (* let p2 = ref return_unit in *) + Lwt.bind p1 (fun () -> Lwt.pause ()) |> ignore; + assert (Lwt.paused_count () = 1); + Lwt.wakeup_paused (); + later (fun () -> + assert (Lwt.paused_count () = 1); + Lwt.wakeup_paused (); + true)); + test "recursive pause in notifier" (fun () -> + Lwt.register_pause_notifier (fun _count -> + (* This will be called in response to a call to [Lwt.pause ()], so we can + expect one paused promise to already be in the queue. *) + assert (Lwt.paused_count () = 1); + Lwt.register_pause_notifier ignore; + Lwt.pause () |> ignore); + Lwt.pause () |> ignore; + assert (Lwt.paused_count () = 2); + Lwt.wakeup_paused (); + Lwt.return true); + test "unpause in pause" (fun () -> + Lwt.register_pause_notifier (fun _count -> + assert (Lwt.paused_count () = 1); + Lwt.wakeup_paused ()); + Lwt.pause () |> ignore; + assert (Lwt.paused_count () = 0); + Lwt.register_pause_notifier ignore; + Lwt.return true); + ] + +let suites = suites @ [ pause_tests ] (* [Lwt.apply] and [Lwt.wrapN]. *) -let lift_tests = suite "apply and wrap" [ - test "apply" begin fun () -> - let p = Lwt.apply (fun s -> Lwt.return (s ^ "bar")) "foo" in - state_is (Lwt.Return "foobar") p - end; - - test "apply: raises" begin fun () -> - let p = Lwt.apply (fun () -> raise Exception) () in - state_is (Lwt.Fail Exception) p - end; - - test "wrap" begin fun () -> - let p = Lwt.wrap (fun () -> "foo") in - state_is (Lwt.Return "foo") p - end; - - test "wrap: raises" begin fun () -> - let p = Lwt.wrap (fun () -> raise Exception) in - state_is (Lwt.Fail Exception) p - end; - - test "wrap1" begin fun () -> - let p = Lwt.wrap1 (fun x1 -> x1) 1 in - state_is (Lwt.Return 1) p - end; - - test "wrap1: raises" begin fun () -> - let p = Lwt.wrap1 (fun _ -> raise Exception) () in - state_is (Lwt.Fail Exception) p - end; - - test "wrap2" begin fun () -> - let p = Lwt.wrap2 (fun x1 x2 -> x1 + x2) 1 2 in - state_is (Lwt.Return 3) p - end; - - test "wrap2: raises" begin fun () -> - let p = Lwt.wrap2 (fun _ _ -> raise Exception) () () in - state_is (Lwt.Fail Exception) p - end; - - test "wrap3" begin fun () -> - let p = Lwt.wrap3 (fun x1 x2 x3 -> x1 + x2 + x3) 1 2 3 in - state_is (Lwt.Return 6) p - end; - - test "wrap3: raises" begin fun () -> - let p = Lwt.wrap3 (fun _ _ _ -> raise Exception) () () () in - state_is (Lwt.Fail Exception) p - end; - - test "wrap4" begin fun () -> - let p = Lwt.wrap4 (fun x1 x2 x3 x4 -> x1 + x2 + x3 + x4) 1 2 3 4 in - state_is (Lwt.Return 10) p - end; - - test "wrap4: raises" begin fun () -> - let p = Lwt.wrap4 (fun _ _ _ _ -> raise Exception) () () () () in - state_is (Lwt.Fail Exception) p - end; - - test "wrap5" begin fun () -> - let p = - Lwt.wrap5 (fun x1 x2 x3 x4 x5 -> x1 + x2 + x3 + x4 + x5) 1 2 3 4 5 in - state_is (Lwt.Return 15) p - end; - - test "wrap5: raises" begin fun () -> - let p = Lwt.wrap5 (fun _ _ _ _ _ -> raise Exception) () () () () () in - state_is (Lwt.Fail Exception) p - end; - - test "wrap6" begin fun () -> - let p = - Lwt.wrap6 - (fun x1 x2 x3 x4 x5 x6 -> x1 + x2 + x3 + x4 + x5 + x6) 1 2 3 4 5 6 - in - state_is (Lwt.Return 21) p - end; - - test "wrap6: raises" begin fun () -> - let p = Lwt.wrap6 (fun _ _ _ _ _ _ -> raise Exception) () () () () () () in - state_is (Lwt.Fail Exception) p - end; - - test "wrap7" begin fun () -> - let p = - Lwt.wrap7 - (fun x1 x2 x3 x4 x5 x6 x7 -> x1 + x2 + x3 + x4 + x5 + x6 + x7) - 1 2 3 4 5 6 7 - in - state_is (Lwt.Return 28) p - end; - - test "wrap7: raises" begin fun () -> - let p = - Lwt.wrap7 (fun _ _ _ _ _ _ _ -> raise Exception) () () () () () () () in - state_is (Lwt.Fail Exception) p - end; -] -let suites = suites @ [lift_tests] - - +let lift_tests = + suite "apply and wrap" + [ + test "apply" (fun () -> + let p = Lwt.apply (fun s -> Lwt.return (s ^ "bar")) "foo" in + state_is (Lwt.Return "foobar") p); + test "apply: raises" (fun () -> + let p = Lwt.apply (fun () -> raise Exception) () in + state_is (Lwt.Fail Exception) p); + test "wrap" (fun () -> + let p = Lwt.wrap (fun () -> "foo") in + state_is (Lwt.Return "foo") p); + test "wrap: raises" (fun () -> + let p = Lwt.wrap (fun () -> raise Exception) in + state_is (Lwt.Fail Exception) p); + test "wrap1" (fun () -> + let p = Lwt.wrap1 (fun x1 -> x1) 1 in + state_is (Lwt.Return 1) p); + test "wrap1: raises" (fun () -> + let p = Lwt.wrap1 (fun _ -> raise Exception) () in + state_is (Lwt.Fail Exception) p); + test "wrap2" (fun () -> + let p = Lwt.wrap2 (fun x1 x2 -> x1 + x2) 1 2 in + state_is (Lwt.Return 3) p); + test "wrap2: raises" (fun () -> + let p = Lwt.wrap2 (fun _ _ -> raise Exception) () () in + state_is (Lwt.Fail Exception) p); + test "wrap3" (fun () -> + let p = Lwt.wrap3 (fun x1 x2 x3 -> x1 + x2 + x3) 1 2 3 in + state_is (Lwt.Return 6) p); + test "wrap3: raises" (fun () -> + let p = Lwt.wrap3 (fun _ _ _ -> raise Exception) () () () in + state_is (Lwt.Fail Exception) p); + test "wrap4" (fun () -> + let p = Lwt.wrap4 (fun x1 x2 x3 x4 -> x1 + x2 + x3 + x4) 1 2 3 4 in + state_is (Lwt.Return 10) p); + test "wrap4: raises" (fun () -> + let p = Lwt.wrap4 (fun _ _ _ _ -> raise Exception) () () () () in + state_is (Lwt.Fail Exception) p); + test "wrap5" (fun () -> + let p = + Lwt.wrap5 (fun x1 x2 x3 x4 x5 -> x1 + x2 + x3 + x4 + x5) 1 2 3 4 5 + in + state_is (Lwt.Return 15) p); + test "wrap5: raises" (fun () -> + let p = Lwt.wrap5 (fun _ _ _ _ _ -> raise Exception) () () () () () in + state_is (Lwt.Fail Exception) p); + test "wrap6" (fun () -> + let p = + Lwt.wrap6 + (fun x1 x2 x3 x4 x5 x6 -> x1 + x2 + x3 + x4 + x5 + x6) + 1 2 3 4 5 6 + in + state_is (Lwt.Return 21) p); + test "wrap6: raises" (fun () -> + let p = + Lwt.wrap6 (fun _ _ _ _ _ _ -> raise Exception) () () () () () () + in + state_is (Lwt.Fail Exception) p); + test "wrap7" (fun () -> + let p = + Lwt.wrap7 + (fun x1 x2 x3 x4 x5 x6 x7 -> x1 + x2 + x3 + x4 + x5 + x6 + x7) + 1 2 3 4 5 6 7 + in + state_is (Lwt.Return 28) p); + test "wrap7: raises" (fun () -> + let p = + Lwt.wrap7 + (fun _ _ _ _ _ _ _ -> raise Exception) + () () () () () () () + in + state_is (Lwt.Fail Exception) p); + ] + +let suites = suites @ [ lift_tests ] (* [Lwt.make_value] and [Lwt.make_error] are deprecated, but test them anyway, for good measure. *) -let make_value_and_error_tests = suite "make_value and make_error" [ - test "make_value" begin fun () -> - Lwt.return ((Lwt.make_value [@ocaml.warning "-3"]) 42 = Result.Ok 42) - end; - - test "make_error" begin fun () -> - Lwt.return - ((Lwt.make_error [@ocaml.warning "-3"]) Exception = - Result.Error Exception) - end; -] -let suites = suites @ [make_value_and_error_tests] - - +let make_value_and_error_tests = + suite "make_value and make_error" + [ + test "make_value" (fun () -> + Lwt.return ((Lwt.make_value [@ocaml.warning "-3"]) 42 = Result.Ok 42)); + test "make_error" (fun () -> + Lwt.return + ((Lwt.make_error [@ocaml.warning "-3"]) Exception + = Result.Error Exception)); + ] + +let suites = suites @ [ make_value_and_error_tests ] (* These tests exercise the callback cleanup mechanism of the Lwt core, which is an implementation detail. When a promise [p] is repeatedly used in functions @@ -4402,46 +3690,48 @@ let suites = suites @ [make_value_and_error_tests] let callback_cleanup_point = 42 -let callback_list_tests = suite "callback cleanup" [ - test "choose" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2 = Lwt.bind p1 (fun s -> Lwt.return (s ^ "bar")) in - let p3 = Lwt.choose [p1; fst (Lwt.wait ())] in - let rec repeat = function - | 0 -> () - | n -> - let p4, r4 = Lwt.wait () in - Lwt.choose [p1; p4] |> ignore; - Lwt.wakeup r4 ""; - repeat (n - 1) - in - repeat (callback_cleanup_point + 1); - Lwt.wakeup r1 "foo"; - Lwt.return - (Lwt.state p2 = Lwt.Return "foobar" && Lwt.state p3 = Lwt.Return "foo") - end; - - test "bind" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p3 = Lwt.bind p1 (fun () -> p2) in - let p4 = Lwt.map ignore p2 in - let p5 = Lwt.map ignore p3 in - let rec repeat = function - | 0 -> () - | n -> - let p6, r6 = Lwt.wait () in - Lwt.choose [p2; p3; p6] |> ignore; - Lwt.wakeup r6 (); - repeat (n - 1) - in - repeat ((callback_cleanup_point / 2) + 1); - Lwt.wakeup r1 (); - Lwt.wakeup r2 (); - Lwt.return (Lwt.state p4 = Lwt.Return () && Lwt.state p5 = Lwt.Return ()) - end; -] -let suites = suites @ [callback_list_tests] +let callback_list_tests = + suite "callback cleanup" + [ + test "choose" (fun () -> + let p1, r1 = Lwt.wait () in + let p2 = Lwt.bind p1 (fun s -> Lwt.return (s ^ "bar")) in + let p3 = Lwt.choose [ p1; fst (Lwt.wait ()) ] in + let rec repeat = function + | 0 -> () + | n -> + let p4, r4 = Lwt.wait () in + Lwt.choose [ p1; p4 ] |> ignore; + Lwt.wakeup r4 ""; + repeat (n - 1) + in + repeat (callback_cleanup_point + 1); + Lwt.wakeup r1 "foo"; + Lwt.return + (Lwt.state p2 = Lwt.Return "foobar" + && Lwt.state p3 = Lwt.Return "foo")); + test "bind" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p3 = Lwt.bind p1 (fun () -> p2) in + let p4 = Lwt.map ignore p2 in + let p5 = Lwt.map ignore p3 in + let rec repeat = function + | 0 -> () + | n -> + let p6, r6 = Lwt.wait () in + Lwt.choose [ p2; p3; p6 ] |> ignore; + Lwt.wakeup r6 (); + repeat (n - 1) + in + repeat ((callback_cleanup_point / 2) + 1); + Lwt.wakeup r1 (); + Lwt.wakeup r2 (); + Lwt.return + (Lwt.state p4 = Lwt.Return () && Lwt.state p5 = Lwt.Return ())); + ] + +let suites = suites @ [ callback_list_tests ] (* @@ -4458,19 +3748,19 @@ let suites = suites @ [callback_list_tests] *) -let tailrec_tests = suite "tailrec" [ - test "tailrec" begin fun () -> - let rec aux f accu n = - if n = 0 then - Lwt.return accu - else - Lwt.bind (f n) (fun s -> aux f (s + accu) (n - 1)) - in - let f n = Lwt.return n in - try - ignore (aux f 0 10000000); - Lwt.return true - with _ -> Lwt.return false - end; -] -let suites = suites @ [tailrec_tests] +let tailrec_tests = + suite "tailrec" + [ + test "tailrec" (fun () -> + let rec aux f accu n = + if n = 0 then Lwt.return accu + else Lwt.bind (f n) (fun s -> aux f (s + accu) (n - 1)) + in + let f n = Lwt.return n in + try + ignore (aux f 0 10000000); + Lwt.return true + with _ -> Lwt.return false); + ] + +let suites = suites @ [ tailrec_tests ] diff --git a/test/core/test_lwt_condition.ml b/test/core/test_lwt_condition.ml index b9dd5500f9..67ec4c15fb 100644 --- a/test/core/test_lwt_condition.ml +++ b/test/core/test_lwt_condition.ml @@ -1,71 +1,55 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Test exception Dummy_error -let suite = suite "lwt_condition" [ - - test "basic wait" begin fun () -> - let c = Lwt_condition.create () in - let w = Lwt_condition.wait c in - let () = Lwt_condition.signal c 1 in - Lwt.bind w (fun v -> Lwt.return (v = 1)) - end; - - test "mutex unlocked during wait" begin fun () -> - let c = Lwt_condition.create () in - let m = Lwt_mutex.create () in - let _ = Lwt_mutex.lock m in - let w = Lwt_condition.wait ~mutex:m c in - Lwt.return (Lwt.state w = Lwt.Sleep - && not (Lwt_mutex.is_locked m)) - end; - - test "mutex relocked after wait" begin fun () -> - let c = Lwt_condition.create () in - let m = Lwt_mutex.create () in - let _ = Lwt_mutex.lock m in - let w = Lwt_condition.wait ~mutex:m c in - let () = Lwt_condition.signal c 1 in - Lwt.bind w (fun v -> - Lwt.return (v = 1 && Lwt_mutex.is_locked m)) - end; - - test "signal is not sticky" begin fun () -> - let c = Lwt_condition.create () in - let () = Lwt_condition.signal c 1 in - let w = Lwt_condition.wait c in - Lwt.return (Lwt.state w = Lwt.Sleep) - end; - - test "broadcast" begin fun () -> - let c = Lwt_condition.create () in - let w1 = Lwt_condition.wait c in - let w2 = Lwt_condition.wait c in - let () = Lwt_condition.broadcast c 1 in - Lwt.bind w1 (fun v1 -> - Lwt.bind w2 (fun v2 -> - Lwt.return (v1 = 1 && v2 = 1))) - end; - - test "broadcast exception" begin fun () -> - let c = Lwt_condition.create () in - let w1 = Lwt_condition.wait c in - let w2 = Lwt_condition.wait c in - let () = Lwt_condition.broadcast_exn c Dummy_error in - Lwt.try_bind - (fun () -> w1) - (fun _ -> Lwt.return_false) - (fun exn1 -> - Lwt.try_bind - (fun () -> w2) - (fun _ -> Lwt.return_false) - (fun exn2 -> - Lwt.return (exn1 = Dummy_error && exn2 = Dummy_error))) - end; - -] +let suite = + suite "lwt_condition" + [ + test "basic wait" (fun () -> + let c = Lwt_condition.create () in + let w = Lwt_condition.wait c in + let () = Lwt_condition.signal c 1 in + Lwt.bind w (fun v -> Lwt.return (v = 1))); + test "mutex unlocked during wait" (fun () -> + let c = Lwt_condition.create () in + let m = Lwt_mutex.create () in + let _ = Lwt_mutex.lock m in + let w = Lwt_condition.wait ~mutex:m c in + Lwt.return (Lwt.state w = Lwt.Sleep && not (Lwt_mutex.is_locked m))); + test "mutex relocked after wait" (fun () -> + let c = Lwt_condition.create () in + let m = Lwt_mutex.create () in + let _ = Lwt_mutex.lock m in + let w = Lwt_condition.wait ~mutex:m c in + let () = Lwt_condition.signal c 1 in + Lwt.bind w (fun v -> Lwt.return (v = 1 && Lwt_mutex.is_locked m))); + test "signal is not sticky" (fun () -> + let c = Lwt_condition.create () in + let () = Lwt_condition.signal c 1 in + let w = Lwt_condition.wait c in + Lwt.return (Lwt.state w = Lwt.Sleep)); + test "broadcast" (fun () -> + let c = Lwt_condition.create () in + let w1 = Lwt_condition.wait c in + let w2 = Lwt_condition.wait c in + let () = Lwt_condition.broadcast c 1 in + Lwt.bind w1 (fun v1 -> + Lwt.bind w2 (fun v2 -> Lwt.return (v1 = 1 && v2 = 1)))); + test "broadcast exception" (fun () -> + let c = Lwt_condition.create () in + let w1 = Lwt_condition.wait c in + let w2 = Lwt_condition.wait c in + let () = Lwt_condition.broadcast_exn c Dummy_error in + Lwt.try_bind + (fun () -> w1) + (fun _ -> Lwt.return_false) + (fun exn1 -> + Lwt.try_bind + (fun () -> w2) + (fun _ -> Lwt.return_false) + (fun exn2 -> + Lwt.return (exn1 = Dummy_error && exn2 = Dummy_error)))); + ] diff --git a/test/core/test_lwt_list.ml b/test/core/test_lwt_list.ml index e1909d96df..7766ecb87f 100644 --- a/test/core/test_lwt_list.ml +++ b/test/core/test_lwt_list.ml @@ -1,36 +1,36 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Test open Lwt.Infix -let (<=>) v v' = - assert (Lwt.state v = v') +let ( <=> ) v v' = assert (Lwt.state v = v') let test_iter f test_list = let incr_ x = Lwt.return (incr x) in let () = - let l = [ref 0; ref 0; ref 0] in + let l = [ ref 0; ref 0; ref 0 ] in let t = f incr_ l in t <=> Lwt.Return (); - List.iter2 (fun v r -> assert (v = !r)) [1; 1; 1] l + List.iter2 (fun v r -> assert (v = !r)) [ 1; 1; 1 ] l in let () = - let l = [ref 0; ref 0; ref 0] in + let l = [ ref 0; ref 0; ref 0 ] in let t, w = Lwt.wait () in - let r = ref [incr_; (fun x -> t >>= (fun () -> incr_ x)); incr_] in - let t' = f (fun x -> - let f = List.hd !r in - let t = f x in - r := List.tl !r; - t) l + let r = ref [ incr_; (fun x -> t >>= fun () -> incr_ x); incr_ ] in + let t' = + f + (fun x -> + let f = List.hd !r in + let t = f x in + r := List.tl !r; + t) + l in t' <=> Sleep; List.iter2 (fun v r -> assert (v = !r)) test_list l; Lwt.wakeup w (); - List.iter2 (fun v r -> assert (v = !r)) [1; 1; 1] l; + List.iter2 (fun v r -> assert (v = !r)) [ 1; 1; 1 ] l; t' <=> Lwt.Return () in () @@ -38,13 +38,10 @@ let test_iter f test_list = let test_exception list_combinator = (* This really should be a local exception, but local exceptions require OCaml 4.04, while Lwt still supports, and is tested on, 4.02. *) - let module E = - struct - exception Exception - end - in + let module E = struct + exception Exception + end in let open E in - let number_of_callback_calls = ref 0 in let callback _ = @@ -60,10 +57,7 @@ let test_exception list_combinator = raised exception should not be leaked up past the creation of the promise. *) let p = - try - list_combinator callback [(); (); ()] - with _exn -> - assert false + try list_combinator callback [ (); (); () ] with _exn -> assert false in (* Check that the promise was rejected with the expected exception. *) @@ -78,19 +72,16 @@ let test_map f test_list = fun () -> let th = incr c; - match !c with - | 5 -> t - | 8 -> t' - | _ -> Lwt.return () + match !c with 5 -> t | 8 -> t' | _ -> Lwt.return () in - th >>= (fun () -> - incr r; - Lwt.return (!r)) + th >>= fun () -> + incr r; + Lwt.return !r in let () = - let l = [(); (); ()] in + let l = [ (); (); () ] in let t1 = f get l in - t1 <=> Lwt.Return [1; 2; 3]; + t1 <=> Lwt.Return [ 1; 2; 3 ]; let t2 = f get l in t2 <=> Lwt.Sleep; let t3 = f get l in @@ -98,7 +89,7 @@ let test_map f test_list = Lwt.cancel t'; t3 <=> Lwt.Fail Lwt.Canceled; Lwt.wakeup w (); - t2 <=> Lwt.Return test_list; + t2 <=> Lwt.Return test_list in () @@ -106,579 +97,438 @@ let test_parallelism map = let t, w = Lwt.wait () in let g _ = Lwt.wakeup_later w (); - Lwt.return () in - let f x = - if x = 0 then t >>= (fun _ -> Lwt.return ()) - else g x + Lwt.return () in - let p = map f [0; 1] in - p >>= (fun _ -> Lwt.return_true) + let f x = if x = 0 then t >>= fun _ -> Lwt.return () else g x in + let p = map f [ 0; 1 ] in + p >>= fun _ -> Lwt.return_true -let test_serialization ?(rev=false) map = +let test_serialization ?(rev = false) map = let other_ran = ref false in let k = if rev then 1 else 0 in let f x = - if x = k then + if x = k then ( Lwt.pause () >>= fun () -> - assert(not !other_ran); - Lwt.return () - else begin + assert (not !other_ran); + Lwt.return ()) + else ( other_ran := true; - Lwt.return () - end + Lwt.return ()) in - let p = map f [0; 1] in - p >>= (fun _ -> Lwt.return_true) + let p = map f [ 0; 1 ] in + p >>= fun _ -> Lwt.return_true let test_for_all_true f = - let l = [true; true] in + let l = [ true; true ] in f (fun x -> Lwt.return (x = true)) l let test_for_all_false f = - let l = [true; true] in - f (fun x -> Lwt.return (x = false)) l >>= fun b -> - Lwt.return (not b) + let l = [ true; true ] in + f (fun x -> Lwt.return (x = false)) l >>= fun b -> Lwt.return (not b) let test_exists_true f = - let l = [true; false] in - f (fun x -> Lwt.return (x = true)) l >>= fun b -> - Lwt.return b + let l = [ true; false ] in + f (fun x -> Lwt.return (x = true)) l >>= fun b -> Lwt.return b let test_exists_false f = - let l = [true; true] in - f (fun x -> Lwt.return (x = false)) l >>= fun b -> - Lwt.return (not b) + let l = [ true; true ] in + f (fun x -> Lwt.return (x = false)) l >>= fun b -> Lwt.return (not b) let test_filter f = - let l = [1; 2; 3; 4] in + let l = [ 1; 2; 3; 4 ] in f (fun x -> Lwt.return (x mod 2 = 0)) l >>= fun after -> - Lwt.return (after = [2; 4]) + Lwt.return (after = [ 2; 4 ]) let test_partition f = - let l = [1; 2; 3; 4] in + let l = [ 1; 2; 3; 4 ] in f (fun x -> Lwt.return (x <= 2)) l >>= fun (a, b) -> - Lwt.return (a = [1; 2] && b = [3; 4]) + Lwt.return (a = [ 1; 2 ] && b = [ 3; 4 ]) let test_filter_map f = - let l = [1; 2; 3; 4] in - let fn = (fun x -> - if x mod 2 = 0 then Lwt.return_some (x * 2) else Lwt.return_none) in - f fn l >>= fun after -> - Lwt.return (after = [4; 8]) + let l = [ 1; 2; 3; 4 ] in + let fn x = if x mod 2 = 0 then Lwt.return_some (x * 2) else Lwt.return_none in + f fn l >>= fun after -> Lwt.return (after = [ 4; 8 ]) let test_iter_i f = let count = ref 0 in - let l = [1; 2; 3] in - f (fun i n -> count := !count + i + n; Lwt.return_unit) l >>= fun () -> - Lwt.return (!count = 9) + let l = [ 1; 2; 3 ] in + f + (fun i n -> + count := !count + i + n; + Lwt.return_unit) + l + >>= fun () -> Lwt.return (!count = 9) let test_map_i f = - let l = [0; 0; 0] in + let l = [ 0; 0; 0 ] in f (fun i n -> Lwt.return (i + n)) l >>= fun after -> - Lwt.return (after = [0; 1; 2]) + Lwt.return (after = [ 0; 1; 2 ]) let test_rev_map f = - let l = [1; 2; 3] in + let l = [ 1; 2; 3 ] in f (fun n -> Lwt.return (n * 2)) l >>= fun after -> - Lwt.return (after = [6; 4; 2]) - -let suite_primary = suite "lwt_list" [ - test "iter_p" begin fun () -> - test_iter Lwt_list.iter_p [1; 0; 1]; - test_exception Lwt_list.iter_p; - Lwt.return true - end; - - test "iter_s" begin fun () -> - test_iter Lwt_list.iter_s [1; 0; 0]; - test_exception Lwt_list.iter_s; - Lwt.return true - end; - - test "map_p" begin fun () -> - test_map Lwt_list.map_p [4; 8; 5]; - test_exception Lwt_list.map_p; - Lwt.return true - end; - - test "map_s" begin fun () -> - test_map Lwt_list.map_s [4; 7; 8]; - test_exception Lwt_list.map_s; - Lwt.return true - end; - - test "fold_left_s" begin fun () -> - let l = [1; 2; 3] in - let f acc v = Lwt.return (v::acc) in - let t = Lwt_list.fold_left_s f [] l in - t <=> Lwt.Return (List.rev l); - Lwt.return true - end; - - test "for_all_s" - (fun () -> test_for_all_true Lwt_list.for_all_s); - - test "for_all_p" - (fun () -> test_for_all_true Lwt_list.for_all_p); - - test "exists_s true" - (fun () -> test_exists_true Lwt_list.exists_s); - - test "exists_p true" - (fun () -> test_exists_true Lwt_list.exists_p); - - test "exists_s false" - (fun () -> test_exists_false Lwt_list.exists_s); - - test "exists_p false" - (fun () -> test_exists_false Lwt_list.exists_p); - - test "filter_s" - (fun () -> test_filter Lwt_list.filter_s); - - test "filter_p" - (fun () -> test_filter Lwt_list.filter_p); - - test "partition_p" - (fun () -> test_partition Lwt_list.partition_p); - - test "partition_s" - (fun () -> test_partition Lwt_list.partition_s); - - test "filter_map_p" - (fun () -> test_filter_map Lwt_list.filter_map_p); - - test "filter_map_s" - (fun () -> test_filter_map Lwt_list.filter_map_s); - - test "iteri_p" - (fun () -> test_iter_i Lwt_list.iteri_p); - - test "iteri_s" - (fun () -> test_iter_i Lwt_list.iteri_s); - - test "mapi_p" - (fun () -> test_map_i Lwt_list.mapi_p); - - test "mapi_s" - (fun () -> test_map_i Lwt_list.mapi_s); - - test "find_s existing" begin fun () -> - let l = [1; 2; 3] in - Lwt_list.find_s (fun n -> Lwt.return ((n mod 2) = 0)) l >>= fun result -> - Lwt.return (result = 2) - end; - - test "find_s missing" begin fun () -> - let l = [1; 3] in - Lwt.catch - (fun () -> - Lwt_list.find_s (fun n -> - Lwt.return ((n mod 2) = 0)) l >>= fun _result -> - Lwt.return false) - (function - | Not_found -> Lwt.return true - | _ -> Lwt.return false) - end; - - test "rev_map_p" - (fun () -> test_rev_map Lwt_list.rev_map_p); - - test "rev_map_s" - (fun () -> test_rev_map Lwt_list.rev_map_s); - - test "fold_right_s" begin fun () -> - let l = [1; 2; 3] in - Lwt_list.fold_right_s (fun a n -> Lwt.return (a + n)) l 0 >>= fun result -> - Lwt.return (result = 6) - end; - - test "iteri_p exception" begin fun () -> - let i f = Lwt_list.iteri_p (fun _ x -> f x) in - test_exception i; - Lwt.return true - end; - - test "iteri_s exception" begin fun () -> - let i f = Lwt_list.iteri_s (fun _ x -> f x) in - test_exception i; - Lwt.return true - end; - - test "map_s exception" begin fun () -> - test_exception Lwt_list.map_s; - Lwt.return true - end; - - test "map_p exception" begin fun () -> - test_exception Lwt_list.map_p; - Lwt.return true - end; - - test "mapi_s exception" begin fun () -> - let m f = Lwt_list.mapi_s (fun _ x -> f x) in - test_exception m; - Lwt.return true - end; - - test "mapi_p exception" begin fun () -> - let m f = Lwt_list.mapi_p (fun _ x -> f x) in - test_exception m; - Lwt.return true - end; - - test "rev_map_s exception" begin fun () -> - test_exception Lwt_list.rev_map_s; - Lwt.return true - end; - - test "rev_map_p exception" begin fun () -> - test_exception Lwt_list.rev_map_p; - Lwt.return true - end; - - test "fold_left_s exception" begin fun () -> - let m f = Lwt_list.fold_left_s (fun _ x -> f x) () in - test_exception m; - Lwt.return true - end; - - test "fold_right_s exception" begin fun() -> - let m f l = Lwt_list.fold_right_s (fun x _ -> f x) l () in - test_exception m; - Lwt.return true - end; - - test "for_all_p exception" begin fun () -> - let m f = - Lwt_list.for_all_p (fun x -> f x >>= (fun _ -> Lwt.return_true)) in - test_exception m; - Lwt.return true - end; - - test "for_all_s exception" begin fun () -> - let m f = - Lwt_list.for_all_s (fun x -> f x >>= (fun _ -> Lwt.return_true)) in - test_exception m; - Lwt.return true - end; - - test "exists_p exception" begin fun () -> - let m f = - Lwt_list.exists_p (fun x -> f x >>= (fun _ -> Lwt.return_false)) in - test_exception m; - Lwt.return true - end; - - test "exists_s exception" begin fun () -> - let m f = - Lwt_list.exists_s (fun x -> f x >>= (fun _ -> Lwt.return_false)) in - test_exception m; - Lwt.return true - end; - - test "find_s exception" begin fun () -> - let m f = Lwt_list.find_s (fun x -> f x >>= (fun _ -> Lwt.return_false)) in - test_exception m; - Lwt.return true - end; - - test "filter_p exception" begin fun () -> - let m f = - Lwt_list.filter_p (fun x -> f x >>= (fun _ -> Lwt.return_false)) in - test_exception m; - Lwt.return true; - end; - - test "filter_s exception" begin fun () -> - let m f = - Lwt_list.filter_s (fun x -> f x >>= (fun _ -> Lwt.return_false)) in - test_exception m; - Lwt.return true; - end; - - test "filter_map_p exception" begin fun () -> - let m f = - Lwt_list.filter_map_p (fun x -> f x >>= (fun _ -> Lwt.return (Some ()))) - in - test_exception m; - Lwt.return true; - end; - - test "filter_map_s exception" begin fun () -> - let m f = - Lwt_list.filter_map_s (fun x -> f x >>= (fun _ -> Lwt.return (Some ()))) - in - test_exception m; - Lwt.return true; - end; - - test "partition_p exception" begin fun () -> - let m f = - Lwt_list.partition_p (fun x -> f x >>= (fun _ -> Lwt.return_false)) in - test_exception m; - Lwt.return true; - end; - - test "partition_s exception" begin fun () -> - let m f = - Lwt_list.partition_s (fun x -> f x >>= (fun _ -> Lwt.return_false)) in - test_exception m; - Lwt.return true; - end; - - test "iter_p parallelism" begin fun () -> - test_parallelism Lwt_list.iter_p - end; - - test "iter_s serialization" begin fun () -> - test_serialization Lwt_list.iter_s - end; - - test "iteri_p parallelism" begin fun () -> - let iter f = Lwt_list.iteri_p (fun _ x -> f x) in - test_parallelism iter - end; - - test "iteri_s serialization" begin fun () -> - let iter f = Lwt_list.iteri_s (fun _ x -> f x) in - test_serialization iter - end; - - test "map_p parallelism" begin fun () -> - test_parallelism Lwt_list.map_p - end; - - test "map_s serialization" begin fun () -> - test_serialization Lwt_list.map_s - end; - - test "mapi_p parallelism" begin fun () -> - let m f = Lwt_list.mapi_p (fun _ x -> f x) in - test_parallelism m - end; - - test "mapi_s serialization" begin fun () -> - let m f = Lwt_list.mapi_s (fun _ x -> f x) in - test_serialization m - end; - - test "rev_map_p parallelism" begin fun () -> - test_parallelism Lwt_list.rev_map_p - end; - - test "rev_map_s serialization" begin fun () -> - test_serialization Lwt_list.rev_map_s - end; - - test "fold_left_s serialization" begin fun () -> - let m f = - Lwt_list.fold_left_s (fun _ x -> f x >>= fun _ -> Lwt.return ()) () in - test_serialization m - end; - - test "fold_right_s serialization" begin fun () -> - let m f l = - Lwt_list.fold_right_s (fun x _ -> f x >>= fun _ -> Lwt.return ()) l () in - test_serialization ~rev:true m - end; - - test "filter_map_p parallelism" begin fun () -> - let m f = - Lwt_list.filter_map_p (fun x -> f x >>= fun u -> Lwt.return (Some u)) in - test_parallelism m - end; - - test "filter_map_s serlialism" begin fun () -> - let m f = - Lwt_list.filter_map_s (fun x -> f x >>= fun u -> Lwt.return (Some u)) in - test_serialization m - end; - - test "for_all_p parallelism" begin fun () -> - let m f = Lwt_list.for_all_p (fun x -> f x >>= fun _ -> Lwt.return_true) in - test_parallelism m - end; - - test "for_all_s serialization" begin fun () -> - let m f = Lwt_list.for_all_s (fun x -> f x >>= fun _ -> Lwt.return_true) in - test_serialization m - end; - - test "exists_p parallelism" begin fun () -> - let m f = Lwt_list.exists_p (fun x -> f x >>= fun _ -> Lwt.return_false) in - test_parallelism m - end; - - test "exists_s serialization" begin fun () -> - let m f = Lwt_list.exists_s (fun x -> f x >>= fun _ -> Lwt.return_false) in - test_serialization m - end; - - test "find_s serialization" begin fun () -> - let m f = Lwt_list.find_s (fun x -> f x >>= fun _ -> Lwt.return_false) in - let handler e = - if e = Not_found then Lwt.return_true - else Lwt.return_false - in - Lwt.catch (fun () -> test_serialization m) handler - end; - - test "filter_p parallelism" begin fun () -> - let m f = Lwt_list.filter_p (fun x -> f x >>= fun _ -> Lwt.return_true) in - test_parallelism m - end; - - test "filter_s serialization" begin fun () -> - let m f = Lwt_list.filter_s (fun x -> f x >>= fun _ -> Lwt.return_true) in - test_serialization m - end; - - - test "filter_map_s serialization" begin fun () -> - let m f = - Lwt_list.filter_map_s (fun x -> f x >>= fun u -> Lwt.return (Some u)) in - test_serialization m - end; - - test "partition_p parallelism" begin fun () -> - let m f l = - Lwt_list.partition_p (fun x -> f x >>= fun _ -> Lwt.return true) l in - test_parallelism m - end; - - test "partition_s serialization" begin fun () -> - let m f l = - Lwt_list.partition_s (fun x -> f x >>= fun _ -> Lwt.return true) l in - test_serialization m - end; -] + Lwt.return (after = [ 6; 4; 2 ]) + +let suite_primary = + suite "lwt_list" + [ + test "iter_p" (fun () -> + test_iter Lwt_list.iter_p [ 1; 0; 1 ]; + test_exception Lwt_list.iter_p; + Lwt.return true); + test "iter_s" (fun () -> + test_iter Lwt_list.iter_s [ 1; 0; 0 ]; + test_exception Lwt_list.iter_s; + Lwt.return true); + test "map_p" (fun () -> + test_map Lwt_list.map_p [ 4; 8; 5 ]; + test_exception Lwt_list.map_p; + Lwt.return true); + test "map_s" (fun () -> + test_map Lwt_list.map_s [ 4; 7; 8 ]; + test_exception Lwt_list.map_s; + Lwt.return true); + test "fold_left_s" (fun () -> + let l = [ 1; 2; 3 ] in + let f acc v = Lwt.return (v :: acc) in + let t = Lwt_list.fold_left_s f [] l in + t <=> Lwt.Return (List.rev l); + Lwt.return true); + test "for_all_s" (fun () -> test_for_all_true Lwt_list.for_all_s); + test "for_all_p" (fun () -> test_for_all_true Lwt_list.for_all_p); + test "exists_s true" (fun () -> test_exists_true Lwt_list.exists_s); + test "exists_p true" (fun () -> test_exists_true Lwt_list.exists_p); + test "exists_s false" (fun () -> test_exists_false Lwt_list.exists_s); + test "exists_p false" (fun () -> test_exists_false Lwt_list.exists_p); + test "filter_s" (fun () -> test_filter Lwt_list.filter_s); + test "filter_p" (fun () -> test_filter Lwt_list.filter_p); + test "partition_p" (fun () -> test_partition Lwt_list.partition_p); + test "partition_s" (fun () -> test_partition Lwt_list.partition_s); + test "filter_map_p" (fun () -> test_filter_map Lwt_list.filter_map_p); + test "filter_map_s" (fun () -> test_filter_map Lwt_list.filter_map_s); + test "iteri_p" (fun () -> test_iter_i Lwt_list.iteri_p); + test "iteri_s" (fun () -> test_iter_i Lwt_list.iteri_s); + test "mapi_p" (fun () -> test_map_i Lwt_list.mapi_p); + test "mapi_s" (fun () -> test_map_i Lwt_list.mapi_s); + test "find_s existing" (fun () -> + let l = [ 1; 2; 3 ] in + Lwt_list.find_s (fun n -> Lwt.return (n mod 2 = 0)) l + >>= fun result -> Lwt.return (result = 2)); + test "find_s missing" (fun () -> + let l = [ 1; 3 ] in + Lwt.catch + (fun () -> + Lwt_list.find_s (fun n -> Lwt.return (n mod 2 = 0)) l + >>= fun _result -> Lwt.return false) + (function Not_found -> Lwt.return true | _ -> Lwt.return false)); + test "rev_map_p" (fun () -> test_rev_map Lwt_list.rev_map_p); + test "rev_map_s" (fun () -> test_rev_map Lwt_list.rev_map_s); + test "fold_right_s" (fun () -> + let l = [ 1; 2; 3 ] in + Lwt_list.fold_right_s (fun a n -> Lwt.return (a + n)) l 0 + >>= fun result -> Lwt.return (result = 6)); + test "iteri_p exception" (fun () -> + let i f = Lwt_list.iteri_p (fun _ x -> f x) in + test_exception i; + Lwt.return true); + test "iteri_s exception" (fun () -> + let i f = Lwt_list.iteri_s (fun _ x -> f x) in + test_exception i; + Lwt.return true); + test "map_s exception" (fun () -> + test_exception Lwt_list.map_s; + Lwt.return true); + test "map_p exception" (fun () -> + test_exception Lwt_list.map_p; + Lwt.return true); + test "mapi_s exception" (fun () -> + let m f = Lwt_list.mapi_s (fun _ x -> f x) in + test_exception m; + Lwt.return true); + test "mapi_p exception" (fun () -> + let m f = Lwt_list.mapi_p (fun _ x -> f x) in + test_exception m; + Lwt.return true); + test "rev_map_s exception" (fun () -> + test_exception Lwt_list.rev_map_s; + Lwt.return true); + test "rev_map_p exception" (fun () -> + test_exception Lwt_list.rev_map_p; + Lwt.return true); + test "fold_left_s exception" (fun () -> + let m f = Lwt_list.fold_left_s (fun _ x -> f x) () in + test_exception m; + Lwt.return true); + test "fold_right_s exception" (fun () -> + let m f l = Lwt_list.fold_right_s (fun x _ -> f x) l () in + test_exception m; + Lwt.return true); + test "for_all_p exception" (fun () -> + let m f = + Lwt_list.for_all_p (fun x -> f x >>= fun _ -> Lwt.return_true) + in + test_exception m; + Lwt.return true); + test "for_all_s exception" (fun () -> + let m f = + Lwt_list.for_all_s (fun x -> f x >>= fun _ -> Lwt.return_true) + in + test_exception m; + Lwt.return true); + test "exists_p exception" (fun () -> + let m f = + Lwt_list.exists_p (fun x -> f x >>= fun _ -> Lwt.return_false) + in + test_exception m; + Lwt.return true); + test "exists_s exception" (fun () -> + let m f = + Lwt_list.exists_s (fun x -> f x >>= fun _ -> Lwt.return_false) + in + test_exception m; + Lwt.return true); + test "find_s exception" (fun () -> + let m f = + Lwt_list.find_s (fun x -> f x >>= fun _ -> Lwt.return_false) + in + test_exception m; + Lwt.return true); + test "filter_p exception" (fun () -> + let m f = + Lwt_list.filter_p (fun x -> f x >>= fun _ -> Lwt.return_false) + in + test_exception m; + Lwt.return true); + test "filter_s exception" (fun () -> + let m f = + Lwt_list.filter_s (fun x -> f x >>= fun _ -> Lwt.return_false) + in + test_exception m; + Lwt.return true); + test "filter_map_p exception" (fun () -> + let m f = + Lwt_list.filter_map_p (fun x -> + f x >>= fun _ -> Lwt.return (Some ())) + in + test_exception m; + Lwt.return true); + test "filter_map_s exception" (fun () -> + let m f = + Lwt_list.filter_map_s (fun x -> + f x >>= fun _ -> Lwt.return (Some ())) + in + test_exception m; + Lwt.return true); + test "partition_p exception" (fun () -> + let m f = + Lwt_list.partition_p (fun x -> f x >>= fun _ -> Lwt.return_false) + in + test_exception m; + Lwt.return true); + test "partition_s exception" (fun () -> + let m f = + Lwt_list.partition_s (fun x -> f x >>= fun _ -> Lwt.return_false) + in + test_exception m; + Lwt.return true); + test "iter_p parallelism" (fun () -> test_parallelism Lwt_list.iter_p); + test "iter_s serialization" (fun () -> test_serialization Lwt_list.iter_s); + test "iteri_p parallelism" (fun () -> + let iter f = Lwt_list.iteri_p (fun _ x -> f x) in + test_parallelism iter); + test "iteri_s serialization" (fun () -> + let iter f = Lwt_list.iteri_s (fun _ x -> f x) in + test_serialization iter); + test "map_p parallelism" (fun () -> test_parallelism Lwt_list.map_p); + test "map_s serialization" (fun () -> test_serialization Lwt_list.map_s); + test "mapi_p parallelism" (fun () -> + let m f = Lwt_list.mapi_p (fun _ x -> f x) in + test_parallelism m); + test "mapi_s serialization" (fun () -> + let m f = Lwt_list.mapi_s (fun _ x -> f x) in + test_serialization m); + test "rev_map_p parallelism" (fun () -> + test_parallelism Lwt_list.rev_map_p); + test "rev_map_s serialization" (fun () -> + test_serialization Lwt_list.rev_map_s); + test "fold_left_s serialization" (fun () -> + let m f = + Lwt_list.fold_left_s (fun _ x -> f x >>= fun _ -> Lwt.return ()) () + in + test_serialization m); + test "fold_right_s serialization" (fun () -> + let m f l = + Lwt_list.fold_right_s + (fun x _ -> f x >>= fun _ -> Lwt.return ()) + l () + in + test_serialization ~rev:true m); + test "filter_map_p parallelism" (fun () -> + let m f = + Lwt_list.filter_map_p (fun x -> + f x >>= fun u -> Lwt.return (Some u)) + in + test_parallelism m); + test "filter_map_s serlialism" (fun () -> + let m f = + Lwt_list.filter_map_s (fun x -> + f x >>= fun u -> Lwt.return (Some u)) + in + test_serialization m); + test "for_all_p parallelism" (fun () -> + let m f = + Lwt_list.for_all_p (fun x -> f x >>= fun _ -> Lwt.return_true) + in + test_parallelism m); + test "for_all_s serialization" (fun () -> + let m f = + Lwt_list.for_all_s (fun x -> f x >>= fun _ -> Lwt.return_true) + in + test_serialization m); + test "exists_p parallelism" (fun () -> + let m f = + Lwt_list.exists_p (fun x -> f x >>= fun _ -> Lwt.return_false) + in + test_parallelism m); + test "exists_s serialization" (fun () -> + let m f = + Lwt_list.exists_s (fun x -> f x >>= fun _ -> Lwt.return_false) + in + test_serialization m); + test "find_s serialization" (fun () -> + let m f = + Lwt_list.find_s (fun x -> f x >>= fun _ -> Lwt.return_false) + in + let handler e = + if e = Not_found then Lwt.return_true else Lwt.return_false + in + Lwt.catch (fun () -> test_serialization m) handler); + test "filter_p parallelism" (fun () -> + let m f = + Lwt_list.filter_p (fun x -> f x >>= fun _ -> Lwt.return_true) + in + test_parallelism m); + test "filter_s serialization" (fun () -> + let m f = + Lwt_list.filter_s (fun x -> f x >>= fun _ -> Lwt.return_true) + in + test_serialization m); + test "filter_map_s serialization" (fun () -> + let m f = + Lwt_list.filter_map_s (fun x -> + f x >>= fun u -> Lwt.return (Some u)) + in + test_serialization m); + test "partition_p parallelism" (fun () -> + let m f l = + Lwt_list.partition_p (fun x -> f x >>= fun _ -> Lwt.return true) l + in + test_parallelism m); + test "partition_s serialization" (fun () -> + let m f l = + Lwt_list.partition_s (fun x -> f x >>= fun _ -> Lwt.return true) l + in + test_serialization m); + ] let test_big_list m = let make_list n = Array.to_list @@ Array.init n (fun x -> x) in let f _ = Lwt.return () in - m f (make_list 10_000_000) >>= (fun _ -> Lwt.return_true) + m f (make_list 10_000_000) >>= fun _ -> Lwt.return_true -let suite_intensive = suite "lwt_list big lists" +let suite_intensive = + suite "lwt_list big lists" ~only_if:(fun () -> - try Sys.getenv "LWT_STRESS_TEST" = "true" with - | Not_found -> false) [ - test "iter_p big list" begin fun () -> - test_big_list Lwt_list.iter_p - end; - - test "iter_s big list" begin fun () -> - test_big_list Lwt_list.iter_s - end; - - test "iteri_p big list" begin fun () -> - let iter f = Lwt_list.iteri_p (fun _ x -> f x) in - test_big_list iter - end; - - test "iteri_s big list" begin fun () -> - let iter f = Lwt_list.iteri_s (fun _ x -> f x) in - test_serialization iter - end; - - test "map_p big list" begin fun () -> - test_big_list Lwt_list.map_p - end; - - test "map_s big list" begin fun () -> - test_serialization Lwt_list.map_s - end; - - test "mapi_p big list" begin fun () -> - let m f = Lwt_list.mapi_p (fun _ x -> f x) in - test_big_list m - end; - - test "mapi_s big list" begin fun () -> - let m f = Lwt_list.mapi_s (fun _ x -> f x) in - test_big_list m - end; - - test "rev_map_p big list" begin fun () -> - test_big_list Lwt_list.rev_map_p - end; - - test "rev_map_s big list" begin fun () -> - test_big_list Lwt_list.rev_map_s - end; - - test "fold_left_s big list" begin fun () -> - let m f = - Lwt_list.fold_left_s (fun _ x -> f x >>= fun _ -> Lwt.return ()) () in - test_big_list m - end; - - test "fold_right_s big list" begin fun () -> - let m f l = - Lwt_list.fold_right_s (fun x _ -> f x >>= fun _ -> Lwt.return ()) l () in - test_big_list m - end; - - test "for_all_p big list" begin fun () -> - let m f = Lwt_list.for_all_p (fun x -> f x >>= fun _ -> Lwt.return_true) in - test_big_list m - end; - - test "for_all_s big list" begin fun () -> - let m f = Lwt_list.for_all_s (fun x -> f x >>= fun _ -> Lwt.return_true) in - test_big_list m - end; - - test "exists_p big list" begin fun () -> - let m f = Lwt_list.exists_p (fun x -> f x >>= fun _ -> Lwt.return_false) in - test_big_list m - end; - - test "exists_s big list" begin fun () -> - let m f = Lwt_list.exists_s (fun x -> f x >>= fun _ -> Lwt.return_false) in - test_big_list m - end; - - test "find_s big list" begin fun () -> - let m f = Lwt_list.find_s (fun x -> f x >>= fun _ -> Lwt.return_false) in - let handler e = - if e = Not_found then Lwt.return_true - else Lwt.return_false - in - Lwt.catch (fun () -> test_big_list m) handler - end; - - test "filter_p big list" begin fun () -> - let m f = Lwt_list.filter_p (fun x -> f x >>= fun _ -> Lwt.return_true) in - test_big_list m - end; - - test "filter_s big list" begin fun () -> - let m f = Lwt_list.filter_s (fun x -> f x >>= fun _ -> Lwt.return_true) in - test_big_list m - end; - - test "filter_map_p big list" begin fun () -> - let m f = - Lwt_list.filter_map_p (fun x -> f x >>= fun u -> Lwt.return (Some u)) in - test_big_list m - end; - - test "filter_map_s big list" begin fun () -> - let m f = - Lwt_list.filter_map_s (fun x -> f x >>= fun u -> Lwt.return (Some u)) in - test_big_list m - end; - - test "partition_p big list" begin fun () -> - let m f l = - Lwt_list.partition_p (fun x -> f x >>= fun _ -> Lwt.return true) l in - test_big_list m - end; - - test "partition_s big list" begin fun () -> - let m f l = - Lwt_list.partition_s (fun x -> f x >>= fun _ -> Lwt.return true) l in - test_big_list m - end; -] + try Sys.getenv "LWT_STRESS_TEST" = "true" with Not_found -> false) + [ + test "iter_p big list" (fun () -> test_big_list Lwt_list.iter_p); + test "iter_s big list" (fun () -> test_big_list Lwt_list.iter_s); + test "iteri_p big list" (fun () -> + let iter f = Lwt_list.iteri_p (fun _ x -> f x) in + test_big_list iter); + test "iteri_s big list" (fun () -> + let iter f = Lwt_list.iteri_s (fun _ x -> f x) in + test_serialization iter); + test "map_p big list" (fun () -> test_big_list Lwt_list.map_p); + test "map_s big list" (fun () -> test_serialization Lwt_list.map_s); + test "mapi_p big list" (fun () -> + let m f = Lwt_list.mapi_p (fun _ x -> f x) in + test_big_list m); + test "mapi_s big list" (fun () -> + let m f = Lwt_list.mapi_s (fun _ x -> f x) in + test_big_list m); + test "rev_map_p big list" (fun () -> test_big_list Lwt_list.rev_map_p); + test "rev_map_s big list" (fun () -> test_big_list Lwt_list.rev_map_s); + test "fold_left_s big list" (fun () -> + let m f = + Lwt_list.fold_left_s (fun _ x -> f x >>= fun _ -> Lwt.return ()) () + in + test_big_list m); + test "fold_right_s big list" (fun () -> + let m f l = + Lwt_list.fold_right_s + (fun x _ -> f x >>= fun _ -> Lwt.return ()) + l () + in + test_big_list m); + test "for_all_p big list" (fun () -> + let m f = + Lwt_list.for_all_p (fun x -> f x >>= fun _ -> Lwt.return_true) + in + test_big_list m); + test "for_all_s big list" (fun () -> + let m f = + Lwt_list.for_all_s (fun x -> f x >>= fun _ -> Lwt.return_true) + in + test_big_list m); + test "exists_p big list" (fun () -> + let m f = + Lwt_list.exists_p (fun x -> f x >>= fun _ -> Lwt.return_false) + in + test_big_list m); + test "exists_s big list" (fun () -> + let m f = + Lwt_list.exists_s (fun x -> f x >>= fun _ -> Lwt.return_false) + in + test_big_list m); + test "find_s big list" (fun () -> + let m f = + Lwt_list.find_s (fun x -> f x >>= fun _ -> Lwt.return_false) + in + let handler e = + if e = Not_found then Lwt.return_true else Lwt.return_false + in + Lwt.catch (fun () -> test_big_list m) handler); + test "filter_p big list" (fun () -> + let m f = + Lwt_list.filter_p (fun x -> f x >>= fun _ -> Lwt.return_true) + in + test_big_list m); + test "filter_s big list" (fun () -> + let m f = + Lwt_list.filter_s (fun x -> f x >>= fun _ -> Lwt.return_true) + in + test_big_list m); + test "filter_map_p big list" (fun () -> + let m f = + Lwt_list.filter_map_p (fun x -> + f x >>= fun u -> Lwt.return (Some u)) + in + test_big_list m); + test "filter_map_s big list" (fun () -> + let m f = + Lwt_list.filter_map_s (fun x -> + f x >>= fun u -> Lwt.return (Some u)) + in + test_big_list m); + test "partition_p big list" (fun () -> + let m f l = + Lwt_list.partition_p (fun x -> f x >>= fun _ -> Lwt.return true) l + in + test_big_list m); + test "partition_s big list" (fun () -> + let m f l = + Lwt_list.partition_s (fun x -> f x >>= fun _ -> Lwt.return true) l + in + test_big_list m); + ] diff --git a/test/core/test_lwt_mutex.ml b/test/core/test_lwt_mutex.ml index ca80386ec5..d460e0b380 100644 --- a/test/core/test_lwt_mutex.ml +++ b/test/core/test_lwt_mutex.ml @@ -1,106 +1,94 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Lwt.Infix open Test -let suite = suite "lwt_mutex" [ - (* See https://github.com/ocsigen/lwt/pull/202#issue-123451878. *) - test "cancel" - (fun () -> - let mutex = Lwt_mutex.create () in - - (* Thread 1: take the mutex and wait. *) - let thread_1_wait, resume_thread_1 = Lwt.wait () in - let thread_1 = Lwt_mutex.with_lock mutex (fun () -> thread_1_wait) in - - (* Thread 2: block on the mutex. *) - let thread_2_locked_mutex = ref false in - let thread_2 = - Lwt_mutex.lock mutex >|= fun () -> - thread_2_locked_mutex := true - in - - (* Cancel thread 2, and make sure it is canceled. *) - Lwt.cancel thread_2; - Lwt.catch - (fun () -> thread_2 >>= fun () -> Lwt.return_false) - (function - | Lwt.Canceled -> Lwt.return_true - | _ -> Lwt.return_false) - >>= fun thread_2_canceled -> - - (* Thread 1: release the mutex. *) - Lwt.wakeup resume_thread_1 (); - thread_1 >>= fun () -> - - (* Thread 3: try to take the mutex. Thread 2 should not have it locked, - since thread 2 was canceled. *) - Lwt_mutex.lock mutex >|= fun () -> - - not !thread_2_locked_mutex && thread_2_canceled); - - (* See https://github.com/ocsigen/lwt/pull/202#issuecomment-227092595. *) - test "cancel while queued by unlock" - (fun () -> - let mutex = Lwt_mutex.create () in - - (* Thread 1: take the mutex and wait. *) - let thread_1_wait, resume_thread_1 = Lwt.wait () in - let thread_1 = Lwt_mutex.with_lock mutex (fun () -> thread_1_wait) in - - (* Thread 2: block on the mutex, then set a flag and release it. *) - let thread_2_waiter_executed = ref false in - let thread_2 = - Lwt_mutex.lock mutex >|= fun () -> - thread_2_waiter_executed := true; - Lwt_mutex.unlock mutex - in - - (* Thread 3: wrap the wakeup of thread 2 in a wakeup of thread 3. *) - let top_level_waiter, wake_top_level_waiter = Lwt.wait () in - let while_waking = - top_level_waiter >>= fun () -> - (* Inside thread 3 wakeup. *) - - (* Thread 1: release the mutex. This queues thread 2 using - wakeup_later inside Lwt_mutex.unlock. *) - Lwt.wakeup resume_thread_1 (); - thread_1 >>= fun () -> - - (* Confirm the mutex is now considered locked by thread 2. *) - let mutex_passed = Lwt_mutex.is_locked mutex in - (* Confirm thread 2 hasn't executed its bind (well, map). It is - queued. *) - let thread_2_was_queued = not !thread_2_waiter_executed in - - (* Try to cancel thread 2. *) - Lwt.cancel thread_2; - - (* Complete thread 2 and check it has not been canceled. *) - Lwt.catch - (fun () -> thread_2 >>= fun () -> Lwt.return_false) - (function - | Lwt.Canceled -> Lwt.return_true - | _ -> Lwt.return_false) - >|= fun thread_2_canceled -> - - (* Confirm that thread 2 ran, and released the mutex. *) - mutex_passed && - thread_2_was_queued && - not thread_2_canceled && - !thread_2_waiter_executed && - not (Lwt_mutex.is_locked mutex) - in - - (* Run thread 3. - * Keep this as wakeup_later to test the issue on 2.3.2 reported in - * https://github.com/ocsigen/lwt/pull/202 - * See also: - * https://github.com/ocsigen/lwt/pull/261 - *) - Lwt.wakeup_later wake_top_level_waiter (); - while_waking); -] +let suite = + suite "lwt_mutex" + [ + (* See https://github.com/ocsigen/lwt/pull/202#issue-123451878. *) + test "cancel" (fun () -> + let mutex = Lwt_mutex.create () in + + (* Thread 1: take the mutex and wait. *) + let thread_1_wait, resume_thread_1 = Lwt.wait () in + let thread_1 = Lwt_mutex.with_lock mutex (fun () -> thread_1_wait) in + + (* Thread 2: block on the mutex. *) + let thread_2_locked_mutex = ref false in + let thread_2 = + Lwt_mutex.lock mutex >|= fun () -> thread_2_locked_mutex := true + in + + (* Cancel thread 2, and make sure it is canceled. *) + Lwt.cancel thread_2; + Lwt.catch + (fun () -> thread_2 >>= fun () -> Lwt.return_false) + (function Lwt.Canceled -> Lwt.return_true | _ -> Lwt.return_false) + >>= fun thread_2_canceled -> + (* Thread 1: release the mutex. *) + Lwt.wakeup resume_thread_1 (); + thread_1 >>= fun () -> + (* Thread 3: try to take the mutex. Thread 2 should not have it locked, + since thread 2 was canceled. *) + Lwt_mutex.lock mutex >|= fun () -> + (not !thread_2_locked_mutex) && thread_2_canceled); + (* See https://github.com/ocsigen/lwt/pull/202#issuecomment-227092595. *) + test "cancel while queued by unlock" (fun () -> + let mutex = Lwt_mutex.create () in + + (* Thread 1: take the mutex and wait. *) + let thread_1_wait, resume_thread_1 = Lwt.wait () in + let thread_1 = Lwt_mutex.with_lock mutex (fun () -> thread_1_wait) in + + (* Thread 2: block on the mutex, then set a flag and release it. *) + let thread_2_waiter_executed = ref false in + let thread_2 = + Lwt_mutex.lock mutex >|= fun () -> + thread_2_waiter_executed := true; + Lwt_mutex.unlock mutex + in + + (* Thread 3: wrap the wakeup of thread 2 in a wakeup of thread 3. *) + let top_level_waiter, wake_top_level_waiter = Lwt.wait () in + let while_waking = + top_level_waiter >>= fun () -> + (* Inside thread 3 wakeup. *) + + (* Thread 1: release the mutex. This queues thread 2 using + wakeup_later inside Lwt_mutex.unlock. *) + Lwt.wakeup resume_thread_1 (); + thread_1 >>= fun () -> + (* Confirm the mutex is now considered locked by thread 2. *) + let mutex_passed = Lwt_mutex.is_locked mutex in + (* Confirm thread 2 hasn't executed its bind (well, map). It is + queued. *) + let thread_2_was_queued = not !thread_2_waiter_executed in + + (* Try to cancel thread 2. *) + Lwt.cancel thread_2; + + (* Complete thread 2 and check it has not been canceled. *) + Lwt.catch + (fun () -> thread_2 >>= fun () -> Lwt.return_false) + (function + | Lwt.Canceled -> Lwt.return_true | _ -> Lwt.return_false) + >|= fun thread_2_canceled -> + (* Confirm that thread 2 ran, and released the mutex. *) + mutex_passed + && thread_2_was_queued + && (not thread_2_canceled) + && !thread_2_waiter_executed + && not (Lwt_mutex.is_locked mutex) + in + + (* Run thread 3. + * Keep this as wakeup_later to test the issue on 2.3.2 reported in + * https://github.com/ocsigen/lwt/pull/202 + * See also: + * https://github.com/ocsigen/lwt/pull/261 + *) + Lwt.wakeup_later wake_top_level_waiter (); + while_waking); + ] diff --git a/test/core/test_lwt_mvar.ml b/test/core/test_lwt_mvar.ml index 59db1938da..dbe2cfb7b7 100644 --- a/test/core/test_lwt_mvar.ml +++ b/test/core/test_lwt_mvar.ml @@ -1,90 +1,65 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Lwt.Infix open Test - - -let state_is = - Lwt.debug_state_is - - - -let suite = suite "lwt_mvar" [ - test "basic take" begin fun () -> - let x = Lwt_mvar.create 0 in - let y = Lwt_mvar.take x in - state_is (Lwt.Return 0) y - end; - - test "take_available (full)" begin fun () -> - let x = Lwt_mvar.create 0 in - let y = Lwt_mvar.take_available x in - Lwt.return (y = Some 0) - end; - - test "take_available (empty)" begin fun () -> - let x = Lwt_mvar.create_empty () in - let y = Lwt_mvar.take_available x in - Lwt.return (y = None) - end; - - test "take_available (twice)" begin fun () -> - let x = Lwt_mvar.create 0 in - let (_ : int option) = Lwt_mvar.take_available x in - let y = Lwt_mvar.take_available x in - Lwt.return (y = None) - end; - - test "is_empty (full)" begin fun () -> - let x = Lwt_mvar.create 0 in - let y = Lwt_mvar.is_empty x in - Lwt.return (not y) - end; - - test "is_empty (empty)" begin fun () -> - let x = Lwt_mvar.create_empty () in - let y = Lwt_mvar.is_empty x in - Lwt.return y - end; - - test "blocking put" begin fun () -> - let x = Lwt_mvar.create 0 in - let y = Lwt_mvar.put x 1 in - Lwt.return (Lwt.state y = Lwt.Sleep) - end; - - test "put-take" begin fun () -> - let x = Lwt_mvar.create_empty () in - let _ = Lwt_mvar.put x 0 in - let y = Lwt_mvar.take x in - state_is (Lwt.Return 0) y - end; - - test "take-put" begin fun () -> - let x = Lwt_mvar.create 0 in - let _ = Lwt_mvar.take x in - let y = Lwt_mvar.put x 1 in - state_is (Lwt.Return ()) y - end; - - test "enqueued writer" begin fun () -> - let x = Lwt_mvar.create 1 in - let y = Lwt_mvar.put x 2 in - let z = Lwt_mvar.take x in - state_is (Lwt.Return ()) y >>= fun y_correct -> - state_is (Lwt.Return 1) z >>= fun z_correct -> - Lwt.return (y_correct && z_correct) - end; - - test "writer cancellation" begin fun () -> - let y = Lwt_mvar.create 1 in - let r1 = Lwt_mvar.put y 2 in - Lwt.cancel r1; - Lwt.return ((Lwt.state (Lwt_mvar.take y) = Lwt.Return 1) - && (Lwt.state (Lwt_mvar.take y) = Lwt.Sleep)) - end; - ] +let state_is = Lwt.debug_state_is + +let suite = + suite "lwt_mvar" + [ + test "basic take" (fun () -> + let x = Lwt_mvar.create 0 in + let y = Lwt_mvar.take x in + state_is (Lwt.Return 0) y); + test "take_available (full)" (fun () -> + let x = Lwt_mvar.create 0 in + let y = Lwt_mvar.take_available x in + Lwt.return (y = Some 0)); + test "take_available (empty)" (fun () -> + let x = Lwt_mvar.create_empty () in + let y = Lwt_mvar.take_available x in + Lwt.return (y = None)); + test "take_available (twice)" (fun () -> + let x = Lwt_mvar.create 0 in + let (_ : int option) = Lwt_mvar.take_available x in + let y = Lwt_mvar.take_available x in + Lwt.return (y = None)); + test "is_empty (full)" (fun () -> + let x = Lwt_mvar.create 0 in + let y = Lwt_mvar.is_empty x in + Lwt.return (not y)); + test "is_empty (empty)" (fun () -> + let x = Lwt_mvar.create_empty () in + let y = Lwt_mvar.is_empty x in + Lwt.return y); + test "blocking put" (fun () -> + let x = Lwt_mvar.create 0 in + let y = Lwt_mvar.put x 1 in + Lwt.return (Lwt.state y = Lwt.Sleep)); + test "put-take" (fun () -> + let x = Lwt_mvar.create_empty () in + let _ = Lwt_mvar.put x 0 in + let y = Lwt_mvar.take x in + state_is (Lwt.Return 0) y); + test "take-put" (fun () -> + let x = Lwt_mvar.create 0 in + let _ = Lwt_mvar.take x in + let y = Lwt_mvar.put x 1 in + state_is (Lwt.Return ()) y); + test "enqueued writer" (fun () -> + let x = Lwt_mvar.create 1 in + let y = Lwt_mvar.put x 2 in + let z = Lwt_mvar.take x in + state_is (Lwt.Return ()) y >>= fun y_correct -> + state_is (Lwt.Return 1) z >>= fun z_correct -> + Lwt.return (y_correct && z_correct)); + test "writer cancellation" (fun () -> + let y = Lwt_mvar.create 1 in + let r1 = Lwt_mvar.put y 2 in + Lwt.cancel r1; + Lwt.return + (Lwt.state (Lwt_mvar.take y) = Lwt.Return 1 + && Lwt.state (Lwt_mvar.take y) = Lwt.Sleep)); + ] diff --git a/test/core/test_lwt_pool.ml b/test/core/test_lwt_pool.ml index 01bf215969..bc0b2229db 100644 --- a/test/core/test_lwt_pool.ml +++ b/test/core/test_lwt_pool.ml @@ -1,179 +1,230 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Test exception Dummy_error -let suite = suite "lwt_pool" [ - - test "basic create-use" begin fun () -> - let gen = fun () -> Lwt.return () in - let p = Lwt_pool.create 1 gen in - Lwt.return (Lwt.state (Lwt_pool.use p Lwt.return) = Lwt.Return ()) - end; - - test "creator exception" begin fun () -> - let gen = fun () -> Lwt.fail Dummy_error in - let p = Lwt_pool.create 1 gen in - let u = Lwt_pool.use p (fun _ -> Lwt.return 0) in - Lwt.return (Lwt.state u = Lwt.Fail Dummy_error) - end; - - test "pool elements are reused" begin fun () -> - let gen = (fun () -> let n = ref 0 in Lwt.return n) in - let p = Lwt_pool.create 1 gen in - let _ = Lwt_pool.use p (fun n -> n := 1; Lwt.return !n) in - let u2 = Lwt_pool.use p (fun n -> Lwt.return !n) in - Lwt.return (Lwt.state u2 = Lwt.Return 1) - end; - - test "pool elements are validated when returned" begin fun () -> - let gen = (fun () -> let n = ref 0 in Lwt.return n) in - let v l = Lwt.return (!l = 0) in - let p = Lwt_pool.create 1 ~validate:v gen in - let _ = Lwt_pool.use p (fun n -> n := 1; Lwt.return !n) in - let u2 = Lwt_pool.use p (fun n -> Lwt.return !n) in - Lwt.return (Lwt.state u2 = Lwt.Return 0) - end; - - test "validation exceptions are propagated to users" begin fun () -> - let c = Lwt_condition.create () in - let gen = (fun () -> let l = ref 0 in Lwt.return l) in - let v l = if !l = 0 then Lwt.return true else Lwt.fail Dummy_error in - let p = Lwt_pool.create 1 ~validate:v gen in - let u1 = Lwt_pool.use p (fun l -> l := 1; Lwt_condition.wait c) in - let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in - let () = Lwt_condition.signal c "done" in - Lwt.bind u1 (fun v1 -> - Lwt.try_bind - (fun () -> u2) - (fun _ -> Lwt.return_false) - (fun exn2 -> - Lwt.return (v1 = "done" && exn2 = Dummy_error))) - end; - - test "multiple creation" begin fun () -> - let gen = (fun () -> let n = ref 0 in Lwt.return n) in - let p = Lwt_pool.create 2 gen in - let _ = Lwt_pool.use p (fun n -> n := 1; Lwt.pause ()) in - let u2 = Lwt_pool.use p (fun n -> Lwt.return !n) in - Lwt.return (Lwt.state u2 = Lwt.Return 0) - end; - - test "users of an empty pool will wait" begin fun () -> - let gen = (fun () -> Lwt.return 0) in - let p = Lwt_pool.create 1 gen in - let _ = Lwt_pool.use p (fun _ -> Lwt.pause ()) in - let u2 = Lwt_pool.use p Lwt.return in - Lwt.return (Lwt.state u2 = Lwt.Sleep) - end; - - test "on check, good elements are retained" begin fun () -> - let gen = (fun () -> let n = ref 1 in Lwt.return n) in - let c = (fun x f -> f (!x > 0)) in - let p = Lwt_pool.create 1 ~check: c gen in - let _ = Lwt_pool.use p (fun n -> n := 2; Lwt.fail Dummy_error) in - let u2 = Lwt_pool.use p (fun n -> Lwt.return !n) in - Lwt.return (Lwt.state u2 = Lwt.Return 2) - end; - - test "on check, bad elements are disposed of and replaced" begin fun () -> - let gen = (fun () -> let n = ref 1 in Lwt.return n) in - let check = (fun n f -> f (!n > 0)) in - let disposed = ref false in - let dispose _ = disposed := true; Lwt.return_unit in - let p = Lwt_pool.create 1 ~check ~dispose gen in - let task = (fun n -> incr n; Lwt.return !n) in - let _ = Lwt_pool.use p (fun n -> n := 0; Lwt.fail Dummy_error) in - let u2 = Lwt_pool.use p task in - Lwt.return (Lwt.state u2 = Lwt.Return 2 && !disposed) - end; - - test "clear disposes of all elements" begin fun () -> - let gen = (fun () -> let n = ref 1 in Lwt.return n) in - let count = ref 0 in - let dispose _ = incr count; Lwt.return_unit in - let p = Lwt_pool.create 2 ~dispose gen in - let u = Lwt_pool.use p (fun _ -> Lwt.pause ()) in - let _ = Lwt_pool.use p (fun _ -> Lwt.return_unit) in - let _ = Lwt_pool.clear p in - Lwt.bind u (fun () -> Lwt.return (!count = 2)) - end; - - test "waiter are notified on replacement" begin fun () -> - let c = Lwt_condition.create () in - let gen = (fun () -> let l = ref 0 in Lwt.return l) in - let v l = if !l = 0 then Lwt.return true else Lwt.fail Dummy_error in - let p = Lwt_pool.create 1 ~validate:v gen in - let u1 = Lwt_pool.use p (fun l -> l := 1; Lwt_condition.wait c) in - let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in - let u3 = Lwt_pool.use p (fun l -> Lwt.return !l) in - let () = Lwt_condition.signal c "done" in - Lwt.bind u1 (fun v1 -> - Lwt.bind u3 (fun v3 -> - Lwt.try_bind - (fun () -> u2) - (fun _ -> Lwt.return_false) - (fun exn2 -> - Lwt.return (v1 = "done" && exn2 = Dummy_error && v3 = 0)))) - end; - - test "waiter are notified on replacement exception" begin fun () -> - let c = Lwt_condition.create () in - let k = ref true in - let gen = fun () -> - if !k then - let l = ref 0 in Lwt.return l - else - Lwt.fail Dummy_error - in - let v l = if !l = 0 then Lwt.return true else Lwt.fail Dummy_error in - let p = Lwt_pool.create 1 ~validate:v gen in - let u1 = Lwt_pool.use p (fun l -> l := 1; k:= false; Lwt_condition.wait c) in - let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in - let u3 = Lwt_pool.use p (fun l -> Lwt.return !l) in - let () = Lwt_condition.signal c "done" in - Lwt.bind u1 (fun v1 -> - Lwt.try_bind - (fun () -> u2) - (fun _ -> Lwt.return_false) - (fun exn2 -> - Lwt.try_bind - (fun () -> u3) - (fun _ -> Lwt.return_false) - (fun exn3 -> - Lwt.return - (v1 = "done" && exn2 = Dummy_error && exn3 = Dummy_error)))) - end; - - test "check and validate can be used together" begin fun () -> - let gen = (fun () -> let l = ref 0 in Lwt.return l) in - let v l = Lwt.return (!l > 0) in - let c l f = f (!l > 1) in - let cond = Lwt_condition.create() in - let p = Lwt_pool.create 1 ~validate:v ~check:c gen in - let _ = Lwt_pool.use p (fun l -> l := 1; Lwt_condition.wait cond) in - let _ = Lwt_pool.use p (fun l -> l := 2; Lwt.fail Dummy_error) in - let u3 = Lwt_pool.use p (fun l -> Lwt.return !l) in - let () = Lwt_condition.signal cond "done" in - Lwt.bind u3 (fun v -> - Lwt.return (v = 2)) - end; - - test "verify default check behavior" begin fun () -> - let gen = (fun () -> let l = ref 0 in Lwt.return l) in - let cond = Lwt_condition.create() in - let p = Lwt_pool.create 1 gen in - let _ = Lwt_pool.use p (fun l -> - Lwt.bind (Lwt_condition.wait cond) - (fun _ -> l:= 1; Lwt.fail Dummy_error)) in - let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in - let () = Lwt_condition.signal cond "done" in - Lwt.bind u2 (fun v -> - Lwt.return (v = 1)) - end; - - ] +let suite = + suite "lwt_pool" + [ + test "basic create-use" (fun () -> + let gen () = Lwt.return () in + let p = Lwt_pool.create 1 gen in + Lwt.return (Lwt.state (Lwt_pool.use p Lwt.return) = Lwt.Return ())); + test "creator exception" (fun () -> + let gen () = Lwt.fail Dummy_error in + let p = Lwt_pool.create 1 gen in + let u = Lwt_pool.use p (fun _ -> Lwt.return 0) in + Lwt.return (Lwt.state u = Lwt.Fail Dummy_error)); + test "pool elements are reused" (fun () -> + let gen () = + let n = ref 0 in + Lwt.return n + in + let p = Lwt_pool.create 1 gen in + let _ = + Lwt_pool.use p (fun n -> + n := 1; + Lwt.return !n) + in + let u2 = Lwt_pool.use p (fun n -> Lwt.return !n) in + Lwt.return (Lwt.state u2 = Lwt.Return 1)); + test "pool elements are validated when returned" (fun () -> + let gen () = + let n = ref 0 in + Lwt.return n + in + let v l = Lwt.return (!l = 0) in + let p = Lwt_pool.create 1 ~validate:v gen in + let _ = + Lwt_pool.use p (fun n -> + n := 1; + Lwt.return !n) + in + let u2 = Lwt_pool.use p (fun n -> Lwt.return !n) in + Lwt.return (Lwt.state u2 = Lwt.Return 0)); + test "validation exceptions are propagated to users" (fun () -> + let c = Lwt_condition.create () in + let gen () = + let l = ref 0 in + Lwt.return l + in + let v l = if !l = 0 then Lwt.return true else Lwt.fail Dummy_error in + let p = Lwt_pool.create 1 ~validate:v gen in + let u1 = + Lwt_pool.use p (fun l -> + l := 1; + Lwt_condition.wait c) + in + let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in + let () = Lwt_condition.signal c "done" in + Lwt.bind u1 (fun v1 -> + Lwt.try_bind + (fun () -> u2) + (fun _ -> Lwt.return_false) + (fun exn2 -> Lwt.return (v1 = "done" && exn2 = Dummy_error)))); + test "multiple creation" (fun () -> + let gen () = + let n = ref 0 in + Lwt.return n + in + let p = Lwt_pool.create 2 gen in + let _ = + Lwt_pool.use p (fun n -> + n := 1; + Lwt.pause ()) + in + let u2 = Lwt_pool.use p (fun n -> Lwt.return !n) in + Lwt.return (Lwt.state u2 = Lwt.Return 0)); + test "users of an empty pool will wait" (fun () -> + let gen () = Lwt.return 0 in + let p = Lwt_pool.create 1 gen in + let _ = Lwt_pool.use p (fun _ -> Lwt.pause ()) in + let u2 = Lwt_pool.use p Lwt.return in + Lwt.return (Lwt.state u2 = Lwt.Sleep)); + test "on check, good elements are retained" (fun () -> + let gen () = + let n = ref 1 in + Lwt.return n + in + let c x f = f (!x > 0) in + let p = Lwt_pool.create 1 ~check:c gen in + let _ = + Lwt_pool.use p (fun n -> + n := 2; + Lwt.fail Dummy_error) + in + let u2 = Lwt_pool.use p (fun n -> Lwt.return !n) in + Lwt.return (Lwt.state u2 = Lwt.Return 2)); + test "on check, bad elements are disposed of and replaced" (fun () -> + let gen () = + let n = ref 1 in + Lwt.return n + in + let check n f = f (!n > 0) in + let disposed = ref false in + let dispose _ = + disposed := true; + Lwt.return_unit + in + let p = Lwt_pool.create 1 ~check ~dispose gen in + let task n = + incr n; + Lwt.return !n + in + let _ = + Lwt_pool.use p (fun n -> + n := 0; + Lwt.fail Dummy_error) + in + let u2 = Lwt_pool.use p task in + Lwt.return (Lwt.state u2 = Lwt.Return 2 && !disposed)); + test "clear disposes of all elements" (fun () -> + let gen () = + let n = ref 1 in + Lwt.return n + in + let count = ref 0 in + let dispose _ = + incr count; + Lwt.return_unit + in + let p = Lwt_pool.create 2 ~dispose gen in + let u = Lwt_pool.use p (fun _ -> Lwt.pause ()) in + let _ = Lwt_pool.use p (fun _ -> Lwt.return_unit) in + let _ = Lwt_pool.clear p in + Lwt.bind u (fun () -> Lwt.return (!count = 2))); + test "waiter are notified on replacement" (fun () -> + let c = Lwt_condition.create () in + let gen () = + let l = ref 0 in + Lwt.return l + in + let v l = if !l = 0 then Lwt.return true else Lwt.fail Dummy_error in + let p = Lwt_pool.create 1 ~validate:v gen in + let u1 = + Lwt_pool.use p (fun l -> + l := 1; + Lwt_condition.wait c) + in + let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in + let u3 = Lwt_pool.use p (fun l -> Lwt.return !l) in + let () = Lwt_condition.signal c "done" in + Lwt.bind u1 (fun v1 -> + Lwt.bind u3 (fun v3 -> + Lwt.try_bind + (fun () -> u2) + (fun _ -> Lwt.return_false) + (fun exn2 -> + Lwt.return (v1 = "done" && exn2 = Dummy_error && v3 = 0))))); + test "waiter are notified on replacement exception" (fun () -> + let c = Lwt_condition.create () in + let k = ref true in + let gen () = + if !k then + let l = ref 0 in + Lwt.return l + else Lwt.fail Dummy_error + in + let v l = if !l = 0 then Lwt.return true else Lwt.fail Dummy_error in + let p = Lwt_pool.create 1 ~validate:v gen in + let u1 = + Lwt_pool.use p (fun l -> + l := 1; + k := false; + Lwt_condition.wait c) + in + let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in + let u3 = Lwt_pool.use p (fun l -> Lwt.return !l) in + let () = Lwt_condition.signal c "done" in + Lwt.bind u1 (fun v1 -> + Lwt.try_bind + (fun () -> u2) + (fun _ -> Lwt.return_false) + (fun exn2 -> + Lwt.try_bind + (fun () -> u3) + (fun _ -> Lwt.return_false) + (fun exn3 -> + Lwt.return + (v1 = "done" && exn2 = Dummy_error && exn3 = Dummy_error))))); + test "check and validate can be used together" (fun () -> + let gen () = + let l = ref 0 in + Lwt.return l + in + let v l = Lwt.return (!l > 0) in + let c l f = f (!l > 1) in + let cond = Lwt_condition.create () in + let p = Lwt_pool.create 1 ~validate:v ~check:c gen in + let _ = + Lwt_pool.use p (fun l -> + l := 1; + Lwt_condition.wait cond) + in + let _ = + Lwt_pool.use p (fun l -> + l := 2; + Lwt.fail Dummy_error) + in + let u3 = Lwt_pool.use p (fun l -> Lwt.return !l) in + let () = Lwt_condition.signal cond "done" in + Lwt.bind u3 (fun v -> Lwt.return (v = 2))); + test "verify default check behavior" (fun () -> + let gen () = + let l = ref 0 in + Lwt.return l + in + let cond = Lwt_condition.create () in + let p = Lwt_pool.create 1 gen in + let _ = + Lwt_pool.use p (fun l -> + Lwt.bind (Lwt_condition.wait cond) (fun _ -> + l := 1; + Lwt.fail Dummy_error)) + in + let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in + let () = Lwt_condition.signal cond "done" in + Lwt.bind u2 (fun v -> Lwt.return (v = 1))); + ] diff --git a/test/core/test_lwt_result.ml b/test/core/test_lwt_result.ml index e9c80d4691..8e58c49ed3 100644 --- a/test/core/test_lwt_result.ml +++ b/test/core/test_lwt_result.ml @@ -1,233 +1,132 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Test exception Dummy_error -let state_is = - Lwt.debug_state_is +let state_is = Lwt.debug_state_is let suite = - suite "lwt_result" [ - test "maps" - (fun () -> - let x = Lwt_result.return 0 in - let correct = Lwt_result.return 1 in - Lwt.return (Lwt_result.map ((+) 1) x = correct) - ); - - test ">|= is a variant of map" - (fun () -> - let x = Lwt_result.return 0 in - let correct = Lwt_result.return 1 in - Lwt.return (Lwt_result.(>|=) x ((+) 1) = correct) - ); - - test "map, error case" - (fun () -> - let x = Lwt_result.fail 0 in - Lwt.return (Lwt_result.map ((+) 1) x = x) - ); - - test "map_err" - (fun () -> - let x = Lwt_result.return 0 in - Lwt.return (Lwt_result.map_err ((+) 1) x = x) - ); - - test "map_err, error case" - (fun () -> - let x = Lwt_result.fail 0 in - let correct = Lwt_result.fail 1 in - Lwt.return (Lwt_result.map_err ((+) 1) x = correct) - ); - - test "bind" - (fun () -> - let x = Lwt_result.return 0 in - let correct = Lwt_result.return 1 in - let actual = Lwt_result.bind x (fun y -> Lwt_result.return (y + 1)) in - Lwt.return (actual = correct) - ); - - test "bind, error case" - (fun () -> - let x = Lwt_result.fail 0 in - let actual = Lwt_result.bind x (fun y -> Lwt_result.return (y + 1)) in - Lwt.return (actual = x) - ); - - test "ok" - (fun () -> - let x = Lwt.return 0 in - Lwt.return (Lwt_result.ok x = Lwt_result.return 0) - ); - - test "catch" - (fun () -> - let x = Lwt.return 0 in - Lwt.return (Lwt_result.catch x = Lwt_result.return 0) - ); - - test "catch, error case" - (fun () -> - let x = Lwt.fail Dummy_error in - Lwt.return (Lwt_result.catch x = Lwt_result.fail Dummy_error) - ); - - test "get_exn" - (fun () -> - let x = Lwt_result.return 0 in - Lwt.return (Lwt_result.get_exn x = Lwt.return 0) - ); - - test "get_exn, error case" - (fun () -> - let x = Lwt_result.fail Dummy_error in - Lwt.return (Lwt_result.get_exn x = Lwt.fail Dummy_error) - ); - - test "bind_lwt" - (fun () -> - let x = Lwt_result.return 0 in - let f y = Lwt.return (y + 1) in - Lwt.return (Lwt_result.bind_lwt x f = Lwt_result.return 1) - ); - - test "bind_lwt, error case" - (fun () -> - let x = Lwt_result.fail 0 in - let f y = Lwt.return (y + 1) in - Lwt.return (Lwt_result.bind_lwt x f = Lwt_result.fail 0) - ); - - test "bind_lwt_err" - (fun () -> - let x = Lwt_result.return 0 in - let f y = Lwt.return (y + 1) in - Lwt.return (Lwt_result.bind_lwt_err x f = Lwt_result.return 0) - ); - - test "bind_lwt_err, error case" - (fun () -> - let x = Lwt_result.fail 0 in - let f y = Lwt.return (y + 1) in - Lwt.return (Lwt_result.bind_lwt_err x f = Lwt_result.fail 1) - ); - - test "bind_result" - (fun () -> - let x = Lwt_result.return 0 in - let f y = Result.Ok (y + 1) in - Lwt.return (Lwt_result.bind_result x f = Lwt_result.return 1) - ); - - test "bind_result, error case" - (fun () -> - let x = Lwt_result.fail 0 in - 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)) - ); - - test "let*" - (fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p' = - let open Lwt_result.Syntax in - let* s1 = p1 in - let* s2 = p2 in - Lwt.return (Result.Ok (s1 ^ s2)) - in - Lwt.wakeup r1 (Result.Ok "foo"); - Lwt.wakeup r2 (Result.Ok "bar"); - state_is (Lwt.Return (Result.Ok "foobar")) p' - ); - - test "and*" - (fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p' = - let open Lwt_result.Syntax in - let* s1 = p1 - and* s2 = p2 in - Lwt.return (Result.Ok (s1 ^ s2)) - in - Lwt.wakeup r1 (Result.Ok "foo"); - Lwt.wakeup r2 (Result.Ok "bar"); - state_is (Lwt.Return (Result.Ok "foobar")) p' - ); - - test "let+/and+" - (fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - let p' = - let open Lwt_result.Syntax in - let+ s1 = p1 - and+ s2 = p2 in - s1 ^ s2 - in - Lwt.wakeup r1 (Result.Ok "foo"); - Lwt.wakeup r2 (Result.Ok "bar"); - state_is (Lwt.Return (Result.Ok "foobar")) p' - ); - ] + suite "lwt_result" + [ + test "maps" (fun () -> + let x = Lwt_result.return 0 in + let correct = Lwt_result.return 1 in + Lwt.return (Lwt_result.map (( + ) 1) x = correct)); + test ">|= is a variant of map" (fun () -> + let x = Lwt_result.return 0 in + let correct = Lwt_result.return 1 in + Lwt.return (Lwt_result.( >|= ) x (( + ) 1) = correct)); + test "map, error case" (fun () -> + let x = Lwt_result.fail 0 in + Lwt.return (Lwt_result.map (( + ) 1) x = x)); + test "map_err" (fun () -> + let x = Lwt_result.return 0 in + Lwt.return (Lwt_result.map_err (( + ) 1) x = x)); + test "map_err, error case" (fun () -> + let x = Lwt_result.fail 0 in + let correct = Lwt_result.fail 1 in + Lwt.return (Lwt_result.map_err (( + ) 1) x = correct)); + test "bind" (fun () -> + let x = Lwt_result.return 0 in + let correct = Lwt_result.return 1 in + let actual = Lwt_result.bind x (fun y -> Lwt_result.return (y + 1)) in + Lwt.return (actual = correct)); + test "bind, error case" (fun () -> + let x = Lwt_result.fail 0 in + let actual = Lwt_result.bind x (fun y -> Lwt_result.return (y + 1)) in + Lwt.return (actual = x)); + test "ok" (fun () -> + let x = Lwt.return 0 in + Lwt.return (Lwt_result.ok x = Lwt_result.return 0)); + test "catch" (fun () -> + let x = Lwt.return 0 in + Lwt.return (Lwt_result.catch x = Lwt_result.return 0)); + test "catch, error case" (fun () -> + let x = Lwt.fail Dummy_error in + Lwt.return (Lwt_result.catch x = Lwt_result.fail Dummy_error)); + test "get_exn" (fun () -> + let x = Lwt_result.return 0 in + Lwt.return (Lwt_result.get_exn x = Lwt.return 0)); + test "get_exn, error case" (fun () -> + let x = Lwt_result.fail Dummy_error in + Lwt.return (Lwt_result.get_exn x = Lwt.fail Dummy_error)); + test "bind_lwt" (fun () -> + let x = Lwt_result.return 0 in + let f y = Lwt.return (y + 1) in + Lwt.return (Lwt_result.bind_lwt x f = Lwt_result.return 1)); + test "bind_lwt, error case" (fun () -> + let x = Lwt_result.fail 0 in + let f y = Lwt.return (y + 1) in + Lwt.return (Lwt_result.bind_lwt x f = Lwt_result.fail 0)); + test "bind_lwt_err" (fun () -> + let x = Lwt_result.return 0 in + let f y = Lwt.return (y + 1) in + Lwt.return (Lwt_result.bind_lwt_err x f = Lwt_result.return 0)); + test "bind_lwt_err, error case" (fun () -> + let x = Lwt_result.fail 0 in + let f y = Lwt.return (y + 1) in + Lwt.return (Lwt_result.bind_lwt_err x f = Lwt_result.fail 1)); + test "bind_result" (fun () -> + let x = Lwt_result.return 0 in + let f y = Result.Ok (y + 1) in + Lwt.return (Lwt_result.bind_result x f = Lwt_result.return 1)); + test "bind_result, error case" (fun () -> + let x = Lwt_result.fail 0 in + 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))); + test "let*" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p' = + let open Lwt_result.Syntax in + let* s1 = p1 in + let* s2 = p2 in + Lwt.return (Result.Ok (s1 ^ s2)) + in + Lwt.wakeup r1 (Result.Ok "foo"); + Lwt.wakeup r2 (Result.Ok "bar"); + state_is (Lwt.Return (Result.Ok "foobar")) p'); + test "and*" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p' = + let open Lwt_result.Syntax in + let* s1 = p1 and* s2 = p2 in + Lwt.return (Result.Ok (s1 ^ s2)) + in + Lwt.wakeup r1 (Result.Ok "foo"); + Lwt.wakeup r2 (Result.Ok "bar"); + state_is (Lwt.Return (Result.Ok "foobar")) p'); + test "let+/and+" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + let p' = + let open Lwt_result.Syntax in + let+ s1 = p1 and+ s2 = p2 in + s1 ^ s2 + in + Lwt.wakeup r1 (Result.Ok "foo"); + Lwt.wakeup r2 (Result.Ok "bar"); + state_is (Lwt.Return (Result.Ok "foobar")) p'); + ] diff --git a/test/core/test_lwt_seq.ml b/test/core/test_lwt_seq.ml index d49e10d7be..122644f7fd 100644 --- a/test/core/test_lwt_seq.ml +++ b/test/core/test_lwt_seq.ml @@ -1,379 +1,368 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Lwt.Syntax - open Test -let l = [1; 2; 3; 4; 5] +let l = [ 1; 2; 3; 4; 5 ] let a = Lwt_seq.of_list l -let rec pause n = - if n <= 0 then - Lwt.return_unit - else - let* () = Lwt.pause () in - pause (n - 1) -let pause n = pause (n mod 5) -let b = - Lwt_seq.unfold_lwt - (function - | [] -> let+ () = pause 2 in None - | x::xs -> let+ () = pause (x+2) in Some (x, xs)) - l - -let suite_base = suite "lwt_seq" [ - test "fold_left" begin fun () -> - let n = ref 1 in - Lwt_seq.fold_left (fun acc x -> - let r = x = !n && acc in - incr n; r) true a - end; - test "fold_left_s" begin fun () -> - let n = ref 1 in - Lwt_seq.fold_left_s (fun acc x -> - let r = x = !n && acc in - incr n; Lwt.return r) true a - end; - test "map" begin fun () -> - let v = Lwt_seq.map (fun x -> (x * 2)) a in - let+ l' = Lwt_seq.to_list v in - l' = [2; 4; 6; 8; 10] - end; - test "map_s" begin fun () -> - let v = Lwt_seq.map_s (fun x -> Lwt.return (x * 2)) a in - let+ l' = Lwt_seq.to_list v in - l' = [2; 4; 6; 8; 10] - end; - - test "filter" begin fun () -> - let v = Lwt_seq.filter (fun x -> (x mod 2 = 0)) a in - let+ l' = Lwt_seq.to_list v in - l' = [2; 4] - end; - test "filter_s" begin fun () -> - let v = Lwt_seq.filter_s (fun x -> Lwt.return (x mod 2 = 0)) a in - let+ l' = Lwt_seq.to_list v in - l' = [2; 4] - end; - - test "iter_n(1)" begin fun () -> - let max_concurrency = 1 in - let running = ref 0 in - let sum = ref 0 in - let f x = - incr running; - assert (!running <= max_concurrency); - let* () = pause x in - sum := !sum + x; - decr running; - Lwt.return_unit - in - let* () = Lwt_seq.iter_n ~max_concurrency f a in - assert (!sum = List.fold_left (+) 0 l); - sum := 0; - let* () = Lwt_seq.iter_n ~max_concurrency f b in - assert (!sum = List.fold_left (+) 0 l); - Lwt.return_true - end; - test "iter_n(2)" begin fun () -> - let max_concurrency = 2 in - let running = ref 0 in - let sum = ref 0 in - let f x = - incr running; - assert (!running <= max_concurrency); - let* () = pause x in - sum := !sum + x; - decr running; - Lwt.return_unit - in - let* () = Lwt_seq.iter_n ~max_concurrency f a in - assert (!sum = List.fold_left (+) 0 l); - sum := 0; - let* () = Lwt_seq.iter_n ~max_concurrency f b in - assert (!sum = List.fold_left (+) 0 l); - Lwt.return_true - end; - test "iter_n(100)" begin fun () -> - let max_concurrency = 100 in - let running = ref 0 in - let sum = ref 0 in - let f x = - incr running; - assert (!running <= max_concurrency); - let* () = pause x in - sum := !sum + x; - decr running; - Lwt.return_unit - in - let* () = Lwt_seq.iter_n ~max_concurrency f a in - assert (!sum = List.fold_left (+) 0 l); - sum := 0; - let* () = Lwt_seq.iter_n ~max_concurrency f b in - assert (!sum = List.fold_left (+) 0 l); - Lwt.return_true - end; - - test "filter_map" begin fun () -> - let v = Lwt_seq.filter_map (fun x -> - if x mod 2 = 0 then Some (x * 2) else None) a - in - let+ l' = Lwt_seq.to_list v in - l' = [4; 8] - end; - test "filter_map_s" begin fun () -> - let v = Lwt_seq.filter_map_s (fun x -> - Lwt.return (if x mod 2 = 0 then Some (x * 2) else None)) a - in - let+ l' = Lwt_seq.to_list v in - l' = [4; 8] - end; - - test "unfold" begin fun () -> - let range first last = - let step i = if i > last then None else Some (i, succ i) in - Lwt_seq.unfold step first - in - let* a = Lwt_seq.to_list (range 1 3) in - let+ b = Lwt_seq.to_list (range 1 0) in - ([1;2;3] = a) && - ([] = b) - end; +let rec pause n = + if n <= 0 then Lwt.return_unit + else + let* () = Lwt.pause () in + pause (n - 1) - test "unfold_lwt" begin fun () -> - let range first last = - let step i = - if i > last then Lwt.return_none else Lwt.return_some (i, succ i) - in - Lwt_seq.unfold_lwt step first - in - let* a = Lwt_seq.to_list (range 1 3) in - let+ b = Lwt_seq.to_list (range 1 0) in - ([1;2;3] = a) && - ([] = b) - end; +let pause n = pause (n mod 5) +let b = + Lwt_seq.unfold_lwt + (function + | [] -> + let+ () = pause 2 in + None + | x :: xs -> + let+ () = pause (x + 2) in + Some (x, xs)) + l - test "fold-into-exception-from-of-seq" begin fun () -> - let fail = fun () -> failwith "XXX" in - let seq = fun () -> Seq.Cons (1, (fun () -> Seq.Cons (2, fail))) in - let a = Lwt_seq.of_seq seq in - let+ n = - Lwt.catch - (fun () -> Lwt_seq.fold_left (+) 0 a) - (function - | Failure x when x = "XXX" -> Lwt.return (-1) - | exc -> raise exc) - in - n = (-1) - end; +let suite_base = + suite "lwt_seq" + [ + test "fold_left" (fun () -> + let n = ref 1 in + Lwt_seq.fold_left + (fun acc x -> + let r = x = !n && acc in + incr n; + r) + true a); + test "fold_left_s" (fun () -> + let n = ref 1 in + Lwt_seq.fold_left_s + (fun acc x -> + let r = x = !n && acc in + incr n; + Lwt.return r) + true a); + test "map" (fun () -> + let v = Lwt_seq.map (fun x -> x * 2) a in + let+ l' = Lwt_seq.to_list v in + l' = [ 2; 4; 6; 8; 10 ]); + test "map_s" (fun () -> + let v = Lwt_seq.map_s (fun x -> Lwt.return (x * 2)) a in + let+ l' = Lwt_seq.to_list v in + l' = [ 2; 4; 6; 8; 10 ]); + test "filter" (fun () -> + let v = Lwt_seq.filter (fun x -> x mod 2 = 0) a in + let+ l' = Lwt_seq.to_list v in + l' = [ 2; 4 ]); + test "filter_s" (fun () -> + let v = Lwt_seq.filter_s (fun x -> Lwt.return (x mod 2 = 0)) a in + let+ l' = Lwt_seq.to_list v in + l' = [ 2; 4 ]); + test "iter_n(1)" (fun () -> + let max_concurrency = 1 in + let running = ref 0 in + let sum = ref 0 in + let f x = + incr running; + assert (!running <= max_concurrency); + let* () = pause x in + sum := !sum + x; + decr running; + Lwt.return_unit + in + let* () = Lwt_seq.iter_n ~max_concurrency f a in + assert (!sum = List.fold_left ( + ) 0 l); + sum := 0; + let* () = Lwt_seq.iter_n ~max_concurrency f b in + assert (!sum = List.fold_left ( + ) 0 l); + Lwt.return_true); + test "iter_n(2)" (fun () -> + let max_concurrency = 2 in + let running = ref 0 in + let sum = ref 0 in + let f x = + incr running; + assert (!running <= max_concurrency); + let* () = pause x in + sum := !sum + x; + decr running; + Lwt.return_unit + in + let* () = Lwt_seq.iter_n ~max_concurrency f a in + assert (!sum = List.fold_left ( + ) 0 l); + sum := 0; + let* () = Lwt_seq.iter_n ~max_concurrency f b in + assert (!sum = List.fold_left ( + ) 0 l); + Lwt.return_true); + test "iter_n(100)" (fun () -> + let max_concurrency = 100 in + let running = ref 0 in + let sum = ref 0 in + let f x = + incr running; + assert (!running <= max_concurrency); + let* () = pause x in + sum := !sum + x; + decr running; + Lwt.return_unit + in + let* () = Lwt_seq.iter_n ~max_concurrency f a in + assert (!sum = List.fold_left ( + ) 0 l); + sum := 0; + let* () = Lwt_seq.iter_n ~max_concurrency f b in + assert (!sum = List.fold_left ( + ) 0 l); + Lwt.return_true); + test "filter_map" (fun () -> + let v = + Lwt_seq.filter_map + (fun x -> if x mod 2 = 0 then Some (x * 2) else None) + a + in + let+ l' = Lwt_seq.to_list v in + l' = [ 4; 8 ]); + test "filter_map_s" (fun () -> + let v = + Lwt_seq.filter_map_s + (fun x -> Lwt.return (if x mod 2 = 0 then Some (x * 2) else None)) + a + in + let+ l' = Lwt_seq.to_list v in + l' = [ 4; 8 ]); + test "unfold" (fun () -> + let range first last = + let step i = if i > last then None else Some (i, succ i) in + Lwt_seq.unfold step first + in + let* a = Lwt_seq.to_list (range 1 3) in + let+ b = Lwt_seq.to_list (range 1 0) in + [ 1; 2; 3 ] = a && [] = b); + test "unfold_lwt" (fun () -> + let range first last = + let step i = + if i > last then Lwt.return_none else Lwt.return_some (i, succ i) + in + Lwt_seq.unfold_lwt step first + in + let* a = Lwt_seq.to_list (range 1 3) in + let+ b = Lwt_seq.to_list (range 1 0) in + [ 1; 2; 3 ] = a && [] = b); + test "fold-into-exception-from-of-seq" (fun () -> + let fail () = failwith "XXX" in + let seq () = Seq.Cons (1, fun () -> Seq.Cons (2, fail)) in + let a = Lwt_seq.of_seq seq in + let+ n = + Lwt.catch + (fun () -> Lwt_seq.fold_left ( + ) 0 a) + (function + | Failure x when x = "XXX" -> Lwt.return (-1) | exc -> raise exc) + in + n = -1); + test "fold-into-immediate-exception-from-of-seq" (fun () -> + let fail () = failwith "XXX" in + let seq = fail in + let a = Lwt_seq.of_seq seq in + let+ n = + Lwt.catch + (fun () -> Lwt_seq.fold_left ( + ) 0 a) + (function + | Failure x when x = "XXX" -> Lwt.return (-1) | exc -> raise exc) + in + n = -1); + test "fold-into-exception-from-of-seq-lwt" (fun () -> + let fail () = failwith "XXX" in + let seq : int Lwt.t Seq.t = + fun () -> + Seq.Cons (Lwt.return 1, fun () -> Seq.Cons (Lwt.return 2, fail)) + in + let a = Lwt_seq.of_seq_lwt seq in + let+ n = + Lwt.catch + (fun () -> Lwt_seq.fold_left ( + ) 0 a) + (function + | Failure x when x = "XXX" -> Lwt.return (-1) | exc -> raise exc) + in + n = -1); + test "fold-into-immediate-exception-from-of-seq-lwt" (fun () -> + let fail () = failwith "XXX" in + let seq : int Lwt.t Seq.t = fail in + let a = Lwt_seq.of_seq_lwt seq in + let+ n = + Lwt.catch + (fun () -> Lwt_seq.fold_left ( + ) 0 a) + (function + | Failure x when x = "XXX" -> Lwt.return (-1) | exc -> raise exc) + in + n = -1); + ] - test "fold-into-immediate-exception-from-of-seq" begin fun () -> - let fail = fun () -> failwith "XXX" in - let seq = fail in - let a = Lwt_seq.of_seq seq in - let+ n = - Lwt.catch - (fun () -> Lwt_seq.fold_left (+) 0 a) - (function - | Failure x when x = "XXX" -> Lwt.return (-1) - | exc -> raise exc) - in - n = (-1) - end; +let fs = [ ( + ); ( - ); (fun x _ -> x); min; max ] - test "fold-into-exception-from-of-seq-lwt" begin fun () -> - let fail = fun () -> failwith "XXX" in - let seq: int Lwt.t Seq.t = fun () -> - Seq.Cons (Lwt.return 1, - fun () -> - Seq.Cons (Lwt.return 2, fail)) in - let a = Lwt_seq.of_seq_lwt seq in - let+ n = - Lwt.catch - (fun () -> Lwt_seq.fold_left (+) 0 a) - (function - | Failure x when x = "XXX" -> Lwt.return (-1) - | exc -> raise exc) - in - n = (-1) - end; +let ls = + [ + []; + l; + l @ l @ l; + List.rev l; + [ 0; 0; 0 ]; + [ max_int; 0; min_int ]; + [ max_int; max_int ]; + ] - test "fold-into-immediate-exception-from-of-seq-lwt" begin fun () -> - let fail = fun () -> failwith "XXX" in - let seq: int Lwt.t Seq.t = fail in - let a = Lwt_seq.of_seq_lwt seq in - let+ n = - Lwt.catch - (fun () -> Lwt_seq.fold_left (+) 0 a) - (function - | Failure x when x = "XXX" -> Lwt.return (-1) - | exc -> raise exc) - in - n = (-1) - end; -] +let cs = [ 0; 1; max_int; min_int; 44; 5 ] -let fs = [(+); (-); (fun x _ -> x); min; max] -let ls = [ - []; - l; - l@l@l; - List.rev l; - [0;0;0]; - [max_int;0;min_int]; - [max_int;max_int]; -] -let cs = [0;1;max_int;min_int;44;5] let with_flc test = - Lwt_list.for_all_s - (fun f -> - Lwt_list.for_all_s - (fun l -> - Lwt_list.for_all_s - (fun c -> test f l c) - cs) - ls) - fs -let equals l1 seq2 = - let* l2 = Lwt_seq.to_list seq2 in - Lwt.return (l1 = l2) -let commutes lf sf l = - equals (lf l) (sf (Lwt_seq.of_list l)) - - -let suite_fuzzing = suite "lwt_seq(pseudo-fuzzing)" [ + Lwt_list.for_all_s + (fun f -> + Lwt_list.for_all_s + (fun l -> Lwt_list.for_all_s (fun c -> test f l c) cs) + ls) + fs - test "map" begin fun () -> - with_flc (fun f l c -> - let lf = List.map (fun x -> f x c) in - let sf = Lwt_seq.map (fun x -> f x c) in - commutes lf sf l - ) - end; - - test "map_s" begin fun () -> - with_flc (fun f l c -> - let lf = List.map (fun x -> f x c) in - let sf = Lwt_seq.map_s (fun x -> Lwt.return (f x c)) in - commutes lf sf l - ) - end; - - test "iter" begin fun () -> - with_flc (fun f l c -> - let lf l = - let r = ref c in - List.iter (fun x -> r := f !r x) l; - [!r] in - let sf s = - let r = ref c in - fun () -> - let* () = Lwt_seq.iter (fun x -> r := f !r x) s in - Lwt.return (Lwt_seq.Cons (!r, Lwt_seq.empty)) in - commutes lf sf l - ) - end; - - test "iter_s" begin fun () -> - with_flc (fun f l c -> - let lf l = - let r = ref c in - List.iter (fun x -> r := f !r x) l; - [!r] in - let sf s = - let r = ref c in - fun () -> - let* () = Lwt_seq.iter_s (fun x -> r := f !r x; Lwt.return_unit) s in - Lwt.return (Lwt_seq.Cons (!r, Lwt_seq.empty)) in - commutes lf sf l - ) - end; - - (* the [f]s commute sufficiently for parallel execution *) - test "iter_p" begin fun () -> - with_flc (fun f l c -> - let lf l = - let r = ref c in - List.iter (fun x -> r := f !r x) l; - [!r] - in - let sf s = - Lwt_seq.return_lwt @@ - let r = ref c in - let+ () = Lwt_seq.iter_p (fun x -> r := f !r x; Lwt.return_unit) s in - !r - in - commutes lf sf l - ) - end; - - test "iter_p (pause)" begin fun () -> - with_flc (fun f l c -> - let lf l = - let r = ref c in - List.iter (fun x -> r := f !r x) l; - [!r] - in - let sf s = - Lwt_seq.return_lwt @@ - let r = ref c in - let+ () = - Lwt_seq.iter_p - (fun x -> - let* () = pause x in - r := f !r x; - pause x) - s - in - !r - in - commutes lf sf l - ) - end; - - test "iter_n" begin fun () -> - l |> Lwt_list.for_all_s @@ fun max_concurrency -> - with_flc (fun f l c -> - let lf l = - let r = ref c in - List.iter (fun x -> r := f !r x) l; - [!r] in - let sf s = - Lwt_seq.return_lwt @@ - let r = ref c in - let+ () = Lwt_seq.iter_n ~max_concurrency (fun x -> r := f !r x; Lwt.return_unit) s in - !r - in - commutes lf sf l - ) - end; +let equals l1 seq2 = + let* l2 = Lwt_seq.to_list seq2 in + Lwt.return (l1 = l2) - test "iter_n (pause)" begin fun () -> - l |> Lwt_list.for_all_s @@ fun max_concurrency -> - with_flc (fun f l c -> - let lf l = - let r = ref c in - List.iter (fun x -> r := f !r x) l; - [!r] in - let sf s = - Lwt_seq.return_lwt @@ - let r = ref c in - let+ () = - Lwt_seq.iter_n ~max_concurrency - (fun x -> - let* () = pause x in - r := f !r x; - pause x) - s - in - !r - in - commutes lf sf l - ) - end; +let commutes lf sf l = equals (lf l) (sf (Lwt_seq.of_list l)) -] +let suite_fuzzing = + suite "lwt_seq(pseudo-fuzzing)" + [ + test "map" (fun () -> + with_flc (fun f l c -> + let lf = List.map (fun x -> f x c) in + let sf = Lwt_seq.map (fun x -> f x c) in + commutes lf sf l)); + test "map_s" (fun () -> + with_flc (fun f l c -> + let lf = List.map (fun x -> f x c) in + let sf = Lwt_seq.map_s (fun x -> Lwt.return (f x c)) in + commutes lf sf l)); + test "iter" (fun () -> + with_flc (fun f l c -> + let lf l = + let r = ref c in + List.iter (fun x -> r := f !r x) l; + [ !r ] + in + let sf s = + let r = ref c in + fun () -> + let* () = Lwt_seq.iter (fun x -> r := f !r x) s in + Lwt.return (Lwt_seq.Cons (!r, Lwt_seq.empty)) + in + commutes lf sf l)); + test "iter_s" (fun () -> + with_flc (fun f l c -> + let lf l = + let r = ref c in + List.iter (fun x -> r := f !r x) l; + [ !r ] + in + let sf s = + let r = ref c in + fun () -> + let* () = + Lwt_seq.iter_s + (fun x -> + r := f !r x; + Lwt.return_unit) + s + in + Lwt.return (Lwt_seq.Cons (!r, Lwt_seq.empty)) + in + commutes lf sf l)); + (* the [f]s commute sufficiently for parallel execution *) + test "iter_p" (fun () -> + with_flc (fun f l c -> + let lf l = + let r = ref c in + List.iter (fun x -> r := f !r x) l; + [ !r ] + in + let sf s = + Lwt_seq.return_lwt + @@ + let r = ref c in + let+ () = + Lwt_seq.iter_p + (fun x -> + r := f !r x; + Lwt.return_unit) + s + in + !r + in + commutes lf sf l)); + test "iter_p (pause)" (fun () -> + with_flc (fun f l c -> + let lf l = + let r = ref c in + List.iter (fun x -> r := f !r x) l; + [ !r ] + in + let sf s = + Lwt_seq.return_lwt + @@ + let r = ref c in + let+ () = + Lwt_seq.iter_p + (fun x -> + let* () = pause x in + r := f !r x; + pause x) + s + in + !r + in + commutes lf sf l)); + test "iter_n" (fun () -> + l + |> Lwt_list.for_all_s @@ fun max_concurrency -> + with_flc (fun f l c -> + let lf l = + let r = ref c in + List.iter (fun x -> r := f !r x) l; + [ !r ] + in + let sf s = + Lwt_seq.return_lwt + @@ + let r = ref c in + let+ () = + Lwt_seq.iter_n ~max_concurrency + (fun x -> + r := f !r x; + Lwt.return_unit) + s + in + !r + in + commutes lf sf l)); + test "iter_n (pause)" (fun () -> + l + |> Lwt_list.for_all_s @@ fun max_concurrency -> + with_flc (fun f l c -> + let lf l = + let r = ref c in + List.iter (fun x -> r := f !r x) l; + [ !r ] + in + let sf s = + Lwt_seq.return_lwt + @@ + let r = ref c in + let+ () = + Lwt_seq.iter_n ~max_concurrency + (fun x -> + let* () = pause x in + r := f !r x; + pause x) + s + in + !r + in + commutes lf sf l)); + ] diff --git a/test/core/test_lwt_sequence.ml b/test/core/test_lwt_sequence.ml index 83c4030ad6..7a5674d57e 100644 --- a/test/core/test_lwt_sequence.ml +++ b/test/core/test_lwt_sequence.ml @@ -1,12 +1,12 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Test [@@@ocaml.warning "-3"] + module Lwt_sequence = Lwt_sequence + [@@@ocaml.warning "+3"] let filled_sequence () = @@ -20,9 +20,7 @@ let filled_sequence () = s let filled_length = 6 - let leftmost_value = 1 - let rightmost_value = 6 let transfer_sequence () = @@ -32,392 +30,334 @@ let transfer_sequence () = s let transfer_length = 2 - let empty_array = [||] - -let l_filled_array = [|1; 2; 3; 4; 5; 6|] - -let r_filled_array = [|6; 5; 4; 3; 2; 1|] - +let l_filled_array = [| 1; 2; 3; 4; 5; 6 |] +let r_filled_array = [| 6; 5; 4; 3; 2; 1 |] let factorial_sequence = 720 let test_iter iter_f array_values seq = let index = ref 0 in Lwt.catch - (fun () -> - iter_f (fun v -> - assert (v = array_values.(!index)); - index := (!index + 1)) seq; - Lwt.return_true) - (function _ -> Lwt.return_false) + (fun () -> + iter_f + (fun v -> + assert (v = array_values.(!index)); + index := !index + 1) + seq; + Lwt.return_true) + (function _ -> Lwt.return_false) let test_iter_node iter_f array_values seq = let index = ref 0 in Lwt.catch - (fun () -> - iter_f (fun n -> - assert ((Lwt_sequence.get n) = array_values.(!index)); - index := (!index + 1)) seq; - Lwt.return_true) - (function _ -> Lwt.return_false) + (fun () -> + iter_f + (fun n -> + assert (Lwt_sequence.get n = array_values.(!index)); + index := !index + 1) + seq; + Lwt.return_true) + (function _ -> Lwt.return_false) let test_iter_rem iter_f array_values seq = let index = ref 0 in Lwt.catch - (fun () -> - iter_f (fun n -> - assert ((Lwt_sequence.get n) = array_values.(!index)); - Lwt_sequence.remove n; - index := (!index + 1)) seq; - Lwt.return_true) - (function _ -> Lwt.return_false) - -let suite = suite "lwt_sequence" [ - - test "create" begin fun () -> - let s = Lwt_sequence.create () in - let _ = assert (Lwt_sequence.is_empty s) in - let len = Lwt_sequence.length s in - Lwt.return (len = 0) - end; - - test "add_l" begin fun () -> - let s = Lwt_sequence.create () in - let n = Lwt_sequence.add_l 1 s in - let _ = assert ((Lwt_sequence.get n) = 1) in - let len = Lwt_sequence.length s in - Lwt.return (len = 1) - end; - - test "add_r" begin fun () -> - let s = Lwt_sequence.create () in - let n = Lwt_sequence.add_r 1 s in - let _ = assert ((Lwt_sequence.get n) = 1) in - let len = Lwt_sequence.length s in - Lwt.return (len = 1) - end; - - test "take_l Empty" begin fun () -> - let s = Lwt_sequence.create () in - Lwt.catch - (fun () -> - let _ = Lwt_sequence.take_l s in - Lwt.return_false) - (function - | Lwt_sequence.Empty -> Lwt.return_true - | _ -> Lwt.return_false) - end; - - test "take_l" begin fun () -> - let s = filled_sequence () in - Lwt.catch - (fun () -> - let v = Lwt_sequence.take_l s in - Lwt.return (leftmost_value = v)) - (function _ -> Lwt.return_false) - end; - - test "take_r Empty" begin fun () -> - let s = Lwt_sequence.create () in - Lwt.catch - (fun () -> - let _ = Lwt_sequence.take_r s in Lwt.return_false) - (function - | Lwt_sequence.Empty -> Lwt.return_true - | _ -> Lwt.return_false) - end; - - test "take_r" begin fun () -> - let s = filled_sequence () in - Lwt.catch - (fun () -> - let v = Lwt_sequence.take_r s in Lwt.return (rightmost_value = v)) - (function _ -> Lwt.return_false) - end; - - test "take_opt_l Empty" begin fun () -> - let s = Lwt_sequence.create () in - match Lwt_sequence.take_opt_l s with - | None -> Lwt.return_true - | _ -> Lwt.return_false - end; - - test "take_opt_l" begin fun () -> - let s = filled_sequence () in - match Lwt_sequence.take_opt_l s with - | None -> Lwt.return_false - | Some v -> Lwt.return (leftmost_value = v) - end; - - test "take_opt_r Empty" begin fun () -> - let s = Lwt_sequence.create () in - match Lwt_sequence.take_opt_r s with - | None -> Lwt.return_true - | _ -> Lwt.return_false - end; - - test "take_opt_r" begin fun () -> - let s = filled_sequence () in - match Lwt_sequence.take_opt_r s with - | None -> Lwt.return_false - | Some v -> Lwt.return (rightmost_value = v) - end; - - test "transfer_l Empty" begin fun () -> - let s = filled_sequence () in - let ts = Lwt_sequence.create () in - let _ = Lwt_sequence.transfer_l ts s in - let len = Lwt_sequence.length s in - Lwt.return (filled_length = len) - end; - - test "transfer_l " begin fun () -> - let s = filled_sequence () in - let ts = transfer_sequence () in - let _ = Lwt_sequence.transfer_l ts s in - let len = Lwt_sequence.length s in - let _ = assert ((filled_length + transfer_length) = len) in - match Lwt_sequence.take_opt_l s with - | None -> Lwt.return_false - | Some v -> Lwt.return (7 = v) - end; - - test "transfer_r Empty" begin fun () -> - let s = filled_sequence () in - let ts = Lwt_sequence.create () in - let _ = Lwt_sequence.transfer_r ts s in - let len = Lwt_sequence.length s in - Lwt.return (filled_length = len) - end; - - test "transfer_r " begin fun () -> - let s = filled_sequence () in - let ts = transfer_sequence () in - let _ = Lwt_sequence.transfer_r ts s in - let len = Lwt_sequence.length s in - let _ = assert ((filled_length + transfer_length) = len) in - match Lwt_sequence.take_opt_r s with - | None -> Lwt.return_false - | Some v -> Lwt.return (8 = v) - end; - - test "iter_l Empty" begin fun () -> - test_iter Lwt_sequence.iter_l empty_array (Lwt_sequence.create ()) - end; - - test "iter_l" begin fun () -> - test_iter Lwt_sequence.iter_l l_filled_array (filled_sequence ()) - end; - - test "iter_r Empty" begin fun () -> - test_iter Lwt_sequence.iter_r empty_array (Lwt_sequence.create ()) - end; - - test "iter_r" begin fun () -> - test_iter Lwt_sequence.iter_r r_filled_array (filled_sequence ()) - end; - - test "iter_node_l Empty" begin fun () -> - test_iter_node Lwt_sequence.iter_node_l empty_array (Lwt_sequence.create ()) - end; - - test "iter_node_l" begin fun () -> - test_iter_node Lwt_sequence.iter_node_l l_filled_array (filled_sequence ()) - end; - - test "iter_node_r Empty" begin fun () -> - test_iter_node Lwt_sequence.iter_node_r empty_array (Lwt_sequence.create ()) - end; - - test "iter_node_r" begin fun () -> - test_iter_node Lwt_sequence.iter_node_r r_filled_array (filled_sequence ()) - end; - - test "iter_node_l with removal" begin fun () -> - test_iter_rem Lwt_sequence.iter_node_l l_filled_array (filled_sequence ()) - end; - - test "iter_node_r with removal" begin fun () -> - test_iter_rem Lwt_sequence.iter_node_r r_filled_array (filled_sequence ()) - end; - - test "fold_l" begin fun () -> - let acc = Lwt_sequence.fold_l (fun v e -> v * e) (filled_sequence ()) 1 in - Lwt.return (factorial_sequence = acc) - end; - - test "fold_l Empty" begin fun () -> - let acc = Lwt_sequence.fold_l (fun v e -> v * e) (Lwt_sequence.create ()) 1 in - Lwt.return (acc = 1) - end; - - test "fold_r" begin fun () -> - let acc = Lwt_sequence.fold_r (fun v e -> v * e) (filled_sequence ()) 1 in - Lwt.return (factorial_sequence = acc) - end; - - test "fold_r Empty" begin fun () -> - let acc = Lwt_sequence.fold_r (fun v e -> v * e) (Lwt_sequence.create ()) 1 in - Lwt.return (acc = 1) - end; - - test "find_node_opt_l Empty" begin fun () -> - let s = Lwt_sequence.create () in - match Lwt_sequence.find_node_opt_l (fun v -> v = 1) s with - | None -> Lwt.return_true - | _ -> Lwt.return_false - end; - - test "find_node_opt_l not found " begin fun () -> - let s = transfer_sequence () in - match Lwt_sequence.find_node_opt_l (fun v -> v = 1) s with - | None -> Lwt.return_true - | _ -> Lwt.return_false - end; - - test "find_node_opt_l" begin fun () -> - let s = filled_sequence () in - match Lwt_sequence.find_node_opt_l (fun v -> v = 1) s with - | None -> Lwt.return_false - | Some n -> if ((Lwt_sequence.get n) = 1) then Lwt.return_true - else Lwt.return_false - end; - - test "find_node_opt_r Empty" begin fun () -> - let s = Lwt_sequence.create () in - match Lwt_sequence.find_node_opt_r (fun v -> v = 1) s with - | None -> Lwt.return_true - | _ -> Lwt.return_false - end; - - test "find_node_opt_r not found " begin fun () -> - let s = transfer_sequence () in - match Lwt_sequence.find_node_opt_r (fun v -> v = 1) s with - | None -> Lwt.return_true - | _ -> Lwt.return_false - end; - - test "find_node_opt_r" begin fun () -> - let s = filled_sequence () in - match Lwt_sequence.find_node_opt_r (fun v -> v = 1) s with - | None -> Lwt.return_false - | Some n -> if ((Lwt_sequence.get n) = 1) then Lwt.return_true - else Lwt.return_false - end; - - test "find_node_l Empty" begin fun () -> - let s = Lwt_sequence.create () in - Lwt.catch - (fun () -> let n = Lwt_sequence.find_node_l (fun v -> v = 1) s in - if ((Lwt_sequence.get n) = 1) then Lwt.return_false - else Lwt.return_false) - (function - | Not_found -> Lwt.return_true - | _ -> Lwt.return_false) - end; - - test "find_node_l" begin fun () -> - let s = filled_sequence () in - Lwt.catch - (fun () -> let n = Lwt_sequence.find_node_l (fun v -> v = 1) s in - if ((Lwt_sequence.get n) = 1) then Lwt.return_true - else Lwt.return_false) - (function _ -> Lwt.return_false) - end; - - test "find_node_r Empty" begin fun () -> - let s = Lwt_sequence.create () in - Lwt.catch - (fun () -> let n = Lwt_sequence.find_node_r (fun v -> v = 1) s in - if ((Lwt_sequence.get n) = 1) then Lwt.return_false - else Lwt.return_false) - (function - | Not_found -> Lwt.return_true - | _ -> Lwt.return_false) - end; - - test "find_node_r" begin fun () -> - let s = filled_sequence () in - Lwt.catch - (fun () -> let n = Lwt_sequence.find_node_r (fun v -> v = 1) s in - if ((Lwt_sequence.get n) = 1) then Lwt.return_true - else Lwt.return_false) + (fun () -> + iter_f + (fun n -> + assert (Lwt_sequence.get n = array_values.(!index)); + Lwt_sequence.remove n; + index := !index + 1) + seq; + Lwt.return_true) (function _ -> Lwt.return_false) - end; - - test "set" begin fun () -> - let s = filled_sequence () in - match Lwt_sequence.find_node_opt_l (fun v -> v = 4) s with - | None -> Lwt.return_false - | Some n -> let _ = Lwt_sequence.set n 10 in - let data = [|1; 2; 3; 10; 5; 6|] in - test_iter Lwt_sequence.iter_l data s - end; - - test "fold_r with multiple removal" begin fun () -> - let s = filled_sequence () in - let n_three = Lwt_sequence.find_node_r (fun v' -> v' = 3) s in - let n_two = Lwt_sequence.find_node_r (fun v' -> v' = 2) s in - let n_four = Lwt_sequence.find_node_r (fun v' -> v' = 4) s in - let acc = Lwt_sequence.fold_r begin fun v e -> - if v = 3 then begin - let _ = Lwt_sequence.remove n_three in - let _ = Lwt_sequence.remove n_two in - ignore(Lwt_sequence.remove n_four) - end; - v * e - end s 1 in - Lwt.return (acc = (factorial_sequence / 2)) - end; - - test "fold_l multiple removal" begin fun () -> - let s = filled_sequence () in - let n_four = Lwt_sequence.find_node_r (fun v' -> v' = 4) s in - let n_five = Lwt_sequence.find_node_r (fun v' -> v' = 5) s in - let n_three = Lwt_sequence.find_node_r (fun v' -> v' = 3) s in - let acc = Lwt_sequence.fold_l begin fun v e -> - if v = 4 then begin - let _ = Lwt_sequence.remove n_four in - let _ = Lwt_sequence.remove n_five in - ignore(Lwt_sequence.remove n_three) - end; - v * e - end s 1 in - Lwt.return (acc = (factorial_sequence / 5)) - end; - test "find_node_r with multiple removal" begin fun () -> - let s = filled_sequence () in - let n_three = Lwt_sequence.find_node_r (fun v' -> v' = 3) s in - let n_two = Lwt_sequence.find_node_r (fun v' -> v' = 2) s in - Lwt.catch - begin fun () -> - let n = Lwt_sequence.find_node_r begin fun v -> - if v = 3 then ( - let _ = Lwt_sequence.remove n_three in - ignore(Lwt_sequence.remove n_two)); - v = 1 - end s in - let v = Lwt_sequence.get n in - Lwt.return (v = 1) - end - (function _ -> Lwt.return_false) - end; - - test "find_node_l with multiple removal" begin fun () -> - let s = filled_sequence () in - let n_three = Lwt_sequence.find_node_r (fun v' -> v' = 3) s in - let n_four = Lwt_sequence.find_node_r (fun v' -> v' = 4) s in - Lwt.catch - begin fun () -> - let n = Lwt_sequence.find_node_l begin fun v -> - if v = 3 then ( - let _ = Lwt_sequence.remove n_three in - ignore(Lwt_sequence.remove n_four)); - v = 6 end s in - let v = Lwt_sequence.get n in - Lwt.return (v = 6) - end - (function _ -> Lwt.return_false) - end; -] +let suite = + suite "lwt_sequence" + [ + test "create" (fun () -> + let s = Lwt_sequence.create () in + let _ = assert (Lwt_sequence.is_empty s) in + let len = Lwt_sequence.length s in + Lwt.return (len = 0)); + test "add_l" (fun () -> + let s = Lwt_sequence.create () in + let n = Lwt_sequence.add_l 1 s in + let _ = assert (Lwt_sequence.get n = 1) in + let len = Lwt_sequence.length s in + Lwt.return (len = 1)); + test "add_r" (fun () -> + let s = Lwt_sequence.create () in + let n = Lwt_sequence.add_r 1 s in + let _ = assert (Lwt_sequence.get n = 1) in + let len = Lwt_sequence.length s in + Lwt.return (len = 1)); + test "take_l Empty" (fun () -> + let s = Lwt_sequence.create () in + Lwt.catch + (fun () -> + let _ = Lwt_sequence.take_l s in + Lwt.return_false) + (function + | Lwt_sequence.Empty -> Lwt.return_true | _ -> Lwt.return_false)); + test "take_l" (fun () -> + let s = filled_sequence () in + Lwt.catch + (fun () -> + let v = Lwt_sequence.take_l s in + Lwt.return (leftmost_value = v)) + (function _ -> Lwt.return_false)); + test "take_r Empty" (fun () -> + let s = Lwt_sequence.create () in + Lwt.catch + (fun () -> + let _ = Lwt_sequence.take_r s in + Lwt.return_false) + (function + | Lwt_sequence.Empty -> Lwt.return_true | _ -> Lwt.return_false)); + test "take_r" (fun () -> + let s = filled_sequence () in + Lwt.catch + (fun () -> + let v = Lwt_sequence.take_r s in + Lwt.return (rightmost_value = v)) + (function _ -> Lwt.return_false)); + test "take_opt_l Empty" (fun () -> + let s = Lwt_sequence.create () in + match Lwt_sequence.take_opt_l s with + | None -> Lwt.return_true + | _ -> Lwt.return_false); + test "take_opt_l" (fun () -> + let s = filled_sequence () in + match Lwt_sequence.take_opt_l s with + | None -> Lwt.return_false + | Some v -> Lwt.return (leftmost_value = v)); + test "take_opt_r Empty" (fun () -> + let s = Lwt_sequence.create () in + match Lwt_sequence.take_opt_r s with + | None -> Lwt.return_true + | _ -> Lwt.return_false); + test "take_opt_r" (fun () -> + let s = filled_sequence () in + match Lwt_sequence.take_opt_r s with + | None -> Lwt.return_false + | Some v -> Lwt.return (rightmost_value = v)); + test "transfer_l Empty" (fun () -> + let s = filled_sequence () in + let ts = Lwt_sequence.create () in + let _ = Lwt_sequence.transfer_l ts s in + let len = Lwt_sequence.length s in + Lwt.return (filled_length = len)); + test "transfer_l " (fun () -> + let s = filled_sequence () in + let ts = transfer_sequence () in + let _ = Lwt_sequence.transfer_l ts s in + let len = Lwt_sequence.length s in + let _ = assert (filled_length + transfer_length = len) in + match Lwt_sequence.take_opt_l s with + | None -> Lwt.return_false + | Some v -> Lwt.return (7 = v)); + test "transfer_r Empty" (fun () -> + let s = filled_sequence () in + let ts = Lwt_sequence.create () in + let _ = Lwt_sequence.transfer_r ts s in + let len = Lwt_sequence.length s in + Lwt.return (filled_length = len)); + test "transfer_r " (fun () -> + let s = filled_sequence () in + let ts = transfer_sequence () in + let _ = Lwt_sequence.transfer_r ts s in + let len = Lwt_sequence.length s in + let _ = assert (filled_length + transfer_length = len) in + match Lwt_sequence.take_opt_r s with + | None -> Lwt.return_false + | Some v -> Lwt.return (8 = v)); + test "iter_l Empty" (fun () -> + test_iter Lwt_sequence.iter_l empty_array (Lwt_sequence.create ())); + test "iter_l" (fun () -> + test_iter Lwt_sequence.iter_l l_filled_array (filled_sequence ())); + test "iter_r Empty" (fun () -> + test_iter Lwt_sequence.iter_r empty_array (Lwt_sequence.create ())); + test "iter_r" (fun () -> + test_iter Lwt_sequence.iter_r r_filled_array (filled_sequence ())); + test "iter_node_l Empty" (fun () -> + test_iter_node Lwt_sequence.iter_node_l empty_array + (Lwt_sequence.create ())); + test "iter_node_l" (fun () -> + test_iter_node Lwt_sequence.iter_node_l l_filled_array + (filled_sequence ())); + test "iter_node_r Empty" (fun () -> + test_iter_node Lwt_sequence.iter_node_r empty_array + (Lwt_sequence.create ())); + test "iter_node_r" (fun () -> + test_iter_node Lwt_sequence.iter_node_r r_filled_array + (filled_sequence ())); + test "iter_node_l with removal" (fun () -> + test_iter_rem Lwt_sequence.iter_node_l l_filled_array + (filled_sequence ())); + test "iter_node_r with removal" (fun () -> + test_iter_rem Lwt_sequence.iter_node_r r_filled_array + (filled_sequence ())); + test "fold_l" (fun () -> + let acc = + Lwt_sequence.fold_l (fun v e -> v * e) (filled_sequence ()) 1 + in + Lwt.return (factorial_sequence = acc)); + test "fold_l Empty" (fun () -> + let acc = + Lwt_sequence.fold_l (fun v e -> v * e) (Lwt_sequence.create ()) 1 + in + Lwt.return (acc = 1)); + test "fold_r" (fun () -> + let acc = + Lwt_sequence.fold_r (fun v e -> v * e) (filled_sequence ()) 1 + in + Lwt.return (factorial_sequence = acc)); + test "fold_r Empty" (fun () -> + let acc = + Lwt_sequence.fold_r (fun v e -> v * e) (Lwt_sequence.create ()) 1 + in + Lwt.return (acc = 1)); + test "find_node_opt_l Empty" (fun () -> + let s = Lwt_sequence.create () in + match Lwt_sequence.find_node_opt_l (fun v -> v = 1) s with + | None -> Lwt.return_true + | _ -> Lwt.return_false); + test "find_node_opt_l not found " (fun () -> + let s = transfer_sequence () in + match Lwt_sequence.find_node_opt_l (fun v -> v = 1) s with + | None -> Lwt.return_true + | _ -> Lwt.return_false); + test "find_node_opt_l" (fun () -> + let s = filled_sequence () in + match Lwt_sequence.find_node_opt_l (fun v -> v = 1) s with + | None -> Lwt.return_false + | Some n -> + if Lwt_sequence.get n = 1 then Lwt.return_true + else Lwt.return_false); + test "find_node_opt_r Empty" (fun () -> + let s = Lwt_sequence.create () in + match Lwt_sequence.find_node_opt_r (fun v -> v = 1) s with + | None -> Lwt.return_true + | _ -> Lwt.return_false); + test "find_node_opt_r not found " (fun () -> + let s = transfer_sequence () in + match Lwt_sequence.find_node_opt_r (fun v -> v = 1) s with + | None -> Lwt.return_true + | _ -> Lwt.return_false); + test "find_node_opt_r" (fun () -> + let s = filled_sequence () in + match Lwt_sequence.find_node_opt_r (fun v -> v = 1) s with + | None -> Lwt.return_false + | Some n -> + if Lwt_sequence.get n = 1 then Lwt.return_true + else Lwt.return_false); + test "find_node_l Empty" (fun () -> + let s = Lwt_sequence.create () in + Lwt.catch + (fun () -> + let n = Lwt_sequence.find_node_l (fun v -> v = 1) s in + if Lwt_sequence.get n = 1 then Lwt.return_false + else Lwt.return_false) + (function Not_found -> Lwt.return_true | _ -> Lwt.return_false)); + test "find_node_l" (fun () -> + let s = filled_sequence () in + Lwt.catch + (fun () -> + let n = Lwt_sequence.find_node_l (fun v -> v = 1) s in + if Lwt_sequence.get n = 1 then Lwt.return_true + else Lwt.return_false) + (function _ -> Lwt.return_false)); + test "find_node_r Empty" (fun () -> + let s = Lwt_sequence.create () in + Lwt.catch + (fun () -> + let n = Lwt_sequence.find_node_r (fun v -> v = 1) s in + if Lwt_sequence.get n = 1 then Lwt.return_false + else Lwt.return_false) + (function Not_found -> Lwt.return_true | _ -> Lwt.return_false)); + test "find_node_r" (fun () -> + let s = filled_sequence () in + Lwt.catch + (fun () -> + let n = Lwt_sequence.find_node_r (fun v -> v = 1) s in + if Lwt_sequence.get n = 1 then Lwt.return_true + else Lwt.return_false) + (function _ -> Lwt.return_false)); + test "set" (fun () -> + let s = filled_sequence () in + match Lwt_sequence.find_node_opt_l (fun v -> v = 4) s with + | None -> Lwt.return_false + | Some n -> + let _ = Lwt_sequence.set n 10 in + let data = [| 1; 2; 3; 10; 5; 6 |] in + test_iter Lwt_sequence.iter_l data s); + test "fold_r with multiple removal" (fun () -> + let s = filled_sequence () in + let n_three = Lwt_sequence.find_node_r (fun v' -> v' = 3) s in + let n_two = Lwt_sequence.find_node_r (fun v' -> v' = 2) s in + let n_four = Lwt_sequence.find_node_r (fun v' -> v' = 4) s in + let acc = + Lwt_sequence.fold_r + (fun v e -> + (if v = 3 then + let _ = Lwt_sequence.remove n_three in + let _ = Lwt_sequence.remove n_two in + ignore (Lwt_sequence.remove n_four)); + v * e) + s 1 + in + Lwt.return (acc = factorial_sequence / 2)); + test "fold_l multiple removal" (fun () -> + let s = filled_sequence () in + let n_four = Lwt_sequence.find_node_r (fun v' -> v' = 4) s in + let n_five = Lwt_sequence.find_node_r (fun v' -> v' = 5) s in + let n_three = Lwt_sequence.find_node_r (fun v' -> v' = 3) s in + let acc = + Lwt_sequence.fold_l + (fun v e -> + (if v = 4 then + let _ = Lwt_sequence.remove n_four in + let _ = Lwt_sequence.remove n_five in + ignore (Lwt_sequence.remove n_three)); + v * e) + s 1 + in + Lwt.return (acc = factorial_sequence / 5)); + test "find_node_r with multiple removal" (fun () -> + let s = filled_sequence () in + let n_three = Lwt_sequence.find_node_r (fun v' -> v' = 3) s in + let n_two = Lwt_sequence.find_node_r (fun v' -> v' = 2) s in + Lwt.catch + (fun () -> + let n = + Lwt_sequence.find_node_r + (fun v -> + (if v = 3 then + let _ = Lwt_sequence.remove n_three in + ignore (Lwt_sequence.remove n_two)); + v = 1) + s + in + let v = Lwt_sequence.get n in + Lwt.return (v = 1)) + (function _ -> Lwt.return_false)); + test "find_node_l with multiple removal" (fun () -> + let s = filled_sequence () in + let n_three = Lwt_sequence.find_node_r (fun v' -> v' = 3) s in + let n_four = Lwt_sequence.find_node_r (fun v' -> v' = 4) s in + Lwt.catch + (fun () -> + let n = + Lwt_sequence.find_node_l + (fun v -> + (if v = 3 then + let _ = Lwt_sequence.remove n_three in + ignore (Lwt_sequence.remove n_four)); + v = 6) + s + in + let v = Lwt_sequence.get n in + Lwt.return (v = 6)) + (function _ -> Lwt.return_false)); + ] diff --git a/test/core/test_lwt_stream.ml b/test/core/test_lwt_stream.ml index 4451b6a253..4b3f62069d 100644 --- a/test/core/test_lwt_stream.ml +++ b/test/core/test_lwt_stream.ml @@ -1,491 +1,425 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Lwt open Test let expect_exit f = Lwt.catch - (fun () -> - f () >>= fun _ -> - Lwt.return_false) - (function - | Exit -> Lwt.return_true - | e -> Lwt.fail e) - -let suite = suite "lwt_stream" [ - test "from" - (fun () -> - let mvar = Lwt_mvar.create_empty () in - let stream = Lwt_stream.from (fun () -> - Lwt_mvar.take mvar >>= fun x -> - return (Some x)) in - let t1 = Lwt_stream.next stream in - let t2 = Lwt_stream.next stream in - let t3 = Lwt_stream.next stream in - Lwt_mvar.put mvar 1 >>= fun () -> - t1 >>= fun x1 -> - t2 >>= fun x2 -> - t3 >>= fun x3 -> - return ([x1; x2; x3] = [1; 1; 1])); - - test "return" - (fun () -> - let stream = Lwt_stream.return 123 in - if Lwt_stream.is_closed stream then - Lwt_stream.next stream >>= fun x -> return (x = 123) - else - Lwt.return_false); - - test "return_lwt" - (fun () -> - let lwt = Lwt.return 123 in - let stream = Lwt_stream.return_lwt lwt in - Lwt_stream.next stream >>= fun x -> - return (x = 123 && Lwt_stream.is_closed stream)); - - test "return_lwt_with_pause" - (fun () -> - let lwt = Lwt.pause () >>= fun () -> Lwt.return 123 in - let stream = Lwt_stream.return_lwt lwt in - Lwt_stream.next stream >>= fun x -> - return (x = 123 && Lwt_stream.is_closed stream)); - - test "return_lwt_with_fail" - (fun () -> - let lwt = Lwt.pause () >>= fun () -> raise (Failure "not today no") in - let stream = Lwt_stream.return_lwt lwt in - Lwt.catch - (fun () -> - Lwt_stream.next stream >>= fun _ -> - Lwt.return_false) - (function - | Lwt_stream.Empty -> Lwt.return_true - | exc -> raise exc)); - - test "of_seq" - (fun () -> - let x = ref false in - let nil = fun () -> x := not !x; Seq.Nil in - let seq = fun () -> Seq.Cons (1, nil) in - let stream = Lwt_stream.of_seq seq in - let x_before = !x in - let closed_before = Lwt_stream.is_closed stream in - Lwt_stream.get stream >>= fun x1 -> - let x_middle = !x in - Lwt_stream.get stream >>= fun x2 -> - let x_after = !x in - let closed_after = Lwt_stream.is_closed stream in - return ([closed_before; closed_after] = [false; true] - && [x_before; x_middle; x_after] = [false; false; true] - && [x1; x2] = [Some 1; None])); - - test "of_lwt_seq" - (fun () -> - let x = ref false in - let nil = fun () -> Lwt.pause () >|= fun () -> x := not !x; Lwt_seq.Nil in - let seq = fun () -> Lwt.pause () >|= fun () -> Lwt_seq.Cons (1, nil) in - let stream = Lwt_stream.of_lwt_seq seq in - let x_before = !x in - let closed_before = Lwt_stream.is_closed stream in - Lwt_stream.get stream >>= fun x1 -> - let x_middle = !x in - Lwt_stream.get stream >>= fun x2 -> - let x_after = !x in - let closed_after = Lwt_stream.is_closed stream in - return ([closed_before; closed_after] = [false; true] - && [x_before; x_middle; x_after] = [false; false; true] - && [x1; x2] = [Some 1; None])); - - test "of_list" - (fun () -> - let stream = Lwt_stream.of_list [1; 2; 3] in - Lwt_stream.next stream >>= fun x1 -> - Lwt_stream.next stream >>= fun x2 -> - Lwt_stream.next stream >>= fun x3 -> - return ([x1; x2; x3] = [1; 2; 3])); - - test "clone" - (fun () -> - let stream1 = Lwt_stream.of_list [1; 2; 3] in - let stream2 = Lwt_stream.clone stream1 in - Lwt_stream.next stream1 >>= fun x1_1 -> - Lwt_stream.next stream2 >>= fun x2_1 -> - Lwt_stream.next stream1 >>= fun x1_2 -> - Lwt_stream.next stream1 >>= fun x1_3 -> - Lwt_stream.next stream2 >>= fun x2_2 -> - Lwt_stream.next stream2 >>= fun x2_3 -> - return ([x1_1; x1_2; x1_3] = [1; 2; 3] && [x2_1; x2_2; x2_3] = [1; 2; 3])); - - test "clone 2" - (fun () -> - let stream1, push = Lwt_stream.create () in - push (Some 1); - let stream2 = Lwt_stream.clone stream1 in - let x1_1 = poll (Lwt_stream.next stream1) in - let x1_2 = poll (Lwt_stream.next stream1) in - let x2_1 = poll (Lwt_stream.next stream2) in - let x2_2 = poll (Lwt_stream.next stream2) in - return ([x1_1;x1_2;x2_1;x2_2] = [Some 1;None;Some 1;None])); - - test "create" - (fun () -> - let stream, push = Lwt_stream.create () in - push (Some 1); - push (Some 2); - push (Some 3); - push None; - Lwt_stream.to_list stream >>= fun l -> - return (l = [1; 2; 3])); - - test "create 2" - (fun () -> - let stream, push = Lwt_stream.create () in - push None; - let t = Lwt_stream.next stream in - return (Lwt.state t = Fail Lwt_stream.Empty)); - - test "create_bounded" - (fun () -> - let stream, push = Lwt_stream.create_bounded 3 in - let acc = true in - let acc = acc && state (push#push 1) = Return () in - let acc = acc && state (push#push 2) = Return () in - let acc = acc && state (push#push 3) = Return () in - let t = push#push 4 in - let acc = acc && state t = Sleep in - let acc = acc && state (push#push 5) = Fail Lwt_stream.Full in - let acc = acc && state (push#push 6) = Fail Lwt_stream.Full in - let acc = acc && state (Lwt_stream.get stream) = Return (Some 1) in - (* Lwt_stream uses wakeup_later so we have to wait a bit. *) - Lwt.pause () >>= fun () -> - let acc = acc && state t = Return () in - let acc = acc && state (Lwt_stream.get stream) = Return (Some 2) in - let acc = acc && state (push#push 7) = Return () in - push#close; - let acc = acc && state (push#push 8) = Fail Lwt_stream.Closed in - let acc = acc && state (Lwt_stream.to_list stream) = Return [3; 4; 7] in - return acc); - - test "create_bounded close" - (fun () -> - let stream, push = Lwt_stream.create_bounded 1 in - let acc = true in - let acc = acc && state (push#push 1) = Return () in - let iter_delayed = Lwt_stream.to_list stream in - Lwt.pause () >>= fun () -> - push#close; - Lwt.pause () >>= fun () -> - let acc = acc && state iter_delayed = Return [1] in - return acc - ); - - test "get_while" - (fun () -> - let stream = Lwt_stream.of_list [1; 2; 3; 4; 5] in - Lwt_stream.get_while (fun x -> x < 3) stream >>= fun l1 -> - Lwt_stream.to_list stream >>= fun l2 -> - return (l1 = [1; 2] && l2 = [3; 4; 5])); - - test "peek" - (fun () -> - let stream = Lwt_stream.of_list [1; 2; 3; 4; 5] in - Lwt_stream.peek stream >>= fun x -> - Lwt_stream.peek stream >>= fun y -> - Lwt_stream.to_list stream >>= fun l -> - return (x = Some 1 && y = Some 1 && l = [1; 2; 3; 4; 5])); - - test "npeek" - (fun () -> - let stream = Lwt_stream.of_list [1; 2; 3; 4; 5] in - Lwt_stream.npeek 3 stream >>= fun x -> - Lwt_stream.npeek 1 stream >>= fun y -> - Lwt_stream.to_list stream >>= fun l -> - return (x = [1; 2; 3] && y = [1] && l = [1; 2; 3; 4; 5])); - - test "get_available" - (fun () -> - let stream, push = Lwt_stream.create () in - push (Some 1); - push (Some 2); - push (Some 3); - let l = Lwt_stream.get_available stream in - push (Some 4); - Lwt_stream.get stream >>= fun x -> - return (l = [1; 2; 3] && x = Some 4)); - - test "get_available_up_to" - (fun () -> - let stream, push = Lwt_stream.create () in - push (Some 1); - push (Some 2); - push (Some 3); - push (Some 4); - let l = Lwt_stream.get_available_up_to 2 stream in - Lwt_stream.get stream >>= fun x -> - return (l = [1; 2] && x = Some 3)); - - test "filter" - (fun () -> - let stream, push = Lwt_stream.create () in - push (Some 1); - push (Some 2); - push (Some 3); - push (Some 4); - let filtered = Lwt_stream.filter ((=) 3) stream in - Lwt_stream.get filtered >>= fun x -> - let l = Lwt_stream.get_available filtered in - return (x = Some 3 && l = [])); - - test "filter_map" - (fun () -> - let stream, push = Lwt_stream.create () in - push (Some 1); - push (Some 2); - push (Some 3); - push (Some 4); - let filtered = Lwt_stream.filter_map (function 3 -> Some "3" | _ -> None ) stream in - Lwt_stream.get filtered >>= fun x -> - let l = Lwt_stream.get_available filtered in - return (x = Some "3" && l = [])); - - test "last_new" - (fun () -> - let stream, push = Lwt_stream.create () in - push (Some 1); - push (Some 2); - push (Some 3); - Lwt_stream.last_new stream >>= fun x -> - return (x = 3)); - - test "cancel push stream 1" - (fun () -> - let stream, _ = Lwt_stream.create () in - let t = Lwt_stream.next stream in - cancel t; - return (state t = Fail Canceled)); - - test "cancel push stream 2" - (fun () -> - let stream, push = Lwt_stream.create () in - let t = Lwt_stream.next stream in - cancel t; - push (Some 1); - let t' = Lwt_stream.next stream in - return (state t' = Return 1)); - - test "cancel push stream 3" - (fun () -> - let stream, push = Lwt_stream.create () in - let t1 = Lwt_stream.next stream in - let t2 = Lwt_stream.next stream in - cancel t1; - push (Some 1); - t2 >>= fun t2_value -> - return (state t1 = Fail Canceled && t2_value = 1)); - - (* check if the push function keeps references to the elements in - the stream *) - test "push and GC" - (fun () -> - let w = Weak.create 5 in - (* Count the number of reachable elements in the stream. *) - let count () = - let rec loop acc idx = - if idx = Weak.length w then - acc - else - match Weak.get w idx with - | None -> loop acc (idx + 1) - | Some _ -> loop (acc + 1) (idx + 1) - in - loop 0 0 - in - (* Run some test and return the push function of the stream. *) - let test () = - let stream, push = Lwt_stream.create () in - assert (count () = 0); - let r1 = Some(ref 1) in - push r1; - Weak.set w 1 r1; - let r2 = Some(ref 2) in - push r2; - Weak.set w 2 r2; - let r3 = Some(ref 3) in - push r3; - Weak.set w 3 r3; - assert (count () = 3); - assert (state (Lwt_stream.next stream) = Return {contents = 1}); - Gc.full_major (); - (* Ocaml can consider that stream is unreachable before the - next line, hence freeing the whole data. *) - assert (count () <= 3); - push - in - let push = test () in - Gc.full_major (); - (* At this point [stream] is unreachable. *) - assert (count () = 0); - (* We have that to force caml to keep a reference on [push]. *) - push (Some(ref 4)); - return true); - - test "map_exn" - (fun () -> - let l = - [Result.Ok 1; - Result.Error Exit; - Result.Error (Failure "plop"); - Result.Ok 42; - Result.Error End_of_file] - in - let q = ref l in - let stream = - Lwt_stream.from - (fun () -> - match !q with - | [] -> - return None - | (Result.Ok x)::l -> + (fun () -> f () >>= fun _ -> Lwt.return_false) + (function Exit -> Lwt.return_true | e -> Lwt.fail e) + +let suite = + suite "lwt_stream" + [ + test "from" (fun () -> + let mvar = Lwt_mvar.create_empty () in + let stream = + Lwt_stream.from (fun () -> + Lwt_mvar.take mvar >>= fun x -> return (Some x)) + in + let t1 = Lwt_stream.next stream in + let t2 = Lwt_stream.next stream in + let t3 = Lwt_stream.next stream in + Lwt_mvar.put mvar 1 >>= fun () -> + t1 >>= fun x1 -> + t2 >>= fun x2 -> + t3 >>= fun x3 -> return ([ x1; x2; x3 ] = [ 1; 1; 1 ])); + test "return" (fun () -> + let stream = Lwt_stream.return 123 in + if Lwt_stream.is_closed stream then + Lwt_stream.next stream >>= fun x -> return (x = 123) + else Lwt.return_false); + test "return_lwt" (fun () -> + let lwt = Lwt.return 123 in + let stream = Lwt_stream.return_lwt lwt in + Lwt_stream.next stream >>= fun x -> + return (x = 123 && Lwt_stream.is_closed stream)); + test "return_lwt_with_pause" (fun () -> + let lwt = Lwt.pause () >>= fun () -> Lwt.return 123 in + let stream = Lwt_stream.return_lwt lwt in + Lwt_stream.next stream >>= fun x -> + return (x = 123 && Lwt_stream.is_closed stream)); + test "return_lwt_with_fail" (fun () -> + let lwt = Lwt.pause () >>= fun () -> raise (Failure "not today no") in + let stream = Lwt_stream.return_lwt lwt in + Lwt.catch + (fun () -> Lwt_stream.next stream >>= fun _ -> Lwt.return_false) + (function Lwt_stream.Empty -> Lwt.return_true | exc -> raise exc)); + test "of_seq" (fun () -> + let x = ref false in + let nil () = + x := not !x; + Seq.Nil + in + let seq () = Seq.Cons (1, nil) in + let stream = Lwt_stream.of_seq seq in + let x_before = !x in + let closed_before = Lwt_stream.is_closed stream in + Lwt_stream.get stream >>= fun x1 -> + let x_middle = !x in + Lwt_stream.get stream >>= fun x2 -> + let x_after = !x in + let closed_after = Lwt_stream.is_closed stream in + return + ([ closed_before; closed_after ] = [ false; true ] + && [ x_before; x_middle; x_after ] = [ false; false; true ] + && [ x1; x2 ] = [ Some 1; None ])); + test "of_lwt_seq" (fun () -> + let x = ref false in + let nil () = + Lwt.pause () >|= fun () -> + x := not !x; + Lwt_seq.Nil + in + let seq () = Lwt.pause () >|= fun () -> Lwt_seq.Cons (1, nil) in + let stream = Lwt_stream.of_lwt_seq seq in + let x_before = !x in + let closed_before = Lwt_stream.is_closed stream in + Lwt_stream.get stream >>= fun x1 -> + let x_middle = !x in + Lwt_stream.get stream >>= fun x2 -> + let x_after = !x in + let closed_after = Lwt_stream.is_closed stream in + return + ([ closed_before; closed_after ] = [ false; true ] + && [ x_before; x_middle; x_after ] = [ false; false; true ] + && [ x1; x2 ] = [ Some 1; None ])); + test "of_list" (fun () -> + let stream = Lwt_stream.of_list [ 1; 2; 3 ] in + Lwt_stream.next stream >>= fun x1 -> + Lwt_stream.next stream >>= fun x2 -> + Lwt_stream.next stream >>= fun x3 -> + return ([ x1; x2; x3 ] = [ 1; 2; 3 ])); + test "clone" (fun () -> + let stream1 = Lwt_stream.of_list [ 1; 2; 3 ] in + let stream2 = Lwt_stream.clone stream1 in + Lwt_stream.next stream1 >>= fun x1_1 -> + Lwt_stream.next stream2 >>= fun x2_1 -> + Lwt_stream.next stream1 >>= fun x1_2 -> + Lwt_stream.next stream1 >>= fun x1_3 -> + Lwt_stream.next stream2 >>= fun x2_2 -> + Lwt_stream.next stream2 >>= fun x2_3 -> + return + ([ x1_1; x1_2; x1_3 ] = [ 1; 2; 3 ] + && [ x2_1; x2_2; x2_3 ] = [ 1; 2; 3 ])); + test "clone 2" (fun () -> + let stream1, push = Lwt_stream.create () in + push (Some 1); + let stream2 = Lwt_stream.clone stream1 in + let x1_1 = poll (Lwt_stream.next stream1) in + let x1_2 = poll (Lwt_stream.next stream1) in + let x2_1 = poll (Lwt_stream.next stream2) in + let x2_2 = poll (Lwt_stream.next stream2) in + return ([ x1_1; x1_2; x2_1; x2_2 ] = [ Some 1; None; Some 1; None ])); + test "create" (fun () -> + let stream, push = Lwt_stream.create () in + push (Some 1); + push (Some 2); + push (Some 3); + push None; + Lwt_stream.to_list stream >>= fun l -> return (l = [ 1; 2; 3 ])); + test "create 2" (fun () -> + let stream, push = Lwt_stream.create () in + push None; + let t = Lwt_stream.next stream in + return (Lwt.state t = Fail Lwt_stream.Empty)); + test "create_bounded" (fun () -> + let stream, push = Lwt_stream.create_bounded 3 in + let acc = true in + let acc = acc && state (push#push 1) = Return () in + let acc = acc && state (push#push 2) = Return () in + let acc = acc && state (push#push 3) = Return () in + let t = push#push 4 in + let acc = acc && state t = Sleep in + let acc = acc && state (push#push 5) = Fail Lwt_stream.Full in + let acc = acc && state (push#push 6) = Fail Lwt_stream.Full in + let acc = acc && state (Lwt_stream.get stream) = Return (Some 1) in + (* Lwt_stream uses wakeup_later so we have to wait a bit. *) + Lwt.pause () >>= fun () -> + let acc = acc && state t = Return () in + let acc = acc && state (Lwt_stream.get stream) = Return (Some 2) in + let acc = acc && state (push#push 7) = Return () in + push#close; + let acc = acc && state (push#push 8) = Fail Lwt_stream.Closed in + let acc = + acc && state (Lwt_stream.to_list stream) = Return [ 3; 4; 7 ] + in + return acc); + test "create_bounded close" (fun () -> + let stream, push = Lwt_stream.create_bounded 1 in + let acc = true in + let acc = acc && state (push#push 1) = Return () in + let iter_delayed = Lwt_stream.to_list stream in + Lwt.pause () >>= fun () -> + push#close; + Lwt.pause () >>= fun () -> + let acc = acc && state iter_delayed = Return [ 1 ] in + return acc); + test "get_while" (fun () -> + let stream = Lwt_stream.of_list [ 1; 2; 3; 4; 5 ] in + Lwt_stream.get_while (fun x -> x < 3) stream >>= fun l1 -> + Lwt_stream.to_list stream >>= fun l2 -> + return (l1 = [ 1; 2 ] && l2 = [ 3; 4; 5 ])); + test "peek" (fun () -> + let stream = Lwt_stream.of_list [ 1; 2; 3; 4; 5 ] in + Lwt_stream.peek stream >>= fun x -> + Lwt_stream.peek stream >>= fun y -> + Lwt_stream.to_list stream >>= fun l -> + return (x = Some 1 && y = Some 1 && l = [ 1; 2; 3; 4; 5 ])); + test "npeek" (fun () -> + let stream = Lwt_stream.of_list [ 1; 2; 3; 4; 5 ] in + Lwt_stream.npeek 3 stream >>= fun x -> + Lwt_stream.npeek 1 stream >>= fun y -> + Lwt_stream.to_list stream >>= fun l -> + return (x = [ 1; 2; 3 ] && y = [ 1 ] && l = [ 1; 2; 3; 4; 5 ])); + test "get_available" (fun () -> + let stream, push = Lwt_stream.create () in + push (Some 1); + push (Some 2); + push (Some 3); + let l = Lwt_stream.get_available stream in + push (Some 4); + Lwt_stream.get stream >>= fun x -> + return (l = [ 1; 2; 3 ] && x = Some 4)); + test "get_available_up_to" (fun () -> + let stream, push = Lwt_stream.create () in + push (Some 1); + push (Some 2); + push (Some 3); + push (Some 4); + let l = Lwt_stream.get_available_up_to 2 stream in + Lwt_stream.get stream >>= fun x -> return (l = [ 1; 2 ] && x = Some 3)); + test "filter" (fun () -> + let stream, push = Lwt_stream.create () in + push (Some 1); + push (Some 2); + push (Some 3); + push (Some 4); + let filtered = Lwt_stream.filter (( = ) 3) stream in + Lwt_stream.get filtered >>= fun x -> + let l = Lwt_stream.get_available filtered in + return (x = Some 3 && l = [])); + test "filter_map" (fun () -> + let stream, push = Lwt_stream.create () in + push (Some 1); + push (Some 2); + push (Some 3); + push (Some 4); + let filtered = + Lwt_stream.filter_map (function 3 -> Some "3" | _ -> None) stream + in + Lwt_stream.get filtered >>= fun x -> + let l = Lwt_stream.get_available filtered in + return (x = Some "3" && l = [])); + test "last_new" (fun () -> + let stream, push = Lwt_stream.create () in + push (Some 1); + push (Some 2); + push (Some 3); + Lwt_stream.last_new stream >>= fun x -> return (x = 3)); + test "cancel push stream 1" (fun () -> + let stream, _ = Lwt_stream.create () in + let t = Lwt_stream.next stream in + cancel t; + return (state t = Fail Canceled)); + test "cancel push stream 2" (fun () -> + let stream, push = Lwt_stream.create () in + let t = Lwt_stream.next stream in + cancel t; + push (Some 1); + let t' = Lwt_stream.next stream in + return (state t' = Return 1)); + test "cancel push stream 3" (fun () -> + let stream, push = Lwt_stream.create () in + let t1 = Lwt_stream.next stream in + let t2 = Lwt_stream.next stream in + cancel t1; + push (Some 1); + t2 >>= fun t2_value -> + return (state t1 = Fail Canceled && t2_value = 1)); + (* check if the push function keeps references to the elements in + the stream *) + test "push and GC" (fun () -> + let w = Weak.create 5 in + (* Count the number of reachable elements in the stream. *) + let count () = + let rec loop acc idx = + if idx = Weak.length w then acc + else + match Weak.get w idx with + | None -> loop acc (idx + 1) + | Some _ -> loop (acc + 1) (idx + 1) + in + loop 0 0 + in + (* Run some test and return the push function of the stream. *) + let test () = + let stream, push = Lwt_stream.create () in + assert (count () = 0); + let r1 = Some (ref 1) in + push r1; + Weak.set w 1 r1; + let r2 = Some (ref 2) in + push r2; + Weak.set w 2 r2; + let r3 = Some (ref 3) in + push r3; + Weak.set w 3 r3; + assert (count () = 3); + assert (state (Lwt_stream.next stream) = Return { contents = 1 }); + Gc.full_major (); + (* Ocaml can consider that stream is unreachable before the + next line, hence freeing the whole data. *) + assert (count () <= 3); + push + in + let push = test () in + Gc.full_major (); + (* At this point [stream] is unreachable. *) + assert (count () = 0); + (* We have that to force caml to keep a reference on [push]. *) + push (Some (ref 4)); + return true); + test "map_exn" (fun () -> + let l = + [ + Result.Ok 1; + Result.Error Exit; + Result.Error (Failure "plop"); + Result.Ok 42; + Result.Error End_of_file; + ] + in + let q = ref l in + let stream = + Lwt_stream.from (fun () -> + match !q with + | [] -> return None + | Result.Ok x :: l -> q := l; return (Some x) - | (Result.Error e)::l -> + | Result.Error e :: l -> q := l; Lwt.fail e) - in - Lwt_stream.to_list (Lwt_stream.wrap_exn stream) >>= fun l' -> - return (l = l')); - - test "is_closed" - (fun () -> - let b1 = Lwt_stream.(is_closed (of_list [])) in - let b2 = Lwt_stream.(is_closed (of_list [1;2;3])) in - let b3 = Lwt_stream.(is_closed (of_array [||])) in - let b4 = Lwt_stream.(is_closed (of_array [|1;2;3;|])) in - let b5 = Lwt_stream.(is_closed (of_string "")) in - let b6 = Lwt_stream.(is_closed (of_string "123")) in - let b7 = Lwt_stream.(is_closed (from_direct (fun () -> Some 1))) in - let st = Lwt_stream.from_direct (fun () -> None) in - let b8 = Lwt_stream.is_closed st in - ignore (Lwt_stream.junk st); - let b9 = Lwt_stream.is_closed st in - return (b1 && b2 && b3 && b4 && b5 && b6 && not b7 && not b8 && b9)); - - test "closed" - (fun () -> - let st = Lwt_stream.from_direct ( - let value = ref (Some 1) in - fun () -> let r = !value in value := None; r) - in - let b = ref false in - Lwt.async (fun () -> - Lwt_stream.closed st >|= fun () -> b := Lwt_stream.is_closed st); - ignore (Lwt_stream.peek st); - let b1 = !b = false in - ignore (Lwt_stream.junk st); - ignore (Lwt_stream.peek st); - let b2 = !b = true in - return (b1 && b2)); - - test "on_termination" - (fun () -> - let st = Lwt_stream.from_direct ( - let value = ref (Some 1) in - fun () -> let r = !value in value := None; r) - in - let b = ref false in - (Lwt_stream.on_termination [@ocaml.warning "-3"]) - st (fun () -> b := true); - ignore (Lwt_stream.peek st); - let b1 = !b = false in - ignore (Lwt_stream.junk st); - ignore (Lwt_stream.peek st); - let b2 = !b = true in - let b3 = Lwt_stream.is_closed st in - Lwt.return (b1 && b2 && b3)); - - test "on_termination when closed" - (fun () -> - let st = Lwt_stream.of_list [] in - let b = ref false in - let b1 = Lwt_stream.is_closed st in - (Lwt_stream.on_termination [@ocaml.warning "-3"]) - st (fun () -> b := true); - Lwt.return (b1 && !b)); - - test "choose_exhausted" - (fun () -> - let open! Lwt_stream in - to_list (choose [of_list []]) >|= fun _ -> true); - - test "exception passing: basic, from" - (fun () -> - let stream = Lwt_stream.from (fun () -> Lwt.fail Exit) in - expect_exit (fun () -> Lwt_stream.get stream)); - - test "exception passing: basic, from_direct" - (fun () -> - let stream = Lwt_stream.from_direct (fun () -> raise Exit) in - expect_exit (fun () -> Lwt_stream.get stream)); - - test "exception passing: to_list" - (fun () -> - let stream = Lwt_stream.from (fun () -> Lwt.fail Exit) in - expect_exit (fun () -> Lwt_stream.to_list stream)); - - test "exception passing: mapped" - (fun () -> - let stream = Lwt_stream.from (fun () -> Lwt.fail Exit) in - let stream = Lwt_stream.map (fun v -> v) stream in - expect_exit (fun () -> Lwt_stream.get stream)); - - test "exception passing: resume, not closed, from" - (fun () -> - let to_feed = ref (Lwt.fail Exit) in - let stream = Lwt_stream.from (fun () -> !to_feed) in - - expect_exit (fun () -> Lwt_stream.get stream) >>= fun got_exit -> - let closed_after_exit = Lwt_stream.is_closed stream in - - to_feed := Lwt.return (Some 0); - Lwt_stream.get stream >>= fun v -> - let got_zero = (v = Some 0) in - - to_feed := Lwt.return_none; - Lwt_stream.get stream >>= fun v -> - let got_none = (v = None) in - let closed_at_end = Lwt_stream.is_closed stream in - - Lwt.return - (got_exit && - not closed_after_exit && - got_zero && - got_none && - closed_at_end)); - - test "exception passing: resume, not closed, from_direct" - (fun () -> - let to_feed = ref (fun () -> raise Exit) in - let stream = Lwt_stream.from_direct (fun () -> !to_feed ()) in - - expect_exit (fun () -> Lwt_stream.get stream) >>= fun got_exit -> - let closed_after_exit = Lwt_stream.is_closed stream in - - to_feed := (fun () -> Some 0); - Lwt_stream.get stream >>= fun v -> - let got_zero = (v = Some 0) in - - to_feed := (fun () -> None); - Lwt_stream.get stream >>= fun v -> - let got_none = (v = None) in - let closed_at_end = Lwt_stream.is_closed stream in - - Lwt.return - (got_exit && - not closed_after_exit && - got_zero && - got_none && - closed_at_end)); -] + in + Lwt_stream.to_list (Lwt_stream.wrap_exn stream) >>= fun l' -> + return (l = l')); + test "is_closed" (fun () -> + let b1 = Lwt_stream.(is_closed (of_list [])) in + let b2 = Lwt_stream.(is_closed (of_list [ 1; 2; 3 ])) in + let b3 = Lwt_stream.(is_closed (of_array [||])) in + let b4 = Lwt_stream.(is_closed (of_array [| 1; 2; 3 |])) in + let b5 = Lwt_stream.(is_closed (of_string "")) in + let b6 = Lwt_stream.(is_closed (of_string "123")) in + let b7 = Lwt_stream.(is_closed (from_direct (fun () -> Some 1))) in + let st = Lwt_stream.from_direct (fun () -> None) in + let b8 = Lwt_stream.is_closed st in + ignore (Lwt_stream.junk st); + let b9 = Lwt_stream.is_closed st in + return (b1 && b2 && b3 && b4 && b5 && b6 && (not b7) && (not b8) && b9)); + test "closed" (fun () -> + let st = + Lwt_stream.from_direct + (let value = ref (Some 1) in + fun () -> + let r = !value in + value := None; + r) + in + let b = ref false in + Lwt.async (fun () -> + Lwt_stream.closed st >|= fun () -> b := Lwt_stream.is_closed st); + ignore (Lwt_stream.peek st); + let b1 = !b = false in + ignore (Lwt_stream.junk st); + ignore (Lwt_stream.peek st); + let b2 = !b = true in + return (b1 && b2)); + test "on_termination" (fun () -> + let st = + Lwt_stream.from_direct + (let value = ref (Some 1) in + fun () -> + let r = !value in + value := None; + r) + in + let b = ref false in + (Lwt_stream.on_termination [@ocaml.warning "-3"]) st (fun () -> + b := true); + ignore (Lwt_stream.peek st); + let b1 = !b = false in + ignore (Lwt_stream.junk st); + ignore (Lwt_stream.peek st); + let b2 = !b = true in + let b3 = Lwt_stream.is_closed st in + Lwt.return (b1 && b2 && b3)); + test "on_termination when closed" (fun () -> + let st = Lwt_stream.of_list [] in + let b = ref false in + let b1 = Lwt_stream.is_closed st in + (Lwt_stream.on_termination [@ocaml.warning "-3"]) st (fun () -> + b := true); + Lwt.return (b1 && !b)); + test "choose_exhausted" (fun () -> + let open! Lwt_stream in + to_list (choose [ of_list [] ]) >|= fun _ -> true); + test "exception passing: basic, from" (fun () -> + let stream = Lwt_stream.from (fun () -> Lwt.fail Exit) in + expect_exit (fun () -> Lwt_stream.get stream)); + test "exception passing: basic, from_direct" (fun () -> + let stream = Lwt_stream.from_direct (fun () -> raise Exit) in + expect_exit (fun () -> Lwt_stream.get stream)); + test "exception passing: to_list" (fun () -> + let stream = Lwt_stream.from (fun () -> Lwt.fail Exit) in + expect_exit (fun () -> Lwt_stream.to_list stream)); + test "exception passing: mapped" (fun () -> + let stream = Lwt_stream.from (fun () -> Lwt.fail Exit) in + let stream = Lwt_stream.map (fun v -> v) stream in + expect_exit (fun () -> Lwt_stream.get stream)); + test "exception passing: resume, not closed, from" (fun () -> + let to_feed = ref (Lwt.fail Exit) in + let stream = Lwt_stream.from (fun () -> !to_feed) in + + expect_exit (fun () -> Lwt_stream.get stream) >>= fun got_exit -> + let closed_after_exit = Lwt_stream.is_closed stream in + + to_feed := Lwt.return (Some 0); + Lwt_stream.get stream >>= fun v -> + let got_zero = v = Some 0 in + + to_feed := Lwt.return_none; + Lwt_stream.get stream >>= fun v -> + let got_none = v = None in + let closed_at_end = Lwt_stream.is_closed stream in + + Lwt.return + (got_exit + && (not closed_after_exit) + && got_zero + && got_none + && closed_at_end)); + test "exception passing: resume, not closed, from_direct" (fun () -> + let to_feed = ref (fun () -> raise Exit) in + let stream = Lwt_stream.from_direct (fun () -> !to_feed ()) in + + expect_exit (fun () -> Lwt_stream.get stream) >>= fun got_exit -> + let closed_after_exit = Lwt_stream.is_closed stream in + + (to_feed := fun () -> Some 0); + Lwt_stream.get stream >>= fun v -> + let got_zero = v = Some 0 in + + (to_feed := fun () -> None); + Lwt_stream.get stream >>= fun v -> + let got_none = v = None in + let closed_at_end = Lwt_stream.is_closed stream in + + Lwt.return + (got_exit + && (not closed_after_exit) + && got_zero + && got_none + && closed_at_end)); + ] diff --git a/test/core/test_lwt_switch.ml b/test/core/test_lwt_switch.ml index 354760be89..101aaf5205 100644 --- a/test/core/test_lwt_switch.ml +++ b/test/core/test_lwt_switch.ml @@ -1,180 +1,161 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Lwt.Infix open Test -let suite = suite "lwt_switch" [ - test "turn_off, add_hook" - (fun () -> - let hook_1_calls = ref 0 in - let hook_2_calls = ref 0 in - - let hook call_counter () = - call_counter := !call_counter + 1; - Lwt.return_unit - in - - let switch = Lwt_switch.create () in - Lwt_switch.add_hook (Some switch) (hook hook_1_calls); - Lwt_switch.add_hook (Some switch) (hook hook_2_calls); - - let check_1 = !hook_1_calls = 0 in - let check_2 = !hook_2_calls = 0 in - - Lwt_switch.turn_off switch >>= fun () -> - - let check_3 = !hook_1_calls = 1 in - let check_4 = !hook_2_calls = 1 in - - Lwt_switch.turn_off switch >|= fun () -> - - let check_5 = !hook_1_calls = 1 in - let check_6 = !hook_2_calls = 1 in - - let check_7 = - try - Lwt_switch.add_hook (Some switch) (fun () -> Lwt.return_unit); - false - with Lwt_switch.Off -> - true - in - - check_1 && check_2 && check_3 && check_4 && check_5 && check_6 && - check_7); - - test "turn_off: hook exception" - (fun () -> - let hook () = raise Exit in - - let switch = Lwt_switch.create () in - Lwt_switch.add_hook (Some switch) hook; - - Lwt.catch - (fun () -> Lwt_switch.turn_off switch >|= fun () -> false) - (function - | Exit -> Lwt.return_true - | _ -> Lwt.return_false)); - - test "with_switch: regular exit" - (fun () -> - let hook_called = ref false in - - Lwt_switch.with_switch (fun switch -> - Lwt_switch.add_hook (Some switch) (fun () -> - hook_called := true; - Lwt.return_unit); - - Lwt.return_unit) - - >|= fun () -> !hook_called); - - test "with_switch: exception" - (fun () -> - let hook_called = ref false in - let exception_caught = ref false in +let suite = + suite "lwt_switch" + [ + test "turn_off, add_hook" (fun () -> + let hook_1_calls = ref 0 in + let hook_2_calls = ref 0 in + + let hook call_counter () = + call_counter := !call_counter + 1; + Lwt.return_unit + in + + let switch = Lwt_switch.create () in + Lwt_switch.add_hook (Some switch) (hook hook_1_calls); + Lwt_switch.add_hook (Some switch) (hook hook_2_calls); + + let check_1 = !hook_1_calls = 0 in + let check_2 = !hook_2_calls = 0 in + + Lwt_switch.turn_off switch >>= fun () -> + let check_3 = !hook_1_calls = 1 in + let check_4 = !hook_2_calls = 1 in + + Lwt_switch.turn_off switch >|= fun () -> + let check_5 = !hook_1_calls = 1 in + let check_6 = !hook_2_calls = 1 in + + let check_7 = + try + Lwt_switch.add_hook (Some switch) (fun () -> Lwt.return_unit); + false + with Lwt_switch.Off -> true + in + + check_1 + && check_2 + && check_3 + && check_4 + && check_5 + && check_6 + && check_7); + test "turn_off: hook exception" (fun () -> + let hook () = raise Exit in + + let switch = Lwt_switch.create () in + Lwt_switch.add_hook (Some switch) hook; + + Lwt.catch + (fun () -> Lwt_switch.turn_off switch >|= fun () -> false) + (function Exit -> Lwt.return_true | _ -> Lwt.return_false)); + test "with_switch: regular exit" (fun () -> + let hook_called = ref false in - Lwt.catch - (fun () -> Lwt_switch.with_switch (fun switch -> - Lwt_switch.add_hook (Some switch) (fun () -> - hook_called := true; - Lwt.return_unit); - - raise Exit)) - (function - | Exit -> - exception_caught := true; - Lwt.return_unit - | _ -> - Lwt.return_unit) - - >|= fun () -> !hook_called && !exception_caught); - - test "check" - (fun () -> - Lwt_switch.check None; - - let switch = Lwt_switch.create () in - Lwt_switch.check (Some switch); - - Lwt_switch.turn_off switch >|= fun () -> - try Lwt_switch.check (Some switch); false - with Lwt_switch.Off -> true); - - test "is_on" - (fun () -> - let switch = Lwt_switch.create () in - let check_1 = Lwt_switch.is_on switch in - Lwt_switch.turn_off switch >|= fun () -> - let check_2 = not (Lwt_switch.is_on switch) in - check_1 && check_2); - - test "add_hook_or_exec" - (fun () -> - let hook_calls = ref 0 in - - let hook () = - hook_calls := !hook_calls + 1; - Lwt.return_unit - in - - Lwt_switch.add_hook_or_exec None hook >>= fun () -> - let check_1 = !hook_calls = 0 in - - let switch = Lwt_switch.create () in - Lwt_switch.add_hook_or_exec (Some switch) hook >>= fun () -> - let check_2 = !hook_calls = 0 in - - Lwt_switch.turn_off switch >>= fun () -> - let check_3 = !hook_calls = 1 in - - Lwt_switch.add_hook_or_exec (Some switch) hook >|= fun () -> - let check_4 = !hook_calls = 2 in - - check_1 && check_2 && check_3 && check_4); - - test "turn_off waits for hooks: regular exit" - (fun () -> - let hooks_finished = ref 0 in - - let hook () = - Lwt.pause () >>= fun () -> - hooks_finished := !hooks_finished + 1; - Lwt.return_unit - in - - let switch = Lwt_switch.create () in - Lwt_switch.add_hook (Some switch) hook; - Lwt_switch.add_hook (Some switch) hook; - - Lwt_switch.turn_off switch >|= fun () -> - !hooks_finished = 2); - - test "turn_off waits for hooks: hook exception" - (fun () -> - let hooks_finished = ref 0 in - - let successful_hook () = - Lwt.pause () >>= fun () -> - hooks_finished := !hooks_finished + 1; - Lwt.return_unit - in - - let failing_hook () = - hooks_finished := !hooks_finished + 1; - raise Exit - in - - let switch = Lwt_switch.create () in - Lwt_switch.add_hook (Some switch) successful_hook; - Lwt_switch.add_hook (Some switch) failing_hook; - Lwt_switch.add_hook (Some switch) successful_hook; - - Lwt.catch - (fun () -> Lwt_switch.turn_off switch) - (fun _ -> Lwt.return_unit) >|= fun () -> - !hooks_finished = 3); -] + Lwt_switch.add_hook (Some switch) (fun () -> + hook_called := true; + Lwt.return_unit); + + Lwt.return_unit) + >|= fun () -> !hook_called); + test "with_switch: exception" (fun () -> + let hook_called = ref false in + let exception_caught = ref false in + + Lwt.catch + (fun () -> + Lwt_switch.with_switch (fun switch -> + Lwt_switch.add_hook (Some switch) (fun () -> + hook_called := true; + Lwt.return_unit); + + raise Exit)) + (function + | Exit -> + exception_caught := true; + Lwt.return_unit + | _ -> Lwt.return_unit) + >|= fun () -> !hook_called && !exception_caught); + test "check" (fun () -> + Lwt_switch.check None; + + let switch = Lwt_switch.create () in + Lwt_switch.check (Some switch); + + Lwt_switch.turn_off switch >|= fun () -> + try + Lwt_switch.check (Some switch); + false + with Lwt_switch.Off -> true); + test "is_on" (fun () -> + let switch = Lwt_switch.create () in + let check_1 = Lwt_switch.is_on switch in + Lwt_switch.turn_off switch >|= fun () -> + let check_2 = not (Lwt_switch.is_on switch) in + check_1 && check_2); + test "add_hook_or_exec" (fun () -> + let hook_calls = ref 0 in + + let hook () = + hook_calls := !hook_calls + 1; + Lwt.return_unit + in + + Lwt_switch.add_hook_or_exec None hook >>= fun () -> + let check_1 = !hook_calls = 0 in + + let switch = Lwt_switch.create () in + Lwt_switch.add_hook_or_exec (Some switch) hook >>= fun () -> + let check_2 = !hook_calls = 0 in + + Lwt_switch.turn_off switch >>= fun () -> + let check_3 = !hook_calls = 1 in + + Lwt_switch.add_hook_or_exec (Some switch) hook >|= fun () -> + let check_4 = !hook_calls = 2 in + + check_1 && check_2 && check_3 && check_4); + test "turn_off waits for hooks: regular exit" (fun () -> + let hooks_finished = ref 0 in + + let hook () = + Lwt.pause () >>= fun () -> + hooks_finished := !hooks_finished + 1; + Lwt.return_unit + in + + let switch = Lwt_switch.create () in + Lwt_switch.add_hook (Some switch) hook; + Lwt_switch.add_hook (Some switch) hook; + + Lwt_switch.turn_off switch >|= fun () -> !hooks_finished = 2); + test "turn_off waits for hooks: hook exception" (fun () -> + let hooks_finished = ref 0 in + + let successful_hook () = + Lwt.pause () >>= fun () -> + hooks_finished := !hooks_finished + 1; + Lwt.return_unit + in + + let failing_hook () = + hooks_finished := !hooks_finished + 1; + raise Exit + in + + let switch = Lwt_switch.create () in + Lwt_switch.add_hook (Some switch) successful_hook; + Lwt_switch.add_hook (Some switch) failing_hook; + Lwt_switch.add_hook (Some switch) successful_hook; + + Lwt.catch + (fun () -> Lwt_switch.turn_off switch) + (fun _ -> Lwt.return_unit) + >|= fun () -> !hooks_finished = 3); + ] diff --git a/test/domain/main.ml b/test/domain/main.ml index aaee0bcca8..ceca59fbfa 100644 --- a/test/domain/main.ml +++ b/test/domain/main.ml @@ -1,7 +1,4 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) -let () = - Test.run "domain" [ - Test_lwt_domain.suite; - ] +let () = Test.run "domain" [ Test_lwt_domain.suite ] diff --git a/test/domain/test_lwt_domain.ml b/test/domain/test_lwt_domain.ml index 0face6c221..4ec39c1215 100644 --- a/test/domain/test_lwt_domain.ml +++ b/test/domain/test_lwt_domain.ml @@ -4,86 +4,75 @@ open Test open Lwt.Infix -let lwt_domain_test = [ - test "run_in_domain" begin fun () -> - let pool = Lwt_domain.setup_pool ~name:"pool_1" 4 in - let f () = 40 + 2 in - Lwt_domain.detach pool f () >>= fun x -> - Lwt.return (x = 42) - end; - test "run_in_main_domain" begin fun () -> - let pool = Option.get (Lwt_domain.lookup_pool "pool_1") in - let f () = - Lwt_domain.run_in_main (fun () -> - Lwt_unix.sleep 0.01 >>= fun () -> - Lwt.return 42) - in - Lwt_domain.detach pool f () >>= fun x -> - Lwt.return (x = 42) - end; - test "run_in_main_domain_exception" begin fun () -> - let pool = Option.get (Lwt_domain.lookup_pool "pool_1") in - let f () = Lwt_domain.detach pool (fun () -> - Lwt_domain.run_in_main (fun () -> - Lwt_unix.sleep 0.01 >>= fun () -> - Lwt.return (5/0))) () - in - Lwt.try_bind f - (fun _ -> Lwt.return_false) - (fun exn -> Lwt.return (exn = Division_by_zero)) - end; - test "fib_domain" begin fun () -> - let pool = Option.get (Lwt_domain.lookup_pool "pool_1") in - let rec fib n = - if n < 2 then n - else fib (n - 1) + fib (n - 2) - in - let l1 = - List.init 10 (fun i -> Lwt_domain.detach pool fib i) in - let l2 = - List.init 10 (fun i -> Lwt.return (fib i)) in - let s1 = Lwt.all l1 in - let s2 = Lwt.all l2 in - Lwt_unix.sleep 0.01 >>= fun () -> - Lwt.return (s1 = s2) - end; - test "invalid_num_domains" begin fun () -> - let set () = - let _ = Lwt_domain.setup_pool (-1) in - Lwt.return_true - in - Lwt.try_bind (fun () -> set ()) - (fun _ -> Lwt.return_false) - (fun exn -> - Lwt.return (exn = Invalid_argument - "Task.setup_pool: num_additional_domains must be at least 0")) - end; - test "detach_exception" begin fun () -> - let pool = Option.get (Lwt_domain.lookup_pool "pool_1") in - let r = Lwt_domain.detach pool (fun () -> 10 / 0) () in - Lwt.try_bind (fun () -> r) - (fun _ -> Lwt_domain.teardown_pool pool; Lwt.return_false) - (fun exn -> Lwt_domain.teardown_pool pool; - Lwt.return (exn = Division_by_zero)) - end; - test "one_domain" begin fun () -> - let p2 = Lwt_domain.setup_pool 1 ~name:"pool2" in - let f n = n * 10 in - Lwt_domain.detach p2 f 100 >>= fun x -> - Lwt.return (x = 1000) - end; - test "pool_already_shutdown" begin fun () -> - let p2 = Option.get (Lwt_domain.lookup_pool "pool2") in - Lwt_domain.teardown_pool p2; - Lwt.try_bind (fun () -> Lwt_domain.detach p2 (fun () -> Lwt.return_true) ()) - (fun _ -> Lwt.return_false) - (fun exn -> Lwt.return - (exn = Invalid_argument "pool already torn down")) - end -] +let lwt_domain_test = + [ + test "run_in_domain" (fun () -> + let pool = Lwt_domain.setup_pool ~name:"pool_1" 4 in + let f () = 40 + 2 in + Lwt_domain.detach pool f () >>= fun x -> Lwt.return (x = 42)); + test "run_in_main_domain" (fun () -> + let pool = Option.get (Lwt_domain.lookup_pool "pool_1") in + let f () = + Lwt_domain.run_in_main (fun () -> + Lwt_unix.sleep 0.01 >>= fun () -> Lwt.return 42) + in + Lwt_domain.detach pool f () >>= fun x -> Lwt.return (x = 42)); + test "run_in_main_domain_exception" (fun () -> + let pool = Option.get (Lwt_domain.lookup_pool "pool_1") in + let f () = + Lwt_domain.detach pool + (fun () -> + Lwt_domain.run_in_main (fun () -> + Lwt_unix.sleep 0.01 >>= fun () -> Lwt.return (5 / 0))) + () + in + Lwt.try_bind f + (fun _ -> Lwt.return_false) + (fun exn -> Lwt.return (exn = Division_by_zero))); + test "fib_domain" (fun () -> + let pool = Option.get (Lwt_domain.lookup_pool "pool_1") in + let rec fib n = if n < 2 then n else fib (n - 1) + fib (n - 2) in + let l1 = List.init 10 (fun i -> Lwt_domain.detach pool fib i) in + let l2 = List.init 10 (fun i -> Lwt.return (fib i)) in + let s1 = Lwt.all l1 in + let s2 = Lwt.all l2 in + Lwt_unix.sleep 0.01 >>= fun () -> Lwt.return (s1 = s2)); + test "invalid_num_domains" (fun () -> + let set () = + let _ = Lwt_domain.setup_pool (-1) in + Lwt.return_true + in + Lwt.try_bind + (fun () -> set ()) + (fun _ -> Lwt.return_false) + (fun exn -> + Lwt.return + (exn + = Invalid_argument + "Task.setup_pool: num_additional_domains must be at least 0"))); + test "detach_exception" (fun () -> + let pool = Option.get (Lwt_domain.lookup_pool "pool_1") in + let r = Lwt_domain.detach pool (fun () -> 10 / 0) () in + Lwt.try_bind + (fun () -> r) + (fun _ -> + Lwt_domain.teardown_pool pool; + Lwt.return_false) + (fun exn -> + Lwt_domain.teardown_pool pool; + Lwt.return (exn = Division_by_zero))); + test "one_domain" (fun () -> + let p2 = Lwt_domain.setup_pool 1 ~name:"pool2" in + let f n = n * 10 in + Lwt_domain.detach p2 f 100 >>= fun x -> Lwt.return (x = 1000)); + test "pool_already_shutdown" (fun () -> + let p2 = Option.get (Lwt_domain.lookup_pool "pool2") in + Lwt_domain.teardown_pool p2; + Lwt.try_bind + (fun () -> Lwt_domain.detach p2 (fun () -> Lwt.return_true) ()) + (fun _ -> Lwt.return_false) + (fun exn -> + Lwt.return (exn = Invalid_argument "pool already torn down"))); + ] -let suite = - suite "lwt_domain" - ( - lwt_domain_test - ) +let suite = suite "lwt_domain" lwt_domain_test diff --git a/test/packaging/dune/core/user.ml b/test/packaging/dune/core/user.ml index 2693f38382..40b0731fa1 100644 --- a/test/packaging/dune/core/user.ml +++ b/test/packaging/dune/core/user.ml @@ -1,2 +1 @@ -let () = - Lwt.return () |> ignore +let () = Lwt.return () |> ignore diff --git a/test/packaging/dune/preemptive/user.ml b/test/packaging/dune/preemptive/user.ml index a77c3b7644..a30b3fc85b 100644 --- a/test/packaging/dune/preemptive/user.ml +++ b/test/packaging/dune/preemptive/user.ml @@ -1,2 +1 @@ -let () = - Lwt_preemptive.simple_init |> ignore +let () = Lwt_preemptive.simple_init |> ignore diff --git a/test/packaging/dune/unix/user.ml b/test/packaging/dune/unix/user.ml index 09909fb8aa..6fd1887076 100644 --- a/test/packaging/dune/unix/user.ml +++ b/test/packaging/dune/unix/user.ml @@ -1,2 +1 @@ -let () = - Lwt_unix.stdout |> ignore +let () = Lwt_unix.stdout |> ignore diff --git a/test/packaging/ocamlfind/core/user.ml b/test/packaging/ocamlfind/core/user.ml index 2693f38382..40b0731fa1 100644 --- a/test/packaging/ocamlfind/core/user.ml +++ b/test/packaging/ocamlfind/core/user.ml @@ -1,2 +1 @@ -let () = - Lwt.return () |> ignore +let () = Lwt.return () |> ignore diff --git a/test/packaging/ocamlfind/preemptive/user.ml b/test/packaging/ocamlfind/preemptive/user.ml index a77c3b7644..a30b3fc85b 100644 --- a/test/packaging/ocamlfind/preemptive/user.ml +++ b/test/packaging/ocamlfind/preemptive/user.ml @@ -1,2 +1 @@ -let () = - Lwt_preemptive.simple_init |> ignore +let () = Lwt_preemptive.simple_init |> ignore diff --git a/test/packaging/ocamlfind/unix/user.ml b/test/packaging/ocamlfind/unix/user.ml index 09909fb8aa..6fd1887076 100644 --- a/test/packaging/ocamlfind/unix/user.ml +++ b/test/packaging/ocamlfind/unix/user.ml @@ -1,2 +1 @@ -let () = - Lwt_unix.stdout |> ignore +let () = Lwt_unix.stdout |> ignore diff --git a/test/ppx/main.ml b/test/ppx/main.ml index 984fee8d97..9a5b444ac8 100644 --- a/test/ppx/main.ml +++ b/test/ppx/main.ml @@ -8,158 +8,104 @@ open Lwt allowed. *) let%lwt structure_let_result = Lwt.return true -let suite = suite "ppx" [ - test "let" - (fun () -> - let%lwt x = return 3 in - return (x + 1 = 4) - ) ; - - test "nested let" - (fun () -> - let%lwt x = return 3 in - let%lwt y = return 4 in - return (x + y = 7) - ) ; - - test "and let" - (fun () -> - let%lwt x = return 3 - and y = return 4 in - return (x + y = 7) - ) ; - - test "match" - (fun () -> - let x = Lwt.return (Some 3) in - match%lwt x with - | Some x -> return (x + 1 = 4) - | None -> return false - ) ; - - test "match-exn" - (fun () -> - let x = Lwt.return (Some 3) in - let x' = Lwt.fail Not_found in - let%lwt a = - match%lwt x with - | exception Not_found -> return false - | Some x -> return (x = 3) - | None -> return false - and b = - match%lwt x' with - | exception Not_found -> return true - | _ -> return false - in - Lwt.return (a && b) - ) ; - - test "if" - (fun () -> - let x = Lwt.return true in - let%lwt a = - if%lwt x then Lwt.return_true else Lwt.return_false - in - let%lwt b = - if%lwt x>|= not then Lwt.return_false else Lwt.return_true - in - (if%lwt x >|= not then Lwt.return_unit) >>= fun () -> - Lwt.return (a && b) - ) ; - - test "for" (* Test for proper sequencing *) - (fun () -> - let r = ref [] in - let f x = - let%lwt () = Lwt_unix.sleep 0.2 in Lwt.return (r := x :: !r) - in - let%lwt () = - for%lwt x = 3 to 5 do f x done - in return (!r = [5 ; 4 ; 3]) - ) ; - - test "while" (* Test for proper sequencing *) - (fun () -> - let r = ref [] in - let f x = - let%lwt () = Lwt_unix.sleep 0.2 in Lwt.return (r := x :: !r) - in - let%lwt () = - let c = ref 2 in - while%lwt !c < 5 do incr c ; f !c done - in return (!r = [5 ; 4 ; 3]) - ) ; - - test "assert" - (fun () -> - let%lwt () = assert%lwt true - in return true - ) ; - - test "try" - (fun () -> - try%lwt - Lwt.fail Not_found - with _ -> return true - ) [@warning("@8@11")] ; - - test "try raise" - (fun () -> - try%lwt - raise Not_found - with _ -> return true - ) [@warning("@8@11")] ; - - test "try fallback" - (fun () -> - try%lwt - try%lwt - Lwt.fail Not_found - with Failure _ -> return false - with Not_found -> return true - ) [@warning("@8@11")] ; - - test "finally body" - (fun () -> - let x = ref false in - begin - (try%lwt - return_unit - with - | _ -> return_unit - ) [%finally x := true; return_unit] - end >>= fun () -> - return !x - ) ; - - test "finally exn" - (fun () -> - let x = ref false in - begin - (try%lwt - raise Not_found - with - | _ -> return_unit - ) [%finally x := true; return_unit] - end >>= fun () -> - return !x - ) ; - - test "finally exn default" - (fun () -> - let x = ref false in - try%lwt - ( raise Not_found )[%finally x := true; return_unit] - >>= fun () -> - return false - with Not_found -> - return !x - ) ; - - test "structure let" - (fun () -> - Lwt.return structure_let_result - ) ; -] +let suite = + suite "ppx" + [ + test "let" (fun () -> + let%lwt x = return 3 in + return (x + 1 = 4)); + test "nested let" (fun () -> + let%lwt x = return 3 in + let%lwt y = return 4 in + return (x + y = 7)); + test "and let" (fun () -> + let%lwt x = return 3 and y = return 4 in + return (x + y = 7)); + test "match" (fun () -> + let x = Lwt.return (Some 3) in + match%lwt x with Some x -> return (x + 1 = 4) | None -> return false); + test "match-exn" (fun () -> + let x = Lwt.return (Some 3) in + let x' = Lwt.fail Not_found in + let%lwt a = + match%lwt x with + | exception Not_found -> return false + | Some x -> return (x = 3) + | None -> return false + and b = + match%lwt x' with + | exception Not_found -> return true + | _ -> return false + in + Lwt.return (a && b)); + test "if" (fun () -> + let x = Lwt.return true in + let%lwt a = if%lwt x then Lwt.return_true else Lwt.return_false in + let%lwt b = + if%lwt x >|= not then Lwt.return_false else Lwt.return_true + in + (if%lwt x >|= not then Lwt.return_unit) >>= fun () -> + Lwt.return (a && b)); + test "for" (* Test for proper sequencing *) (fun () -> + let r = ref [] in + let f x = + let%lwt () = Lwt_unix.sleep 0.2 in + Lwt.return (r := x :: !r) + in + let%lwt () = + for%lwt x = 3 to 5 do + f x + done + in + return (!r = [ 5; 4; 3 ])); + test "while" (* Test for proper sequencing *) (fun () -> + let r = ref [] in + let f x = + let%lwt () = Lwt_unix.sleep 0.2 in + Lwt.return (r := x :: !r) + in + let%lwt () = + let c = ref 2 in + while%lwt !c < 5 do + incr c; + f !c + done + in + return (!r = [ 5; 4; 3 ])); + test "assert" (fun () -> + let%lwt () = assert%lwt true in + return true); + (test "try" (fun () -> try%lwt Lwt.fail Not_found with _ -> return true) + [@warning "@8@11"]); + (test "try raise" (fun () -> + try%lwt raise Not_found with _ -> return true) [@warning "@8@11"]); + (test "try fallback" (fun () -> + try%lwt try%lwt Lwt.fail Not_found with Failure _ -> return false + with Not_found -> return true) [@warning "@8@11"]); + test "finally body" (fun () -> + let x = ref false in + (try%lwt return_unit with _ -> return_unit) + [%finally + x := true; + return_unit] + >>= fun () -> return !x); + test "finally exn" (fun () -> + let x = ref false in + (try%lwt raise Not_found with _ -> return_unit) + [%finally + x := true; + return_unit] + >>= fun () -> return !x); + test "finally exn default" (fun () -> + let x = ref false in + try%lwt + (raise Not_found) + [%finally + x := true; + return_unit] + >>= fun () -> return false + with Not_found -> return !x); + test "structure let" (fun () -> Lwt.return structure_let_result); + ] let _ = Test.run "ppx" [ suite ] diff --git a/test/ppx_expect/cases/let_1.ml b/test/ppx_expect/cases/let_1.ml index d091f1ebdc..780c1b8e2d 100644 --- a/test/ppx_expect/cases/let_1.ml +++ b/test/ppx_expect/cases/let_1.ml @@ -1,3 +1,3 @@ let _ = let%lwt () = Lwt.return 5 in - Lwt.return ();; + Lwt.return () diff --git a/test/ppx_expect/cases/let_2.ml b/test/ppx_expect/cases/let_2.ml index 9538bf72d6..fc815581ef 100644 --- a/test/ppx_expect/cases/let_2.ml +++ b/test/ppx_expect/cases/let_2.ml @@ -1,3 +1,3 @@ let _ = let%lwt () = Lwt.return () in - ();; + () diff --git a/test/ppx_expect/cases/let_3.ml b/test/ppx_expect/cases/let_3.ml index cf3ef63336..77d8f7ef35 100644 --- a/test/ppx_expect/cases/let_3.ml +++ b/test/ppx_expect/cases/let_3.ml @@ -1,3 +1,3 @@ let _ = let%lwt () = Lwt.return () and () = Lwt.return 5 in - Lwt.return ();; + Lwt.return () diff --git a/test/ppx_expect/cases/let_4.ml b/test/ppx_expect/cases/let_4.ml index cd78604ba5..feb11d9659 100644 --- a/test/ppx_expect/cases/let_4.ml +++ b/test/ppx_expect/cases/let_4.ml @@ -1,3 +1,3 @@ let _ = let%lwt foo = Lwt.return () and bar = Lwt.return 5 in - Lwt.return (foo + bar);; + Lwt.return (foo + bar) diff --git a/test/ppx_expect/cases/match_1.ml b/test/ppx_expect/cases/match_1.ml index 622f9ff720..10695c8544 100644 --- a/test/ppx_expect/cases/match_1.ml +++ b/test/ppx_expect/cases/match_1.ml @@ -1,6 +1 @@ -let _ = - match%lwt - Lwt.return 5 - with - | () -> - Lwt.return ();; +let _ = match%lwt Lwt.return 5 with () -> Lwt.return () diff --git a/test/ppx_expect/cases/match_2.ml b/test/ppx_expect/cases/match_2.ml index d666ee7daa..abb28e07d5 100644 --- a/test/ppx_expect/cases/match_2.ml +++ b/test/ppx_expect/cases/match_2.ml @@ -1,6 +1 @@ -let _ = - match%lwt - () - with - | () -> - Lwt.return ();; +let _ = match%lwt () with () -> Lwt.return () diff --git a/test/ppx_expect/cases/match_3.ml b/test/ppx_expect/cases/match_3.ml index 3c48a2e862..aa2594411a 100644 --- a/test/ppx_expect/cases/match_3.ml +++ b/test/ppx_expect/cases/match_3.ml @@ -1,6 +1 @@ -let _ = - match%lwt - Lwt.return () - with - | () -> - 5;; +let _ = match%lwt Lwt.return () with () -> 5 diff --git a/test/ppx_expect/cases/match_4.ml b/test/ppx_expect/cases/match_4.ml index b5b215838b..65e4ddfe58 100644 --- a/test/ppx_expect/cases/match_4.ml +++ b/test/ppx_expect/cases/match_4.ml @@ -1,8 +1,4 @@ let _ = - match%lwt - Lwt.return () - with - | () -> - Lwt.return () - | exception End_of_file -> - Lwt.return 5 + match%lwt Lwt.return () with + | () -> Lwt.return () + | exception End_of_file -> Lwt.return 5 diff --git a/test/ppx_expect/cases/try_1.ml b/test/ppx_expect/cases/try_1.ml index 64cced26e1..61234f8190 100644 --- a/test/ppx_expect/cases/try_1.ml +++ b/test/ppx_expect/cases/try_1.ml @@ -1,4 +1 @@ -let _ = - try%lwt - 5 - with _ -> Lwt.return ();; +let _ = try%lwt 5 with _ -> Lwt.return () diff --git a/test/ppx_expect/cases/try_2.ml b/test/ppx_expect/cases/try_2.ml index 6bbf130e90..f4894ac5d7 100644 --- a/test/ppx_expect/cases/try_2.ml +++ b/test/ppx_expect/cases/try_2.ml @@ -1,4 +1 @@ -let _ = - try%lwt - Lwt.return () - with _ -> 5;; +let _ = try%lwt Lwt.return () with _ -> 5 diff --git a/test/ppx_expect/cases/try_3.ml b/test/ppx_expect/cases/try_3.ml index 00d0d20ec7..33c2a753fa 100644 --- a/test/ppx_expect/cases/try_3.ml +++ b/test/ppx_expect/cases/try_3.ml @@ -1,4 +1 @@ -let _ = - try%lwt - Lwt.return () - with _ -> Lwt.return 5;; +let _ = try%lwt Lwt.return () with _ -> Lwt.return 5 diff --git a/test/ppx_expect/main.ml b/test/ppx_expect/main.ml index 9188f7a4c0..681c149da4 100644 --- a/test/ppx_expect/main.ml +++ b/test/ppx_expect/main.ml @@ -1,6 +1,6 @@ let test_directory = "cases" let package_directory = "../../../install/default/lib" -let (//) = Filename.concat +let ( // ) = Filename.concat let _read_file name = let buffer = Buffer.create 4096 in @@ -8,14 +8,15 @@ let _read_file name = try let rec read () = - try input_char channel |> Buffer.add_char buffer; read () + try + input_char channel |> Buffer.add_char buffer; + read () with End_of_file -> () in read (); close_in channel; Buffer.contents buffer - with exn -> close_in_noerr channel; raise exn @@ -40,21 +41,22 @@ let diff reference result = match status with | 0 -> () | 1 -> - let _ : int =_run_int (command ^ " > delta") in - let delta = _read_file "delta" in - Printf.eprintf "> %s:\n\n%s" command delta; - failwith "Output does not match expected" + let (_ : int) = _run_int (command ^ " > delta") in + let delta = _read_file "delta" in + Printf.eprintf "> %s:\n\n%s" command delta; + failwith "Output does not match expected" | _ -> _command_failed command ~status let run_test name = - let ml_name = test_directory // name ^ ".ml" in - let expect_name = test_directory // name ^ ".expect" in - let fixed_name = test_directory // name ^ ".fixed" in + let ml_name = (test_directory // name) ^ ".ml" in + let expect_name = (test_directory // name) ^ ".expect" in + let fixed_name = (test_directory // name) ^ ".fixed" in let command = Printf.sprintf "%s %s ocamlfind c %s -linkpkg -thread -package %s %s > %s 2>&1" - ("OCAMLPATH=" ^ package_directory) "OCAML_ERROR_STYLE=short" - "-color=never" "lwt.unix,lwt_ppx" ml_name fixed_name + ("OCAMLPATH=" ^ package_directory) + "OCAML_ERROR_STYLE=short" "-color=never" "lwt.unix,lwt_ppx" ml_name + fixed_name in ignore (_run_int command); diff expect_name fixed_name @@ -67,17 +69,19 @@ let () = |> List.map Filename.chop_extension in let only_if () = - Sys.cygwin = false && Sys.win32 = false && - (* 4.02.3 prints file paths differently *) - Scanf.sscanf Sys.ocaml_version "%u.%u" - (fun major minor -> (major, minor) >= (4, 4)) + Sys.cygwin = false + && Sys.win32 = false + && (* 4.02.3 prints file paths differently *) + Scanf.sscanf Sys.ocaml_version "%u.%u" (fun major minor -> + (major, minor) >= (4, 4)) in - let suite = Test.suite "ppx_expect" ( - List.map (fun test_case -> - Test.test_direct test_case ~only_if (fun () -> - run_test test_case; - true - ) - ) test_cases) + let suite = + Test.suite "ppx_expect" + (List.map + (fun test_case -> + Test.test_direct test_case ~only_if (fun () -> + run_test test_case; + true)) + test_cases) in - Test.run "ppx_expect" [suite] + Test.run "ppx_expect" [ suite ] diff --git a/test/ppx_let/test.ml b/test/ppx_let/test.ml index e742fabbfd..f3f48816a2 100644 --- a/test/ppx_let/test.ml +++ b/test/ppx_let/test.ml @@ -21,7 +21,4 @@ let () = let x = Lwt_main.run p in - if x = Ok 10 then - exit 0 - else - exit 1 + if x = Ok 10 then exit 0 else exit 1 diff --git a/test/react/main.ml b/test/react/main.ml index 9dacc31099..8ac74b44c5 100644 --- a/test/react/main.ml +++ b/test/react/main.ml @@ -1,9 +1,4 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - -Test.run "react" [ - Test_lwt_event.suite; - Test_lwt_signal.suite; -] +Test.run "react" [ Test_lwt_event.suite; Test_lwt_signal.suite ] diff --git a/test/react/test_lwt_event.ml b/test/react/test_lwt_event.ml index b1493aebac..60a541a97e 100644 --- a/test/react/test_lwt_event.ml +++ b/test/react/test_lwt_event.ml @@ -1,125 +1,126 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Test open Lwt -let suite = suite "lwt_event" [ - test "to_stream" - (fun () -> - let event, push = React.E.create () in - let stream = Lwt_react.E.to_stream event in - let t = Lwt_stream.next stream in - assert (state t = Sleep); - push 42; - return (state t = Return 42)); - - test "to_stream 2" - (fun () -> - let event, push = React.E.create () in - let stream = Lwt_react.E.to_stream event in - push 1; - push 2; - push 3; - Lwt.bind (Lwt_stream.nget 3 stream) (fun l -> - return (l = [1; 2; 3]))); - - test "map_s" - (fun () -> - let l = ref [] in - let event, push = React.E.create () in - let event' = Lwt_react.E.map_s (fun x -> l := x :: !l; return ()) event in - ignore event'; - push 1; - return (!l = [1])); - - test "map_p" - (fun () -> - let l = ref [] in - let event, push = React.E.create () in - let event' = Lwt_react.E.map_p (fun x -> l := x :: !l; return ()) event in - ignore event'; - push 1; - return (!l = [1])); - - test "limit_race" - (fun () -> - let l = ref [] in - let event, push = Lwt_react.E.create() in - let prepend n = l := n :: !l - in - let event' = - event - |> Lwt_react.E.limit (fun () -> - let p = Lwt_unix.sleep 1. in - Lwt.async (fun () -> - Lwt_unix.sleep 0.1 >|= fun () -> - Lwt.on_success p (fun () -> push 2)); p) - |> React.E.map prepend - in - push 0; - push 1; - - Lwt_unix.sleep 2.5 >>= fun () -> - let result = !l = [2; 2; 0] in - if not result then begin - List.iter (Printf.eprintf "%i ") !l; - prerr_newline () - end; - ignore (Lwt_react.opaque_identity event'); - return result); - - test "of_stream" - (fun () -> - let stream, push = Lwt_stream.create () in - let l = ref [] in - let event = React.E.map (fun x -> l := x :: !l) (Lwt_react.E.of_stream stream) in - ignore event; - push (Some 1); - push (Some 2); - push (Some 3); - Lwt.wakeup_paused (); - return (!l = [3; 2; 1])); - - test "limit" - (fun () -> - let event, push = React.E.create () in - let cond = Lwt_condition.create () in - let event' = Lwt_react.E.limit (fun () -> Lwt_condition.wait cond) event in - let l = ref [] in - let event'' = React.E.map (fun x -> l := x :: !l) event' in - ignore event'; - ignore event''; - push 1; - push 0; - push 2; (* overwrites previous 0 *) - Lwt_condition.signal cond (); - Lwt.pause () >>= fun () -> - push 3; - Lwt_condition.signal cond (); - Lwt.pause () >>= fun () -> - push 4; - Lwt_condition.signal cond (); - Lwt.pause () >>= fun () -> - return (!l = [4; 3; 2; 1])); - - test "with_finaliser lifetime" begin fun () -> - let e, push = React.E.create () in - let finalizer_ran = ref false in - let e' = Lwt_react.E.with_finaliser (fun () -> finalizer_ran := true) e in - - Gc.full_major (); - let check1 = !finalizer_ran = false in - - let p = Lwt_react.E.next e' in - push (); - p >>= fun () -> - - Gc.full_major (); - let check2 = !finalizer_ran = true in - - Lwt.return (check1 && check2) - end; -] +let suite = + suite "lwt_event" + [ + test "to_stream" (fun () -> + let event, push = React.E.create () in + let stream = Lwt_react.E.to_stream event in + let t = Lwt_stream.next stream in + assert (state t = Sleep); + push 42; + return (state t = Return 42)); + test "to_stream 2" (fun () -> + let event, push = React.E.create () in + let stream = Lwt_react.E.to_stream event in + push 1; + push 2; + push 3; + Lwt.bind (Lwt_stream.nget 3 stream) (fun l -> + return (l = [ 1; 2; 3 ]))); + test "map_s" (fun () -> + let l = ref [] in + let event, push = React.E.create () in + let event' = + Lwt_react.E.map_s + (fun x -> + l := x :: !l; + return ()) + event + in + ignore event'; + push 1; + return (!l = [ 1 ])); + test "map_p" (fun () -> + let l = ref [] in + let event, push = React.E.create () in + let event' = + Lwt_react.E.map_p + (fun x -> + l := x :: !l; + return ()) + event + in + ignore event'; + push 1; + return (!l = [ 1 ])); + test "limit_race" (fun () -> + let l = ref [] in + let event, push = Lwt_react.E.create () in + let prepend n = l := n :: !l in + let event' = + event + |> Lwt_react.E.limit (fun () -> + let p = Lwt_unix.sleep 1. in + Lwt.async (fun () -> + Lwt_unix.sleep 0.1 >|= fun () -> + Lwt.on_success p (fun () -> push 2)); + p) + |> React.E.map prepend + in + push 0; + push 1; + + Lwt_unix.sleep 2.5 >>= fun () -> + let result = !l = [ 2; 2; 0 ] in + if not result then ( + List.iter (Printf.eprintf "%i ") !l; + prerr_newline ()); + ignore (Lwt_react.opaque_identity event'); + return result); + test "of_stream" (fun () -> + let stream, push = Lwt_stream.create () in + let l = ref [] in + let event = + React.E.map (fun x -> l := x :: !l) (Lwt_react.E.of_stream stream) + in + ignore event; + push (Some 1); + push (Some 2); + push (Some 3); + Lwt.wakeup_paused (); + return (!l = [ 3; 2; 1 ])); + test "limit" (fun () -> + let event, push = React.E.create () in + let cond = Lwt_condition.create () in + let event' = + Lwt_react.E.limit (fun () -> Lwt_condition.wait cond) event + in + let l = ref [] in + let event'' = React.E.map (fun x -> l := x :: !l) event' in + ignore event'; + ignore event''; + push 1; + push 0; + push 2; + (* overwrites previous 0 *) + Lwt_condition.signal cond (); + Lwt.pause () >>= fun () -> + push 3; + Lwt_condition.signal cond (); + Lwt.pause () >>= fun () -> + push 4; + Lwt_condition.signal cond (); + Lwt.pause () >>= fun () -> return (!l = [ 4; 3; 2; 1 ])); + test "with_finaliser lifetime" (fun () -> + let e, push = React.E.create () in + let finalizer_ran = ref false in + let e' = + Lwt_react.E.with_finaliser (fun () -> finalizer_ran := true) e + in + + Gc.full_major (); + let check1 = !finalizer_ran = false in + + let p = Lwt_react.E.next e' in + push (); + p >>= fun () -> + Gc.full_major (); + let check2 = !finalizer_ran = true in + + Lwt.return (check1 && check2)); + ] diff --git a/test/react/test_lwt_signal.ml b/test/react/test_lwt_signal.ml index 32245f7fcf..841223d18c 100644 --- a/test/react/test_lwt_signal.ml +++ b/test/react/test_lwt_signal.ml @@ -1,73 +1,67 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Test open Lwt -let suite = suite "lwt_signal" [ - test "limit" - (fun () -> - let s, push = React.S.create 0 in - let cond = Lwt_condition.create () in - let s' = Lwt_react.S.limit (fun () -> Lwt_condition.wait cond) s in - let l = ref [] in - let e = React.E.map (fun x -> l := x :: !l) (React.S.changes s') in - ignore e; - Lwt_condition.signal cond (); - Lwt.pause () >>= fun () -> - push 1; - push 0; - push 2; (* overwrites previous 0 *) - Lwt_condition.signal cond (); - Lwt.pause () >>= fun () -> - push 3; - Lwt_condition.signal cond (); - Lwt.pause () >>= fun () -> - push 4; - Lwt_condition.signal cond (); - Lwt.pause () >>= fun () -> - return (!l = [4; 3; 2; 1])); - - test "limit race condition" begin fun () -> - let change_count = ref 0 in - - let underlying_signal, set = React.S.create 0 in - - underlying_signal - |> Lwt_react.S.limit (fun () -> - let p = Lwt_unix.sleep 1. in - Lwt.async (fun () -> - Lwt_unix.sleep 0.1 >|= fun () -> - Lwt.on_success p (fun () -> - set 2)); - p) - |> React.S.changes - |> React.E.map (fun _ -> incr change_count) - |> ignore; +let suite = + suite "lwt_signal" + [ + test "limit" (fun () -> + let s, push = React.S.create 0 in + let cond = Lwt_condition.create () in + let s' = Lwt_react.S.limit (fun () -> Lwt_condition.wait cond) s in + let l = ref [] in + let e = React.E.map (fun x -> l := x :: !l) (React.S.changes s') in + ignore e; + Lwt_condition.signal cond (); + Lwt.pause () >>= fun () -> + push 1; + push 0; + push 2; + (* overwrites previous 0 *) + Lwt_condition.signal cond (); + Lwt.pause () >>= fun () -> + push 3; + Lwt_condition.signal cond (); + Lwt.pause () >>= fun () -> + push 4; + Lwt_condition.signal cond (); + Lwt.pause () >>= fun () -> return (!l = [ 4; 3; 2; 1 ])); + test "limit race condition" (fun () -> + let change_count = ref 0 in - set 1; + let underlying_signal, set = React.S.create 0 in - Lwt_unix.sleep 2. >|= fun () -> - !change_count = 1 - end; + underlying_signal + |> Lwt_react.S.limit (fun () -> + let p = Lwt_unix.sleep 1. in + Lwt.async (fun () -> + Lwt_unix.sleep 0.1 >|= fun () -> + Lwt.on_success p (fun () -> set 2)); + p) + |> React.S.changes + |> React.E.map (fun _ -> incr change_count) + |> ignore; - test "with_finaliser lifetime" begin fun () -> - let s, set = React.S.create 0 in - let finalizer_ran = ref false in - let s' = Lwt_react.S.with_finaliser (fun () -> finalizer_ran := true) s in + set 1; - Gc.full_major (); - let check1 = !finalizer_ran = false in + Lwt_unix.sleep 2. >|= fun () -> !change_count = 1); + test "with_finaliser lifetime" (fun () -> + let s, set = React.S.create 0 in + let finalizer_ran = ref false in + let s' = + Lwt_react.S.with_finaliser (fun () -> finalizer_ran := true) s + in - let p = Lwt_react.E.next (React.S.changes s') in - set 1; - p >>= fun _ -> + Gc.full_major (); + let check1 = !finalizer_ran = false in - Gc.full_major (); - let check2 = !finalizer_ran = true in + let p = Lwt_react.E.next (React.S.changes s') in + set 1; + p >>= fun _ -> + Gc.full_major (); + let check2 = !finalizer_ran = true in - Lwt.return (check1 && check2) - end; -] + Lwt.return (check1 && check2)); + ] diff --git a/test/test.ml b/test/test.ml index 8765a179b2..2ff8142fc7 100644 --- a/test/test.ml +++ b/test/test.ml @@ -1,8 +1,6 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - type test = { test_name : string; skip_if_this_is_false : unit -> bool; @@ -10,102 +8,81 @@ type test = { run : unit -> bool Lwt.t; } -type outcome = - | Passed - | Failed - | Exception of exn - | Skipped +type outcome = Passed | Failed | Exception of exn | Skipped exception Skip exception Duplicate_Test_Names of string let test_direct test_name ?(only_if = fun () -> true) run = - let run = - fun () -> - Lwt.return (run ()) - in - {test_name; skip_if_this_is_false = only_if; sequential = false; run} + let run () = Lwt.return (run ()) in + { test_name; skip_if_this_is_false = only_if; sequential = false; run } let test test_name ?(only_if = fun () -> true) ?(sequential = false) run = - {test_name; skip_if_this_is_false = only_if; sequential; run} + { test_name; skip_if_this_is_false = only_if; sequential; run } -module Log = -struct +module Log = struct let log_file = let pid = Unix.getpid () in let ms = Unix.gettimeofday () |> modf |> fst in let filename = Printf.sprintf "test.%i.%03.0f.log" pid (ms *. 1e3) in open_out filename - let () = - at_exit (fun () -> close_out_noerr log_file) + let () = at_exit (fun () -> close_out_noerr log_file) let start_time = ref None + let elapsed () = let now = Unix.gettimeofday () in match !start_time with | None -> - start_time := Some now; - 0. - | Some start_time -> - now -. start_time + start_time := Some now; + 0. + | Some start_time -> now -. start_time let write identifier message = - Printf.ksprintf (output_string log_file) "%s [%07.3f]: %s\n" - identifier (mod_float (elapsed ()) 1000.) message; + Printf.ksprintf (output_string log_file) "%s [%07.3f]: %s\n" identifier + (mod_float (elapsed ()) 1000.) + message; flush log_file - let log k = - k (fun identifier -> - Printf.ksprintf (write identifier)) + + let log k = k (fun identifier -> Printf.ksprintf (write identifier)) end let log = Log.log -let run_test : test -> outcome Lwt.t = fun test -> - if test.skip_if_this_is_false () = false then begin - log @@ (fun k -> k test.test_name "skipping"); - Lwt.return Skipped - end - - else begin +let run_test : test -> outcome Lwt.t = + fun test -> + if test.skip_if_this_is_false () = false then ( + (log @@ fun k -> k test.test_name "skipping"); + Lwt.return Skipped) + else let start_time = Unix.gettimeofday () in - log @@ (fun k -> k test.test_name "starting"); + (log @@ fun k -> k test.test_name "starting"); (* Lwt.async_exception_hook handling inspired by https://github.com/mirage/alcotest/issues/45 *) let async_exception_promise, async_exception_occurred = Lwt.task () in let old_async_exception_hook = !Lwt.async_exception_hook in - Lwt.async_exception_hook := (fun exn -> - Lwt.wakeup_later async_exception_occurred (Exception exn)); + (Lwt.async_exception_hook := + fun exn -> Lwt.wakeup_later async_exception_occurred (Exception exn)); Lwt.finalize (fun () -> let test_completion_promise = Lwt.try_bind - (fun () -> - test.run ()) - + (fun () -> test.run ()) (fun test_did_pass -> - if test_did_pass then - Lwt.return Passed - else - Lwt.return Failed) - + if test_did_pass then Lwt.return Passed else Lwt.return Failed) (function - | Skip -> - Lwt.return Skipped - - | exn_raised_by_test -> - Lwt.return (Exception exn_raised_by_test)) + | Skip -> Lwt.return Skipped + | exn_raised_by_test -> Lwt.return (Exception exn_raised_by_test)) in - Lwt.pick [test_completion_promise; async_exception_promise]) - + Lwt.pick [ test_completion_promise; async_exception_promise ]) (fun () -> Lwt.async_exception_hook := old_async_exception_hook; let elapsed = Unix.gettimeofday () -. start_time in - log @@ (fun k -> k test.test_name "finished in %.3f s" elapsed); + (log @@ fun k -> k test.test_name "finished in %.3f s" elapsed); Lwt.return_unit) - end let outcome_to_character : outcome -> string = function | Passed -> "." @@ -113,8 +90,6 @@ let outcome_to_character : outcome -> string = function | Exception _ -> "E" | Skipped -> "S" - - type suite = { suite_name : string; suite_tests : test list; @@ -123,108 +98,97 @@ type suite = { let contains_dup_tests suite tests = let names = - List.map (fun t -> "suite:" ^ suite ^ " test:" ^ t.test_name) tests in + List.map (fun t -> "suite:" ^ suite ^ " test:" ^ t.test_name) tests + in let sorted_unique_names = List.sort_uniq String.compare names in let counts = - List.map (fun x -> - let tests = List.find_all (fun y -> y = x) names in - (x, List.length tests)) sorted_unique_names in - let dups = List.filter (fun (_, count) -> count > 1) counts |> - List.map (fun (name, _) -> name) in - if List.length dups > 0 then - Some dups - else - None + List.map + (fun x -> + let tests = List.find_all (fun y -> y = x) names in + (x, List.length tests)) + sorted_unique_names + in + let dups = + List.filter (fun (_, count) -> count > 1) counts + |> List.map (fun (name, _) -> name) + in + if List.length dups > 0 then Some dups else None let suite name ?(only_if = fun () -> true) tests = match contains_dup_tests name tests with - | Some names -> raise (Duplicate_Test_Names (String.concat ", " names)) - | None -> (); - {suite_name = name; - suite_tests = tests; - skip_suite_if_this_is_false = only_if} - -let run_test_suite : suite -> ((string * outcome) list) Lwt.t = fun suite -> - if suite.skip_suite_if_this_is_false () = false then + | Some names -> raise (Duplicate_Test_Names (String.concat ", " names)) + | None -> + (); + { + suite_name = name; + suite_tests = tests; + skip_suite_if_this_is_false = only_if; + } + +let run_test_suite : suite -> (string * outcome) list Lwt.t = + fun suite -> + if suite.skip_suite_if_this_is_false () = false then ( let outcomes = suite.suite_tests - |> List.map (fun {test_name; _} -> (test_name, Skipped)) + |> List.map (fun { test_name; _ } -> (test_name, Skipped)) in (outcome_to_character Skipped).[0] |> String.make (List.length outcomes) |> print_string; flush stdout; - Lwt.return outcomes - + Lwt.return outcomes) else - suite.suite_tests |> Lwt_list.map_s begin fun test -> - Lwt.bind (run_test test) (fun outcome -> - outcome |> outcome_to_character |> print_string; - flush stdout; - Lwt.return (test.test_name, outcome)) - end - -let outcomes_all_ok : (_ * outcome) list -> bool = fun outcomes -> + suite.suite_tests + |> Lwt_list.map_s (fun test -> + Lwt.bind (run_test test) (fun outcome -> + outcome |> outcome_to_character |> print_string; + flush stdout; + Lwt.return (test.test_name, outcome))) + +let outcomes_all_ok : (_ * outcome) list -> bool = + fun outcomes -> outcomes |> List.for_all (fun (_test_name, outcome) -> - match outcome with - | Passed | Skipped -> true - | Failed | Exception _ -> false) + match outcome with + | Passed | Skipped -> true + | Failed | Exception _ -> false) let show_failures : (string * outcome) list -> unit = List.iter (fun (test_name, outcome) -> - match outcome with - | Passed - | Skipped -> - () - - | Failed -> - Printf.eprintf - "Test '%s' produced 'false'\n" test_name + match outcome with + | Passed | Skipped -> () + | Failed -> Printf.eprintf "Test '%s' produced 'false'\n" test_name + | Exception exn -> + Printf.eprintf "Test '%s' raised '%s'\n" test_name + (Printexc.to_string exn)) - | Exception exn -> - Printf.eprintf - "Test '%s' raised '%s'\n" test_name (Printexc.to_string exn)) - - - -type ('a, 'b) aggregated_outcomes = ('a * (('b * outcome) list)) list +type ('a, 'b) aggregated_outcomes = ('a * ('b * outcome) list) list let fold_over_outcomes : - ('a -> outcome -> 'a) -> - 'a -> - (_, _) aggregated_outcomes -> - 'a = - fun f init outcomes -> - - List.fold_left (fun accumulator (_suite_name, test_outcomes) -> - List.fold_left (fun accumulator (_test_name, test_outcome) -> - f accumulator test_outcome) - accumulator - test_outcomes) - init - outcomes - -let count_ran : (_, _) aggregated_outcomes -> int = fun outcomes -> + ('a -> outcome -> 'a) -> 'a -> (_, _) aggregated_outcomes -> 'a = + fun f init outcomes -> + List.fold_left + (fun accumulator (_suite_name, test_outcomes) -> + List.fold_left + (fun accumulator (_test_name, test_outcome) -> + f accumulator test_outcome) + accumulator test_outcomes) + init outcomes + +let count_ran : (_, _) aggregated_outcomes -> int = + fun outcomes -> outcomes |> fold_over_outcomes - (fun count -> function - | Skipped -> - count - | _ -> - count + 1) - 0 - -let count_skipped : (_, _) aggregated_outcomes -> int = fun outcomes -> + (fun count -> function Skipped -> count | _ -> count + 1) + 0 + +let count_skipped : (_, _) aggregated_outcomes -> int = + fun outcomes -> outcomes |> fold_over_outcomes - (fun count -> function - | Skipped -> - count + 1 - | _ -> - count) - 0 + (fun count -> function Skipped -> count + 1 | _ -> count) + 0 (* Runs a series of test suites. If one of the test suites fails, does not run subsequent suites. *) @@ -242,31 +206,27 @@ let run library_name suites = let rec loop_over_suites aggregated_outcomes suites = match suites with | [] -> - let end_time = Unix.gettimeofday () in - Printf.printf - "\nOk. %i tests ran, %i tests skipped in %.2f seconds\n" - (count_ran aggregated_outcomes) - (count_skipped aggregated_outcomes) - (end_time -. start_time); - Lwt.return_unit - - | suite::rest -> - Lwt.bind (run_test_suite suite) begin fun outcomes -> - if not (outcomes_all_ok outcomes) then begin - print_newline (); - flush stdout; - Printf.eprintf "Failures in test suite '%s':\n" suite.suite_name; - show_failures outcomes; - exit 1 - end - else - loop_over_suites - ((suite.suite_name, outcomes)::aggregated_outcomes) rest - end + let end_time = Unix.gettimeofday () in + Printf.printf "\nOk. %i tests ran, %i tests skipped in %.2f seconds\n" + (count_ran aggregated_outcomes) + (count_skipped aggregated_outcomes) + (end_time -. start_time); + Lwt.return_unit + | suite :: rest -> + Lwt.bind (run_test_suite suite) (fun outcomes -> + if not (outcomes_all_ok outcomes) then ( + print_newline (); + flush stdout; + Printf.eprintf "Failures in test suite '%s':\n" suite.suite_name; + show_failures outcomes; + exit 1) + else + loop_over_suites + ((suite.suite_name, outcomes) :: aggregated_outcomes) + rest) in - loop_over_suites [] suites - |> Lwt_main.run + loop_over_suites [] suites |> Lwt_main.run let concurrent library_name suites = Printexc.register_printer (function @@ -276,14 +236,9 @@ let concurrent library_name suites = Printf.printf "Testing library '%s'...\n" library_name; let open Lwt.Infix in - let run_test (suite, test) = - begin - if suite.skip_suite_if_this_is_false () = false then - Lwt.return Skipped - else - run_test test - end + (if suite.skip_suite_if_this_is_false () = false then Lwt.return Skipped + else run_test test) >|= fun outcome -> print_string (outcome_to_character outcome); flush stdout; @@ -295,47 +250,38 @@ let concurrent library_name suites = (* List all the tests. *) suites |> List.map (fun suite -> - suite.suite_tests - |> List.map (fun test -> - (suite, test))) + suite.suite_tests |> List.map (fun test -> (suite, test))) |> List.flatten - (* Separate the tests that must be run sequentially, and run them. *) |> List.partition (fun (_suite, test) -> test.sequential) |> fun (sequential, concurrent) -> - Lwt_list.map_s run_test sequential - >>= fun sequential_outcomes -> - + Lwt_list.map_s run_test sequential >>= fun sequential_outcomes -> (* Run the tests that can be run concurrently. *) - concurrent - |> Lwt_list.map_p run_test - + concurrent |> Lwt_list.map_p run_test (* Summarize the results. *) >>= fun concurrent_outcomes -> let outcomes = sequential_outcomes @ concurrent_outcomes in - if outcomes_all_ok outcomes then + if outcomes_all_ok outcomes then ( let end_time = Unix.gettimeofday () in - let aggregated_outcomes = [(), outcomes] in - Printf.printf - "\nOk. %i tests ran, %i tests skipped in %.2f seconds\n" + let aggregated_outcomes = [ ((), outcomes) ] in + Printf.printf "\nOk. %i tests ran, %i tests skipped in %.2f seconds\n" (count_ran aggregated_outcomes) (count_skipped aggregated_outcomes) (end_time -. start_time); - Lwt.return_unit - else begin + Lwt.return_unit) + else ( print_newline (); flush stdout; - outcomes |> List.iter (function - | (suite, test), Failed -> - Printf.eprintf "Test '%s' in suite '%s' produced 'false'\n" - test.test_name suite.suite_name - | (suite, test), Exception exn -> - Printf.eprintf "Test '%s' in suite '%s' raised '%s'\n" - test.test_name suite.suite_name (Printexc.to_string exn) - | _ -> - ()); - exit 1 - end + outcomes + |> List.iter (function + | (suite, test), Failed -> + Printf.eprintf "Test '%s' in suite '%s' produced 'false'\n" + test.test_name suite.suite_name + | (suite, test), Exception exn -> + Printf.eprintf "Test '%s' in suite '%s' raised '%s'\n" + test.test_name suite.suite_name (Printexc.to_string exn) + | _ -> ()); + exit 1) let concurrent library_name suites = Lwt_main.run (concurrent library_name suites) @@ -344,9 +290,12 @@ let with_async_exception_hook hook f = let old_hook = !Lwt.async_exception_hook in Lwt.async_exception_hook := hook; Lwt.finalize f (fun () -> - Lwt.async_exception_hook := old_hook; - Lwt.return ()) + Lwt.async_exception_hook := old_hook; + Lwt.return ()) let instrument = function | true -> Printf.ksprintf (fun _s -> true) - | false -> Printf.ksprintf (fun s -> prerr_endline ("\n" ^ s); false) + | false -> + Printf.ksprintf (fun s -> + prerr_endline ("\n" ^ s); + false) diff --git a/test/test.mli b/test/test.mli index 8d18ffa44f..6ddd646691 100644 --- a/test/test.mli +++ b/test/test.mli @@ -1,8 +1,6 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (** Helpers for tests. *) type test @@ -20,24 +18,23 @@ exception Skip [Test.Skip]. *) val test_direct : string -> ?only_if:(unit -> bool) -> (unit -> bool) -> test -(** Defines a test. [run] must returns [true] if the test succeeded - and [false] otherwise. [only_if] is used to conditionally skip the - test. *) +(** Defines a test. [run] must returns [true] if the test succeeded and [false] + otherwise. [only_if] is used to conditionally skip the test. *) val test : string -> ?only_if:(unit -> bool) -> ?sequential:bool -> (unit -> bool Lwt.t) -> - test + test (** Like [test_direct], but defines a test which runs a thread. *) val suite : string -> ?only_if:(unit -> bool) -> test list -> suite (** Defines a suite of tests *) val run : string -> suite list -> unit -(** Run all the given tests and exit the program with an exit code - of [0] if all tests succeeded and with [1] otherwise. *) +(** Run all the given tests and exit the program with an exit code of [0] if all + tests succeeded and with [1] otherwise. *) val concurrent : string -> suite list -> unit (** Same as [run], but runs all the tests concurrently. *) diff --git a/test/test_unix.ml b/test/test_unix.ml index 6bdbfb20bb..cd84e647b8 100644 --- a/test/test_unix.ml +++ b/test/test_unix.ml @@ -1,16 +1,13 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - let temp_name = let rng = Random.State.make_self_init () in fun () -> let number = Random.State.int rng 10000 in Printf.sprintf "lwt-testing-%04d" number -let temp_file () = - Filename.temp_file ~temp_dir:"." "lwt-testing-" "" +let temp_file () = Filename.temp_file ~temp_dir:"." "lwt-testing-" "" let temp_directory () = let rec attempt () = diff --git a/test/test_unix.mli b/test/test_unix.mli index 0658621bf7..f7bddc5425 100644 --- a/test/test_unix.mli +++ b/test/test_unix.mli @@ -1,8 +1,6 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - val temp_name : unit -> string (** Generates the name of a temporary file (or directory) in [_build/]. Note that a file at the path may already exist. *) diff --git a/test/unix/luv_main.ml b/test/unix/luv_main.ml index 38578b1839..b4e44e73b9 100644 --- a/test/unix/luv_main.ml +++ b/test/unix/luv_main.ml @@ -1,20 +1,21 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for - details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) + details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Tester let () = Lwt_engine.set (new Lwt_luv.engine) let () = - Test.concurrent "unix with luv" [ - Test_lwt_unix.suite; - Test_lwt_io.suite; - Test_lwt_io_non_block.suite; - Test_lwt_process.suite; - Test_lwt_engine.suite; - Test_mcast.suite; - Test_lwt_fmt.suite; - Test_lwt_timeout.suite; - Test_lwt_bytes.suite; - Test_sleep_and_timeout.suite; - ] + Test.concurrent "unix with luv" + [ + Test_lwt_unix.suite; + Test_lwt_io.suite; + Test_lwt_io_non_block.suite; + Test_lwt_process.suite; + Test_lwt_engine.suite; + Test_mcast.suite; + Test_lwt_fmt.suite; + Test_lwt_timeout.suite; + Test_lwt_bytes.suite; + Test_sleep_and_timeout.suite; + ] diff --git a/test/unix/main.ml b/test/unix/main.ml index 34d2d49837..2d9caf1c5d 100644 --- a/test/unix/main.ml +++ b/test/unix/main.ml @@ -4,15 +4,16 @@ open Tester let () = - Test.concurrent "unix" [ - Test_lwt_unix.suite; - Test_lwt_io.suite; - Test_lwt_io_non_block.suite; - Test_lwt_process.suite; - Test_lwt_engine.suite; - Test_mcast.suite; - Test_lwt_fmt.suite; - Test_lwt_timeout.suite; - Test_lwt_bytes.suite; - Test_sleep_and_timeout.suite; - ] + Test.concurrent "unix" + [ + Test_lwt_unix.suite; + Test_lwt_io.suite; + Test_lwt_io_non_block.suite; + Test_lwt_process.suite; + Test_lwt_engine.suite; + Test_mcast.suite; + Test_lwt_fmt.suite; + Test_lwt_timeout.suite; + Test_lwt_bytes.suite; + Test_sleep_and_timeout.suite; + ] diff --git a/test/unix/test_lwt_bytes.ml b/test/unix/test_lwt_bytes.ml index 4c42542bb0..969741fa6e 100644 --- a/test/unix/test_lwt_bytes.ml +++ b/test/unix/test_lwt_bytes.ml @@ -4,55 +4,45 @@ open Lwt.Infix open Test -let bytes_equal (b1:Bytes.t) (b2:Bytes.t) = b1 = b2 +let bytes_equal (b1 : Bytes.t) (b2 : Bytes.t) = b1 = b2 let tcp_server_client_exchange server_logic client_logic = let server_is_ready, notify_server_is_ready = Lwt.wait () in let server () = let sock = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in let sockaddr = Lwt_unix.ADDR_INET (Unix.inet_addr_loopback, 0) in - Lwt_unix.bind sock sockaddr - >>= fun () -> + Lwt_unix.bind sock sockaddr >>= fun () -> let server_address = Lwt_unix.getsockname sock in let () = Lwt_unix.listen sock 5 in Lwt.wakeup_later notify_server_is_ready server_address; - Lwt_unix.accept sock - >>= fun (fd_client, _) -> - server_logic fd_client - >>= fun _n -> Lwt_unix.close fd_client - >>= fun () -> Lwt_unix.close sock + Lwt_unix.accept sock >>= fun (fd_client, _) -> + server_logic fd_client >>= fun _n -> + Lwt_unix.close fd_client >>= fun () -> Lwt_unix.close sock in let client () = - server_is_ready - >>= fun sockaddr -> + server_is_ready >>= fun sockaddr -> let sock = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in - Lwt_unix.connect sock sockaddr - >>= fun () -> - client_logic sock - >>= fun _n -> Lwt_unix.close sock + Lwt_unix.connect sock sockaddr >>= fun () -> + client_logic sock >>= fun _n -> Lwt_unix.close sock in - Lwt.join [client (); server ()] + Lwt.join [ client (); server () ] let udp_server_client_exchange server_logic client_logic = let server_is_ready, notify_server_is_ready = Lwt.wait () in let server () = let sock = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_DGRAM 0 in let sockaddr = Lwt_unix.ADDR_INET (Unix.inet_addr_loopback, 0) in - Lwt_unix.bind sock sockaddr - >>= fun () -> + Lwt_unix.bind sock sockaddr >>= fun () -> let server_address = Lwt_unix.getsockname sock in Lwt.wakeup_later notify_server_is_ready server_address; - server_logic sock - >>= fun (_n, _sockaddr) -> Lwt_unix.close sock + server_logic sock >>= fun (_n, _sockaddr) -> Lwt_unix.close sock in let client () = - server_is_ready - >>= fun sockaddr -> + server_is_ready >>= fun sockaddr -> let sock = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_DGRAM 0 in - client_logic sock sockaddr - >>= fun (_n) -> Lwt_unix.close sock + client_logic sock sockaddr >>= fun _n -> Lwt_unix.close sock in - Lwt.join [client (); server ()] + Lwt.join [ client (); server () ] let gen_buf n = let buf = Lwt_bytes.create n in @@ -74,14 +64,11 @@ let file_suffix = let test_mincore buff_len offset n_states = let test_file = Printf.sprintf "bytes_mincore_write_%i" (file_suffix ()) in - Lwt_unix.openfile test_file [O_RDWR;O_TRUNC; O_CREAT] 0o666 - >>= fun fd -> + Lwt_unix.openfile test_file [ O_RDWR; O_TRUNC; O_CREAT ] 0o666 >>= fun fd -> let buf_write = gen_buf buff_len in - Lwt_bytes.write fd buf_write 0 buff_len - >>= fun _n -> - Lwt_unix.close fd - >>= fun () -> - let fd = Unix.openfile test_file [O_RDONLY] 0 in + Lwt_bytes.write fd buf_write 0 buff_len >>= fun _n -> + Lwt_unix.close fd >>= fun () -> + let fd = Unix.openfile test_file [ O_RDONLY ] 0 in let shared = false in let size = buff_len in let buffer = Lwt_bytes.map_file ~fd ~shared ~size () in @@ -91,755 +78,605 @@ let test_mincore buff_len offset n_states = let test_wait_mincore buff_len offset = let test_file = Printf.sprintf "bytes_mincore_write_%i" (file_suffix ()) in - Lwt_unix.openfile test_file [O_RDWR;O_TRUNC; O_CREAT] 0o666 - >>= fun fd -> + Lwt_unix.openfile test_file [ O_RDWR; O_TRUNC; O_CREAT ] 0o666 >>= fun fd -> let buf_write = gen_buf buff_len in - Lwt_bytes.write fd buf_write 0 buff_len - >>= fun _n -> - Lwt_unix.close fd - >>= fun () -> - let fd = Unix.openfile test_file [O_RDONLY] 0 in + Lwt_bytes.write fd buf_write 0 buff_len >>= fun _n -> + Lwt_unix.close fd >>= fun () -> + let fd = Unix.openfile test_file [ O_RDONLY ] 0 in let shared = false in let size = buff_len in let buffer = Lwt_bytes.map_file ~fd ~shared ~size () in Lwt_bytes.wait_mincore buffer offset -let suite = suite "lwt_bytes" [ - test "create" begin fun () -> - let len = 5 in - let buff = Lwt_bytes.create len in - let len' = Bigarray.Array1.dim buff in - Lwt.return (len = len') - end; - - test "get/set" begin fun () -> - let buff = Lwt_bytes.create 4 in - let () = Lwt_bytes.set buff 0 'a' in - let () = Lwt_bytes.set buff 1 'b' in - let () = Lwt_bytes.set buff 2 'c' in - let check = Lwt_bytes.get buff 0 = 'a' && - Lwt_bytes.get buff 1 = 'b' && - Lwt_bytes.get buff 2 = 'c' - in Lwt.return check - end; - - test "get out of bounds : lower limit" begin fun () -> - let buff = Lwt_bytes.create 3 in - match Lwt_bytes.get buff (-1) with - | exception Invalid_argument _ -> Lwt.return true - | _ -> Lwt.return false - end; - - test "get out of bounds : upper limit" begin fun () -> - let buff = Lwt_bytes.create 3 in - match Lwt_bytes.get buff 3 with - | exception Invalid_argument _ -> Lwt.return true - | _ -> Lwt.return false - end; - - test "set out of bounds : lower limit" begin fun () -> - let buff = Lwt_bytes.create 3 in - match Lwt_bytes.set buff (-1) 'a' with - | exception Invalid_argument _ -> Lwt.return true - | () -> Lwt.return false - end; - - test "set out of bounds : upper limit" begin fun () -> - let buff = Lwt_bytes.create 3 in - match Lwt_bytes.set buff 3 'a' with - | exception Invalid_argument _ -> Lwt.return true - | () -> Lwt.return false - end; - - test "unsafe_get/unsafe_set" begin fun () -> - let buff = Lwt_bytes.create 4 in - let () = Lwt_bytes.unsafe_set buff 0 'a' in - let () = Lwt_bytes.unsafe_set buff 1 'b' in - let () = Lwt_bytes.unsafe_set buff 2 'c' in - let check = Lwt_bytes.unsafe_get buff 0 = 'a' && - Lwt_bytes.unsafe_get buff 1 = 'b' && - Lwt_bytes.unsafe_get buff 2 = 'c' - in Lwt.return check - end; - - test "of bytes" begin fun () -> - let bytes = Bytes.of_string "abc" in - let buff = Lwt_bytes.of_bytes bytes in - let check = Lwt_bytes.get buff 0 = Bytes.get bytes 0 && - Lwt_bytes.get buff 1 = Bytes.get bytes 1 && - Lwt_bytes.get buff 2 = Bytes.get bytes 2 - in Lwt.return check - end; - - test "of string" begin fun () -> - let buff = Lwt_bytes.of_string "abc" in - let check = Lwt_bytes.get buff 0 = 'a' && - Lwt_bytes.get buff 1 = 'b' && - Lwt_bytes.get buff 2 = 'c' - in Lwt.return check - end; - - test "to bytes" begin fun () -> - let bytes = Bytes.of_string "abc" in - let buff = Lwt_bytes.of_bytes bytes in - let bytes' = Lwt_bytes.to_bytes buff in - let check = bytes_equal bytes bytes' in - Lwt.return check - end; - - test "to string" begin fun () -> - let str = "abc" in - let buff = Lwt_bytes.of_string str in - let str' = Lwt_bytes.to_string buff in - let check = str = str' in - Lwt.return check - end; - - test "blit" begin fun () -> - let str1 = "abc" in - let buf1 = Lwt_bytes.of_string str1 in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - let () = Lwt_bytes.blit buf1 0 buf2 3 3 in - let check = "abcabc" = Lwt_bytes.to_string buf2 in - Lwt.return check - end; - - test "blit source out of bounds: lower limit" begin fun () -> - let str1 = "abc" in - let buf1 = Lwt_bytes.of_string str1 in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - match Lwt_bytes.blit buf1 (-1) buf2 3 3 with - | exception Invalid_argument _ -> Lwt.return true - | () -> Lwt.return false - end; - - test "blit source out of bounds: upper limit" begin fun () -> - let str1 = "abc" in - let buf1 = Lwt_bytes.of_string str1 in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - match Lwt_bytes.blit buf1 1 buf2 3 3 with - | exception Invalid_argument _ -> Lwt.return true - | () -> Lwt.return false - end; - - test "blit destination out of bounds: lower limit" begin fun () -> - let str1 = "abc" in - let buf1 = Lwt_bytes.of_string str1 in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - match Lwt_bytes.blit buf1 0 buf2 (-1) 3 with - | exception Invalid_argument _ -> Lwt.return true - | () -> Lwt.return false - end; - - test "blit destination out of bounds: upper limit" begin fun () -> - let str1 = "abc" in - let buf1 = Lwt_bytes.of_string str1 in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - match Lwt_bytes.blit buf1 0 buf2 4 3 with - | exception Invalid_argument _ -> Lwt.return true - | () -> Lwt.return false - end; - - test "blit length out of bounds: lower limit" begin fun () -> - let str1 = "abc" in - let buf1 = Lwt_bytes.of_string str1 in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - match Lwt_bytes.blit buf1 0 buf2 3 (-1) with - | exception Invalid_argument _ -> Lwt.return true - | () -> Lwt.return false - end; - - test "blit from bytes" begin fun () -> - let bytes1 = Bytes.of_string "abc" in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - let () = Lwt_bytes.blit_from_bytes bytes1 0 buf2 3 3 in - let check = "abcabc" = Lwt_bytes.to_string buf2 in - Lwt.return check - end; - - test "blit from bytes source out of bounds: lower limit" begin fun () -> - let bytes1 = Bytes.of_string "abc" in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - match Lwt_bytes.blit_from_bytes bytes1 (-1) buf2 3 3 with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "blit from bytes source out of bounds: upper limit" begin fun () -> - let bytes1 = Bytes.of_string "abc" in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - match Lwt_bytes.blit_from_bytes bytes1 1 buf2 3 3 with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "blit from bytes destination out of bounds: lower limit" begin fun () -> - let bytes1 = Bytes.of_string "abc" in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - match Lwt_bytes.blit_from_bytes bytes1 0 buf2 (-1) 3 with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "blit from bytes destination out of bounds: upper limit" begin fun () -> - let bytes1 = Bytes.of_string "abc" in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - match Lwt_bytes.blit_from_bytes bytes1 0 buf2 4 3 with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "blit from bytes length out of bounds: lower limit" begin fun () -> - let bytes1 = Bytes.of_string "abc" in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - match Lwt_bytes.blit_from_bytes bytes1 0 buf2 3 (-1) with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "blit from string" begin fun () -> - let string1 = "abc" in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - let () = Lwt_bytes.blit_from_string string1 0 buf2 3 3 in - let check = "abcabc" = Lwt_bytes.to_string buf2 in - Lwt.return check - end; - - test "blit from string source out of bounds: lower limit" begin fun () -> - let string1 = "abc" in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - match Lwt_bytes.blit_from_string string1 (-1) buf2 3 3 with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "blit from string source out of bounds: upper limit" begin fun () -> - let string1 = "abc" in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - match Lwt_bytes.blit_from_string string1 1 buf2 3 3 with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "blit from string destination out of bounds: lower limit" begin fun () -> - let string1 = "abc" in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - match Lwt_bytes.blit_from_string string1 0 buf2 (-1) 3 with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "blit from string destination out of bounds: upper limit" begin fun () -> - let string1 = "abc" in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - match Lwt_bytes.blit_from_string string1 0 buf2 4 3 with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "blit from string length out of bounds: lower limit" begin fun () -> - let string1 = "abc" in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - match Lwt_bytes.blit_from_string string1 0 buf2 3 (-1) with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "blit from string length out of bounds: upper limit" begin fun () -> - let string1 = "abc" in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - match Lwt_bytes.blit_from_string string1 0 buf2 3 10 with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "blit to bytes" begin fun () -> - let str1 = "abc" in - let buf1 = Lwt_bytes.of_string str1 in - let str2 = "abcdef" in - let bytes2 = Bytes.of_string str2 in - let () = Lwt_bytes.blit_to_bytes buf1 0 bytes2 3 3 in - let check = "abcabc" = Bytes.to_string bytes2 in - Lwt.return check - end; - - test "blit to bytes source out of bounds: lower limit" begin fun () -> - let str1 = "abc" in - let buf1 = Lwt_bytes.of_string str1 in - let str2 = "abcdef" in - let bytes2 = Bytes.of_string str2 in - match Lwt_bytes.blit_to_bytes buf1 (-1) bytes2 3 3 with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "blit to bytes source out of bounds: upper limit" begin fun () -> - let str1 = "abc" in - let buf1 = Lwt_bytes.of_string str1 in - let str2 = "abcdef" in - let bytes2 = Bytes.of_string str2 in - match Lwt_bytes.blit_to_bytes buf1 1 bytes2 3 3 with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "blit to bytes destination out of bounds: lower limit" begin fun () -> - let str1 = "abc" in - let buf1 = Lwt_bytes.of_string str1 in - let str2 = "abcdef" in - let bytes2 = Bytes.of_string str2 in - match Lwt_bytes.blit_to_bytes buf1 0 bytes2 (-1) 3 with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "blit to bytes destination out of bounds: upper limit" begin fun () -> - let str1 = "abc" in - let buf1 = Lwt_bytes.of_string str1 in - let str2 = "abcdef" in - let bytes2 = Bytes.of_string str2 in - match Lwt_bytes.blit_to_bytes buf1 0 bytes2 4 3 with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "blit to bytes length out of bounds: lower limit" begin fun () -> - let str1 = "abc" in - let buf1 = Lwt_bytes.of_string str1 in - let str2 = "abcdef" in - let bytes2 = Bytes.of_string str2 in - match Lwt_bytes.blit_to_bytes buf1 0 bytes2 3 (-1) with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "unsafe blit" begin fun () -> - let str1 = "abc" in - let buf1 = Lwt_bytes.of_string str1 in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - let () = Lwt_bytes.unsafe_blit buf1 0 buf2 3 3 in - let check = "abcabc" = Lwt_bytes.to_string buf2 in - Lwt.return check - end; - - test "unsafe blit from bytes" begin fun () -> - let bytes1 = Bytes.of_string "abc" in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - let () = Lwt_bytes.unsafe_blit_from_bytes bytes1 0 buf2 3 3 in - let check = "abcabc" = Lwt_bytes.to_string buf2 in - Lwt.return check - end; - - test "unsafe blit from string" begin fun () -> - let string1 = "abc" in - let str2 = "abcdef" in - let buf2 = Lwt_bytes.of_string str2 in - let () = Lwt_bytes.unsafe_blit_from_string string1 0 buf2 3 3 in - let check = "abcabc" = Lwt_bytes.to_string buf2 in - Lwt.return check - end; - - test "unsafe blit to bytes" begin fun () -> - let str1 = "abc" in - let buf1 = Lwt_bytes.of_string str1 in - let str2 = "abcdef" in - let bytes2 = Bytes.of_string str2 in - let () = Lwt_bytes.unsafe_blit_to_bytes buf1 0 bytes2 3 3 in - let check = "abcabc" = Bytes.to_string bytes2 in - Lwt.return check - end; - - test "proxy" begin fun () -> - let str = "abcdef" in - let buf = Lwt_bytes.of_string str in - let buf' = Lwt_bytes.proxy buf 3 3 in - let check1 = "def" = Lwt_bytes.to_string buf' in - let () = Lwt_bytes.set buf 3 'a' in - let check2 = "aef" = Lwt_bytes.to_string buf' in - Lwt.return (check1 && check2) - end; - - test "proxy offset out of bounds: lower limit" begin fun () -> - let str = "abcdef" in - let buf = Lwt_bytes.of_string str in - match Lwt_bytes.proxy buf (-1) 3 with - | exception Invalid_argument _ -> Lwt.return_true - | _ -> Lwt.return_false - end; - - test "proxy offset out of bounds: upper limit" begin fun () -> - let str = "abcdef" in - let buf = Lwt_bytes.of_string str in - match Lwt_bytes.proxy buf 4 3 with - | exception Invalid_argument _ -> Lwt.return_true - | _ -> Lwt.return_false - end; - - test "proxy length out of bounds: lower limit" begin fun () -> - let str = "abcdef" in - let buf = Lwt_bytes.of_string str in - match Lwt_bytes.proxy buf 3 (-1) with - | exception Invalid_argument _ -> Lwt.return_true - | _ -> Lwt.return_false - end; - - test "extract" begin fun () -> - let str = "abcdef" in - let buf = Lwt_bytes.of_string str in - let buf' = Lwt_bytes.extract buf 3 3 in - let check = "def" = Lwt_bytes.to_string buf' in - Lwt.return check - end; - - test "extract offset out of bounds: lower limit" begin fun () -> - let str = "abcdef" in - let buf = Lwt_bytes.of_string str in - match Lwt_bytes.extract buf (-1) 3 with - | exception Invalid_argument _ -> Lwt.return_true - | _ -> Lwt.return_false - end; - - test "extract offset out of bounds: upper limit" begin fun () -> - let str = "abcdef" in - let buf = Lwt_bytes.of_string str in - match Lwt_bytes.extract buf 4 3 with - | exception Invalid_argument _ -> Lwt.return_true - | _ -> Lwt.return_false - end; - - test "extract length out of bounds: lower limit" begin fun () -> - let str = "abcdef" in - let buf = Lwt_bytes.of_string str in - match Lwt_bytes.extract buf 3 (-1) with - | exception Invalid_argument _ -> Lwt.return_true - | _ -> Lwt.return_false - end; - - test "copy" begin fun () -> - let str = "abc" in - let buf = Lwt_bytes.of_string str in - let buf' = Lwt_bytes.copy buf in - let check = str = Lwt_bytes.to_string buf' in - Lwt.return check - end; - - test "fill" begin fun () -> - let str = "abcdef" in - let buf = Lwt_bytes.of_string str in - let () = Lwt_bytes.fill buf 3 3 'a' in - let check = "abcaaa" = Lwt_bytes.to_string buf in - Lwt.return check - end; - - test "fill offset out of bounds: lower limit" begin fun () -> - let str = "abcdef" in - let buf = Lwt_bytes.of_string str in - match Lwt_bytes.fill buf (-1) 3 'a' with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "fill offset out of bounds: upper limit" begin fun () -> - let str = "abcdef" in - let buf = Lwt_bytes.of_string str in - match Lwt_bytes.fill buf 4 3 'a' with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "fill length out of bounds lower limit" begin fun () -> - let str = "abcdef" in - let buf = Lwt_bytes.of_string str in - match Lwt_bytes.fill buf 3 (-1) 'a' with - | exception Invalid_argument _ -> Lwt.return_true - | () -> Lwt.return_false - end; - - test "unsafe fill" begin fun () -> - let str = "abcdef" in - let buf = Lwt_bytes.of_string str in - let () = Lwt_bytes.unsafe_fill buf 3 3 'a' in - let check = "abcaaa" = Lwt_bytes.to_string buf in - Lwt.return check - end; - - test "bytes read" begin fun () -> - let test_file = "bytes_io_data" in - Lwt_unix.openfile test_file [O_RDONLY] 0 - >>= fun fd -> - let buf = Lwt_bytes.create 6 in - Lwt_bytes.read fd buf 0 6 - >>= fun _n -> - let check = "abcdef" = Lwt_bytes.to_string buf in - Lwt_unix.close fd - >>= fun () -> - Lwt.return check - end; - - test "read: buffer retention" ~sequential:true begin fun () -> - let buffer = Lwt_bytes.create 3 in - - let read_fd, write_fd = Lwt_unix.pipe () in - Lwt_unix.set_blocking read_fd true; - - Lwt_unix.write_string write_fd "foo" 0 3 >>= fun _ -> - - let retained = Lwt_unix.retained buffer in - Lwt_bytes.read read_fd buffer 0 3 >>= fun _ -> - - Lwt_unix.close write_fd >>= fun () -> - Lwt_unix.close read_fd >|= fun () -> - - !retained - end; - - test "bytes write" begin fun () -> - let test_file = "bytes_io_data_write" in - Lwt_unix.openfile test_file [O_RDWR;O_TRUNC; O_CREAT] 0o666 - >>= fun fd -> - let buf_write = Lwt_bytes.of_string "abc" in - Lwt_bytes.write fd buf_write 0 3 - >>= fun _n -> - Lwt_unix.close fd - >>= fun () -> - Lwt_unix.openfile test_file [O_RDONLY] 0 - >>= fun fd -> - let buf_read = Lwt_bytes.create 3 in - Lwt_bytes.read fd buf_read 0 3 - >>= fun _n -> - let check = buf_write = buf_read in - Lwt_unix.close fd - >>= fun () -> - Lwt.return check - end; - - test "write: buffer retention" ~sequential:true begin fun () -> - let buffer = Lwt_bytes.create 3 in - - let read_fd, write_fd = Lwt_unix.pipe () in - Lwt_unix.set_blocking write_fd true; - - let retained = Lwt_unix.retained buffer in - Lwt_bytes.write write_fd buffer 0 3 >>= fun _ -> - - Lwt_unix.close write_fd >>= fun () -> - Lwt_unix.close read_fd >|= fun () -> - - !retained - end; - - test "bytes recv" ~only_if:(fun () -> not Sys.win32) begin fun () -> - let buf = gen_buf 6 in - let server_logic socket = - Lwt_unix.write_string socket "abcdefghij" 0 9 - in - let client_logic socket = - Lwt_bytes.recv socket buf 0 6 [] - in - tcp_server_client_exchange server_logic client_logic - >>= fun () -> - let check = "abcdef" = Lwt_bytes.to_string buf in - Lwt.return check - end; - - test "bytes send" ~only_if:(fun () -> not Sys.win32) begin fun () -> - let buf = gen_buf 6 in - let server_logic socket = - Lwt_bytes.send socket (Lwt_bytes.of_string "abcdef") 0 6 [] - in - let client_logic socket = - Lwt_bytes.recv socket buf 0 6 [] - in - tcp_server_client_exchange server_logic client_logic - >>= fun () -> - let check = "abcdef" = Lwt_bytes.to_string buf in - Lwt.return check - end; - - test "bytes recvfrom" ~only_if:(fun () -> not Sys.win32) begin fun () -> - let buf = gen_buf 6 in - let server_logic socket = - Lwt_bytes.recvfrom socket buf 0 6 [] - in - let client_logic socket sockaddr = - Lwt_unix.sendto socket (Bytes.of_string "abcdefghij") 0 9 [] sockaddr - in - udp_server_client_exchange server_logic client_logic - >>= fun () -> - let check = "abcdef" = Lwt_bytes.to_string buf in - Lwt.return check - end; - - test "bytes sendto" ~only_if:(fun () -> not Sys.win32) begin fun () -> - let buf = gen_buf 6 in - let server_logic socket = - Lwt_bytes.recvfrom socket buf 0 6 [] - in - let client_logic socket sockaddr = - let message = Lwt_bytes.of_string "abcdefghij" in - Lwt_bytes.sendto socket message 0 9 [] sockaddr - in - udp_server_client_exchange server_logic client_logic - >>= fun () -> - let check = "abcdef" = Lwt_bytes.to_string buf in - Lwt.return check - end; - - test "bytes recv_msg" ~only_if:(fun () -> not Sys.win32) begin fun () -> - let buffer = gen_buf 6 in - let offset = 0 in - let io_vectors = [Lwt_bytes.io_vector ~buffer ~offset ~length:6] in - let server_logic socket = - (Lwt_bytes.recv_msg [@ocaml.warning "-3"]) ~socket ~io_vectors - in - let client_logic socket sockaddr = - let message = Lwt_bytes.of_string "abcdefghij" in - Lwt_bytes.sendto socket message 0 9 [] sockaddr - in - udp_server_client_exchange server_logic client_logic - >>= fun () -> - let check = "abcdef" = Lwt_bytes.to_string buffer in - Lwt.return check - end; - - test "bytes send_msg" ~only_if:(fun () -> not Sys.win32) begin fun () -> - let buffer = gen_buf 6 in - let offset = 0 in - let server_logic socket = - let io_vectors = [Lwt_bytes.io_vector ~buffer ~offset ~length:6] in - (Lwt_bytes.recv_msg [@ocaml.warning "-3"]) ~socket ~io_vectors - in - let client_logic socket sockaddr = - Lwt_unix.connect socket sockaddr - >>= fun () -> - let message = Lwt_bytes.of_string "abcdefghij" in - let io_vectors = [Lwt_bytes.io_vector ~buffer:message ~offset ~length:9] in - (Lwt_bytes.send_msg [@ocaml.warning "-3"]) ~socket ~io_vectors ~fds:[] - in - udp_server_client_exchange server_logic client_logic - >>= fun () -> - let check = "abcdef" = Lwt_bytes.to_string buffer in - Lwt.return check - end; - - test "send_msgto" ~only_if:(fun () -> not Sys.win32) begin fun () -> - let buffer = gen_buf 6 in - let offset = 0 in - let server_logic socket = - let io_vectors = [Lwt_bytes.io_vector ~buffer ~offset ~length:6] in - (Lwt_bytes.recv_msg [@ocaml.warning "-3"]) ~socket ~io_vectors - in - let client_logic socket sockaddr = - let message = Lwt_bytes.of_string "abcdefghij" in - let io_vectors = Lwt_unix.IO_vectors.create () in - Lwt_unix.IO_vectors.append_bigarray io_vectors message offset 9; - Lwt_unix.send_msgto ~socket ~io_vectors ~fds:[] ~dest:sockaddr - in - udp_server_client_exchange server_logic client_logic - >>= fun () -> - let check = "abcdef" = Lwt_bytes.to_string buffer in - Lwt.return check - end; - - test "map_file" begin fun () -> - let test_file = "bytes_io_data" in - let fd = Unix.openfile test_file [O_RDONLY] 0 in - let shared = false in - let size = 6 in - let buffer = Lwt_bytes.map_file ~fd ~shared ~size () in - let check = "abcdef" = Lwt_bytes.to_string buffer in - let () = Unix.close fd in - Lwt.return check - end; - - test "page_size" begin fun () -> - let sizes = [4096; 65536] in - Lwt.return (List.mem Lwt_bytes.page_size sizes) - end; - - test "mincore buffer length = page_size * 2, n_states = 1" - ~only_if:(fun () -> not Sys.win32) begin fun () -> - test_mincore (Lwt_bytes.page_size * 2) Lwt_bytes.page_size 1 - >>= fun () -> Lwt.return true - end; - - test "mincore buffer length = page_size * 2, n_states = 2" - ~only_if:(fun () -> not Sys.win32) begin fun () -> - Lwt.catch +let suite = + suite "lwt_bytes" + [ + test "create" (fun () -> + let len = 5 in + let buff = Lwt_bytes.create len in + let len' = Bigarray.Array1.dim buff in + Lwt.return (len = len')); + test "get/set" (fun () -> + let buff = Lwt_bytes.create 4 in + let () = Lwt_bytes.set buff 0 'a' in + let () = Lwt_bytes.set buff 1 'b' in + let () = Lwt_bytes.set buff 2 'c' in + let check = + Lwt_bytes.get buff 0 = 'a' + && Lwt_bytes.get buff 1 = 'b' + && Lwt_bytes.get buff 2 = 'c' + in + Lwt.return check); + test "get out of bounds : lower limit" (fun () -> + let buff = Lwt_bytes.create 3 in + match Lwt_bytes.get buff (-1) with + | exception Invalid_argument _ -> Lwt.return true + | _ -> Lwt.return false); + test "get out of bounds : upper limit" (fun () -> + let buff = Lwt_bytes.create 3 in + match Lwt_bytes.get buff 3 with + | exception Invalid_argument _ -> Lwt.return true + | _ -> Lwt.return false); + test "set out of bounds : lower limit" (fun () -> + let buff = Lwt_bytes.create 3 in + match Lwt_bytes.set buff (-1) 'a' with + | exception Invalid_argument _ -> Lwt.return true + | () -> Lwt.return false); + test "set out of bounds : upper limit" (fun () -> + let buff = Lwt_bytes.create 3 in + match Lwt_bytes.set buff 3 'a' with + | exception Invalid_argument _ -> Lwt.return true + | () -> Lwt.return false); + test "unsafe_get/unsafe_set" (fun () -> + let buff = Lwt_bytes.create 4 in + let () = Lwt_bytes.unsafe_set buff 0 'a' in + let () = Lwt_bytes.unsafe_set buff 1 'b' in + let () = Lwt_bytes.unsafe_set buff 2 'c' in + let check = + Lwt_bytes.unsafe_get buff 0 = 'a' + && Lwt_bytes.unsafe_get buff 1 = 'b' + && Lwt_bytes.unsafe_get buff 2 = 'c' + in + Lwt.return check); + test "of bytes" (fun () -> + let bytes = Bytes.of_string "abc" in + let buff = Lwt_bytes.of_bytes bytes in + let check = + Lwt_bytes.get buff 0 = Bytes.get bytes 0 + && Lwt_bytes.get buff 1 = Bytes.get bytes 1 + && Lwt_bytes.get buff 2 = Bytes.get bytes 2 + in + Lwt.return check); + test "of string" (fun () -> + let buff = Lwt_bytes.of_string "abc" in + let check = + Lwt_bytes.get buff 0 = 'a' + && Lwt_bytes.get buff 1 = 'b' + && Lwt_bytes.get buff 2 = 'c' + in + Lwt.return check); + test "to bytes" (fun () -> + let bytes = Bytes.of_string "abc" in + let buff = Lwt_bytes.of_bytes bytes in + let bytes' = Lwt_bytes.to_bytes buff in + let check = bytes_equal bytes bytes' in + Lwt.return check); + test "to string" (fun () -> + let str = "abc" in + let buff = Lwt_bytes.of_string str in + let str' = Lwt_bytes.to_string buff in + let check = str = str' in + Lwt.return check); + test "blit" (fun () -> + let str1 = "abc" in + let buf1 = Lwt_bytes.of_string str1 in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + let () = Lwt_bytes.blit buf1 0 buf2 3 3 in + let check = "abcabc" = Lwt_bytes.to_string buf2 in + Lwt.return check); + test "blit source out of bounds: lower limit" (fun () -> + let str1 = "abc" in + let buf1 = Lwt_bytes.of_string str1 in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + match Lwt_bytes.blit buf1 (-1) buf2 3 3 with + | exception Invalid_argument _ -> Lwt.return true + | () -> Lwt.return false); + test "blit source out of bounds: upper limit" (fun () -> + let str1 = "abc" in + let buf1 = Lwt_bytes.of_string str1 in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + match Lwt_bytes.blit buf1 1 buf2 3 3 with + | exception Invalid_argument _ -> Lwt.return true + | () -> Lwt.return false); + test "blit destination out of bounds: lower limit" (fun () -> + let str1 = "abc" in + let buf1 = Lwt_bytes.of_string str1 in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + match Lwt_bytes.blit buf1 0 buf2 (-1) 3 with + | exception Invalid_argument _ -> Lwt.return true + | () -> Lwt.return false); + test "blit destination out of bounds: upper limit" (fun () -> + let str1 = "abc" in + let buf1 = Lwt_bytes.of_string str1 in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + match Lwt_bytes.blit buf1 0 buf2 4 3 with + | exception Invalid_argument _ -> Lwt.return true + | () -> Lwt.return false); + test "blit length out of bounds: lower limit" (fun () -> + let str1 = "abc" in + let buf1 = Lwt_bytes.of_string str1 in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + match Lwt_bytes.blit buf1 0 buf2 3 (-1) with + | exception Invalid_argument _ -> Lwt.return true + | () -> Lwt.return false); + test "blit from bytes" (fun () -> + let bytes1 = Bytes.of_string "abc" in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + let () = Lwt_bytes.blit_from_bytes bytes1 0 buf2 3 3 in + let check = "abcabc" = Lwt_bytes.to_string buf2 in + Lwt.return check); + test "blit from bytes source out of bounds: lower limit" (fun () -> + let bytes1 = Bytes.of_string "abc" in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + match Lwt_bytes.blit_from_bytes bytes1 (-1) buf2 3 3 with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "blit from bytes source out of bounds: upper limit" (fun () -> + let bytes1 = Bytes.of_string "abc" in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + match Lwt_bytes.blit_from_bytes bytes1 1 buf2 3 3 with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "blit from bytes destination out of bounds: lower limit" (fun () -> + let bytes1 = Bytes.of_string "abc" in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + match Lwt_bytes.blit_from_bytes bytes1 0 buf2 (-1) 3 with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "blit from bytes destination out of bounds: upper limit" (fun () -> + let bytes1 = Bytes.of_string "abc" in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + match Lwt_bytes.blit_from_bytes bytes1 0 buf2 4 3 with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "blit from bytes length out of bounds: lower limit" (fun () -> + let bytes1 = Bytes.of_string "abc" in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + match Lwt_bytes.blit_from_bytes bytes1 0 buf2 3 (-1) with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "blit from string" (fun () -> + let string1 = "abc" in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + let () = Lwt_bytes.blit_from_string string1 0 buf2 3 3 in + let check = "abcabc" = Lwt_bytes.to_string buf2 in + Lwt.return check); + test "blit from string source out of bounds: lower limit" (fun () -> + let string1 = "abc" in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + match Lwt_bytes.blit_from_string string1 (-1) buf2 3 3 with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "blit from string source out of bounds: upper limit" (fun () -> + let string1 = "abc" in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + match Lwt_bytes.blit_from_string string1 1 buf2 3 3 with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "blit from string destination out of bounds: lower limit" (fun () -> + let string1 = "abc" in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + match Lwt_bytes.blit_from_string string1 0 buf2 (-1) 3 with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "blit from string destination out of bounds: upper limit" (fun () -> + let string1 = "abc" in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + match Lwt_bytes.blit_from_string string1 0 buf2 4 3 with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "blit from string length out of bounds: lower limit" (fun () -> + let string1 = "abc" in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + match Lwt_bytes.blit_from_string string1 0 buf2 3 (-1) with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "blit from string length out of bounds: upper limit" (fun () -> + let string1 = "abc" in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + match Lwt_bytes.blit_from_string string1 0 buf2 3 10 with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "blit to bytes" (fun () -> + let str1 = "abc" in + let buf1 = Lwt_bytes.of_string str1 in + let str2 = "abcdef" in + let bytes2 = Bytes.of_string str2 in + let () = Lwt_bytes.blit_to_bytes buf1 0 bytes2 3 3 in + let check = "abcabc" = Bytes.to_string bytes2 in + Lwt.return check); + test "blit to bytes source out of bounds: lower limit" (fun () -> + let str1 = "abc" in + let buf1 = Lwt_bytes.of_string str1 in + let str2 = "abcdef" in + let bytes2 = Bytes.of_string str2 in + match Lwt_bytes.blit_to_bytes buf1 (-1) bytes2 3 3 with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "blit to bytes source out of bounds: upper limit" (fun () -> + let str1 = "abc" in + let buf1 = Lwt_bytes.of_string str1 in + let str2 = "abcdef" in + let bytes2 = Bytes.of_string str2 in + match Lwt_bytes.blit_to_bytes buf1 1 bytes2 3 3 with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "blit to bytes destination out of bounds: lower limit" (fun () -> + let str1 = "abc" in + let buf1 = Lwt_bytes.of_string str1 in + let str2 = "abcdef" in + let bytes2 = Bytes.of_string str2 in + match Lwt_bytes.blit_to_bytes buf1 0 bytes2 (-1) 3 with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "blit to bytes destination out of bounds: upper limit" (fun () -> + let str1 = "abc" in + let buf1 = Lwt_bytes.of_string str1 in + let str2 = "abcdef" in + let bytes2 = Bytes.of_string str2 in + match Lwt_bytes.blit_to_bytes buf1 0 bytes2 4 3 with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "blit to bytes length out of bounds: lower limit" (fun () -> + let str1 = "abc" in + let buf1 = Lwt_bytes.of_string str1 in + let str2 = "abcdef" in + let bytes2 = Bytes.of_string str2 in + match Lwt_bytes.blit_to_bytes buf1 0 bytes2 3 (-1) with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "unsafe blit" (fun () -> + let str1 = "abc" in + let buf1 = Lwt_bytes.of_string str1 in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + let () = Lwt_bytes.unsafe_blit buf1 0 buf2 3 3 in + let check = "abcabc" = Lwt_bytes.to_string buf2 in + Lwt.return check); + test "unsafe blit from bytes" (fun () -> + let bytes1 = Bytes.of_string "abc" in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + let () = Lwt_bytes.unsafe_blit_from_bytes bytes1 0 buf2 3 3 in + let check = "abcabc" = Lwt_bytes.to_string buf2 in + Lwt.return check); + test "unsafe blit from string" (fun () -> + let string1 = "abc" in + let str2 = "abcdef" in + let buf2 = Lwt_bytes.of_string str2 in + let () = Lwt_bytes.unsafe_blit_from_string string1 0 buf2 3 3 in + let check = "abcabc" = Lwt_bytes.to_string buf2 in + Lwt.return check); + test "unsafe blit to bytes" (fun () -> + let str1 = "abc" in + let buf1 = Lwt_bytes.of_string str1 in + let str2 = "abcdef" in + let bytes2 = Bytes.of_string str2 in + let () = Lwt_bytes.unsafe_blit_to_bytes buf1 0 bytes2 3 3 in + let check = "abcabc" = Bytes.to_string bytes2 in + Lwt.return check); + test "proxy" (fun () -> + let str = "abcdef" in + let buf = Lwt_bytes.of_string str in + let buf' = Lwt_bytes.proxy buf 3 3 in + let check1 = "def" = Lwt_bytes.to_string buf' in + let () = Lwt_bytes.set buf 3 'a' in + let check2 = "aef" = Lwt_bytes.to_string buf' in + Lwt.return (check1 && check2)); + test "proxy offset out of bounds: lower limit" (fun () -> + let str = "abcdef" in + let buf = Lwt_bytes.of_string str in + match Lwt_bytes.proxy buf (-1) 3 with + | exception Invalid_argument _ -> Lwt.return_true + | _ -> Lwt.return_false); + test "proxy offset out of bounds: upper limit" (fun () -> + let str = "abcdef" in + let buf = Lwt_bytes.of_string str in + match Lwt_bytes.proxy buf 4 3 with + | exception Invalid_argument _ -> Lwt.return_true + | _ -> Lwt.return_false); + test "proxy length out of bounds: lower limit" (fun () -> + let str = "abcdef" in + let buf = Lwt_bytes.of_string str in + match Lwt_bytes.proxy buf 3 (-1) with + | exception Invalid_argument _ -> Lwt.return_true + | _ -> Lwt.return_false); + test "extract" (fun () -> + let str = "abcdef" in + let buf = Lwt_bytes.of_string str in + let buf' = Lwt_bytes.extract buf 3 3 in + let check = "def" = Lwt_bytes.to_string buf' in + Lwt.return check); + test "extract offset out of bounds: lower limit" (fun () -> + let str = "abcdef" in + let buf = Lwt_bytes.of_string str in + match Lwt_bytes.extract buf (-1) 3 with + | exception Invalid_argument _ -> Lwt.return_true + | _ -> Lwt.return_false); + test "extract offset out of bounds: upper limit" (fun () -> + let str = "abcdef" in + let buf = Lwt_bytes.of_string str in + match Lwt_bytes.extract buf 4 3 with + | exception Invalid_argument _ -> Lwt.return_true + | _ -> Lwt.return_false); + test "extract length out of bounds: lower limit" (fun () -> + let str = "abcdef" in + let buf = Lwt_bytes.of_string str in + match Lwt_bytes.extract buf 3 (-1) with + | exception Invalid_argument _ -> Lwt.return_true + | _ -> Lwt.return_false); + test "copy" (fun () -> + let str = "abc" in + let buf = Lwt_bytes.of_string str in + let buf' = Lwt_bytes.copy buf in + let check = str = Lwt_bytes.to_string buf' in + Lwt.return check); + test "fill" (fun () -> + let str = "abcdef" in + let buf = Lwt_bytes.of_string str in + let () = Lwt_bytes.fill buf 3 3 'a' in + let check = "abcaaa" = Lwt_bytes.to_string buf in + Lwt.return check); + test "fill offset out of bounds: lower limit" (fun () -> + let str = "abcdef" in + let buf = Lwt_bytes.of_string str in + match Lwt_bytes.fill buf (-1) 3 'a' with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "fill offset out of bounds: upper limit" (fun () -> + let str = "abcdef" in + let buf = Lwt_bytes.of_string str in + match Lwt_bytes.fill buf 4 3 'a' with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "fill length out of bounds lower limit" (fun () -> + let str = "abcdef" in + let buf = Lwt_bytes.of_string str in + match Lwt_bytes.fill buf 3 (-1) 'a' with + | exception Invalid_argument _ -> Lwt.return_true + | () -> Lwt.return_false); + test "unsafe fill" (fun () -> + let str = "abcdef" in + let buf = Lwt_bytes.of_string str in + let () = Lwt_bytes.unsafe_fill buf 3 3 'a' in + let check = "abcaaa" = Lwt_bytes.to_string buf in + Lwt.return check); + test "bytes read" (fun () -> + let test_file = "bytes_io_data" in + Lwt_unix.openfile test_file [ O_RDONLY ] 0 >>= fun fd -> + let buf = Lwt_bytes.create 6 in + Lwt_bytes.read fd buf 0 6 >>= fun _n -> + let check = "abcdef" = Lwt_bytes.to_string buf in + Lwt_unix.close fd >>= fun () -> Lwt.return check); + test "read: buffer retention" ~sequential:true (fun () -> + let buffer = Lwt_bytes.create 3 in + + let read_fd, write_fd = Lwt_unix.pipe () in + Lwt_unix.set_blocking read_fd true; + + Lwt_unix.write_string write_fd "foo" 0 3 >>= fun _ -> + let retained = Lwt_unix.retained buffer in + Lwt_bytes.read read_fd buffer 0 3 >>= fun _ -> + Lwt_unix.close write_fd >>= fun () -> + Lwt_unix.close read_fd >|= fun () -> !retained); + test "bytes write" (fun () -> + let test_file = "bytes_io_data_write" in + Lwt_unix.openfile test_file [ O_RDWR; O_TRUNC; O_CREAT ] 0o666 + >>= fun fd -> + let buf_write = Lwt_bytes.of_string "abc" in + Lwt_bytes.write fd buf_write 0 3 >>= fun _n -> + Lwt_unix.close fd >>= fun () -> + Lwt_unix.openfile test_file [ O_RDONLY ] 0 >>= fun fd -> + let buf_read = Lwt_bytes.create 3 in + Lwt_bytes.read fd buf_read 0 3 >>= fun _n -> + let check = buf_write = buf_read in + Lwt_unix.close fd >>= fun () -> Lwt.return check); + test "write: buffer retention" ~sequential:true (fun () -> + let buffer = Lwt_bytes.create 3 in + + let read_fd, write_fd = Lwt_unix.pipe () in + Lwt_unix.set_blocking write_fd true; + + let retained = Lwt_unix.retained buffer in + Lwt_bytes.write write_fd buffer 0 3 >>= fun _ -> + Lwt_unix.close write_fd >>= fun () -> + Lwt_unix.close read_fd >|= fun () -> !retained); + test "bytes recv" + ~only_if:(fun () -> not Sys.win32) (fun () -> - test_mincore (Lwt_bytes.page_size * 2) Lwt_bytes.page_size 2 - >>= fun () -> Lwt.return false - ) - (function - | Invalid_argument _message -> Lwt.return true - | exn -> Lwt.fail exn - ) - end; - - test "mincore buffer length = page_size * 2 + 1, n_states = 2" - ~only_if:(fun () -> not Sys.win32) begin fun () -> - test_mincore (Lwt_bytes.page_size * 2 + 1) Lwt_bytes.page_size 2 - >>= fun () -> - Lwt.return true - end; - - test "mincore buffer length = page_size , n_states = 0" - ~only_if:(fun () -> not Sys.win32) begin fun () -> - test_mincore (Lwt_bytes.page_size * 2 + 1) Lwt_bytes.page_size 0 - >>= fun () -> Lwt.return true - end; - - test "wait_mincore correct bounds" - ~only_if:(fun () -> not Sys.win32) begin fun () -> - test_wait_mincore (Lwt_bytes.page_size * 2 + 1) Lwt_bytes.page_size - >>= fun () -> Lwt.return true - end; - - test "wait_mincore offset < 0" - ~only_if:(fun () -> not Sys.win32) begin fun () -> - Lwt.catch + let buf = gen_buf 6 in + let server_logic socket = + Lwt_unix.write_string socket "abcdefghij" 0 9 + in + let client_logic socket = Lwt_bytes.recv socket buf 0 6 [] in + tcp_server_client_exchange server_logic client_logic >>= fun () -> + let check = "abcdef" = Lwt_bytes.to_string buf in + Lwt.return check); + test "bytes send" + ~only_if:(fun () -> not Sys.win32) (fun () -> - test_wait_mincore (Lwt_bytes.page_size * 2 + 1) (-1) - >>= fun () -> Lwt.return false - ) - (function - | Invalid_argument _message -> Lwt.return true - | exn -> Lwt.fail exn - ) - end; - - test "wait_mincore offset > buffer length" - ~only_if:(fun () -> not Sys.win32) begin fun () -> - Lwt.catch + let buf = gen_buf 6 in + let server_logic socket = + Lwt_bytes.send socket (Lwt_bytes.of_string "abcdef") 0 6 [] + in + let client_logic socket = Lwt_bytes.recv socket buf 0 6 [] in + tcp_server_client_exchange server_logic client_logic >>= fun () -> + let check = "abcdef" = Lwt_bytes.to_string buf in + Lwt.return check); + test "bytes recvfrom" + ~only_if:(fun () -> not Sys.win32) + (fun () -> + let buf = gen_buf 6 in + let server_logic socket = Lwt_bytes.recvfrom socket buf 0 6 [] in + let client_logic socket sockaddr = + Lwt_unix.sendto socket + (Bytes.of_string "abcdefghij") + 0 9 [] sockaddr + in + udp_server_client_exchange server_logic client_logic >>= fun () -> + let check = "abcdef" = Lwt_bytes.to_string buf in + Lwt.return check); + test "bytes sendto" + ~only_if:(fun () -> not Sys.win32) + (fun () -> + let buf = gen_buf 6 in + let server_logic socket = Lwt_bytes.recvfrom socket buf 0 6 [] in + let client_logic socket sockaddr = + let message = Lwt_bytes.of_string "abcdefghij" in + Lwt_bytes.sendto socket message 0 9 [] sockaddr + in + udp_server_client_exchange server_logic client_logic >>= fun () -> + let check = "abcdef" = Lwt_bytes.to_string buf in + Lwt.return check); + test "bytes recv_msg" + ~only_if:(fun () -> not Sys.win32) + (fun () -> + let buffer = gen_buf 6 in + let offset = 0 in + let io_vectors = [ Lwt_bytes.io_vector ~buffer ~offset ~length:6 ] in + let server_logic socket = + (Lwt_bytes.recv_msg [@ocaml.warning "-3"]) ~socket ~io_vectors + in + let client_logic socket sockaddr = + let message = Lwt_bytes.of_string "abcdefghij" in + Lwt_bytes.sendto socket message 0 9 [] sockaddr + in + udp_server_client_exchange server_logic client_logic >>= fun () -> + let check = "abcdef" = Lwt_bytes.to_string buffer in + Lwt.return check); + test "bytes send_msg" + ~only_if:(fun () -> not Sys.win32) + (fun () -> + let buffer = gen_buf 6 in + let offset = 0 in + let server_logic socket = + let io_vectors = + [ Lwt_bytes.io_vector ~buffer ~offset ~length:6 ] + in + (Lwt_bytes.recv_msg [@ocaml.warning "-3"]) ~socket ~io_vectors + in + let client_logic socket sockaddr = + Lwt_unix.connect socket sockaddr >>= fun () -> + let message = Lwt_bytes.of_string "abcdefghij" in + let io_vectors = + [ Lwt_bytes.io_vector ~buffer:message ~offset ~length:9 ] + in + (Lwt_bytes.send_msg [@ocaml.warning "-3"]) ~socket ~io_vectors + ~fds:[] + in + udp_server_client_exchange server_logic client_logic >>= fun () -> + let check = "abcdef" = Lwt_bytes.to_string buffer in + Lwt.return check); + test "send_msgto" + ~only_if:(fun () -> not Sys.win32) + (fun () -> + let buffer = gen_buf 6 in + let offset = 0 in + let server_logic socket = + let io_vectors = + [ Lwt_bytes.io_vector ~buffer ~offset ~length:6 ] + in + (Lwt_bytes.recv_msg [@ocaml.warning "-3"]) ~socket ~io_vectors + in + let client_logic socket sockaddr = + let message = Lwt_bytes.of_string "abcdefghij" in + let io_vectors = Lwt_unix.IO_vectors.create () in + Lwt_unix.IO_vectors.append_bigarray io_vectors message offset 9; + Lwt_unix.send_msgto ~socket ~io_vectors ~fds:[] ~dest:sockaddr + in + udp_server_client_exchange server_logic client_logic >>= fun () -> + let check = "abcdef" = Lwt_bytes.to_string buffer in + Lwt.return check); + test "map_file" (fun () -> + let test_file = "bytes_io_data" in + let fd = Unix.openfile test_file [ O_RDONLY ] 0 in + let shared = false in + let size = 6 in + let buffer = Lwt_bytes.map_file ~fd ~shared ~size () in + let check = "abcdef" = Lwt_bytes.to_string buffer in + let () = Unix.close fd in + Lwt.return check); + test "page_size" (fun () -> + let sizes = [ 4096; 65536 ] in + Lwt.return (List.mem Lwt_bytes.page_size sizes)); + test "mincore buffer length = page_size * 2, n_states = 1" + ~only_if:(fun () -> not Sys.win32) + (fun () -> + test_mincore (Lwt_bytes.page_size * 2) Lwt_bytes.page_size 1 + >>= fun () -> Lwt.return true); + test "mincore buffer length = page_size * 2, n_states = 2" + ~only_if:(fun () -> not Sys.win32) + (fun () -> + Lwt.catch + (fun () -> + test_mincore (Lwt_bytes.page_size * 2) Lwt_bytes.page_size 2 + >>= fun () -> Lwt.return false) + (function + | Invalid_argument _message -> Lwt.return true + | exn -> Lwt.fail exn)); + test "mincore buffer length = page_size * 2 + 1, n_states = 2" + ~only_if:(fun () -> not Sys.win32) + (fun () -> + test_mincore ((Lwt_bytes.page_size * 2) + 1) Lwt_bytes.page_size 2 + >>= fun () -> Lwt.return true); + test "mincore buffer length = page_size , n_states = 0" + ~only_if:(fun () -> not Sys.win32) + (fun () -> + test_mincore ((Lwt_bytes.page_size * 2) + 1) Lwt_bytes.page_size 0 + >>= fun () -> Lwt.return true); + test "wait_mincore correct bounds" + ~only_if:(fun () -> not Sys.win32) + (fun () -> + test_wait_mincore ((Lwt_bytes.page_size * 2) + 1) Lwt_bytes.page_size + >>= fun () -> Lwt.return true); + test "wait_mincore offset < 0" + ~only_if:(fun () -> not Sys.win32) + (fun () -> + Lwt.catch + (fun () -> + test_wait_mincore ((Lwt_bytes.page_size * 2) + 1) (-1) + >>= fun () -> Lwt.return false) + (function + | Invalid_argument _message -> Lwt.return true + | exn -> Lwt.fail exn)); + test "wait_mincore offset > buffer length" + ~only_if:(fun () -> not Sys.win32) (fun () -> - let buff_len = Lwt_bytes.page_size * 2 + 1 in - test_wait_mincore buff_len (buff_len + 1) - >>= fun () -> Lwt.return false - ) - (function - | Invalid_argument _message -> Lwt.return true - | exn -> Lwt.fail exn - ) - end; - ] + Lwt.catch + (fun () -> + let buff_len = (Lwt_bytes.page_size * 2) + 1 in + test_wait_mincore buff_len (buff_len + 1) >>= fun () -> + Lwt.return false) + (function + | Invalid_argument _message -> Lwt.return true + | exn -> Lwt.fail exn)); + ] diff --git a/test/unix/test_lwt_engine.ml b/test/unix/test_lwt_engine.ml index f1c6473d4e..2a07dbfc8c 100644 --- a/test/unix/test_lwt_engine.ml +++ b/test/unix/test_lwt_engine.ml @@ -1,81 +1,74 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Test open Lwt.Infix -let selection_tests = [ - test "libev: default when enabled in build bot" - (fun () -> - if not Lwt_config._HAVE_LIBEV then Lwt.return_true - else - (* Check if this is running inside Travis or AppVeyor. *) - let in_travis = - try ignore (Sys.getenv "TRAVIS_COMMIT"); true - with Not_found -> false - in - - let in_appveyor = - try ignore (Sys.getenv "APPVEYOR_REPO_COMMIT"); true - with Not_found -> false - in - - if not (in_travis || in_appveyor) then Lwt.return_true - else Lwt.return Lwt_config.libev_default); -] +let selection_tests = + [ + test "libev: default when enabled in build bot" (fun () -> + if not Lwt_config._HAVE_LIBEV then Lwt.return_true + else + (* Check if this is running inside Travis or AppVeyor. *) + let in_travis = + try + ignore (Sys.getenv "TRAVIS_COMMIT"); + true + with Not_found -> false + in + + let in_appveyor = + try + ignore (Sys.getenv "APPVEYOR_REPO_COMMIT"); + true + with Not_found -> false + in + + if not (in_travis || in_appveyor) then Lwt.return_true + else Lwt.return Lwt_config.libev_default); + ] let tests = selection_tests -let timing_tests = [ - test "libev: timer delays are not too short" begin fun () -> - let start = Unix.gettimeofday () in - - Lwt.catch - (fun () -> - (* Block the entire process for one second. If using libev, libev's - notion of the current time is not updated during this period. *) - let () = Unix.sleep 1 in - - (* At this point, libev thinks that the time is what it was about one - second ago. Now schedule exception Lwt_unix.Timeout to be raised in - 0.5 seconds. If the implementation is incorrect, the exception will - be raised immediately, because the 0.5 seconds will be measured - relative to libev's "current" time of one second ago. *) - Lwt_unix.timeout 0.5) - - (function - | Lwt_unix.Timeout -> - Lwt.return (Unix.gettimeofday ()) - | exn -> - Lwt.fail exn) - - >>= fun stop -> - - Lwt.return (stop -. start >= 1.5) - end; -] +let timing_tests = + [ + test "libev: timer delays are not too short" (fun () -> + let start = Unix.gettimeofday () in + + Lwt.catch + (fun () -> + (* Block the entire process for one second. If using libev, libev's + notion of the current time is not updated during this period. *) + let () = Unix.sleep 1 in + + (* At this point, libev thinks that the time is what it was about one + second ago. Now schedule exception Lwt_unix.Timeout to be raised in + 0.5 seconds. If the implementation is incorrect, the exception will + be raised immediately, because the 0.5 seconds will be measured + relative to libev's "current" time of one second ago. *) + Lwt_unix.timeout 0.5) + (function + | Lwt_unix.Timeout -> Lwt.return (Unix.gettimeofday ()) + | exn -> Lwt.fail exn) + >>= fun stop -> Lwt.return (stop -. start >= 1.5)); + ] let tests = tests @ timing_tests -let run_tests = [ - test "Lwt_main.run: nested call" ~sequential:true begin fun () -> - (* The test itself is already running under Lwt_main.run, so we just have to - call it once and make sure we get an exception. *) - - (* Make sure we are running in a callback called by Lwt_main.run, not - synchronously when the testing executable is loaded. *) - Lwt.pause () >>= fun () -> - - try - Lwt_main.run (Lwt.return ()); - Lwt.return false - with Failure _ -> - Lwt.return true - end; -] +let run_tests = + [ + test "Lwt_main.run: nested call" ~sequential:true (fun () -> + (* The test itself is already running under Lwt_main.run, so we just have to + call it once and make sure we get an exception. *) + + (* Make sure we are running in a callback called by Lwt_main.run, not + synchronously when the testing executable is loaded. *) + Lwt.pause () >>= fun () -> + try + Lwt_main.run (Lwt.return ()); + Lwt.return false + with Failure _ -> Lwt.return true); + ] let tests = tests @ run_tests - let suite = suite "lwt_engine" tests diff --git a/test/unix/test_lwt_fmt.ml b/test/unix/test_lwt_fmt.ml index 2400263ff0..b1fd494f7a 100644 --- a/test/unix/test_lwt_fmt.ml +++ b/test/unix/test_lwt_fmt.ml @@ -1,8 +1,6 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Test open Lwt.Infix @@ -16,47 +14,46 @@ let testchan () = in let oc = Lwt_io.make ~mode:Output f in let fmt = Lwt_fmt.of_channel oc in - fmt, (fun () -> Buffer.contents b) - -let suite = suite "lwt_fmt" [ - test "flushing" (fun () -> - let fmt, f = testchan () in - Lwt_fmt.fprintf fmt "%s%i%s%!" "bla" 3 "blo" >>= fun () -> - Lwt.return (f () = {|bla3blo|}) - ); - test "with combinator" (fun () -> - let fmt, f = testchan () in - Lwt_fmt.fprintf fmt "%a%!" Format.pp_print_int 3 >>= fun () -> - Lwt.return (f () = {|3|}) - ); - test "box" (fun () -> - let fmt, f = testchan () in - Lwt_fmt.fprintf fmt "@[%i@,%i@]%!" 1 2 >>= fun () -> - Lwt.return (f () = "1\n 2") - ); - test "boxsplit" (fun () -> - let fmt, f = testchan () in - Lwt_fmt.fprintf fmt "@[%i" 1 >>= fun () -> - Lwt_fmt.fprintf fmt "@,%i@]" 2 >>= fun () -> - Lwt_fmt.flush fmt >>= fun () -> - Lwt.return (f () = "1\n 2") - ); - test "box close with flush" (fun () -> - let fmt, f = testchan () in - Lwt_fmt.fprintf fmt "@[%i" 1 >>= fun () -> - Lwt_fmt.fprintf fmt "@,%i" 2 >>= fun () -> - Lwt_fmt.flush fmt >>= fun () -> - Lwt.return (f () = "1\n 2") - ); + (fmt, fun () -> Buffer.contents b) - test "stream" (fun () -> - let stream, fmt = Lwt_fmt.make_stream () in - Lwt_fmt.fprintf fmt "@[%i@,%i@]%!" 1 2 >>= fun () -> - Lwt.return (Lwt_stream.get_available stream = [ - String ("1", 0, 1); - String ("\n", 0, 1); - String (" ", 0, 2); - String ("2", 0, 1); - Flush]) - ); - ] +let suite = + suite "lwt_fmt" + [ + test "flushing" (fun () -> + let fmt, f = testchan () in + Lwt_fmt.fprintf fmt "%s%i%s%!" "bla" 3 "blo" >>= fun () -> + Lwt.return (f () = {|bla3blo|})); + test "with combinator" (fun () -> + let fmt, f = testchan () in + Lwt_fmt.fprintf fmt "%a%!" Format.pp_print_int 3 >>= fun () -> + Lwt.return (f () = {|3|})); + test "box" (fun () -> + let fmt, f = testchan () in + Lwt_fmt.fprintf fmt "@[%i@,%i@]%!" 1 2 >>= fun () -> + Lwt.return (f () = "1\n 2")); + test "boxsplit" (fun () -> + let fmt, f = testchan () in + Lwt_fmt.fprintf fmt "@[%i" 1 >>= fun () -> + Lwt_fmt.fprintf fmt "@,%i@]" 2 >>= fun () -> + Lwt_fmt.flush fmt >>= fun () -> Lwt.return (f () = "1\n 2")); + test "box close with flush" (fun () -> + let fmt, f = testchan () in + Lwt_fmt.fprintf fmt "@[%i" 1 >>= fun () -> + Lwt_fmt.fprintf fmt "@,%i" 2 >>= fun () -> + Lwt_fmt.flush fmt >>= fun () -> Lwt.return (f () = "1\n 2")); + test "stream" (fun () -> + let stream, fmt = Lwt_fmt.make_stream () in + Lwt_fmt.fprintf fmt "@[%i@,%i@]%!" 1 2 >>= fun () -> + Lwt.return + (Lwt_stream.get_available stream + = [ + String ("1", 0, 1); + String ("\n", 0, 1); + String + ( " ", + 0, + 2 ); + String ("2", 0, 1); + Flush; + ])); + ] diff --git a/test/unix/test_lwt_io.ml b/test/unix/test_lwt_io.ml index 19e349c378..fda90b2957 100644 --- a/test/unix/test_lwt_io.ml +++ b/test/unix/test_lwt_io.ml @@ -1,15 +1,15 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] + module Lwt_sequence = Lwt_sequence + [@@@ocaml.warning "+3"] open Test @@ -24,34 +24,26 @@ let local = Unix.ADDR_INET (Unix.inet_addr_loopback, !last_port) (* Helpers for [establish_server] tests. *) -module Establish_server = -struct +module Establish_server = struct let with_client f = let local = local () in let handler_finished, notify_handler_finished = Lwt.wait () in - Lwt_io.establish_server_with_client_address - local + Lwt_io.establish_server_with_client_address local (fun _client_address channels -> Lwt.finalize (fun () -> f channels) (fun () -> Lwt.wakeup notify_handler_finished (); Lwt.return_unit)) - >>= fun server -> - let client_finished = - Lwt_io.with_connection - local - (fun (_, out_channel) -> - Lwt_io.write out_channel "hello world" >>= fun () -> - handler_finished) + Lwt_io.with_connection local (fun (_, out_channel) -> + Lwt_io.write out_channel "hello world" >>= fun () -> handler_finished) in - client_finished >>= fun () -> - Lwt_io.shutdown_server server + client_finished >>= fun () -> Lwt_io.shutdown_server server (* Hacky is_closed functions that attempt to read from/write to the channels to see if they are closed. *) @@ -59,619 +51,512 @@ struct Lwt.catch (fun () -> Lwt_io.read_char channel >|= fun _ -> false) (function - | Lwt_io.Channel_closed _ -> Lwt.return_true - | _ -> Lwt.return_false) + | Lwt_io.Channel_closed _ -> Lwt.return_true | _ -> Lwt.return_false) let is_closed_out channel = Lwt.catch (fun () -> Lwt_io.write_char channel 'a' >|= fun () -> false) (function - | Lwt_io.Channel_closed _ -> Lwt.return_true - | _ -> Lwt.return_false) + | Lwt_io.Channel_closed _ -> Lwt.return_true | _ -> Lwt.return_false) end -let suite = suite "lwt_io" [ - test "auto-flush" ~sequential:true - (fun () -> - let sent = ref [] in - let oc = - Lwt_io.make - ~mode:Lwt_io.output - (fun buf ofs len -> - let bytes = Bytes.create len in - Lwt_bytes.blit_to_bytes buf ofs bytes 0 len; - sent := bytes :: !sent; - Lwt.return len) - in - Lwt_io.write oc "foo" >>= fun () -> - Lwt_io.write oc "bar" >>= fun () -> - if !sent <> [] then begin - prerr_endline "auto-flush: !sent not empty"; - Lwt.return false - end - else - Lwt_unix.sleep 0.1 >>= fun () -> - let test_result = !sent = [Bytes.of_string "foobar"] in - if not test_result then - !sent - |> List.map Bytes.to_string - |> List.map (Printf.sprintf "'%s'") - |> String.concat "," - |> Printf.eprintf "auto-flush: !sent = %s"; - Lwt.return test_result); - - test "auto-flush in atomic" ~sequential:true - (fun () -> - let sent = ref [] in - let oc = - Lwt_io.make - ~mode:Lwt_io.output - (fun buf ofs len -> - let bytes = Bytes.create len in - Lwt_bytes.blit_to_bytes buf ofs bytes 0 len; - sent := bytes :: !sent; - Lwt.return len) - in - Lwt_io.atomic - (fun oc -> +let suite = + suite "lwt_io" + [ + test "auto-flush" ~sequential:true (fun () -> + let sent = ref [] in + let oc = + Lwt_io.make ~mode:Lwt_io.output (fun buf ofs len -> + let bytes = Bytes.create len in + Lwt_bytes.blit_to_bytes buf ofs bytes 0 len; + sent := bytes :: !sent; + Lwt.return len) + in Lwt_io.write oc "foo" >>= fun () -> Lwt_io.write oc "bar" >>= fun () -> - if !sent <> [] then begin - prerr_endline "auto-flush atomic: !sent not empty"; - Lwt.return false - end + if !sent <> [] then ( + prerr_endline "auto-flush: !sent not empty"; + Lwt.return false) else Lwt_unix.sleep 0.1 >>= fun () -> - let test_result = !sent = [Bytes.of_string "foobar"] in + let test_result = !sent = [ Bytes.of_string "foobar" ] in if not test_result then !sent |> List.map Bytes.to_string |> List.map (Printf.sprintf "'%s'") |> String.concat "," - |> Printf.eprintf "auto-flush atomic: !sent = %s"; - Lwt.return test_result) - oc); - - (* Without the corresponding bugfix, which is to handle ENOTCONN from - Lwt_unix.shutdown, this test raises an exception from the handler's calls - to close. *) - test "establish_server_1: shutdown: client closes first" - ~only_if:(fun () -> - not (Lwt_config._HAVE_LIBEV && Lwt_config.libev_default)) - (* Note: this test is currently flaky on Linux with libev enabled, so we skip - it in that case. *) - (fun () -> - let wait_for_client, client_finished = Lwt.wait () in - - let handler_wait, run_handler = Lwt.wait () in - let handler = - handler_wait >>= fun (in_channel, out_channel) -> - wait_for_client >>= fun () -> - Lwt_io.close in_channel >>= fun () -> - Lwt_io.close out_channel >>= fun () -> - Lwt.return_true - in - - let local = local () in - - let server = - (Lwt_io.Versioned.establish_server_1 [@ocaml.warning "-3"]) - local (fun channels -> Lwt.wakeup run_handler channels) - in - - Lwt_io.with_connection local (fun _ -> Lwt.return_unit) >>= fun () -> - Lwt.wakeup client_finished (); - Lwt_io.shutdown_server server >>= fun () -> - handler); - - (* Counterpart to establish_server: shutdown test. Confirms that shutdown is - implemented correctly in open_connection. *) - test "open_connection: shutdown: server closes first" - (fun () -> - let wait_for_server, server_finished = Lwt.wait () in - - let local = local () in - - let server = - (Lwt_io.Versioned.establish_server_1 [@ocaml.warning "-3"]) - local (fun (in_channel, out_channel) -> - Lwt.async (fun () -> - Lwt_io.close in_channel >>= fun () -> - Lwt_io.close out_channel >|= fun () -> - Lwt.wakeup server_finished ())) - in - - Lwt_io.with_connection local (fun _ -> - wait_for_server >>= fun () -> - Lwt.return_true) - - >>= fun result -> - - Lwt_io.shutdown_server server >|= fun () -> - result); - - test "establish_server: implicit close" - (fun () -> - let open Establish_server in - - let in_channel' = ref Lwt_io.stdin in - let out_channel' = ref Lwt_io.stdout in - - let in_open_in_handler = ref false in - let out_open_in_handler = ref false in - - let run = - Establish_server.with_client - (fun (in_channel, out_channel) -> - in_channel' := in_channel; - out_channel' := out_channel; - - is_closed_out out_channel >>= fun yes -> - out_open_in_handler := not yes; - - is_closed_in in_channel >|= fun yes -> - in_open_in_handler := not yes) - in - - run >>= fun () -> - (* Give a little time for the close system calls on the connection sockets - to complete. The Lwt_io and Lwt_unix APIs do not currently allow - binding on the implicit closes of these sockets, so resorting to a - delay. *) - Lwt_unix.sleep 0.05 >>= fun () -> - - is_closed_in !in_channel' >>= fun in_closed_after_handler -> - is_closed_out !out_channel' >|= fun out_closed_after_handler -> - - !out_open_in_handler && - !in_open_in_handler && - in_closed_after_handler && - out_closed_after_handler); - - test ~sequential:true "establish_server: implicit close on exception" - (fun () -> - let open Establish_server in - - let in_channel' = ref Lwt_io.stdin in - let out_channel' = ref Lwt_io.stdout in - let exit_raised = ref false in - - let run () = - Establish_server.with_client - (fun (in_channel, out_channel) -> - in_channel' := in_channel; - out_channel' := out_channel; - raise Exit) - in - - with_async_exception_hook - (function - | Exit -> exit_raised := true; - | _ -> ()) - run - - >>= fun () -> - (* See comment in other implicit close test. *) - Lwt_unix.sleep 0.05 >>= fun () -> - - is_closed_in !in_channel' >>= fun in_closed_after_handler -> - is_closed_out !out_channel' >|= fun out_closed_after_handler -> - - in_closed_after_handler && out_closed_after_handler); - - (* This does a simple double close of the channels (second close is implicit). - If something breaks, the test will finish with an exception, or - Lwt.async_exception_hook will kill the process. *) - test "establish_server: explicit close" - (fun () -> - let open Establish_server in - - let closed_explicitly = ref false in - - let run = - Establish_server.with_client - (fun (in_channel, out_channel) -> - Lwt_io.close in_channel >>= fun () -> - Lwt_io.close out_channel >>= fun () -> - is_closed_in in_channel >>= fun in_closed_in_handler -> - is_closed_out out_channel >|= fun out_closed_in_handler -> - closed_explicitly := in_closed_in_handler && out_closed_in_handler) - in - - run >|= fun () -> - !closed_explicitly); - - test "with_connection" - (fun () -> - let open Establish_server in - - let in_channel' = ref Lwt_io.stdin in - let out_channel' = ref Lwt_io.stdout in - - let local = local () in - - Lwt_io.establish_server_with_client_address local - (fun _client_address _channels -> Lwt.return_unit) - >>= fun server -> - - Lwt_io.with_connection local (fun (in_channel, out_channel) -> - in_channel' := in_channel; - out_channel' := out_channel; - Lwt.return_unit) - - >>= fun () -> - Lwt_io.shutdown_server server >>= fun () -> - is_closed_in !in_channel' >>= fun in_closed -> - is_closed_out !out_channel' >|= fun out_closed -> - in_closed && out_closed); - - (* Makes the channel fail with EBADF on close. Tries to close the channel - manually, and handles the exception. When with_close_connection tries to - close the socket again implicitly, that should not raise the exception - again. *) - test "with_close_connection: no duplicate exceptions" - (fun () -> - let exceptions_observed = ref 0 in - - let expecting_ebadf f = - Lwt.catch f - (function - | Unix.Unix_error (Unix.EBADF, _, _) -> - exceptions_observed := !exceptions_observed + 1; - Lwt.return_unit - | exn -> - Lwt.fail exn) [@ocaml.warning "-4"] - in - - let fd_r, fd_w = Lwt_unix.pipe () in - let in_channel = Lwt_io.of_fd ~mode:Lwt_io.input fd_r in - let out_channel = Lwt_io.of_fd ~mode:Lwt_io.output fd_w in - - Lwt_unix.close fd_r >>= fun () -> - Lwt_unix.close fd_w >>= fun () -> - - expecting_ebadf (fun () -> - Lwt_io.with_close_connection - (fun _ -> - expecting_ebadf (fun () -> Lwt_io.close in_channel) >>= fun () -> - expecting_ebadf (fun () -> Lwt_io.close out_channel)) - (in_channel, out_channel)) - >|= fun () -> - !exceptions_observed = 2); - - test "open_temp_file" - (fun () -> - Lwt_io.open_temp_file () >>= fun (fname, out_chan) -> - Lwt_io.write out_chan "test file content" >>= fun () -> - Lwt_io.close out_chan >>= fun _ -> - Unix.unlink fname; Lwt.return_true - ); - - test "with_temp_filename" - (fun () -> - let prefix = "test_tempfile" in - let filename = ref "." in - let wrap f (filename', chan) = filename := filename'; f chan in - let write_data chan = Lwt_io.write chan "test file content" in - let write_data_fail _ = Lwt.fail Dummy_error in - Lwt_io.with_temp_file (wrap write_data) ~prefix >>= fun _ -> - let no_temps1 = not (Sys.file_exists !filename) in - Lwt.catch - (fun () -> Lwt_io.with_temp_file (wrap write_data_fail)) - (fun exn -> - if exn = Dummy_error - then Lwt.return (not (Sys.file_exists !filename)) - else Lwt.return_false - ) - >>= fun no_temps2 -> - Lwt.return (no_temps1 && no_temps2) - ); - - (* Verify that no exceptions are thrown if the function passed to - with_temp_file closes the channel on its own. *) - test "with_temp_filename close handle" - (fun () -> - let f (_, chan) = Lwt_io.write chan "test file content" >>= fun _ -> - Lwt_io.close chan in - Lwt_io.with_temp_file f >>= fun _ -> Lwt.return_true; - ); - - test "create_temp_dir" begin fun () -> - let prefix = "temp_dir" in - let suffix = "_foo" in - Lwt_io.create_temp_dir ~parent:Filename.current_dir_name ~prefix ~suffix () - >>= fun path -> - - let name = Filename.basename path in - let prefix_matches = String.sub name 0 (String.length prefix) = prefix in - let actual_suffix = - String.sub - name (String.length name - String.length suffix) (String.length suffix) - in - let suffix_matches = actual_suffix = suffix in - let directory_exists = Sys.is_directory path in - - Lwt_unix.rmdir path >>= fun () -> - - Lwt.return (prefix_matches && suffix_matches && directory_exists) - end; - - test "with_temp_dir" ~sequential:true begin fun () -> - Lwt_io.with_temp_dir ~parent:Filename.current_dir_name ~prefix:"temp_dir" - begin fun path -> - - let directory_existed = Sys.is_directory path in - - open_out (Filename.concat path "foo") |> close_out; - open_out (Filename.concat path "bar") |> close_out; - let had_files = Array.length (Sys.readdir path) = 2 in - - Lwt.return (path, directory_existed, had_files) - end >>= fun (path, directory_existed, had_files) -> - - let directory_removed = not (Sys.file_exists path) in - - Lwt.return (directory_existed && had_files && directory_removed) - end; + |> Printf.eprintf "auto-flush: !sent = %s"; + Lwt.return test_result); + test "auto-flush in atomic" ~sequential:true (fun () -> + let sent = ref [] in + let oc = + Lwt_io.make ~mode:Lwt_io.output (fun buf ofs len -> + let bytes = Bytes.create len in + Lwt_bytes.blit_to_bytes buf ofs bytes 0 len; + sent := bytes :: !sent; + Lwt.return len) + in + Lwt_io.atomic + (fun oc -> + Lwt_io.write oc "foo" >>= fun () -> + Lwt_io.write oc "bar" >>= fun () -> + if !sent <> [] then ( + prerr_endline "auto-flush atomic: !sent not empty"; + Lwt.return false) + else + Lwt_unix.sleep 0.1 >>= fun () -> + let test_result = !sent = [ Bytes.of_string "foobar" ] in + if not test_result then + !sent + |> List.map Bytes.to_string + |> List.map (Printf.sprintf "'%s'") + |> String.concat "," + |> Printf.eprintf "auto-flush atomic: !sent = %s"; + Lwt.return test_result) + oc); + (* Without the corresponding bugfix, which is to handle ENOTCONN from + Lwt_unix.shutdown, this test raises an exception from the handler's calls + to close. *) + test "establish_server_1: shutdown: client closes first" + ~only_if:(fun () -> + not (Lwt_config._HAVE_LIBEV && Lwt_config.libev_default)) + (* Note: this test is currently flaky on Linux with libev enabled, so we skip + it in that case. *) + (fun () -> + let wait_for_client, client_finished = Lwt.wait () in - test "file_length on directory" begin fun () -> - Lwt.catch - (fun () -> - Lwt_io.file_length "." >>= fun _ -> - Lwt.return false) - (function - | Unix.Unix_error (Unix.EISDIR, "file_length", ".") -> - Lwt.return true - | exn -> Lwt.fail exn) - end; - - test "input channel of_bytes initial position" - (fun () -> - let ichan = Lwt_io.of_bytes ~mode:Lwt_io.input @@ Lwt_bytes.of_string "abcd" in - Lwt.return (Lwt_io.position ichan = 0L) - ); - - test "input channel of_bytes position after read" - (fun () -> - let ichan = Lwt_io.of_bytes ~mode:Lwt_io.input @@ Lwt_bytes.of_string "abcd" in - Lwt_io.read_char ichan >|= fun _ -> - Lwt_io.position ichan = 1L - ); - - test "input channel of_bytes position after set_position" - (fun () -> - let ichan = Lwt_io.of_bytes ~mode:Lwt_io.input @@ Lwt_bytes.of_string "abcd" in - Lwt_io.set_position ichan 2L >|= fun () -> - Lwt_io.position ichan = 2L - ); - - test "output channel of_bytes initial position" - (fun () -> - let ochan = Lwt_io.of_bytes ~mode:Lwt_io.output @@ Lwt_bytes.create 4 in - Lwt.return (Lwt_io.position ochan = 0L) - ); - - test "output channel of_bytes position after read" - (fun () -> - let ochan = Lwt_io.of_bytes ~mode:Lwt_io.output @@ Lwt_bytes.create 4 in - Lwt_io.write_char ochan 'a' >|= fun _ -> - Lwt_io.position ochan = 1L - ); - - test "output channel of_bytes position after set_position" - (fun () -> - let ochan = Lwt_io.of_bytes ~mode:Lwt_io.output @@ Lwt_bytes.create 4 in - Lwt_io.set_position ochan 2L >|= fun _ -> - Lwt_io.position ochan = 2L - ); - - test "NumberIO.LE.read_int" begin fun () -> - Lwt_bytes.of_string "\x01\x02\x03\x04" - |> Lwt_io.(of_bytes ~mode:input) - |> Lwt_io.LE.read_int - >|= (=) 0x04030201 - end; - - test "NumberIO.BE.read_int" begin fun () -> - Lwt_bytes.of_string "\x01\x02\x03\x04" - |> Lwt_io.(of_bytes ~mode:input) - |> Lwt_io.BE.read_int - >|= (=) 0x01020304 - end; - - test "NumberIO.LE.read_int16" begin fun () -> - Lwt_bytes.of_string "\x01\x02" - |> Lwt_io.(of_bytes ~mode:input) - |> Lwt_io.LE.read_int16 - >|= (=) 0x0201 - end; - - test "NumberIO.BE.read_int16" begin fun () -> - Lwt_bytes.of_string "\x01\x02" - |> Lwt_io.(of_bytes ~mode:input) - |> Lwt_io.BE.read_int16 - >|= (=) 0x0102 - end; - - test "NumberIO.LE.read_int16, negative" begin fun () -> - Lwt_bytes.of_string "\xfe\xff" - |> Lwt_io.(of_bytes ~mode:input) - |> Lwt_io.LE.read_int16 - >|= (=) (-2) - end; - - test "NumberIO.BE.read_int16, negative" begin fun () -> - Lwt_bytes.of_string "\xff\xfe" - |> Lwt_io.(of_bytes ~mode:input) - |> Lwt_io.BE.read_int16 - >|= (=) (-2) - end; - - test "NumberIO.LE.read_int32" begin fun () -> - Lwt_bytes.of_string "\x01\x02\x03\x04" - |> Lwt_io.(of_bytes ~mode:input) - |> Lwt_io.LE.read_int32 - >|= (=) 0x04030201l - end; - - test "NumberIO.BE.read_int32" begin fun () -> - Lwt_bytes.of_string "\x01\x02\x03\x04" - |> Lwt_io.(of_bytes ~mode:input) - |> Lwt_io.BE.read_int32 - >|= (=) 0x01020304l - end; - - test "NumberIO.LE.read_int64" begin fun () -> - Lwt_bytes.of_string "\x01\x02\x03\x04\x05\x06\x07\x08" - |> Lwt_io.(of_bytes ~mode:input) - |> Lwt_io.LE.read_int64 - >|= (=) 0x0807060504030201L - end; - - test "NumberIO.BE.read_int64" begin fun () -> - Lwt_bytes.of_string "\x01\x02\x03\x04\x05\x06\x07\x08" - |> Lwt_io.(of_bytes ~mode:input) - |> Lwt_io.BE.read_int64 - >|= (=) 0x0102030405060708L - end; - - test "NumberIO.LE.read_float32" begin fun () -> - Lwt_bytes.of_string "\x80\x01\x81\x47" - |> Lwt_io.(of_bytes ~mode:input) - |> Lwt_io.LE.read_float32 - >|= fun n -> instrument (n = 66051.) "NumberIO.LE.read_float32: %f" n - end; - - test "NumberIO.BE.read_float32" begin fun () -> - Lwt_bytes.of_string "\x47\x81\x01\x80" - |> Lwt_io.(of_bytes ~mode:input) - |> Lwt_io.BE.read_float32 - >|= fun n -> instrument (n = 66051.) "NumberIO.BE.read_float32: %f" n - end; - - test "NumberIO.LE.read_float64" begin fun () -> - Lwt_bytes.of_string "\x70\x60\x50\x40\x30\x20\xf0\x42" - |> Lwt_io.(of_bytes ~mode:input) - |> Lwt_io.LE.read_float64 - >|= Int64.bits_of_float - >|= (=) 0x42F0203040506070L - end; - - test "NumberIO.BE.read_float64" begin fun () -> - Lwt_bytes.of_string "\x42\xf0\x20\x30\x40\x50\x60\x70" - |> Lwt_io.(of_bytes ~mode:input) - |> Lwt_io.BE.read_float64 - >|= Int64.bits_of_float - >|= (=) 0x42F0203040506070L - end; - - test "NumberIO.LE.write_int" begin fun () -> - let buffer = Lwt_bytes.create 4 in - Lwt_io.LE.write_int (Lwt_io.(of_bytes ~mode:output) buffer) - 0x01020304 >>= fun () -> - Lwt.return (Lwt_bytes.to_string buffer = "\x04\x03\x02\x01") - end; - - test "NumberIO.BE.write_int" begin fun () -> - let buffer = Lwt_bytes.create 4 in - Lwt_io.BE.write_int (Lwt_io.(of_bytes ~mode:output) buffer) - 0x01020304 >>= fun () -> - Lwt.return (Lwt_bytes.to_string buffer = "\x01\x02\x03\x04") - end; - - test "NumberIO.LE.write_int16" begin fun () -> - let buffer = Lwt_bytes.create 2 in - Lwt_io.LE.write_int16 (Lwt_io.(of_bytes ~mode:output) buffer) - 0x0102 >>= fun () -> - Lwt.return (Lwt_bytes.to_string buffer = "\x02\x01") - end; - - test "NumberIO.BE.write_int16" begin fun () -> - let buffer = Lwt_bytes.create 2 in - Lwt_io.BE.write_int16 (Lwt_io.(of_bytes ~mode:output) buffer) - 0x0102 >>= fun () -> - Lwt.return (Lwt_bytes.to_string buffer = "\x01\x02") - end; - - test "NumberIO.LE.write_int32" begin fun () -> - let buffer = Lwt_bytes.create 4 in - Lwt_io.LE.write_int32 (Lwt_io.(of_bytes ~mode:output) buffer) - 0x01020304l >>= fun () -> - Lwt.return (Lwt_bytes.to_string buffer = "\x04\x03\x02\x01") - end; - - test "NumberIO.BE.write_int32" begin fun () -> - let buffer = Lwt_bytes.create 4 in - Lwt_io.BE.write_int32 (Lwt_io.(of_bytes ~mode:output) buffer) - 0x01020304l >>= fun () -> - Lwt.return (Lwt_bytes.to_string buffer = "\x01\x02\x03\x04") - end; - - test "NumberIO.LE.write_int64" begin fun () -> - let buffer = Lwt_bytes.create 8 in - Lwt_io.LE.write_int64 (Lwt_io.(of_bytes ~mode:output) buffer) - 0x0102030405060708L >>= fun () -> - Lwt.return (Lwt_bytes.to_string buffer = "\x08\x07\x06\x05\x04\x03\x02\x01") - end; - - test "NumberIO.BE.write_int64" begin fun () -> - let buffer = Lwt_bytes.create 8 in - Lwt_io.BE.write_int64 (Lwt_io.(of_bytes ~mode:output) buffer) - 0x0102030405060708L >>= fun () -> - Lwt.return (Lwt_bytes.to_string buffer = "\x01\x02\x03\x04\x05\x06\x07\x08") - end; - - test "NumberIO.LE.write_float32" begin fun () -> - let buffer = Lwt_bytes.create 4 in - Lwt_io.LE.write_float32 (Lwt_io.(of_bytes ~mode:output) buffer) - 66051. >|= fun () -> - instrument (Lwt_bytes.to_string buffer = "\x80\x01\x81\x47") - "NumberIO.LE.write_float32: %02X %02X %02X %02X" - (Char.code (Lwt_bytes.get buffer 0)) - (Char.code (Lwt_bytes.get buffer 1)) - (Char.code (Lwt_bytes.get buffer 2)) - (Char.code (Lwt_bytes.get buffer 3)) - end; - - test "NumberIO.BE.write_float32" begin fun () -> - let buffer = Lwt_bytes.create 4 in - Lwt_io.BE.write_float32 (Lwt_io.(of_bytes ~mode:output) buffer) - 66051. >|= fun () -> - instrument (Lwt_bytes.to_string buffer = "\x47\x81\x01\x80") - "NumberIO.BE.write_float32: %02X %02X %02X %02X" - (Char.code (Lwt_bytes.get buffer 0)) - (Char.code (Lwt_bytes.get buffer 1)) - (Char.code (Lwt_bytes.get buffer 2)) - (Char.code (Lwt_bytes.get buffer 3)) - end; - - test "NumberIO.LE.write_float64" begin fun () -> - let buffer = Lwt_bytes.create 8 in - Lwt_io.LE.write_float64 (Lwt_io.(of_bytes ~mode:output) buffer) - (Int64.float_of_bits 0x42F0203040506070L) >>= fun () -> - Lwt.return (Lwt_bytes.to_string buffer = "\x70\x60\x50\x40\x30\x20\xf0\x42") - end; - - test "NumberIO.BE.write_float64" begin fun () -> - let buffer = Lwt_bytes.create 8 in - Lwt_io.BE.write_float64 (Lwt_io.(of_bytes ~mode:output) buffer) - (Int64.float_of_bits 0x42F0203040506070L) >>= fun () -> - Lwt.return (Lwt_bytes.to_string buffer = "\x42\xf0\x20\x30\x40\x50\x60\x70") - end; - - test "Write from Lwt_bytes" begin fun () -> - let bytes = Lwt_bytes.of_string "Hello World" in - let out = Lwt_bytes.create 11 in - Lwt_io.write_from_exactly_bigstring (Lwt_io.(of_bytes ~mode:output) out) - bytes 0 11 >>= fun () -> - Lwt.return (Lwt_bytes.to_string out = "Hello World") - end; - - test "Read from Lwt_bytes" begin fun () -> - let bytes_in = Lwt_bytes.create 11 in - let bytes = Lwt_bytes.of_string "Hello World" in - Lwt_io.read_into_exactly_bigstring (Lwt_io.(of_bytes ~mode:input) bytes) - bytes_in 0 11 >>= fun () -> - Lwt.return (Lwt_bytes.to_string bytes_in = "Hello World") - end; -] + let handler_wait, run_handler = Lwt.wait () in + let handler = + handler_wait >>= fun (in_channel, out_channel) -> + wait_for_client >>= fun () -> + Lwt_io.close in_channel >>= fun () -> + Lwt_io.close out_channel >>= fun () -> Lwt.return_true + in + + let local = local () in + + let server = + (Lwt_io.Versioned.establish_server_1 [@ocaml.warning "-3"]) local + (fun channels -> Lwt.wakeup run_handler channels) + in + + Lwt_io.with_connection local (fun _ -> Lwt.return_unit) >>= fun () -> + Lwt.wakeup client_finished (); + Lwt_io.shutdown_server server >>= fun () -> handler); + (* Counterpart to establish_server: shutdown test. Confirms that shutdown is + implemented correctly in open_connection. *) + test "open_connection: shutdown: server closes first" (fun () -> + let wait_for_server, server_finished = Lwt.wait () in + + let local = local () in + + let server = + (Lwt_io.Versioned.establish_server_1 [@ocaml.warning "-3"]) local + (fun (in_channel, out_channel) -> + Lwt.async (fun () -> + Lwt_io.close in_channel >>= fun () -> + Lwt_io.close out_channel >|= fun () -> + Lwt.wakeup server_finished ())) + in + + Lwt_io.with_connection local (fun _ -> + wait_for_server >>= fun () -> Lwt.return_true) + >>= fun result -> + Lwt_io.shutdown_server server >|= fun () -> result); + test "establish_server: implicit close" (fun () -> + let open Establish_server in + let in_channel' = ref Lwt_io.stdin in + let out_channel' = ref Lwt_io.stdout in + + let in_open_in_handler = ref false in + let out_open_in_handler = ref false in + + let run = + Establish_server.with_client (fun (in_channel, out_channel) -> + in_channel' := in_channel; + out_channel' := out_channel; + + is_closed_out out_channel >>= fun yes -> + out_open_in_handler := not yes; + + is_closed_in in_channel >|= fun yes -> + in_open_in_handler := not yes) + in + + run >>= fun () -> + (* Give a little time for the close system calls on the connection sockets + to complete. The Lwt_io and Lwt_unix APIs do not currently allow + binding on the implicit closes of these sockets, so resorting to a + delay. *) + Lwt_unix.sleep 0.05 >>= fun () -> + is_closed_in !in_channel' >>= fun in_closed_after_handler -> + is_closed_out !out_channel' >|= fun out_closed_after_handler -> + !out_open_in_handler + && !in_open_in_handler + && in_closed_after_handler + && out_closed_after_handler); + test ~sequential:true "establish_server: implicit close on exception" + (fun () -> + let open Establish_server in + let in_channel' = ref Lwt_io.stdin in + let out_channel' = ref Lwt_io.stdout in + let exit_raised = ref false in + + let run () = + Establish_server.with_client (fun (in_channel, out_channel) -> + in_channel' := in_channel; + out_channel' := out_channel; + raise Exit) + in + + with_async_exception_hook + (function Exit -> exit_raised := true | _ -> ()) + run + >>= fun () -> + (* See comment in other implicit close test. *) + Lwt_unix.sleep 0.05 >>= fun () -> + is_closed_in !in_channel' >>= fun in_closed_after_handler -> + is_closed_out !out_channel' >|= fun out_closed_after_handler -> + in_closed_after_handler && out_closed_after_handler); + (* This does a simple double close of the channels (second close is implicit). + If something breaks, the test will finish with an exception, or + Lwt.async_exception_hook will kill the process. *) + test "establish_server: explicit close" (fun () -> + let open Establish_server in + let closed_explicitly = ref false in + + let run = + Establish_server.with_client (fun (in_channel, out_channel) -> + Lwt_io.close in_channel >>= fun () -> + Lwt_io.close out_channel >>= fun () -> + is_closed_in in_channel >>= fun in_closed_in_handler -> + is_closed_out out_channel >|= fun out_closed_in_handler -> + closed_explicitly := + in_closed_in_handler && out_closed_in_handler) + in + + run >|= fun () -> !closed_explicitly); + test "with_connection" (fun () -> + let open Establish_server in + let in_channel' = ref Lwt_io.stdin in + let out_channel' = ref Lwt_io.stdout in + + let local = local () in + + Lwt_io.establish_server_with_client_address local + (fun _client_address _channels -> Lwt.return_unit) + >>= fun server -> + Lwt_io.with_connection local (fun (in_channel, out_channel) -> + in_channel' := in_channel; + out_channel' := out_channel; + Lwt.return_unit) + >>= fun () -> + Lwt_io.shutdown_server server >>= fun () -> + is_closed_in !in_channel' >>= fun in_closed -> + is_closed_out !out_channel' >|= fun out_closed -> + in_closed && out_closed); + (* Makes the channel fail with EBADF on close. Tries to close the channel + manually, and handles the exception. When with_close_connection tries to + close the socket again implicitly, that should not raise the exception + again. *) + test "with_close_connection: no duplicate exceptions" (fun () -> + let exceptions_observed = ref 0 in + + let expecting_ebadf f = + (Lwt.catch f (function + | Unix.Unix_error (Unix.EBADF, _, _) -> + exceptions_observed := !exceptions_observed + 1; + Lwt.return_unit + | exn -> Lwt.fail exn) + [@ocaml.warning "-4"]) + in + + let fd_r, fd_w = Lwt_unix.pipe () in + let in_channel = Lwt_io.of_fd ~mode:Lwt_io.input fd_r in + let out_channel = Lwt_io.of_fd ~mode:Lwt_io.output fd_w in + + Lwt_unix.close fd_r >>= fun () -> + Lwt_unix.close fd_w >>= fun () -> + expecting_ebadf (fun () -> + Lwt_io.with_close_connection + (fun _ -> + expecting_ebadf (fun () -> Lwt_io.close in_channel) + >>= fun () -> + expecting_ebadf (fun () -> Lwt_io.close out_channel)) + (in_channel, out_channel)) + >|= fun () -> !exceptions_observed = 2); + test "open_temp_file" (fun () -> + Lwt_io.open_temp_file () >>= fun (fname, out_chan) -> + Lwt_io.write out_chan "test file content" >>= fun () -> + Lwt_io.close out_chan >>= fun _ -> + Unix.unlink fname; + Lwt.return_true); + test "with_temp_filename" (fun () -> + let prefix = "test_tempfile" in + let filename = ref "." in + let wrap f (filename', chan) = + filename := filename'; + f chan + in + let write_data chan = Lwt_io.write chan "test file content" in + let write_data_fail _ = Lwt.fail Dummy_error in + Lwt_io.with_temp_file (wrap write_data) ~prefix >>= fun _ -> + let no_temps1 = not (Sys.file_exists !filename) in + Lwt.catch + (fun () -> Lwt_io.with_temp_file (wrap write_data_fail)) + (fun exn -> + if exn = Dummy_error then + Lwt.return (not (Sys.file_exists !filename)) + else Lwt.return_false) + >>= fun no_temps2 -> Lwt.return (no_temps1 && no_temps2)); + (* Verify that no exceptions are thrown if the function passed to + with_temp_file closes the channel on its own. *) + test "with_temp_filename close handle" (fun () -> + let f (_, chan) = + Lwt_io.write chan "test file content" >>= fun _ -> Lwt_io.close chan + in + Lwt_io.with_temp_file f >>= fun _ -> Lwt.return_true); + test "create_temp_dir" (fun () -> + let prefix = "temp_dir" in + let suffix = "_foo" in + Lwt_io.create_temp_dir ~parent:Filename.current_dir_name ~prefix + ~suffix () + >>= fun path -> + let name = Filename.basename path in + let prefix_matches = + String.sub name 0 (String.length prefix) = prefix + in + let actual_suffix = + String.sub name + (String.length name - String.length suffix) + (String.length suffix) + in + let suffix_matches = actual_suffix = suffix in + let directory_exists = Sys.is_directory path in + + Lwt_unix.rmdir path >>= fun () -> + Lwt.return (prefix_matches && suffix_matches && directory_exists)); + test "with_temp_dir" ~sequential:true (fun () -> + Lwt_io.with_temp_dir ~parent:Filename.current_dir_name + ~prefix:"temp_dir" (fun path -> + let directory_existed = Sys.is_directory path in + + open_out (Filename.concat path "foo") |> close_out; + open_out (Filename.concat path "bar") |> close_out; + let had_files = Array.length (Sys.readdir path) = 2 in + + Lwt.return (path, directory_existed, had_files)) + >>= fun (path, directory_existed, had_files) -> + let directory_removed = not (Sys.file_exists path) in + + Lwt.return (directory_existed && had_files && directory_removed)); + test "file_length on directory" (fun () -> + Lwt.catch + (fun () -> Lwt_io.file_length "." >>= fun _ -> Lwt.return false) + (function + | Unix.Unix_error (Unix.EISDIR, "file_length", ".") -> + Lwt.return true + | exn -> Lwt.fail exn)); + test "input channel of_bytes initial position" (fun () -> + let ichan = + Lwt_io.of_bytes ~mode:Lwt_io.input @@ Lwt_bytes.of_string "abcd" + in + Lwt.return (Lwt_io.position ichan = 0L)); + test "input channel of_bytes position after read" (fun () -> + let ichan = + Lwt_io.of_bytes ~mode:Lwt_io.input @@ Lwt_bytes.of_string "abcd" + in + Lwt_io.read_char ichan >|= fun _ -> Lwt_io.position ichan = 1L); + test "input channel of_bytes position after set_position" (fun () -> + let ichan = + Lwt_io.of_bytes ~mode:Lwt_io.input @@ Lwt_bytes.of_string "abcd" + in + Lwt_io.set_position ichan 2L >|= fun () -> Lwt_io.position ichan = 2L); + test "output channel of_bytes initial position" (fun () -> + let ochan = + Lwt_io.of_bytes ~mode:Lwt_io.output @@ Lwt_bytes.create 4 + in + Lwt.return (Lwt_io.position ochan = 0L)); + test "output channel of_bytes position after read" (fun () -> + let ochan = + Lwt_io.of_bytes ~mode:Lwt_io.output @@ Lwt_bytes.create 4 + in + Lwt_io.write_char ochan 'a' >|= fun _ -> Lwt_io.position ochan = 1L); + test "output channel of_bytes position after set_position" (fun () -> + let ochan = + Lwt_io.of_bytes ~mode:Lwt_io.output @@ Lwt_bytes.create 4 + in + Lwt_io.set_position ochan 2L >|= fun _ -> Lwt_io.position ochan = 2L); + test "NumberIO.LE.read_int" (fun () -> + Lwt_bytes.of_string "\x01\x02\x03\x04" + |> Lwt_io.(of_bytes ~mode:input) + |> Lwt_io.LE.read_int + >|= ( = ) 0x04030201); + test "NumberIO.BE.read_int" (fun () -> + Lwt_bytes.of_string "\x01\x02\x03\x04" + |> Lwt_io.(of_bytes ~mode:input) + |> Lwt_io.BE.read_int + >|= ( = ) 0x01020304); + test "NumberIO.LE.read_int16" (fun () -> + Lwt_bytes.of_string "\x01\x02" + |> Lwt_io.(of_bytes ~mode:input) + |> Lwt_io.LE.read_int16 + >|= ( = ) 0x0201); + test "NumberIO.BE.read_int16" (fun () -> + Lwt_bytes.of_string "\x01\x02" + |> Lwt_io.(of_bytes ~mode:input) + |> Lwt_io.BE.read_int16 + >|= ( = ) 0x0102); + test "NumberIO.LE.read_int16, negative" (fun () -> + Lwt_bytes.of_string "\xfe\xff" + |> Lwt_io.(of_bytes ~mode:input) + |> Lwt_io.LE.read_int16 + >|= ( = ) (-2)); + test "NumberIO.BE.read_int16, negative" (fun () -> + Lwt_bytes.of_string "\xff\xfe" + |> Lwt_io.(of_bytes ~mode:input) + |> Lwt_io.BE.read_int16 + >|= ( = ) (-2)); + test "NumberIO.LE.read_int32" (fun () -> + Lwt_bytes.of_string "\x01\x02\x03\x04" + |> Lwt_io.(of_bytes ~mode:input) + |> Lwt_io.LE.read_int32 + >|= ( = ) 0x04030201l); + test "NumberIO.BE.read_int32" (fun () -> + Lwt_bytes.of_string "\x01\x02\x03\x04" + |> Lwt_io.(of_bytes ~mode:input) + |> Lwt_io.BE.read_int32 + >|= ( = ) 0x01020304l); + test "NumberIO.LE.read_int64" (fun () -> + Lwt_bytes.of_string "\x01\x02\x03\x04\x05\x06\x07\x08" + |> Lwt_io.(of_bytes ~mode:input) + |> Lwt_io.LE.read_int64 + >|= ( = ) 0x0807060504030201L); + test "NumberIO.BE.read_int64" (fun () -> + Lwt_bytes.of_string "\x01\x02\x03\x04\x05\x06\x07\x08" + |> Lwt_io.(of_bytes ~mode:input) + |> Lwt_io.BE.read_int64 + >|= ( = ) 0x0102030405060708L); + test "NumberIO.LE.read_float32" (fun () -> + Lwt_bytes.of_string "\x80\x01\x81\x47" + |> Lwt_io.(of_bytes ~mode:input) + |> Lwt_io.LE.read_float32 + >|= fun n -> instrument (n = 66051.) "NumberIO.LE.read_float32: %f" n); + test "NumberIO.BE.read_float32" (fun () -> + Lwt_bytes.of_string "\x47\x81\x01\x80" + |> Lwt_io.(of_bytes ~mode:input) + |> Lwt_io.BE.read_float32 + >|= fun n -> instrument (n = 66051.) "NumberIO.BE.read_float32: %f" n); + test "NumberIO.LE.read_float64" (fun () -> + Lwt_bytes.of_string "\x70\x60\x50\x40\x30\x20\xf0\x42" + |> Lwt_io.(of_bytes ~mode:input) + |> Lwt_io.LE.read_float64 + >|= Int64.bits_of_float + >|= ( = ) 0x42F0203040506070L); + test "NumberIO.BE.read_float64" (fun () -> + Lwt_bytes.of_string "\x42\xf0\x20\x30\x40\x50\x60\x70" + |> Lwt_io.(of_bytes ~mode:input) + |> Lwt_io.BE.read_float64 + >|= Int64.bits_of_float + >|= ( = ) 0x42F0203040506070L); + test "NumberIO.LE.write_int" (fun () -> + let buffer = Lwt_bytes.create 4 in + Lwt_io.LE.write_int (Lwt_io.(of_bytes ~mode:output) buffer) 0x01020304 + >>= fun () -> + Lwt.return (Lwt_bytes.to_string buffer = "\x04\x03\x02\x01")); + test "NumberIO.BE.write_int" (fun () -> + let buffer = Lwt_bytes.create 4 in + Lwt_io.BE.write_int (Lwt_io.(of_bytes ~mode:output) buffer) 0x01020304 + >>= fun () -> + Lwt.return (Lwt_bytes.to_string buffer = "\x01\x02\x03\x04")); + test "NumberIO.LE.write_int16" (fun () -> + let buffer = Lwt_bytes.create 2 in + Lwt_io.LE.write_int16 (Lwt_io.(of_bytes ~mode:output) buffer) 0x0102 + >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x02\x01")); + test "NumberIO.BE.write_int16" (fun () -> + let buffer = Lwt_bytes.create 2 in + Lwt_io.BE.write_int16 (Lwt_io.(of_bytes ~mode:output) buffer) 0x0102 + >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x01\x02")); + test "NumberIO.LE.write_int32" (fun () -> + let buffer = Lwt_bytes.create 4 in + Lwt_io.LE.write_int32 + (Lwt_io.(of_bytes ~mode:output) buffer) + 0x01020304l + >>= fun () -> + Lwt.return (Lwt_bytes.to_string buffer = "\x04\x03\x02\x01")); + test "NumberIO.BE.write_int32" (fun () -> + let buffer = Lwt_bytes.create 4 in + Lwt_io.BE.write_int32 + (Lwt_io.(of_bytes ~mode:output) buffer) + 0x01020304l + >>= fun () -> + Lwt.return (Lwt_bytes.to_string buffer = "\x01\x02\x03\x04")); + test "NumberIO.LE.write_int64" (fun () -> + let buffer = Lwt_bytes.create 8 in + Lwt_io.LE.write_int64 + (Lwt_io.(of_bytes ~mode:output) buffer) + 0x0102030405060708L + >>= fun () -> + Lwt.return + (Lwt_bytes.to_string buffer = "\x08\x07\x06\x05\x04\x03\x02\x01")); + test "NumberIO.BE.write_int64" (fun () -> + let buffer = Lwt_bytes.create 8 in + Lwt_io.BE.write_int64 + (Lwt_io.(of_bytes ~mode:output) buffer) + 0x0102030405060708L + >>= fun () -> + Lwt.return + (Lwt_bytes.to_string buffer = "\x01\x02\x03\x04\x05\x06\x07\x08")); + test "NumberIO.LE.write_float32" (fun () -> + let buffer = Lwt_bytes.create 4 in + Lwt_io.LE.write_float32 (Lwt_io.(of_bytes ~mode:output) buffer) 66051. + >|= fun () -> + instrument + (Lwt_bytes.to_string buffer = "\x80\x01\x81\x47") + "NumberIO.LE.write_float32: %02X %02X %02X %02X" + (Char.code (Lwt_bytes.get buffer 0)) + (Char.code (Lwt_bytes.get buffer 1)) + (Char.code (Lwt_bytes.get buffer 2)) + (Char.code (Lwt_bytes.get buffer 3))); + test "NumberIO.BE.write_float32" (fun () -> + let buffer = Lwt_bytes.create 4 in + Lwt_io.BE.write_float32 (Lwt_io.(of_bytes ~mode:output) buffer) 66051. + >|= fun () -> + instrument + (Lwt_bytes.to_string buffer = "\x47\x81\x01\x80") + "NumberIO.BE.write_float32: %02X %02X %02X %02X" + (Char.code (Lwt_bytes.get buffer 0)) + (Char.code (Lwt_bytes.get buffer 1)) + (Char.code (Lwt_bytes.get buffer 2)) + (Char.code (Lwt_bytes.get buffer 3))); + test "NumberIO.LE.write_float64" (fun () -> + let buffer = Lwt_bytes.create 8 in + Lwt_io.LE.write_float64 + (Lwt_io.(of_bytes ~mode:output) buffer) + (Int64.float_of_bits 0x42F0203040506070L) + >>= fun () -> + Lwt.return + (Lwt_bytes.to_string buffer = "\x70\x60\x50\x40\x30\x20\xf0\x42")); + test "NumberIO.BE.write_float64" (fun () -> + let buffer = Lwt_bytes.create 8 in + Lwt_io.BE.write_float64 + (Lwt_io.(of_bytes ~mode:output) buffer) + (Int64.float_of_bits 0x42F0203040506070L) + >>= fun () -> + Lwt.return + (Lwt_bytes.to_string buffer = "\x42\xf0\x20\x30\x40\x50\x60\x70")); + test "Write from Lwt_bytes" (fun () -> + let bytes = Lwt_bytes.of_string "Hello World" in + let out = Lwt_bytes.create 11 in + Lwt_io.write_from_exactly_bigstring + (Lwt_io.(of_bytes ~mode:output) out) + bytes 0 11 + >>= fun () -> Lwt.return (Lwt_bytes.to_string out = "Hello World")); + test "Read from Lwt_bytes" (fun () -> + let bytes_in = Lwt_bytes.create 11 in + let bytes = Lwt_bytes.of_string "Hello World" in + Lwt_io.read_into_exactly_bigstring + (Lwt_io.(of_bytes ~mode:input) bytes) + bytes_in 0 11 + >>= fun () -> Lwt.return (Lwt_bytes.to_string bytes_in = "Hello World")); + ] diff --git a/test/unix/test_lwt_io_non_block.ml b/test/unix/test_lwt_io_non_block.ml index fe59241806..216959aeef 100644 --- a/test/unix/test_lwt_io_non_block.ml +++ b/test/unix/test_lwt_io_non_block.ml @@ -1,51 +1,37 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Test open Lwt.Infix let test_file = "Lwt_io_test" let file_contents = "test file content" -let suite = suite "lwt_io non blocking io" [ - test ~sequential:true "file does not exist" - (fun () -> Lwt_unix.file_exists test_file >|= fun r -> not r); - - test ~sequential:true "file does not exist (invalid path)" - (fun () -> Lwt_unix.file_exists (test_file ^ "/foo") >|= fun r -> not r); - - test ~sequential:true "file does not exist (LargeFile)" - (fun () -> Lwt_unix.LargeFile.file_exists test_file >|= fun r -> not r); - - test ~sequential:true "file does not exist (LargeFile, invalid path)" - (fun () -> Lwt_unix.LargeFile.file_exists (test_file ^ "/foo") >|= fun r -> not r); - - test ~sequential:true "create file" - (fun () -> - Lwt_io.open_file ~mode:Lwt_io.output test_file >>= fun out_chan -> - Lwt_io.write out_chan file_contents >>= fun () -> - Lwt_io.close out_chan >>= fun () -> - Lwt.return_true); - - test ~sequential:true "file exists" - (fun () -> Lwt_unix.file_exists test_file); - - test ~sequential:true "file exists (LargeFile)" - (fun () -> Lwt_unix.LargeFile.file_exists test_file); - - - test ~sequential:true "read file" - (fun () -> - Lwt_io.open_file ~mode:Lwt_io.input test_file >>= fun in_chan -> - Lwt_io.read in_chan >>= fun s -> - Lwt_io.close in_chan >>= fun () -> - Lwt.return (s = file_contents)); - - test ~sequential:true "remove file" - (fun () -> - Unix.unlink test_file; - Lwt.return_true); - -] +let suite = + suite "lwt_io non blocking io" + [ + test ~sequential:true "file does not exist" (fun () -> + Lwt_unix.file_exists test_file >|= fun r -> not r); + test ~sequential:true "file does not exist (invalid path)" (fun () -> + Lwt_unix.file_exists (test_file ^ "/foo") >|= fun r -> not r); + test ~sequential:true "file does not exist (LargeFile)" (fun () -> + Lwt_unix.LargeFile.file_exists test_file >|= fun r -> not r); + test ~sequential:true "file does not exist (LargeFile, invalid path)" + (fun () -> + Lwt_unix.LargeFile.file_exists (test_file ^ "/foo") >|= fun r -> not r); + test ~sequential:true "create file" (fun () -> + Lwt_io.open_file ~mode:Lwt_io.output test_file >>= fun out_chan -> + Lwt_io.write out_chan file_contents >>= fun () -> + Lwt_io.close out_chan >>= fun () -> Lwt.return_true); + test ~sequential:true "file exists" (fun () -> + Lwt_unix.file_exists test_file); + test ~sequential:true "file exists (LargeFile)" (fun () -> + Lwt_unix.LargeFile.file_exists test_file); + test ~sequential:true "read file" (fun () -> + Lwt_io.open_file ~mode:Lwt_io.input test_file >>= fun in_chan -> + Lwt_io.read in_chan >>= fun s -> + Lwt_io.close in_chan >>= fun () -> Lwt.return (s = file_contents)); + test ~sequential:true "remove file" (fun () -> + Unix.unlink test_file; + Lwt.return_true); + ] diff --git a/test/unix/test_lwt_process.ml b/test/unix/test_lwt_process.ml index 25bde6cbe8..feab56d7f1 100644 --- a/test/unix/test_lwt_process.ml +++ b/test/unix/test_lwt_process.ml @@ -1,20 +1,21 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Test open Lwt.Infix -let suite = suite "lwt_process" [ - (* The sleep command is not available on Win32. *) - test "lazy_undefined" ~only_if:(fun () -> not Sys.win32) - (fun () -> - Lwt_process.with_process_in - ~timeout:1. ("sleep", [| "sleep"; "2" |]) - (fun p -> - Lwt.catch - (fun () -> Lwt_io.read p#stdout) - (fun _ -> Lwt.return "")) - >>= fun _ -> Lwt.return_true) -] +let suite = + suite "lwt_process" + [ + (* The sleep command is not available on Win32. *) + test "lazy_undefined" + ~only_if:(fun () -> not Sys.win32) + (fun () -> + Lwt_process.with_process_in ~timeout:1. + ("sleep", [| "sleep"; "2" |]) + (fun p -> + Lwt.catch + (fun () -> Lwt_io.read p#stdout) + (fun _ -> Lwt.return "")) + >>= fun _ -> Lwt.return_true); + ] diff --git a/test/unix/test_lwt_timeout.ml b/test/unix/test_lwt_timeout.ml index 727e5e5233..74273449ef 100644 --- a/test/unix/test_lwt_timeout.ml +++ b/test/unix/test_lwt_timeout.ml @@ -1,277 +1,229 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Test open Lwt.Infix (* Note: due to the time delays in the tests of this suite, it could really benefit from an option to run tests in parallel. *) -let suite = suite "Lwt_timeout" [ - test "basic" begin fun () -> - let p, r = Lwt.wait () in - - let start_time = Unix.gettimeofday () in - - let timeout = - Lwt_timeout.create 1 (fun () -> - let delta = Unix.gettimeofday () -. start_time in - Lwt.wakeup_later r delta) - in - Lwt_timeout.start timeout; - - p >|= fun delta -> - instrument (delta >= 2. && delta < 3.) - "Lwt_timeout: basic: %f %f" start_time delta - (* The above is a bug of the current implementation: it always gives too - long a timeout. *) - end; - - test "not started" begin fun () -> - let p, r = Lwt.wait () in - - Lwt_timeout.create 1 (fun () -> - Lwt.wakeup_later r false) - |> ignore; - - Lwt.async (fun () -> - Lwt_unix.sleep 3. >|= fun () -> - Lwt.wakeup_later r true); - - p - end; - - test "double start" begin fun () -> - let completions = ref 0 in - - let timeout = - Lwt_timeout.create 1 (fun () -> - completions := !completions + 1) - in - Lwt_timeout.start timeout; - Lwt_timeout.start timeout; - - Lwt_unix.sleep 3. >|= fun () -> - instrument (!completions = 1) "Lwt_timeout: double start: %i" !completions - end; - - test "restart" begin fun () -> - let p, r = Lwt.wait () in - - let completions = ref 0 in - - (* A dummy timeout, just to set up the reference. *) - let timeout = ref (Lwt_timeout.create 1 ignore) in - - timeout := - Lwt_timeout.create 1 (fun () -> - completions := !completions + 1; - if !completions < 2 then - Lwt_timeout.start !timeout - else - Lwt.wakeup_later r true); - Lwt_timeout.start !timeout; - - p - end; - - test "stop" begin fun () -> - let p, r = Lwt.wait () in - - let timeout = - Lwt_timeout.create 1 (fun () -> - Lwt.wakeup_later r false) - in - Lwt_timeout.start timeout; - Lwt_timeout.stop timeout; - - Lwt.async (fun () -> - Lwt_unix.sleep 3. >|= fun () -> - Lwt.wakeup_later r true); - - p - end; - - test "stop when not stopped" begin fun () -> - Lwt_timeout.create 1 ignore - |> Lwt_timeout.stop; - - Lwt.return true - end; - - test "invalid delay" begin fun () -> - try - ignore (Lwt_timeout.create 0 ignore); - Lwt.return false - with Invalid_argument _ -> - Lwt.return true - end; - - test "change" begin fun () -> - let p, r = Lwt.wait () in - - let start_time = Unix.gettimeofday () in - - let timeout = - Lwt_timeout.create 5 (fun () -> - let delta = Unix.gettimeofday () -. start_time in - Lwt.wakeup_later r delta) - in - Lwt_timeout.change timeout 1; - Lwt_timeout.start timeout; - - p >|= fun delta -> - instrument (delta >= 1.9 && delta < 3.1) - "Lwt_timeout: change: %f %f" start_time delta - end; - - test "change does not start" begin fun () -> - let p, r = Lwt.wait () in - - let timeout = - Lwt_timeout.create 1 (fun () -> - Lwt.wakeup_later r false) - in - Lwt_timeout.change timeout 1; - - Lwt.async (fun () -> - Lwt_unix.sleep 3. >|= fun () -> - Lwt.wakeup_later r true); - - p - end; - - test "change after start" begin fun () -> - let p, r = Lwt.wait () in - - let start_time = Unix.gettimeofday () in - - let timeout = - Lwt_timeout.create 5 (fun () -> - let delta = Unix.gettimeofday () -. start_time in - Lwt.wakeup_later r delta) - in - Lwt_timeout.start timeout; - Lwt_timeout.change timeout 1; - - p >|= fun delta -> - instrument (delta >= 1.9 && delta < 3.1) - "Lwt_timeout: change after start: %f %f" start_time delta - end; - - test "change: invalid delay" begin fun () -> - let timeout = (Lwt_timeout.create 1 ignore) in - try - Lwt_timeout.change timeout 0; - Lwt.return false - with Invalid_argument _ -> - Lwt.return true - end; - - test ~sequential:true "exception in action" begin fun () -> - let p, r = Lwt.wait () in - - Test.with_async_exception_hook - (fun exn -> - match exn with - | Exit -> Lwt.wakeup_later r true - | _ -> raise exn) - (fun () -> - Lwt_timeout.create 1 (fun () -> raise Exit) - |> Lwt_timeout.start; - - p) - end; - - test "set_exn_handler" begin fun () -> - let p, r = Lwt.wait () in - - Lwt_timeout.set_exn_handler (fun exn -> - match exn with - | Exit -> Lwt.wakeup_later r true - | _ -> raise exn); - - Lwt_timeout.create 1 (fun () -> raise Exit) - |> Lwt_timeout.start; - - p >|= fun result -> - Lwt_timeout.set_exn_handler (fun exn -> - !Lwt.async_exception_hook exn); - result - end; - - test "two" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - - let start_time = Unix.gettimeofday () in - - Lwt_timeout.create 1 (fun () -> - let delta = Unix.gettimeofday () -. start_time in - Lwt.wakeup r1 delta) - |> Lwt_timeout.start; - - Lwt_timeout.create 2 (fun () -> - let delta = Unix.gettimeofday () -. start_time in - Lwt.wakeup r2 delta) - |> Lwt_timeout.start; - - p1 >>= fun delta1 -> - p2 >|= fun delta2 -> - instrument (delta1 >= 1.9 && delta1 < 3. && delta2 >= 2.9 && delta2 < 4.) - "Lwt_timeout: two: %f %f %f" start_time delta1 delta2 - end; - - test "simultaneous" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - - let start_time = Unix.gettimeofday () in - - Lwt_timeout.create 1 (fun () -> - let delta = Unix.gettimeofday () -. start_time in - Lwt.wakeup r1 delta) - |> Lwt_timeout.start; - - Lwt_timeout.create 1 (fun () -> - let delta = Unix.gettimeofday () -. start_time in - Lwt.wakeup r2 delta) - |> Lwt_timeout.start; - - p1 >>= fun delta1 -> - p2 >|= fun delta2 -> - instrument (delta1 >= 1. && delta1 < 2.6 && delta2 >= 1. && delta2 < 2.6) - "Lwt_timeout: simultaneous: %f %f %f" start_time delta1 delta2 - end; - - test "two, first stopped" begin fun () -> - let p1, r1 = Lwt.wait () in - let p2, r2 = Lwt.wait () in - - let start_time = Unix.gettimeofday () in - - let timeout1 = - Lwt_timeout.create 1 (fun () -> - Lwt.wakeup r1 false) - in - Lwt_timeout.start timeout1; - - Lwt_timeout.create 2 (fun () -> - let delta = Unix.gettimeofday () -. start_time in - Lwt.wakeup r2 delta) - |> Lwt_timeout.start; - - Lwt_timeout.stop timeout1; - Lwt.async (fun () -> - Lwt_unix.sleep 3. >|= fun () -> - Lwt.wakeup r1 true); - - p1 >>= fun timeout1_not_fired -> - p2 >|= fun delta2 -> - instrument (timeout1_not_fired && delta2 >= 1.5 && delta2 < 3.5) - "Lwt_timeout: two, first stopped: %b %f %f" - timeout1_not_fired start_time delta2 - end; -] +let suite = + suite "Lwt_timeout" + [ + test "basic" (fun () -> + let p, r = Lwt.wait () in + + let start_time = Unix.gettimeofday () in + + let timeout = + Lwt_timeout.create 1 (fun () -> + let delta = Unix.gettimeofday () -. start_time in + Lwt.wakeup_later r delta) + in + Lwt_timeout.start timeout; + + p >|= fun delta -> + instrument + (delta >= 2. && delta < 3.) + "Lwt_timeout: basic: %f %f" start_time delta + (* The above is a bug of the current implementation: it always gives too + long a timeout. *)); + test "not started" (fun () -> + let p, r = Lwt.wait () in + + Lwt_timeout.create 1 (fun () -> Lwt.wakeup_later r false) |> ignore; + + Lwt.async (fun () -> + Lwt_unix.sleep 3. >|= fun () -> Lwt.wakeup_later r true); + + p); + test "double start" (fun () -> + let completions = ref 0 in + + let timeout = + Lwt_timeout.create 1 (fun () -> completions := !completions + 1) + in + Lwt_timeout.start timeout; + Lwt_timeout.start timeout; + + Lwt_unix.sleep 3. >|= fun () -> + instrument (!completions = 1) "Lwt_timeout: double start: %i" + !completions); + test "restart" (fun () -> + let p, r = Lwt.wait () in + + let completions = ref 0 in + + (* A dummy timeout, just to set up the reference. *) + let timeout = ref (Lwt_timeout.create 1 ignore) in + + timeout := + Lwt_timeout.create 1 (fun () -> + completions := !completions + 1; + if !completions < 2 then Lwt_timeout.start !timeout + else Lwt.wakeup_later r true); + Lwt_timeout.start !timeout; + + p); + test "stop" (fun () -> + let p, r = Lwt.wait () in + + let timeout = + Lwt_timeout.create 1 (fun () -> Lwt.wakeup_later r false) + in + Lwt_timeout.start timeout; + Lwt_timeout.stop timeout; + + Lwt.async (fun () -> + Lwt_unix.sleep 3. >|= fun () -> Lwt.wakeup_later r true); + + p); + test "stop when not stopped" (fun () -> + Lwt_timeout.create 1 ignore |> Lwt_timeout.stop; + + Lwt.return true); + test "invalid delay" (fun () -> + try + ignore (Lwt_timeout.create 0 ignore); + Lwt.return false + with Invalid_argument _ -> Lwt.return true); + test "change" (fun () -> + let p, r = Lwt.wait () in + + let start_time = Unix.gettimeofday () in + + let timeout = + Lwt_timeout.create 5 (fun () -> + let delta = Unix.gettimeofday () -. start_time in + Lwt.wakeup_later r delta) + in + Lwt_timeout.change timeout 1; + Lwt_timeout.start timeout; + + p >|= fun delta -> + instrument + (delta >= 1.9 && delta < 3.1) + "Lwt_timeout: change: %f %f" start_time delta); + test "change does not start" (fun () -> + let p, r = Lwt.wait () in + + let timeout = + Lwt_timeout.create 1 (fun () -> Lwt.wakeup_later r false) + in + Lwt_timeout.change timeout 1; + + Lwt.async (fun () -> + Lwt_unix.sleep 3. >|= fun () -> Lwt.wakeup_later r true); + + p); + test "change after start" (fun () -> + let p, r = Lwt.wait () in + + let start_time = Unix.gettimeofday () in + + let timeout = + Lwt_timeout.create 5 (fun () -> + let delta = Unix.gettimeofday () -. start_time in + Lwt.wakeup_later r delta) + in + Lwt_timeout.start timeout; + Lwt_timeout.change timeout 1; + + p >|= fun delta -> + instrument + (delta >= 1.9 && delta < 3.1) + "Lwt_timeout: change after start: %f %f" start_time delta); + test "change: invalid delay" (fun () -> + let timeout = Lwt_timeout.create 1 ignore in + try + Lwt_timeout.change timeout 0; + Lwt.return false + with Invalid_argument _ -> Lwt.return true); + test ~sequential:true "exception in action" (fun () -> + let p, r = Lwt.wait () in + + Test.with_async_exception_hook + (fun exn -> + match exn with Exit -> Lwt.wakeup_later r true | _ -> raise exn) + (fun () -> + Lwt_timeout.create 1 (fun () -> raise Exit) |> Lwt_timeout.start; + + p)); + test "set_exn_handler" (fun () -> + let p, r = Lwt.wait () in + + Lwt_timeout.set_exn_handler (fun exn -> + match exn with Exit -> Lwt.wakeup_later r true | _ -> raise exn); + + Lwt_timeout.create 1 (fun () -> raise Exit) |> Lwt_timeout.start; + + p >|= fun result -> + Lwt_timeout.set_exn_handler (fun exn -> !Lwt.async_exception_hook exn); + result); + test "two" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + + let start_time = Unix.gettimeofday () in + + Lwt_timeout.create 1 (fun () -> + let delta = Unix.gettimeofday () -. start_time in + Lwt.wakeup r1 delta) + |> Lwt_timeout.start; + + Lwt_timeout.create 2 (fun () -> + let delta = Unix.gettimeofday () -. start_time in + Lwt.wakeup r2 delta) + |> Lwt_timeout.start; + + p1 >>= fun delta1 -> + p2 >|= fun delta2 -> + instrument + (delta1 >= 1.9 && delta1 < 3. && delta2 >= 2.9 && delta2 < 4.) + "Lwt_timeout: two: %f %f %f" start_time delta1 delta2); + test "simultaneous" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + + let start_time = Unix.gettimeofday () in + + Lwt_timeout.create 1 (fun () -> + let delta = Unix.gettimeofday () -. start_time in + Lwt.wakeup r1 delta) + |> Lwt_timeout.start; + + Lwt_timeout.create 1 (fun () -> + let delta = Unix.gettimeofday () -. start_time in + Lwt.wakeup r2 delta) + |> Lwt_timeout.start; + + p1 >>= fun delta1 -> + p2 >|= fun delta2 -> + instrument + (delta1 >= 1. && delta1 < 2.6 && delta2 >= 1. && delta2 < 2.6) + "Lwt_timeout: simultaneous: %f %f %f" start_time delta1 delta2); + test "two, first stopped" (fun () -> + let p1, r1 = Lwt.wait () in + let p2, r2 = Lwt.wait () in + + let start_time = Unix.gettimeofday () in + + let timeout1 = Lwt_timeout.create 1 (fun () -> Lwt.wakeup r1 false) in + Lwt_timeout.start timeout1; + + Lwt_timeout.create 2 (fun () -> + let delta = Unix.gettimeofday () -. start_time in + Lwt.wakeup r2 delta) + |> Lwt_timeout.start; + + Lwt_timeout.stop timeout1; + Lwt.async (fun () -> + Lwt_unix.sleep 3. >|= fun () -> Lwt.wakeup r1 true); + + p1 >>= fun timeout1_not_fired -> + p2 >|= fun delta2 -> + instrument + (timeout1_not_fired && delta2 >= 1.5 && delta2 < 3.5) + "Lwt_timeout: two, first stopped: %b %f %f" timeout1_not_fired + start_time delta2); + ] diff --git a/test/unix/test_mcast.ml b/test/unix/test_mcast.ml index a5bcf405dd..1985b3c074 100644 --- a/test/unix/test_mcast.ml +++ b/test/unix/test_mcast.ml @@ -1,18 +1,18 @@ (* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) - - open Lwt.Infix open Test let debug = false let hello = Bytes.unsafe_of_string "Hello, World!" + let mcast_addr = let last_group = ref 0 in fun () -> incr last_group; Printf.sprintf "225.0.0.%i" !last_group + let mcast_port = let last_port = ref 4421 in fun () -> @@ -20,54 +20,57 @@ let mcast_port = !last_port let child mcast_addr join fd = - if join then Lwt_unix.mcast_add_membership fd (Unix.inet_addr_of_string mcast_addr); + if join then + Lwt_unix.mcast_add_membership fd (Unix.inet_addr_of_string mcast_addr); let buf = Bytes.create 50 in - Lwt_unix.with_timeout 1. (fun () -> Lwt_unix.read fd buf 0 (Bytes.length buf)) >>= fun n -> + Lwt_unix.with_timeout 1. (fun () -> Lwt_unix.read fd buf 0 (Bytes.length buf)) + >>= fun n -> if debug then - Printf.printf "\nReceived multicast message %S\n%!" (Bytes.unsafe_to_string (Bytes.sub buf 0 n)); + Printf.printf "\nReceived multicast message %S\n%!" + (Bytes.unsafe_to_string (Bytes.sub buf 0 n)); if Bytes.sub buf 0 n <> hello then Lwt.fail (Failure "unexpected multicast message") - else - Lwt.return_unit + else Lwt.return_unit let parent mcast_addr mcast_port set_loop fd = Lwt_unix.mcast_set_loop fd set_loop; - let addr = Lwt_unix.ADDR_INET (Unix.inet_addr_of_string mcast_addr, mcast_port) in + let addr = + Lwt_unix.ADDR_INET (Unix.inet_addr_of_string mcast_addr, mcast_port) + in Lwt_unix.sendto fd hello 0 (Bytes.length hello) [] addr >>= fun _ -> if debug then - Printf.printf "\nSending multicast message %S to %s:%d\n%!" (Bytes.unsafe_to_string hello) + Printf.printf "\nSending multicast message %S to %s:%d\n%!" + (Bytes.unsafe_to_string hello) mcast_addr mcast_port; Lwt.return_unit let test_mcast name join set_loop = - test name ~only_if:(fun () -> not Sys.win32) begin fun () -> - let mcast_addr = mcast_addr () in - let mcast_port = mcast_port () in - let should_timeout = not join || not set_loop in - let fd1 = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in - let fd2 = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in - let t () = - Lwt.catch - (fun () -> - Lwt_unix.(bind - fd1 (ADDR_INET (Unix.inet_addr_any, mcast_port))) >>= fun () -> - let t1 = child mcast_addr join fd1 in - let t2 = parent mcast_addr mcast_port set_loop fd2 in - Lwt.join [t1; t2] >>= fun () -> Lwt.return true - ) - (function - | Lwt_unix.Timeout -> - Lwt.return should_timeout - | Unix.Unix_error (Unix.EINVAL, "send", _) - | Unix.Unix_error (Unix.ENODEV, "setsockopt", _) - | Unix.Unix_error (Unix.ENETUNREACH, "send", _) -> - Lwt.fail Skip - | e -> - Lwt.fail e - ) - in - Lwt.finalize t (fun () -> Lwt.join [Lwt_unix.close fd1; Lwt_unix.close fd2]) - end + test name + ~only_if:(fun () -> not Sys.win32) + (fun () -> + let mcast_addr = mcast_addr () in + let mcast_port = mcast_port () in + let should_timeout = (not join) || not set_loop in + let fd1 = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in + let fd2 = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in + let t () = + Lwt.catch + (fun () -> + Lwt_unix.(bind fd1 (ADDR_INET (Unix.inet_addr_any, mcast_port))) + >>= fun () -> + let t1 = child mcast_addr join fd1 in + let t2 = parent mcast_addr mcast_port set_loop fd2 in + Lwt.join [ t1; t2 ] >>= fun () -> Lwt.return true) + (function + | Lwt_unix.Timeout -> Lwt.return should_timeout + | Unix.Unix_error (Unix.EINVAL, "send", _) + | Unix.Unix_error (Unix.ENODEV, "setsockopt", _) + | Unix.Unix_error (Unix.ENETUNREACH, "send", _) -> + Lwt.fail Skip + | e -> Lwt.fail e) + in + Lwt.finalize t (fun () -> + Lwt.join [ Lwt_unix.close fd1; Lwt_unix.close fd2 ])) let suite = suite "unix_mcast" diff --git a/test/unix/test_sleep_and_timeout.ml b/test/unix/test_sleep_and_timeout.ml index dcf4f1ca99..97179c5c84 100644 --- a/test/unix/test_sleep_and_timeout.ml +++ b/test/unix/test_sleep_and_timeout.ml @@ -10,87 +10,74 @@ let cmp_elapsed_time test_name start_time expected_time = let elapsed_time = Unix.gettimeofday () -. start_time in let diff = elapsed_time -. expected_time in let result = diff >= 0. && diff <= 0.2 in - instrument result "Lwt_unix sleep and timeout: %s: %f %f %f %b" - test_name elapsed_time expected_time diff (Lwt_sys.have `libev) + instrument result "Lwt_unix sleep and timeout: %s: %f %f %f %b" test_name + elapsed_time expected_time diff + (Lwt_sys.have `libev) -let suite = suite "Lwt_unix sleep and timeout" [ - test "sleep" begin fun () -> - let start_time = Unix.gettimeofday () in - let duration = 1.0 in - Lwt_unix.sleep duration - >>= fun () -> - let check = cmp_elapsed_time "sleep" start_time duration in - Lwt.return check - end; - - test "timeout" begin fun () -> - let start_time = Unix.gettimeofday () in - let duration = 1.0 in - Lwt.catch - (fun () -> - Lwt_unix.timeout duration - >>= fun () -> Lwt.return_false - ) - (function - | Lwt_unix.Timeout -> - let check = cmp_elapsed_time "timeout" start_time duration in - Lwt.return check - | exn -> Lwt.fail exn - ) - end; - - test "with_timeout : no timeout" begin fun () -> - let duration = 1.0 in - Lwt_unix.with_timeout duration Lwt.pause - >>= fun () -> Lwt.return_true - end; - - test "with_timeout : timeout" begin fun () -> - let start_time = Unix.gettimeofday () in - let duration = 1.0 in - let f () = Lwt_unix.sleep 2.0 in - Lwt.catch - (fun () -> - Lwt_unix.with_timeout duration f - >>= fun () -> - Printf.eprintf "\nno timeout\n"; - Lwt.return false - ) - (function - | Lwt_unix.Timeout -> - let check = - cmp_elapsed_time "with_timeout : timeout" start_time duration in - Lwt.return check - | exn -> Lwt.fail exn - ) - end; - - test "pause" begin fun () -> - let bind_callback_ran = ref false in - Lwt.async (fun () -> Lwt.return () >|= fun () -> bind_callback_ran := true); - let bind_is_immediate = !bind_callback_ran in - let pause_callback_ran = ref false in - Lwt.async (fun () -> Lwt.pause () >|= fun () -> pause_callback_ran := true); - let pause_is_immediate = !pause_callback_ran in - Lwt.return (bind_is_immediate && not pause_is_immediate) - end; - - test "auto_pause" begin fun () -> - let f = Lwt_unix.auto_pause 1.0 in - let run_auto_pause () = - let callback_ran = ref false in - Lwt.async (fun () -> f () >|= fun () -> callback_ran := true); - !callback_ran; - in - let check1 = run_auto_pause () in - let check2 = run_auto_pause () in - Lwt_unix.sleep 1.0 - >|= fun () -> - let check3 = run_auto_pause () in - let check4 = run_auto_pause () in - let check5 = run_auto_pause () in - let check = check1 && check2 && not check3 && check4 && check5 in - instrument check "Lwt_unix sleep and timeout: auto_pause: %b %b %b %b %b" - check1 check2 check3 check4 check5 - end; - ] +let suite = + suite "Lwt_unix sleep and timeout" + [ + test "sleep" (fun () -> + let start_time = Unix.gettimeofday () in + let duration = 1.0 in + Lwt_unix.sleep duration >>= fun () -> + let check = cmp_elapsed_time "sleep" start_time duration in + Lwt.return check); + test "timeout" (fun () -> + let start_time = Unix.gettimeofday () in + let duration = 1.0 in + Lwt.catch + (fun () -> Lwt_unix.timeout duration >>= fun () -> Lwt.return_false) + (function + | Lwt_unix.Timeout -> + let check = cmp_elapsed_time "timeout" start_time duration in + Lwt.return check + | exn -> Lwt.fail exn)); + test "with_timeout : no timeout" (fun () -> + let duration = 1.0 in + Lwt_unix.with_timeout duration Lwt.pause >>= fun () -> Lwt.return_true); + test "with_timeout : timeout" (fun () -> + let start_time = Unix.gettimeofday () in + let duration = 1.0 in + let f () = Lwt_unix.sleep 2.0 in + Lwt.catch + (fun () -> + Lwt_unix.with_timeout duration f >>= fun () -> + Printf.eprintf "\nno timeout\n"; + Lwt.return false) + (function + | Lwt_unix.Timeout -> + let check = + cmp_elapsed_time "with_timeout : timeout" start_time + duration + in + Lwt.return check + | exn -> Lwt.fail exn)); + test "pause" (fun () -> + let bind_callback_ran = ref false in + Lwt.async (fun () -> + Lwt.return () >|= fun () -> bind_callback_ran := true); + let bind_is_immediate = !bind_callback_ran in + let pause_callback_ran = ref false in + Lwt.async (fun () -> + Lwt.pause () >|= fun () -> pause_callback_ran := true); + let pause_is_immediate = !pause_callback_ran in + Lwt.return (bind_is_immediate && not pause_is_immediate)); + test "auto_pause" (fun () -> + let f = Lwt_unix.auto_pause 1.0 in + let run_auto_pause () = + let callback_ran = ref false in + Lwt.async (fun () -> f () >|= fun () -> callback_ran := true); + !callback_ran + in + let check1 = run_auto_pause () in + let check2 = run_auto_pause () in + Lwt_unix.sleep 1.0 >|= fun () -> + let check3 = run_auto_pause () in + let check4 = run_auto_pause () in + let check5 = run_auto_pause () in + let check = check1 && check2 && (not check3) && check4 && check5 in + instrument check + "Lwt_unix sleep and timeout: auto_pause: %b %b %b %b %b" check1 + check2 check3 check4 check5); + ]