From 9711cfb8c8c4283a65df20ccf252f12d9a39867c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 16 Jan 2023 13:45:31 +0100 Subject: [PATCH 1/4] Lwtreslib: use Seqes to implement Seq --- manifest/main.ml | 9 +- opam/tezos-lwt-result-stdlib.opam | 1 + opam/virtual/octez-deps.opam | 1 + src/lib_lwt_result_stdlib/bare/sigs/dune | 1 + src/lib_lwt_result_stdlib/bare/sigs/seq.ml | 148 ++++--- src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml | 301 +++---------- src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml | 117 ++--- src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml | 123 ++---- src/lib_lwt_result_stdlib/bare/structs/dune | 1 + .../bare/structs/hashtbl.ml | 28 +- src/lib_lwt_result_stdlib/bare/structs/map.ml | 12 +- src/lib_lwt_result_stdlib/bare/structs/seq.ml | 136 ++---- .../bare/structs/seq_e.ml | 300 +++---------- .../bare/structs/seq_es.ml | 403 +++--------------- .../bare/structs/seq_s.ml | 247 +++-------- src/lib_lwt_result_stdlib/bare/structs/set.ml | 12 +- src/lib_lwt_result_stdlib/lwtreslib.mli | 29 +- src/lib_lwt_result_stdlib/test/dune | 3 - .../test/test_fuzzing_helpers.ml | 205 --------- .../test/test_fuzzing_seq_against_stdlib.ml | 132 ------ .../test/test_fuzzing_seq_tiered.ml | 244 ----------- .../test/test_seq_basic.ml | 237 ++++++++-- src/lib_lwt_result_stdlib/traced/sigs/seq.ml | 31 ++ .../traced/structs/seq.ml | 25 ++ .../traced/structs/seq_es.ml | 6 +- 25 files changed, 737 insertions(+), 2015 deletions(-) delete mode 100644 src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml delete mode 100644 src/lib_lwt_result_stdlib/test/test_fuzzing_seq_against_stdlib.ml delete mode 100644 src/lib_lwt_result_stdlib/test/test_fuzzing_seq_tiered.ml diff --git a/manifest/main.ml b/manifest/main.ml index 3801a206e843..04af7760ab07 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -319,6 +319,8 @@ let secp256k1_internal = "secp256k1-internal" version +let seqes = external_lib ~js_compatible:true "seqes" V.(at_least "0.2") + let str = external_lib ~js_compatible:true "str" ~opam:"" V.True let tar = external_lib "tar" V.True @@ -538,7 +540,7 @@ let octez_lwt_result_stdlib_bare_sigs = ~path:"src/lib_lwt_result_stdlib/bare/sigs" ~internal_name:"bare_sigs" ~js_compatible:true - ~deps:[lwt; octez_lwt_result_stdlib_bare_functor_outputs] + ~deps:[seqes; lwt; octez_lwt_result_stdlib_bare_functor_outputs] ~opam_with_test:Only_on_64_arch let octez_lwt_result_stdlib_bare_structs = @@ -547,7 +549,7 @@ let octez_lwt_result_stdlib_bare_structs = ~path:"src/lib_lwt_result_stdlib/bare/structs" ~internal_name:"bare_structs" ~js_compatible:true - ~deps:[lwt; octez_lwt_result_stdlib_bare_sigs] + ~deps:[seqes; lwt; octez_lwt_result_stdlib_bare_sigs] ~opam_with_test:Only_on_64_arch let octez_lwt_result_stdlib_traced_functor_outputs = @@ -627,10 +629,7 @@ let _octez_lwt_result_stdlib_tests = "test_list_basic"; "test_list_basic_lwt"; "test_seq_basic"; - "test_fuzzing_helpers"; "test_fuzzing_lib"; - "test_fuzzing_seq_tiered"; - "test_fuzzing_seq_against_stdlib"; "test_fuzzing_list_against_stdlib"; "test_fuzzing_option_against_stdlib"; "test_fuzzing_set_against_stdlib"; diff --git a/opam/tezos-lwt-result-stdlib.opam b/opam/tezos-lwt-result-stdlib.opam index d24b598a9d8c..80c024b84a43 100644 --- a/opam/tezos-lwt-result-stdlib.opam +++ b/opam/tezos-lwt-result-stdlib.opam @@ -11,6 +11,7 @@ depends: [ "dune" { >= "3.0" } "ocaml" { >= "4.14" } "lwt" { >= "5.6.0" } + "seqes" { >= "0.2" } "tezt" { with-test & >= "3.0.0" } "octez-alcotezt" {with-test} "qcheck-alcotest" { with-test & >= "0.20" } diff --git a/opam/virtual/octez-deps.opam b/opam/virtual/octez-deps.opam index f36f04578f82..7fbc2f2f34ef 100644 --- a/opam/virtual/octez-deps.opam +++ b/opam/virtual/octez-deps.opam @@ -86,6 +86,7 @@ depends: [ "resto-directory" { >= "1.0" } "ringo" { >= "1.0.0" } "secp256k1-internal" { >= "0.4.0" } + "seqes" { >= "0.2" } "tar" "tar-unix" { >= "2.0.1" & < "3.0.0" } "tezos-plompiler" { >= "1.0.1" & < "2.0.0" } diff --git a/src/lib_lwt_result_stdlib/bare/sigs/dune b/src/lib_lwt_result_stdlib/bare/sigs/dune index 65f92f0c7ee5..4b2eb3666b10 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/dune +++ b/src/lib_lwt_result_stdlib/bare/sigs/dune @@ -6,6 +6,7 @@ (public_name tezos-lwt-result-stdlib.bare.sigs) (instrumentation (backend bisect_ppx)) (libraries + seqes lwt tezos-lwt-result-stdlib.bare.functor-outputs) (js_of_ocaml)) diff --git a/src/lib_lwt_result_stdlib/bare/sigs/seq.ml b/src/lib_lwt_result_stdlib/bare/sigs/seq.ml index 35a8cd0d4e98..2c9a1ed3882c 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq.ml @@ -32,12 +32,18 @@ See {!Lwtreslib} for a general description of traversors and the meaning for the name suffixes. A full description is also below. - All traversal functions that are suffixed with [_e] are within the result - monad. Note that these functions have a "fail-early" behaviour: the + Note the [Seq] module (along with the [Seq_*] modules) (unlike other + modules of Lwtreslib) uses submodules to organise different monadic + traversors. This is because the implementation of the [Seq] module is + delegated to the [Seqes] library which uses functors which produces + (sub)modules. + + All traversal functions that are inside the [E] submodule are within the + result monad. Note that these functions have a "fail-early" behaviour: the traversal is interrupted as soon as any of the intermediate application fails (i.e., returns an [Error _]). - All traversal functions that are suffixed with [_s] are within the Lwt + All traversal functions that are inside the [S] submodule are within the Lwt monad. These functions traverse the elements sequentially: the promise for a given step of the traversal is only initiated when the promise for the previous step is resolved. Note that these functions have a fail-early @@ -55,8 +61,8 @@ whole-traversal promise is only rejected once all the other step promises have resolved. - All the traversal functions that are suffixed with [_es] are within the - combined error-and-Lwt monad. These function traverse the elements + All the traversal functions that are inside the [ES] submodule are within + the combined error-and-Lwt monad. These function traverse the elements sequentially with a fail-early behaviour for both rejection (as an Lwt promise) and failure (as a result). @@ -70,7 +76,7 @@ Because of the type of {!Stdlib.Seq.t}, some interactions with Lwt are not possible. Specifically, note that the type includes the variant [unit -> 'a node] which is not within Lwt nor within the result monad. - As a result, some of the traversals ([map_s], [map_e], etc.) cannot be + As a result, some of the traversals ([S.map], [E.map], etc.) cannot be applied lazily. Check-out the [S] variants ({!Seq_s.S}, {!Seq_e.S}, and @@ -80,59 +86,49 @@ convert from the standard [S.t]. *) module type S = sig - (** {3 Common interface with Stdlib} *) + (** {3 Common interface with Stdlib} + + Note that some functions (namely [init], [take], and [drop]) are shadowed + with exception-less versions. + Note that [once] is not shadowed. Be careful when using [once]: the + resulting sequence is {e ephemeral} and using in a non-ephemeral way + raises an exception. As a safer alternative, you can use + [Seq_e.of_seq_once] which gives you a result-based (exception-less) + ephemeral sequence. *) include module type of Stdlib.Seq with type 'a t = 'a Stdlib.Seq.t and type 'a node = 'a Stdlib.Seq.node - (** {3 Lwtreslib-specific extensions} *) + (** {3 Lwtreslib-specific safety-shadowing} *) - (** [first s] is [None] if [s] is empty, it is [Some x] where [x] is the - first element of [s] otherwise. - - Note that [first] forces the first element of the sequence, which can have - side-effects or be computationally expensive. Consider, e.g., the case - where [s = filter (fun …) s']: [first s] can force multiple of the values - from [s']. *) - val first : 'a t -> 'a option - - (** Similar to {!fold_left} but wraps the traversal in {!result}. The - traversal is interrupted if one of the step returns an [Error _]. *) - val fold_left_e : - ('a -> 'b -> ('a, 'trace) result) -> 'a -> 'b t -> ('a, 'trace) result - - (** Similar to {!fold_left} but wraps the traversing in {!Lwt}. Each step of - the traversal is started after the previous one has resolved. The - traversal is interrupted if one of the promise is rejected. *) - val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b t -> 'a Lwt.t - - (** Similar to {!fold_left} but wraps the traversing in [result Lwt.t]. - Each step of the traversal is started after the previous one resolved. The - traversal is interrupted if one of the step is rejected or is fulfilled - with [Error _]. *) - val fold_left_es : - ('a -> 'b -> ('a, 'trace) result Lwt.t) -> - 'a -> - 'b t -> - ('a, 'trace) result Lwt.t + val init : + when_negative_length:'err -> int -> (int -> 'a) -> ('a t, 'err) result + + val take : when_negative_length:'err -> int -> 'a t -> ('a t, 'err) result + + val drop : when_negative_length:'err -> int -> 'a t -> ('a t, 'err) result - (** Similar to {!iter} but wraps the iteration in {!result}. The iteration - is interrupted if one of the step returns an [Error _]. *) - val iter_e : ('a -> (unit, 'trace) result) -> 'a t -> (unit, 'trace) result + module E : + Seqes.Sigs.SEQMON2TRAVERSORS + with type ('a, 'e) mon := ('a, 'e) result + with type ('a, 'e) callermon := ('a, 'e) result + with type ('a, 'e) t := 'a Stdlib.Seq.t - (** Similar to {!iter} but wraps the iteration in {!Lwt}. Each step - of the iteration is started after the previous one resolved. The iteration - is interrupted if one of the promise is rejected. *) - val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t + module S : + Seqes.Sigs.SEQMON1TRAVERSORS + with type 'a mon := 'a Lwt.t + with type 'a callermon := 'a Lwt.t + with type 'a t := 'a Stdlib.Seq.t - (** Similar to {!iter} but wraps the iteration in [result Lwt.t]. Each step - of the iteration is started after the previous one resolved. The iteration - is interrupted if one of the promise is rejected of fulfilled with an - [Error _]. *) - val iter_es : - ('a -> (unit, 'trace) result Lwt.t) -> 'a t -> (unit, 'trace) result Lwt.t + module ES : + Seqes.Sigs.SEQMON2TRAVERSORS + with type ('a, 'e) mon := ('a, 'e) result Lwt.t + with type ('a, 'e) callermon := ('a, 'e) result Lwt.t + with type ('a, 'e) t := 'a Stdlib.Seq.t + + (** {3 Lwtreslib-specific extensions} *) (** Similar to {!iter} but wraps the iteration in [result Lwt.t]. All the steps of the iteration are started concurrently. The promise [iter_ep] @@ -154,14 +150,52 @@ module type S = sig them is. *) val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t - (** {3 Values which have made it to the Stdlib since then} - - This section is for forward compatibility: bringing you the features of - more recent OCaml Stdlib than we compile against. *) + (** Similar to {!iteri} but wraps the iteration in [result Lwt.t]. All the + steps of the iteration are started concurrently. The promise [iteri_ep] + resolves once all the promises of the traversal resolve. At this point it + either: + - is rejected if at least one of the promises is, otherwise + - is fulfilled with [Error _] if at least one of the promises is, + otherwise + - is fulfilled with [Ok ()] if all the promises are. *) + val iteri_ep : + (int -> 'a -> (unit, 'trace) result Lwt.t) -> + 'a t -> + (unit, 'trace list) result Lwt.t - (** [concat s] is a sequence containing the elements of the elements of [s]. *) - val concat : 'a t t -> 'a t + (** Similar to {!iteri} but wraps the iteration in {!Lwt}. All the + steps of the iteration are started concurrently. The promise [iter_p f s] + is resolved only once all the promises of the iteration are. At this point + it is either fulfilled if all promises are, or rejected if at least one of + them is. *) + val iteri_p : (int -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t + + (** Similar to {!iter2} but wraps the iteration in [result Lwt.t]. All the + steps of the iteration are started concurrently. The promise + [iter2_ep f s1 s2] resolves once all the promises of the traversal resolve. + At this point it is either: + - rejected if at least one of the promises is, + - fulfilled with [Error _] if at least one of the promises is, + - fulfilled with [Ok ()] if all of the promises are. + + Note that similarly to {!Stdlib.Seq.iter2} this function iterates on the + common-length prefix of the two sequences. As a result, the iteration can + be successful even if the two sequences are of different lengths. *) + val iter2_ep : + ('a -> 'b -> (unit, 'trace) result Lwt.t) -> + 'a t -> + 'b t -> + (unit, 'trace list) result Lwt.t - (** [concat_map] is an alias for {!flat_map} *) - val concat_map : ('a -> 'b t) -> 'a t -> 'b t + (** Similar to {!iter2} but wraps the iteration in {!Lwt}. All the + steps of the iteration are started concurrently. The promise + [iter2_p f s1 s2] resolves once all the promises of the traversal resolve. + At this point it is either: + - rejected if at least one of the promises is, + - fulfilled with [()] if all of the promises are. + + Note that similarly to {!Stdlib.Seq.iter2} this function iterates on the + common-length prefix of the two sequences. As a result, the iteration can + be successful even if the two sequences are of different lengths. *) + val iter2_p : ('a -> 'b -> unit Lwt.t) -> 'a t -> 'b t -> unit Lwt.t end diff --git a/src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml b/src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml index 52032504b41a..b62d4c339b07 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml @@ -26,43 +26,19 @@ (** The [S] signature is similar to {!Seq.S} except that suspended nodes are wrapped in a result. - This allows some additional traversors ([map_e], etc.) to be applied lazily. + This allows some additional traversors ([E.map], etc.) to be applied lazily. The functions [of_seq] and [of_seq_e] allow conversion from vanilla sequences. *) module type S = sig - (** This is similar to {!Stdlib.Seq.S}[.t] but the suspended node is a result. - - Consequently, the sequence of elements may be interrupted by an error. - Specifically, there are two possible kinds of sequences: - - - {e interrupted sequences} where one of the suspended nodes is not - returned and an [Error _] is produced instead, and - - {e whole sequences} where all the suspended nodes are actually returned - inside an [Ok _]. - - All the traversors below treat sequence interruption as an error that is - returned as is. - - Also note that nodes are suspended by a continuation rather than a lazy - block. As a result, different traversals of the same sequence can lead to - repeated evaluations of the same elements, or distinct sets of elements, - or even a different kind of sequence. E.g., if a suspended sequence fails - or succeeds depending on the content of a reference. - - This is not recommended. You should use deterministic sequences that do - not depend on state. Or you should use one-shot sequences that are used - once and then never again. The documentation of this module is written - assuming you adhere to these constraints. *) type ('a, 'e) t = unit -> (('a, 'e) node, 'e) result and (+'a, 'e) node = Nil | Cons of 'a * ('a, 'e) t - (** A whole sequence of zero elements. *) - val empty : ('a, 'e) t - - (** [return x] is a whole sequence containing the single element [x]. *) - val return : 'a -> ('a, 'e) t + include + Seqes.Sigs.SEQMON2ALL + with type ('a, 'e) mon := ('a, 'e) result + with type ('a, 'e) t := ('a, 'e) t (** [return_e (Ok x)] is a whole sequence containing the single element [x]. [return_e (Error e)] is a sequence immediately interrupted by the error @@ -72,156 +48,13 @@ module type S = sig (** [interrupted e] is a sequence immediately interrupted by the error [e]. *) val interrupted : 'e -> ('a, 'e) t - (** [nil] is the node forming the empty sequence. *) - val nil : ('a, 'e) node - - (** [cons x s] is the sequence containing [x] followed by [s]. It is a whole - sequence if [s] is. *) - val cons : 'a -> ('a, 'e) t -> ('a, 'e) t - - (** [cons_e (Ok x) s] is the sequence containing [x] followed by [s]. It is a - whole sequence if [s] is. - - [cons_e (Error e) s] is a sequence immediately interrupted by [e]. *) - val cons_e : ('a, 'e) result -> ('a, 'e) t -> ('a, 'e) t - - (** [append s1 s2] is a sequence [s]. - If [s1] is a whole sequence then [s] is composed of all the elements of - [s1] followed by [s2]. - If [s1] is an interrupted sequence then [s] is indistinguishable from - [s1]. - - [s] is a whole sequence if both [s1] and [s2] are. *) - val append : ('a, 'e) t -> ('a, 'e) t -> ('a, 'e) t - - (** [first s] is [None] if [s] is empty, it is [Some (Error e)] if [s] is - immediately interrupted by [e], it is [Some (Ok x)] where [x] is the - first element of [s] otherwise. - - Note that [first] forces the first element of the sequence, which can have - side-effects or be computationally expensive. Consider, e.g., the case - where [s = filter (fun …) s']: [first s] can force multiple of the values - from [s']. *) - val first : ('a, 'e) t -> ('a, 'e) result option - - (** [fold_left f init seq] is - - - if [seq] is a whole sequence, then [Ok x] where [x] is the result of - folding [f] over all the elements of [seq] starting with [init], or - - if [seq] is interrupted by [Error e], then [Error e]. - - Note that, as with all other traversors below, if the sequence is - interrupted, all the side-effects of [f] on the successful prefix of - [seq] have already been applied before the traversal returns [Error _]. *) - val fold_left : ('a -> 'b -> 'a) -> 'a -> ('b, 'e) t -> ('a, 'e) result - - (** [fold_left_e f init seq] folds [f] over the elements of [seq] with an - accumulator set at [init]. It stops traversal (returning [Error _]) if [f] - returns an [Error _] or if the sequence is interrupted. Otherwise it - returns [Ok _]. - - This function does not discriminate between interruption and traversal - errors. The {!fold_left_e_discriminated} provide such a distinction. *) - val fold_left_e : - ('a -> 'b -> ('a, 'e) result) -> 'a -> ('b, 'e) t -> ('a, 'e) result - - (** [fold_left_e_discriminated f init seq] is the same as {!fold_left_e} but - errors from [f] are wrapped in [Right] whilst interruptions in [seq] are - wrapped in [Left]. - - [fold_left_e_discriminated f init seq] is equivalent to - -{[ -fold_left_e - (fun acc item -> - f acc item |> Result.map_error (fun e -> Either.Right e)) - init - (s |> map_error (fun e -> Either.Left e)) -]} - *) - val fold_left_e_discriminated : - ('a -> 'b -> ('a, 'f) result) -> - 'a -> - ('b, 'e) t -> - ('a, ('e, 'f) Either.t) result - - (** [fold_left_s f init seq] is a promise that resolves to - - - if [seq] is a whole sequence, then [Ok x] where [x] is the result of - folding [f] over all the elements of [seq] starting with [init], or - - if [seq] is interrupted by [Error e], then [Error e]. - - Note that if it returns [Error _], the side-effects of [f] on previous - elements have already been applied anyway. - - The elements are traversed sequentially. Specifically, a node's suspension - is called only when the [f]-promise of the previous node has resolved. - Thus, there might be yielding in between suspensions being called. *) - val fold_left_s : - ('a -> 'b -> 'a Lwt.t) -> 'a -> ('b, 'e) t -> ('a, 'e) result Lwt.t - - (** [fold_left_es f init seq] is a promise that resolves to - - - if [seq] is a whole sequence and [f]-promises always resolve - successfully, then the result of folding [f] over all the elements of - [seq] starting with [init], - - otherwise, [Error _] with the error that interrupts the sequence or with - an error returned by [f], whichever happens first. - - The elements are traversed sequentially. Specifically, a node's suspension - is called only when the [f]-promise of the previous node has resolved. - Thus, there might be yielding in between suspensions being called. *) - val fold_left_es : - ('a -> 'b -> ('a, 'e) result Lwt.t) -> - 'a -> - ('b, 'e) t -> - ('a, 'e) result Lwt.t - - (** [fold_left_es_discriminated f init seq] is the same as {!fold_left_es} but - errors from [f] are wrapped in [Right] whilst interruptions in [seq] are - wrapped in [Left]. - - [fold_left_es_discriminated f init seq] is equivalent to - -{[ -fold_left_es - (fun acc item -> - let+ r = f acc item in - Result.map_error Either.right r) - init - (s |> map_error Either.left) -]} - *) - val fold_left_es_discriminated : - ('a -> 'b -> ('a, 'f) result Lwt.t) -> - 'a -> - ('b, 'e) t -> - ('a, ('e, 'f) Either.t) result Lwt.t - - (** [iter f seq] is [fold_left (fun () x -> f x) () seq] *) - val iter : ('a -> unit) -> ('a, 'e) t -> (unit, 'e) result - - (** [iter_e f seq] is [fold_left_e (fun () x -> f x) () seq] *) - val iter_e : ('a -> (unit, 'e) result) -> ('a, 'e) t -> (unit, 'e) result - - (** [iter_e_discriminated f seq] is like {!iter_e} but the errors from [f] - and [seq] are kept separate. *) - val iter_e_discriminated : - ('a -> (unit, 'f) result) -> ('a, 'e) t -> (unit, ('e, 'f) Either.t) result - - (** [iter_s f seq] is [fold_left_s (fun () x -> f x) () seq] *) - val iter_s : ('a -> unit Lwt.t) -> ('a, 'e) t -> (unit, 'e) result Lwt.t - - (** [iter_es f seq] is [fold_left_es (fun () x -> f x) () seq] *) - val iter_es : - ('a -> (unit, 'e) result Lwt.t) -> ('a, 'e) t -> (unit, 'e) result Lwt.t + (** [map_error f seq] is a sequence [feq]. - (** [iter_es_discriminated f seq] is like {!iter_es} but the errors from [f] - and [seq] are kept separate. *) - val iter_es_discriminated : - ('a -> (unit, 'f) result Lwt.t) -> - ('a, 'e) t -> - (unit, ('e, 'f) Either.t) result Lwt.t + - If [seq] is a whole sequence, then [feq] is the same whole sequence. + - If [seq] is an interrupted sequence, then [feq] is a sequence + interrupted by [Error (f e)] where the elements of the successful prefix + are the elements of the successful prefix of [seq]. *) + val map_error : ('e -> 'f) -> ('a, 'e) t -> ('a, 'f) t (** [iter_p f seq] is a promise [p]. @@ -235,78 +68,50 @@ fold_left_es best-effort semantic of Lwtreslib. *) val iter_p : ('a -> unit Lwt.t) -> ('a, 'e) t -> (unit, 'e) result Lwt.t - (** There is no [iter_ep] in [Bare]. The reason is that there can be two - sources of failures and there is no satisfying way to combine failures for - the caller. *) - - (** [map f seq] is a sequence [feq]. - - - If [seq] is a whole sequence, then [feq] is a whole sequence where the - elements are the result of the application of [f] on the elements of - [seq]. - - If [seq] is an interrupted sequence, then [feq] is a sequence - interrupted by [Error e] where the elements of the successful prefix are - the result of the application of [f] on the elements of the successful - prefix of [seq]. - *) - val map : ('a -> 'b) -> ('a, 'e) t -> ('b, 'e) t - - (** [map_error f seq] is a sequence [feq]. - - - If [seq] is a whole sequence, then [feq] is the same whole sequence. - - If [seq] is an interrupted sequence, then [feq] is a sequence - interrupted by [Error (f e)] where the elements of the successful prefix - are the elements of the successful prefix of [seq]. *) - val map_error : ('e -> 'f) -> ('a, 'e) t -> ('a, 'f) t - - (** [map_e f seq] is a sequence [feq]. - - - If [seq] is a whole sequence and if [f] is successful on all the - elements of [seq], then [feq] is a whole sequence where the elements are - [x] where [Ok x] is the result of the application of [f] on the elements - of [seq]. - - Otherwise [feq] is a sequence composed of elements of [seq] mapped by - [f] and interrupted by [f] returning [Error] or by [seq]'s interruption - (whichever comes first). *) - val map_e : ('a -> ('b, 'e) result) -> ('a, 'e) t -> ('b, 'e) t - - (** There is no [map_e_discriminated] because the result of a [map*] is a - sequence ([t]) and so any error (even from [f]) is, in essence, an - interruption of the resulting sequence. - - If you need to apply such a distinction and you are ready to deal with the - resulting [Either.t]-interruptible sequence, you can arrange this manually - using {!map_error} and [Result.map_error]. - - A similar remark applies to the other combinators below. *) - - (** [filter f s] is a sequence of the same kind as [s] with only the elements - for which [f] returns [true]. *) - val filter : ('a -> bool) -> ('a, 'e) t -> ('a, 'e) t - - (** [filter_e f s] is a sequence that is interrupted like [s] or by [f] being - unsuccessful (whichever comes first) or whole (if neither cases apply). - Whichever is the case, the elements of the resulting sequence are the - elements of [s] for which [f] returns [Ok true]. *) - val filter_e : ('a -> (bool, 'e) result) -> ('a, 'e) t -> ('a, 'e) t - - (** [filter_map f s] is a sequence of the same kind as [s] where the elements - are transformed by [f] (when it returns [Some _]) or dropped (when it - returns [None]). *) - val filter_map : ('a -> 'b option) -> ('a, 'e) t -> ('b, 'e) t - - (** [filter_map_e f s] is a sequence that is whole or that is interrupted in - the same way as [s] (if it is) or that is interrupted by [f] (if it - happens). Whichever the case, the elements of the sequence or the - successful prefix thereof are transformed by [f] (when it returns - [Some _]) or dropped (when it returns [None]). *) - val filter_map_e : ('a -> ('b option, 'e) result) -> ('a, 'e) t -> ('b, 'e) t - - val unfold : ('b -> ('a * 'b) option) -> 'b -> ('a, 'e) t + (** [cons_e (Ok x) s] is the sequence containing [x] followed by [s]. It is a + whole sequence if [s] is. - val unfold_e : ('b -> (('a * 'b) option, 'e) result) -> 'b -> ('a, 'e) t + [cons_e (Error e) s] is a sequence immediately interrupted by [e]. *) + val cons_e : ('a, 'e) result -> ('a, 'e) t -> ('a, 'e) t - val of_seq : 'a Stdlib.Seq.t -> ('a, 'e) t + val take : + when_negative_length:'err -> int -> ('a, 'e) t -> (('a, 'e) t, 'err) result + + val drop : + when_negative_length:'err -> int -> ('a, 'e) t -> (('a, 'e) t, 'err) result + + module E : + Seqes.Sigs.SEQMON2TRANSFORMERS + with type ('a, 'e) t := ('a, 'e) t + and type ('a, 'e) mon := ('a, 'e) result + and type ('a, 'e) callermon := ('a, 'e) result + + module S : + Seqes.Sigs.SEQMON2TRAVERSORS + with type ('a, 'e) t := ('a, 'e) t + and type ('a, 'e) mon := ('a, 'e) result Lwt.t + and type ('a, 'e) callermon := 'a Lwt.t + + module ES : + Seqes.Sigs.SEQMON2TRAVERSORS + with type ('a, 'e) t := ('a, 'e) t + and type ('a, 'e) mon := ('a, 'e) result Lwt.t + and type ('a, 'e) callermon := ('a, 'e) result Lwt.t + + (** [of_seq_catch s] is a sequence with the same elements as [s] which is + interrupted when forcing an element of the sequence raises an exception. *) + val of_seq_catch : 'a Stdlib.Seq.t -> ('a, exn) t + + (** [of_seq_once ~when_forced_twice s] is a sequence with the same elements as + [s] which is interrupted when an element of the sequence is forced twice. + + In other words, it is equivalent to + {[map_error + (function Seq.Forced_twice -> when_forced_twice | e -> raise e) + (of_seq_catch (Seq.once s)) + ]} + *) + val of_seq_once : when_forced_twice:'e -> 'a Stdlib.Seq.t -> ('a, 'e) t val of_seq_e : ('a, 'e) result Stdlib.Seq.t -> ('a, 'e) t end diff --git a/src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml b/src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml index f68a57867e0f..8f999f04296b 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml @@ -26,7 +26,7 @@ (** The [S] signature is similar to {!Seq.S} except that suspended nodes are wrapped in a result-Lwt. - This allows some additional traversors ([map_ep], etc.) to be applied + This allows some additional traversors ([ES.map], etc.) to be applied lazily. The functions [of_seq] and [of_seq_*] allow conversion from vanilla @@ -47,11 +47,28 @@ module type S = sig and ('a, 'e) t = unit -> (('a, 'e) node, 'e) result Lwt.t - val empty : ('a, 'e) t - - val nil : ('a, 'e) node - - val cons : 'a -> ('a, 'e) t -> ('a, 'e) t + include + Seqes.Sigs.SEQMON2ALL + with type ('a, 'e) mon := ('a, 'e) result Lwt.t + with type ('a, 'e) t := ('a, 'e) t + + module E : + Seqes.Sigs.SEQMON2TRANSFORMERS + with type ('a, 'e) mon := ('a, 'e) result Lwt.t + with type ('a, 'e) callermon := ('a, 'e) result + with type ('a, 'e) t := ('a, 'e) t + + module S : + Seqes.Sigs.SEQMON2TRANSFORMERS + with type ('a, 'e) mon := ('a, 'e) result Lwt.t + with type ('a, 'e) callermon := 'a Lwt.t + with type ('a, 'e) t := ('a, 'e) t + + module ES : + Seqes.Sigs.SEQMON2TRANSFORMERS + with type ('a, 'e) mon := ('a, 'e) result Lwt.t + with type ('a, 'e) callermon := ('a, 'e) result Lwt.t + with type ('a, 'e) t := ('a, 'e) t val cons_s : 'a Lwt.t -> ('a, 'e) t -> ('a, 'e) t @@ -59,10 +76,6 @@ module type S = sig val cons_es : ('a, 'e) result Lwt.t -> ('a, 'e) t -> ('a, 'e) t - val append : ('a, 'e) t -> ('a, 'e) t -> ('a, 'e) t - - val return : 'a -> ('a, 'e) t - val return_e : ('a, 'e) result -> ('a, 'e) t val return_s : 'a Lwt.t -> ('a, 'e) t @@ -73,91 +86,15 @@ module type S = sig val interrupted_s : 'e Lwt.t -> ('a, 'e) t - val first : ('a, 'e) t -> ('a, 'e) result option Lwt.t - - val fold_left : ('a -> 'b -> 'a) -> 'a -> ('b, 'e) t -> ('a, 'e) result Lwt.t - - val fold_left_e : - ('a -> 'b -> ('a, 'e) result) -> 'a -> ('b, 'e) t -> ('a, 'e) result Lwt.t - - val fold_left_e_discriminated : - ('a -> 'b -> ('a, 'f) result) -> - 'a -> - ('b, 'e) t -> - ('a, ('e, 'f) Either.t) result Lwt.t - - val fold_left_s : - ('a -> 'b -> 'a Lwt.t) -> 'a -> ('b, 'e) t -> ('a, 'e) result Lwt.t - - val fold_left_es : - ('a -> 'b -> ('a, 'e) result Lwt.t) -> - 'a -> - ('b, 'e) t -> - ('a, 'e) result Lwt.t - - val fold_left_es_discriminated : - ('a -> 'b -> ('a, 'f) result Lwt.t) -> - 'a -> - ('b, 'e) t -> - ('a, ('e, 'f) Either.t) result Lwt.t - - val iter : ('a -> unit) -> ('a, 'e) t -> (unit, 'e) result Lwt.t - - val iter_e : - ('a -> (unit, 'e) result) -> ('a, 'e) t -> (unit, 'e) result Lwt.t - - val iter_e_discriminated : - ('a -> (unit, 'f) result) -> - ('a, 'e) t -> - (unit, ('e, 'f) Either.t) result Lwt.t - - val iter_s : ('a -> unit Lwt.t) -> ('a, 'e) t -> (unit, 'e) result Lwt.t - - val iter_es : - ('a -> (unit, 'e) result Lwt.t) -> ('a, 'e) t -> (unit, 'e) result Lwt.t - - val iter_es_discriminated : - ('a -> (unit, 'f) result Lwt.t) -> - ('a, 'e) t -> - (unit, ('e, 'f) Either.t) result Lwt.t - - val map : ('a -> 'b) -> ('a, 'e) t -> ('b, 'e) t - - val map_e : ('a -> ('b, 'e) result) -> ('a, 'e) t -> ('b, 'e) t - - val map_s : ('a -> 'b Lwt.t) -> ('a, 'e) t -> ('b, 'e) t - - val map_es : ('a -> ('b, 'e) result Lwt.t) -> ('a, 'e) t -> ('b, 'e) t - val map_error : ('e -> 'f) -> ('a, 'e) t -> ('a, 'f) t val map_error_s : ('e -> 'f Lwt.t) -> ('a, 'e) t -> ('a, 'f) t - val filter : ('a -> bool) -> ('a, 'e) t -> ('a, 'e) t - - val filter_e : ('a -> (bool, 'e) result) -> ('a, 'e) t -> ('a, 'e) t - - val filter_s : ('a -> bool Lwt.t) -> ('a, 'e) t -> ('a, 'e) t - - val filter_es : ('a -> (bool, 'e) result Lwt.t) -> ('a, 'e) t -> ('a, 'e) t - - val filter_map : ('a -> 'b option) -> ('a, 'e) t -> ('b, 'e) t - - val filter_map_e : ('a -> ('b option, 'e) result) -> ('a, 'e) t -> ('b, 'e) t - - val filter_map_s : ('a -> 'b option Lwt.t) -> ('a, 'e) t -> ('b, 'e) t - - val filter_map_es : - ('a -> ('b option, 'e) result Lwt.t) -> ('a, 'e) t -> ('b, 'e) t - - val unfold : ('b -> ('a * 'b) option) -> 'b -> ('a, 'e) t - - val unfold_s : ('b -> ('a * 'b) option Lwt.t) -> 'b -> ('a, 'e) t - - val unfold_e : ('b -> (('a * 'b) option, 'e) result) -> 'b -> ('a, 'e) t + val take : + when_negative_length:'err -> int -> ('a, 'e) t -> (('a, 'e) t, 'err) result - val unfold_es : - ('b -> (('a * 'b) option, 'e) result Lwt.t) -> 'b -> ('a, 'e) t + val drop : + when_negative_length:'err -> int -> ('a, 'e) t -> (('a, 'e) t, 'err) result val of_seq : 'a Stdlib.Seq.t -> ('a, 'e) t diff --git a/src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml b/src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml index dfeb30cb839d..ab3a2761a00b 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml @@ -26,7 +26,7 @@ (** The [S] signature is similar to {!Seq.S} except that suspended nodes are wrapped in a promise. - This allows some additional traversors ([map_s], etc.) to be applied lazily. + This allows some additional traversors ([S.map], etc.) to be applied lazily. The functions [of_seq] and [of_seq_s] allow conversion from vanilla sequences. *) @@ -36,92 +36,35 @@ module type S = sig and 'a t = unit -> 'a node Lwt.t - (** [empty] is a sequence with no elements. *) - val empty : 'a t + include + Seqes.Sigs.SEQMON1ALL with type 'a mon := 'a Lwt.t with type 'a t := 'a t - (** [return x] is a sequence with the single element [x]. *) - val return : 'a -> 'a t + module E : + Seqes.Sigs.SEQMON2TRAVERSORS + with type ('a, 'e) mon := ('a, 'e) result Lwt.t + with type ('a, 'e) callermon := ('a, 'e) result + with type ('a, 'e) t := 'a t + + module S : + Seqes.Sigs.SEQMON1TRANSFORMERS + with type 'a mon := 'a Lwt.t + with type 'a callermon := 'a Lwt.t + with type 'a t := 'a t + + module ES : + Seqes.Sigs.SEQMON2TRAVERSORS + with type ('a, 'e) mon := ('a, 'e) result Lwt.t + with type ('a, 'e) callermon := ('a, 'e) result Lwt.t + with type ('a, 'e) t := 'a t (** [return_s p] is a sequence with the value the promise [p] resolves to as its single element. *) val return_s : 'a Lwt.t -> 'a t - (** [cons x s] is the sequence containing [x] followed by [s]. It is a whole - sequence if [s] is. *) - val cons : 'a -> 'a t -> 'a t - (** [cons_s p s] is the sequence containing the value the promise [p] resolves to, followed by [s]. *) val cons_s : 'a Lwt.t -> 'a t -> 'a t - (** [append s1 s2] is a sequence [s] containing the elements of [s1] followed - by the elements of [s2]. *) - val append : 'a t -> 'a t -> 'a t - - (** [first s] resolves to [None] if [s] is empty (and its suspended node - resolves), it resolves to [Some x] where [x] is the first element of [s], - it does not resolve if the promised node of [s] doesn't. - - Note that [first] forces the first element of the sequence, which can have - side-effects or be computationally expensive. Consider, e.g., the case - where [s = filter (fun …) s']: [first s] can force multiple of the values - from [s']. *) - val first : 'a t -> 'a option Lwt.t - - (** Similar to {!fold_left} but applies to Lwt-suspended sequences. Because - the nodes are suspended in promises, traversing may yield and, - consequently, the function [fold_left] returns a promise. *) - val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a Lwt.t - - (** Similar to {!fold_left} but wraps the traversal in {!result}. The - traversal is interrupted if one of the step returns an [Error _]. *) - val fold_left_e : - ('a -> 'b -> ('a, 'trace) result) -> 'a -> 'b t -> ('a, 'trace) result Lwt.t - - (** Similar to {!fold_left} but the folder is within Lwt. *) - val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b t -> 'a Lwt.t - - (** Similar to {!fold_left} but the folder is within result-Lwt. Traversal is - interrupted if one of the step resolves to an [Error _]. *) - val fold_left_es : - ('a -> 'b -> ('a, 'trace) result Lwt.t) -> - 'a -> - 'b t -> - ('a, 'trace) result Lwt.t - - (** [iter f s] applies [f] to each element of [s]. *) - val iter : ('a -> unit) -> 'a t -> unit Lwt.t - - (** Similar to {!iter} but wraps the iteration in {!result}. The iteration - is interrupted if one of the steps returns an [Error _]. *) - val iter_e : - ('a -> (unit, 'trace) result) -> 'a t -> (unit, 'trace) result Lwt.t - - (** Similar to {!iter} but wraps the iteration in {!Lwt}. Each step - of the iteration is started after the previous one is resolved. *) - val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t - - (** Similar to {!iter} but wraps the iteration in [result Lwt.t]. Each step - of the iteration is started after the previous one resolved. The iteration - is interrupted if one of the promise is rejected of fulfilled with an - [Error _]. *) - val iter_es : - ('a -> (unit, 'trace) result Lwt.t) -> 'a t -> (unit, 'trace) result Lwt.t - - (** Similar to {!iter} but wraps the iteration in [result Lwt.t]. The - steps of the iteration are started concurrently: one iteration starts - as soon as a node becomes resolved. The promise [iter_ep] - resolves once all the promises of the traversal resolve. At this point it - either: - - is rejected if at least one of the promises is, otherwise - - is fulfilled with [Error _] if at least one of the promises is, - otherwise - - is fulfilled with [Ok ()] if all the promises are. *) - val iter_ep : - ('a -> (unit, 'trace) result Lwt.t) -> - 'a t -> - (unit, 'trace list) result Lwt.t - (** Similar to {!iter} but wraps the iteration in {!Lwt}. The steps of the iteration are started concurrently: one iteration is started as soon as the node becomes resolved. The promise [iter_p f s] @@ -130,26 +73,16 @@ module type S = sig them is. *) val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t - val map : ('a -> 'b) -> 'a t -> 'b t - - val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t - - val filter : ('a -> bool) -> 'a t -> 'a t - - (** Similar to {!filter} but wraps the transformation in {!Lwt.t}. Each - test of the predicate is done sequentially, only starting once the - previous one has resolved. *) - val filter_s : ('a -> bool Lwt.t) -> 'a t -> 'a t - - val filter_map : ('a -> 'b option) -> 'a t -> 'b t - - (** Similar to {!filter_map} but within [Lwt.t]. Not lazy and not - tail-recursive. *) - val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t + (** Similar to {!iteri} but wraps the iteration in {!Lwt}. All the + steps of the iteration are started concurrently. The promise [iteri_p f s] + is resolved only once all the promises of the iteration are. At this point + it is either fulfilled if all promises are, or rejected if at least one of + them is. *) + val iteri_p : (int -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t - val unfold : ('b -> ('a * 'b) option) -> 'b -> 'a t + val take : when_negative_length:'err -> int -> 'a t -> ('a t, 'err) result - val unfold_s : ('b -> ('a * 'b) option Lwt.t) -> 'b -> 'a t + val drop : when_negative_length:'err -> int -> 'a t -> ('a t, 'err) result val of_seq : 'a Stdlib.Seq.t -> 'a t diff --git a/src/lib_lwt_result_stdlib/bare/structs/dune b/src/lib_lwt_result_stdlib/bare/structs/dune index f8cf88904eca..ba667d43a85c 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/dune +++ b/src/lib_lwt_result_stdlib/bare/structs/dune @@ -6,6 +6,7 @@ (public_name tezos-lwt-result-stdlib.bare.structs) (instrumentation (backend bisect_ppx)) (libraries + seqes lwt tezos-lwt-result-stdlib.bare.sigs) (js_of_ocaml)) diff --git a/src/lib_lwt_result_stdlib/bare/structs/hashtbl.ml b/src/lib_lwt_result_stdlib/bare/structs/hashtbl.ml index 03f2b826c082..427e8b08e8e8 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/hashtbl.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/hashtbl.ml @@ -39,24 +39,24 @@ module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t = struct open Seq include Stdlib.Hashtbl.Make (H) - let iter_e f t = iter_e (fun (k, v) -> f k v) (to_seq t) + let iter_e f t = E.iter (fun (k, v) -> f k v) (to_seq t) - let iter_s f t = iter_s (fun (k, v) -> f k v) (to_seq t) + let iter_s f t = S.iter (fun (k, v) -> f k v) (to_seq t) - let iter_es f t = iter_es (fun (k, v) -> f k v) (to_seq t) + let iter_es f t = ES.iter (fun (k, v) -> f k v) (to_seq t) let iter_p f t = iter_p (fun (k, v) -> f k v) (to_seq t) let iter_ep f t = iter_ep (fun (k, v) -> f k v) (to_seq t) let fold_e f t init = - fold_left_e (fun acc (k, v) -> f k v acc) init (to_seq t) + E.fold_left (fun acc (k, v) -> f k v acc) init (to_seq t) let fold_s f t init = - fold_left_s (fun acc (k, v) -> f k v acc) init (to_seq t) + S.fold_left (fun acc (k, v) -> f k v acc) init (to_seq t) let fold_es f t init = - fold_left_es (fun acc (k, v) -> f k v acc) init (to_seq t) + ES.fold_left (fun acc (k, v) -> f k v acc) init (to_seq t) let find = find_opt @@ -73,24 +73,24 @@ module MakeSeeded (H : Stdlib.Hashtbl.SeededHashedType) : open Seq include Stdlib.Hashtbl.MakeSeeded (H) - let iter_e f t = iter_e (fun (k, v) -> f k v) (to_seq t) + let iter_e f t = E.iter (fun (k, v) -> f k v) (to_seq t) - let iter_s f t = iter_s (fun (k, v) -> f k v) (to_seq t) + let iter_s f t = S.iter (fun (k, v) -> f k v) (to_seq t) - let iter_es f t = iter_es (fun (k, v) -> f k v) (to_seq t) + let iter_es f t = ES.iter (fun (k, v) -> f k v) (to_seq t) let iter_ep f t = iter_ep (fun (k, v) -> f k v) (to_seq t) let iter_p f t = iter_p (fun (k, v) -> f k v) (to_seq t) let fold_e f t init = - fold_left_e (fun acc (k, v) -> f k v acc) init (to_seq t) + E.fold_left (fun acc (k, v) -> f k v acc) init (to_seq t) let fold_s f t init = - fold_left_s (fun acc (k, v) -> f k v acc) init (to_seq t) + S.fold_left (fun acc (k, v) -> f k v acc) init (to_seq t) let fold_es f t init = - fold_left_es (fun acc (k, v) -> f k v acc) init (to_seq t) + ES.fold_left (fun acc (k, v) -> f k v acc) init (to_seq t) let find = find_opt @@ -160,7 +160,7 @@ struct let mem t k = T.mem t k let iter_with_waiting_es f t = - iter_es + ES.iter (fun (k, p) -> let open Lwt_result_syntax in Lwt.try_bind @@ -170,7 +170,7 @@ struct (T.to_seq t) let fold_with_waiting_es f t init = - fold_left_es + ES.fold_left (fun acc (k, p) -> let open Lwt_result_syntax in Lwt.try_bind diff --git a/src/lib_lwt_result_stdlib/bare/structs/map.ml b/src/lib_lwt_result_stdlib/bare/structs/map.ml index 2004206570dd..6d86ee606c1f 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/map.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/map.ml @@ -29,24 +29,24 @@ module Make (Ord : Stdlib.Map.OrderedType) : S with type key = Ord.t = struct open Seq include Stdlib.Map.Make (Ord) - let iter_e f t = iter_e (fun (k, v) -> f k v) (to_seq t) + let iter_e f t = E.iter (fun (k, v) -> f k v) (to_seq t) - let iter_s f t = iter_s (fun (k, v) -> f k v) (to_seq t) + let iter_s f t = S.iter (fun (k, v) -> f k v) (to_seq t) - let iter_es f t = iter_es (fun (k, v) -> f k v) (to_seq t) + let iter_es f t = ES.iter (fun (k, v) -> f k v) (to_seq t) let iter_ep f t = iter_ep (fun (k, v) -> f k v) (to_seq t) let iter_p f t = iter_p (fun (k, v) -> f k v) (to_seq t) let fold_e f t init = - fold_left_e (fun acc (k, v) -> f k v acc) init (to_seq t) + E.fold_left (fun acc (k, v) -> f k v acc) init (to_seq t) let fold_s f t init = - fold_left_s (fun acc (k, v) -> f k v acc) init (to_seq t) + S.fold_left (fun acc (k, v) -> f k v acc) init (to_seq t) let fold_es f t init = - fold_left_es (fun acc (k, v) -> f k v acc) init (to_seq t) + ES.fold_left (fun acc (k, v) -> f k v acc) init (to_seq t) let min_binding = min_binding_opt diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq.ml b/src/lib_lwt_result_stdlib/bare/structs/seq.ml index 5ec4c020f1e5..555e313f0c16 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq.ml @@ -26,92 +26,18 @@ open Monad include Stdlib.Seq -let cons item t () = Cons (item, t) +let init ~when_negative_length n f = + if n < 0 then Error when_negative_length else Ok (init n f) -let rec append ta tb () = - match ta () with Nil -> tb () | Cons (item, ta) -> Cons (item, append ta tb) +let take ~when_negative_length n s = + if n < 0 then Error when_negative_length else Ok (take n s) -let first s = match s () with Nil -> None | Cons (x, _) -> Some x +let drop ~when_negative_length n s = + if n < 0 then Error when_negative_length else Ok (drop n s) -let rec fold_left_e f acc seq = - match seq () with - | Nil -> Ok acc - | Cons (item, seq) -> - let open Result_syntax in - let* acc = f acc item in - fold_left_e f acc seq - -let rec fold_left_s f acc seq = - let open Lwt_syntax in - match seq () with - | Nil -> return acc - | Cons (item, seq) -> - let* acc = f acc item in - fold_left_s f acc seq - -let fold_left_s f acc seq = - let open Lwt_syntax in - match seq () with - | Nil -> return acc - | Cons (item, seq) -> - let* acc = lwt_apply2 f acc item in - fold_left_s f acc seq - -let rec fold_left_es f acc seq = - let open Lwt_result_syntax in - match seq () with - | Nil -> return acc - | Cons (item, seq) -> - let* acc = f acc item in - fold_left_es f acc seq - -let fold_left_es f acc seq = - let open Lwt_result_syntax in - match seq () with - | Nil -> return acc - | Cons (item, seq) -> - let* acc = lwt_apply2 f acc item in - fold_left_es f acc seq - -let rec iter_e f seq = - let open Result_syntax in - match seq () with - | Nil -> return_unit - | Cons (item, seq) -> - let* () = f item in - iter_e f seq - -let rec iter_s f seq = - let open Lwt_syntax in - match seq () with - | Nil -> return_unit - | Cons (item, seq) -> - let* () = f item in - iter_s f seq - -let iter_s f seq = - let open Lwt_syntax in - match seq () with - | Nil -> return_unit - | Cons (item, seq) -> - let* () = Lwt.apply f item in - iter_s f seq - -let rec iter_es f seq = - let open Lwt_result_syntax in - match seq () with - | Nil -> return_unit - | Cons (item, seq) -> - let* () = f item in - iter_es f seq - -let iter_es f seq = - let open Lwt_result_syntax in - match seq () with - | Nil -> return_unit - | Cons (item, seq) -> - let* () = Lwt.apply f item in - iter_es f seq +module E = Seqes.Standard.Make2 (Result) +module S = Seqes.Standard.Make1 (Lwt) +module ES = Seqes.Standard.Make2 (Lwt_result) let iter_ep f seq = let rec iter_ep f seq (acc : (unit, 'error) result Lwt.t list) = @@ -129,12 +55,40 @@ let iter_p f seq = in iter_p f seq [] -let rec unfold f a () = - match f a with None -> Nil | Some (item, a) -> Cons (item, unfold f a) - -let concat_map = flat_map +let iteri_ep f seq = + let rec iteri_ep f i seq (acc : (unit, 'error) result Lwt.t list) = + match seq () with + | Nil -> Lwt_result_syntax.join acc + | Cons (item, seq) -> iteri_ep f (i + 1) seq (lwt_apply2 f i item :: acc) + in + iteri_ep f 0 seq [] -let rec concat seq () = - match seq () with - | Nil -> Nil - | Cons (subseq, restseq) -> append subseq (concat restseq) () +let iteri_p f seq = + let rec iteri_p f i seq acc = + match seq () with + | Nil -> Lwt_syntax.join acc + | Cons (item, seq) -> iteri_p f (i + 1) seq (lwt_apply2 f i item :: acc) + in + iteri_p f 0 seq [] + +let iter2_ep f seqa seqb = + let rec iter2_ep f seqa seqb (acc : (unit, 'error) result Lwt.t list) = + let a = seqa () in + let b = seqb () in + match (a, b) with + | Nil, Nil | Nil, Cons _ | Cons _, Nil -> Lwt_result_syntax.join acc + | Cons (itema, seqa), Cons (itemb, seqb) -> + iter2_ep f seqa seqb (lwt_apply2 f itema itemb :: acc) + in + iter2_ep f seqa seqb [] + +let iter2_p f seqa seqb = + let rec iter2_p f seqa seqb acc = + let a = seqa () in + let b = seqb () in + match (a, b) with + | Nil, Nil | Nil, Cons _ | Cons _, Nil -> Lwt_syntax.join acc + | Cons (itema, seqa), Cons (itemb, seqb) -> + iter2_p f seqa seqb (lwt_apply2 f itema itemb :: acc) + in + iter2_p f seqa seqb [] diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml b/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml index f50e85bcf88c..2ba0eb5a5d12 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml @@ -29,18 +29,42 @@ open Monad here is the Result monad, we open its syntax module for the whole file (and shadow it when needed. *) open Result_syntax - -type (+'a, 'e) node = Nil | Cons of 'a * ('a, 'e) t - -and ('a, 'e) t = unit -> (('a, 'e) node, 'e) result - -let nil = Nil - -let nil_e = Ok Nil - -let empty () = Ok Nil - -let return x () = Ok (Cons (x, empty)) +include Seqes.Monadic.Make2 (Result) +module E = M + +module S = + MakeTraversors + (struct + type ('a, 'e) t = 'a Lwt.t + + let return = Lwt.return + + let bind = Lwt.bind + end) + (Lwt_result) + (struct + let bind = Lwt.bind + end) + (struct + let bind x f = + match x with Error _ as err -> Lwt.return err | Ok v -> f v + end) + +module ES = + MakeTraversors (Lwt_result) (Lwt_result) + (struct + let bind = Lwt_result.bind + end) + (struct + let bind x f = + match x with Error _ as err -> Lwt.return err | Ok v -> f v + end) + +let take ~when_negative_length k seq = + if k < 0 then Error when_negative_length else Ok (take k seq) + +let drop ~when_negative_length k seq = + if k < 0 then Error when_negative_length else Ok (drop k seq) let return_e r () = let* r in @@ -48,177 +72,16 @@ let return_e r () = let interrupted e () = Error e -let cons item t () = Ok (Cons (item, t)) - let cons_e item t () = let* item in Ok (Cons (item, t)) -let rec append ta tb () = - let* n = ta () in - match n with - | Nil -> tb () - | Cons (item, ta) -> Ok (Cons (item, append ta tb)) - -let first s = - match s () with - | Ok Nil -> None - | Ok (Cons (x, _)) -> Some (Ok x) - | Error _ as error -> Some error - -let rec fold_left f acc seq = - let* n = seq () in - match n with - | Nil -> Ok acc - | Cons (item, seq) -> fold_left f (f acc item) seq - -let rec fold_left_e f acc seq = - let* n = seq () in - match n with - | Nil -> Ok acc - | Cons (item, seq) -> - let* acc = f acc item in - fold_left_e f acc seq - -let rec fold_left_e_discriminated f acc seq = - let* n = Result.map_error Either.left @@ seq () in - match n with - | Nil -> Ok acc - | Cons (item, seq) -> - let* acc = Result.map_error Either.right @@ f acc item in - fold_left_e_discriminated f acc seq - -let rec fold_left_s f acc seq = - match seq () with - | Error _ as e -> Lwt.return e - | Ok Nil -> Lwt.return_ok acc - | Ok (Cons (item, seq)) -> - let open Lwt_syntax in - let* acc = f acc item in - fold_left_s f acc seq - -let fold_left_s f acc seq = - match seq () with - | Error _ as e -> Lwt.return e - | Ok Nil -> Lwt.return_ok acc - | Ok (Cons (item, seq)) -> - let open Lwt_syntax in - let* acc = lwt_apply2 f acc item in - fold_left_s f acc seq - -let rec fold_left_es f acc seq = - let open Lwt_result_syntax in - match seq () with - | Error _ as e -> Lwt.return e - | Ok Nil -> return acc - | Ok (Cons (item, seq)) -> - let* acc = f acc item in - fold_left_es f acc seq - -let fold_left_es f acc seq = - let open Lwt_result_syntax in - match seq () with - | Error _ as e -> Lwt.return e - | Ok Nil -> return acc - | Ok (Cons (item, seq)) -> - let* acc = lwt_apply2 f acc item in - fold_left_es f acc seq - -let rec fold_left_es_discriminated f acc seq = - let open Lwt_result_syntax in - match seq () with - | Error e -> Lwt.return_error (Either.left e) - | Ok Nil -> return acc - | Ok (Cons (item, seq)) -> - let* acc = Lwt_result.map_error Either.right @@ f acc item in - fold_left_es_discriminated f acc seq - -let fold_left_es_discriminated f acc seq = - let open Lwt_result_syntax in - match seq () with - | Error e -> Lwt.return_error (Either.Left e) - | Ok Nil -> return acc - | Ok (Cons (item, seq)) -> - let* acc = Lwt_result.map_error Either.right @@ lwt_apply2 f acc item in - fold_left_es_discriminated f acc seq - -let rec iter f seq = - let* n = seq () in - match n with - | Nil -> return_unit - | Cons (item, seq) -> - f item ; - iter f seq - -let rec iter_e f seq = - let* n = seq () in - match n with - | Nil -> return_unit - | Cons (item, seq) -> - let* () = f item in - iter_e f seq - -let rec iter_e_discriminated f seq = - let* n = Result.map_error Either.left @@ seq () in - match n with - | Nil -> return_unit - | Cons (item, seq) -> - let* () = Result.map_error Either.right @@ f item in - iter_e_discriminated f seq - -let rec iter_s f seq = - match seq () with - | Error _ as e -> Lwt.return e - | Ok Nil -> Lwt_result_syntax.return_unit - | Ok (Cons (item, seq)) -> - let open Lwt_syntax in - let* () = f item in - iter_s f seq - -let iter_s f seq = - match seq () with - | Error _ as e -> Lwt.return e - | Ok Nil -> Lwt_result_syntax.return_unit - | Ok (Cons (item, seq)) -> - let open Lwt_syntax in - let* () = Lwt.apply f item in - iter_s f seq - -let rec iter_es f seq = - let open Lwt_result_syntax in - match seq () with - | Error _ as e -> Lwt.return e - | Ok Nil -> return_unit - | Ok (Cons (item, seq)) -> - let* () = f item in - iter_es f seq - -let iter_es f seq = - let open Lwt_result_syntax in - match seq () with - | Error _ as e -> Lwt.return e - | Ok Nil -> return_unit - | Ok (Cons (item, seq)) -> - let* () = Lwt.apply f item in - iter_es f seq - -let rec iter_es_discriminated f seq = - let open Lwt_result_syntax in - match seq () with - | Error e -> Lwt.return_error (Either.Left e) - | Ok Nil -> return_unit - | Ok (Cons (item, seq)) -> - let* () = Lwt_result.map_error Either.right @@ f item in - iter_es_discriminated f seq - -let iter_es_discriminated f seq = - let open Lwt_result_syntax in +let rec map_error (f : 'e -> 'f) (seq : ('a, 'e) t) : ('a, 'f) t = + fun () -> match seq () with - | Error e -> Lwt.return_error (Either.Left e) - | Ok Nil -> return_unit - | Ok (Cons (item, seq)) -> - let* () = Lwt_result.map_error Either.right @@ Lwt.apply f item in - iter_es_discriminated f seq + | Ok Nil as n -> n + | Ok (Cons (item, seq)) -> Ok (Cons (item, map_error f seq)) + | Error e -> Error (f e) let iter_p f seq = let rec iter_p acc f seq = @@ -235,79 +98,24 @@ let iter_p f seq = in iter_p [] f seq -let rec map f seq () = - let* n = seq () in - match n with - | Nil -> nil_e - | Cons (item, seq) -> Ok (Cons (f item, map f seq)) - -let rec map_e f seq () = - let* n = seq () in - match n with - | Nil -> nil_e - | Cons (item, seq) -> - let* item = f item in - Ok (Cons (item, map_e f seq)) - -let rec map_error (f : 'e -> 'f) (seq : ('a, 'e) t) : ('a, 'f) t = - fun () -> +let rec of_seq_catch seq () = match seq () with - | Ok Nil -> nil_e - | Ok (Cons (item, seq)) -> Ok (Cons (item, map_error f seq)) - | Error e -> Error (f e) - -let rec filter f seq () = - let* n = seq () in - match n with - | Nil -> nil_e - | Cons (item, seq) -> - if f item then Ok (Cons (item, seq)) else filter f seq () + | exception e -> Error e + | Stdlib.Seq.Nil -> Ok Nil + | Stdlib.Seq.Cons (e, seq) -> Ok (Cons (e, of_seq_catch seq)) -let rec filter_e f seq () = - let* n = seq () in - match n with - | Nil -> nil_e - | Cons (item, seq) -> - let* b = f item in - if b then Ok (Cons (item, filter_e f seq)) else filter_e f seq () - -let rec filter_map f seq () = - let* n = seq () in - match n with - | Nil -> nil_e - | Cons (item, seq) -> ( - match f item with - | None -> filter_map f seq () - | Some item -> Ok (Cons (item, filter_map f seq))) - -let rec filter_map_e f seq () = - let* n = seq () in - match n with - | Nil -> nil_e - | Cons (item, seq) -> ( - let* item_o = f item in - match item_o with - | None -> filter_map_e f seq () - | Some item -> Ok (Cons (item, filter_map_e f seq))) - -let rec unfold f a () = - match f a with - | None -> nil_e - | Some (item, a) -> Ok (Cons (item, unfold f a)) - -let rec unfold_e f a () = - let* more = f a in - match more with - | None -> nil_e - | Some (item, a) -> Ok (Cons (item, unfold_e f a)) - -let rec of_seq seq () = +let rec of_seq_once ~when_forced_twice seq () = match seq () with - | Stdlib.Seq.Nil -> nil_e - | Stdlib.Seq.Cons (e, seq) -> Ok (Cons (e, of_seq seq)) + | exception Seq.Forced_twice -> Error when_forced_twice + | Stdlib.Seq.Nil -> Ok Nil + | Stdlib.Seq.Cons (e, seq) -> + Ok (Cons (e, of_seq_once ~when_forced_twice seq)) + +let of_seq_once ~when_forced_twice seq = + of_seq_once ~when_forced_twice (Seq.once seq) let rec of_seq_e seq () = match seq () with - | Stdlib.Seq.Nil -> nil_e + | Stdlib.Seq.Nil -> Ok Nil | Stdlib.Seq.Cons (Ok e, seq) -> Ok (Cons (e, of_seq_e seq)) | Stdlib.Seq.Cons ((Error _ as e), _) -> e diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq_es.ml b/src/lib_lwt_result_stdlib/bare/structs/seq_es.ml index b0cdaa250164..9112261b59e3 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq_es.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_es.ml @@ -29,379 +29,100 @@ open Monad here is the combined Lwt-Result monad, we open its syntax module for the whole file (and shadow it when needed. *) open Lwt_result_syntax - -type (+'a, 'e) node = Nil | Cons of 'a * ('a, 'e) t - -and ('a, 'e) t = unit -> (('a, 'e) node, 'e) result Lwt.t - -let protect seq () = Lwt.apply seq () - -let nil = Nil - -let nil_e = Ok Nil - -let nil_es = Lwt.return nil_e - -let empty () = nil_es - -(* we define [return] at the end of the file to avoid shadowing the opened - Lwt_result_syntax *) +include Seqes.Monadic.Make2 (Lwt_result) let return_e r () = let*? x = r in - return (Cons (x, empty)) + Lwt_result_syntax.return (Cons (x, empty)) let return_s p () = - let open Lwt_syntax in - let* x = p in - return_ok (Cons (x, empty)) + let*! x = p in + Lwt_result_syntax.return (Cons (x, empty)) let return_es p () = let* x = p in - return (Cons (x, empty)) + Lwt_result_syntax.return (Cons (x, empty)) let interrupted e () = Lwt.return (Error e) let interrupted_s p () = Lwt_syntax.( let* ) p Lwt.return_error -let cons item t () = return (Cons (item, t)) - -let cons_e item t () = - match item with - | Error _ as e -> Lwt.return e - | Ok item -> return (Cons (item, t)) - -let cons_s item t () = - let open Lwt_syntax in - let* item in - return_ok (Cons (item, t)) - -let cons_es item t () = - let* item in - return (Cons (item, t)) - -let rec append ta tb () = - let* n = ta () in - match n with - | Nil -> tb () - | Cons (item, ta) -> return (Cons (item, append ta tb)) - -let first s = - let open Lwt_syntax in - let* n_r = s () in - match n_r with - | Ok Nil -> return_none - | Ok (Cons (x, _)) -> return_some (Ok x) - | Error _ as error -> return_some error - -let rec fold_left f acc seq = - let* n = seq () in - match n with - | Nil -> return acc - | Cons (item, seq) -> fold_left f (f acc item) seq - -let fold_left f acc seq = fold_left f acc @@ protect seq - -let rec fold_left_e f acc seq = - let* n = seq () in - match n with - | Nil -> return acc - | Cons (item, seq) -> - let*? acc = f acc item in - fold_left_e f acc seq - -let fold_left_e f acc seq = fold_left_e f acc @@ protect seq - -let rec fold_left_e_discriminated f acc seq = - let* n = Lwt_result.map_error Either.left @@ seq () in - match n with - | Nil -> return acc - | Cons (item, seq) -> - let*? acc = Result.map_error Either.right @@ f acc item in - fold_left_e_discriminated f acc seq - -let fold_left_e_discriminated f acc seq = - fold_left_e_discriminated f acc @@ protect seq - -let rec fold_left_s f acc seq = - let* n = seq () in - match n with - | Nil -> return acc - | Cons (item, seq) -> - let*! acc = f acc item in - fold_left_s f acc seq - -let fold_left_s f acc seq = fold_left_s f acc @@ protect seq - -let rec fold_left_es f acc seq = - let* n = seq () in - match n with - | Nil -> return acc - | Cons (item, seq) -> - let* acc = f acc item in - fold_left_es f acc seq - -let fold_left_es f acc seq = fold_left_es f acc @@ protect seq - -let rec fold_left_es_discriminated f acc seq = - let* n = Lwt_result.map_error Either.left @@ seq () in - match n with - | Nil -> return acc - | Cons (item, seq) -> - let* acc = Lwt_result.map_error Either.right @@ f acc item in - fold_left_es_discriminated f acc seq - -let fold_left_es_discriminated f acc seq = - fold_left_es_discriminated f acc @@ protect seq - -let rec iter f seq = - let* n = seq () in - match n with - | Nil -> return_unit - | Cons (item, seq) -> - f item ; - iter f seq - -let iter f seq = iter f @@ protect seq - -let rec iter_e f seq = - let* n = seq () in - match n with - | Nil -> return_unit - | Cons (item, seq) -> - let*? () = f item in - iter_e f seq - -let iter_e f seq = iter_e f @@ protect seq - -let rec iter_e_discriminated f seq = - let* n = Lwt_result.map_error Either.left @@ seq () in - match n with - | Nil -> return_unit - | Cons (item, seq) -> - let*? () = Result.map_error Either.right @@ f item in - iter_e_discriminated f seq - -let iter_e_discriminated f seq = iter_e_discriminated f @@ protect seq - -let rec iter_s f seq = - let* n = seq () in - match n with - | Nil -> Lwt_result_syntax.return_unit - | Cons (item, seq) -> - let*! () = f item in - iter_s f seq - -let iter_s f seq = iter_s f @@ protect seq - -let rec iter_es f seq = - let* n = seq () in - match n with - | Nil -> Lwt_result_syntax.return_unit - | Cons (item, seq) -> - let* () = f item in - iter_es f seq - -let iter_es f seq = iter_es f @@ protect seq - -let rec iter_es_discriminated f seq = - let* n = Lwt_result.map_error Either.left @@ seq () in - match n with - | Nil -> Lwt_result_syntax.return_unit - | Cons (item, seq) -> - let* () = Lwt_result.map_error Either.right @@ f item in - iter_es_discriminated f seq - -let iter_es_discriminated f seq = iter_es_discriminated f @@ protect seq - -let rec map f seq () = - let* n = seq () in - match n with - | Nil -> nil_es - | Cons (item, seq) -> return (Cons (f item, map f seq)) - -let map f seq = map f @@ protect seq - -let rec map_e f seq () = - let* n = seq () in - match n with - | Nil -> nil_es - | Cons (item, seq) -> - let*? item = f item in - return (Cons (item, map_e f seq)) - -let map_e f seq = map_e f @@ protect seq - -let rec map_s f seq () = - let* n = seq () in - match n with - | Nil -> nil_es - | Cons (item, seq) -> - let*! item = f item in - return (Cons (item, map_s f seq)) - -let map_s f seq = map_s f @@ protect seq - -let rec map_es f seq () = - let* n = seq () in - match n with - | Nil -> nil_es - | Cons (item, seq) -> - let* item = f item in - return (Cons (item, map_es f seq)) - -let map_es f seq = map_es f @@ protect seq - -let rec map_error f seq () = - let open Lwt_syntax in - let* n_r = seq () in - match n_r with - | Ok Nil -> nil_es - | Ok (Cons (item, seq)) -> return_ok (Cons (item, map_error f seq)) - | Error e -> return_error (f e) - -let map_error f seq = map_error f @@ protect seq - -let rec map_error_s f seq () = - let open Lwt_syntax in - let* n_r = seq () in - match n_r with - | Ok Nil -> nil_es - | Ok (Cons (item, seq)) -> return_ok (Cons (item, map_error_s f seq)) +let rec map_error f s () = + let*! r = s () in + match r with + | Ok Nil -> Lwt_result_syntax.return Nil + | Ok (Cons (x, s)) -> Lwt_result_syntax.return (Cons (x, map_error f s)) + | Error e -> Lwt_result_syntax.fail (f e) + +let rec map_error_s f s () = + let*! r = s () in + match r with + | Ok Nil -> Lwt_result_syntax.return Nil + | Ok (Cons (x, s)) -> Lwt_result_syntax.return (Cons (x, map_error_s f s)) | Error e -> - let* e = f e in - return_error e + let*! e = f e in + Lwt_result_syntax.fail e -let rec filter f seq () = - let* n = seq () in - match n with - | Nil -> nil_es - | Cons (item, seq) -> - if f item then return (Cons (item, seq)) else filter f seq () +let take ~when_negative_length n s = + if n < 0 then Error when_negative_length else Ok (take n s) -let filter f seq = filter f @@ protect seq +let drop ~when_negative_length n s = + if n < 0 then Error when_negative_length else Ok (drop n s) -let rec filter_e f seq () = - let* n = seq () in - match n with - | Nil -> nil_es - | Cons (item, seq) -> - let*? b = f item in - if b then return (Cons (item, filter_e f seq)) else filter_e f seq () +module S = + Make + (struct + type ('a, 'e) t = 'a Lwt.t -let filter_e f seq = filter_e f @@ protect seq + let bind = Lwt.bind -let rec filter_s f seq () = - let* n = seq () in - match n with - | Nil -> nil_es - | Cons (item, seq) -> - let*! b = f item in - if b then return (Cons (item, filter_s f seq)) else filter_s f seq () + let return = Lwt.return + end) + (struct + let bind = Lwt.bind + end) -let filter_s f seq = filter_s f @@ protect seq +module E = + Make + (Result) + (struct + let bind x f = + match x with Error _ as err -> Lwt.return err | Ok x -> f x + end) -let rec filter_es f seq () = - let* n = seq () in - match n with - | Nil -> nil_es - | Cons (item, seq) -> - let* b = f item in - if b then return (Cons (item, filter_es f seq)) else filter_es f seq () - -let filter_es f seq = filter_es f @@ protect seq - -let rec filter_map f seq () = - let* n = seq () in - match n with - | Nil -> nil_es - | Cons (item, seq) -> ( - match f item with - | None -> filter_map f seq () - | Some item -> return (Cons (item, filter_map f seq))) - -let filter_map f seq = filter_map f @@ protect seq - -let rec filter_map_e f seq () = - let* n = seq () in - match n with - | Nil -> nil_es - | Cons (item, seq) -> ( - let*? o = f item in - match o with - | None -> filter_map_e f seq () - | Some item -> return (Cons (item, filter_map_e f seq))) - -let filter_map_e f seq = filter_map_e f @@ protect seq - -let rec filter_map_s f seq () = - let* n = seq () in - match n with - | Nil -> nil_es - | Cons (item, seq) -> ( - let*! o = f item in - match o with - | None -> filter_map_s f seq () - | Some item -> return (Cons (item, filter_map_s f seq))) - -let filter_map_s f seq = filter_map_s f @@ protect seq - -let rec filter_map_es f seq () = - let* n = seq () in - match n with - | Nil -> nil_es - | Cons (item, seq) -> ( - let* o = f item in - match o with - | None -> filter_map_es f seq () - | Some item -> return (Cons (item, filter_map_es f seq))) - -let filter_map_es f seq = filter_map_es f @@ protect seq - -let rec unfold f a () = - match f a with - | None -> nil_es - | Some (item, a) -> return (Cons (item, unfold f a)) - -let rec unfold_s f a () = - let open Lwt_syntax in - let* cont = f a in - match cont with - | None -> nil_es - | Some (item, a) -> return_ok (Cons (item, unfold_s f a)) +module ES = M -let rec unfold_e f a () = - match f a with +let cons_e item t () = + match item with | Error _ as e -> Lwt.return e - | Ok None -> nil_es - | Ok (Some (item, a)) -> return (Cons (item, unfold_e f a)) + | Ok item -> Lwt_result_syntax.return (Cons (item, t)) -let rec unfold_es f a () = - let* n = f a in - match n with - | None -> nil_es - | Some (item, a) -> return (Cons (item, unfold_es f a)) +let cons_s item t () = + let open Lwt_syntax in + let* item in + return_ok (Cons (item, t)) -let rec of_seq seq () = - match seq () with - | Stdlib.Seq.Nil -> nil_es - | Stdlib.Seq.Cons (e, seq) -> return (Cons (e, of_seq seq)) +let cons_es item t () = + let* item in + Lwt_result_syntax.return (Cons (item, t)) let rec of_seq_e seq () = match seq () with - | Stdlib.Seq.Nil -> nil_es - | Stdlib.Seq.Cons (Ok e, seq) -> return (Cons (e, of_seq_e seq)) + | Stdlib.Seq.Nil -> empty () + | Stdlib.Seq.Cons (Ok e, seq) -> + Lwt_result_syntax.return (Cons (e, of_seq_e seq)) | Stdlib.Seq.Cons ((Error _ as e), _) -> Lwt.return e let rec of_seqe seq () = match seq () with - | Ok Seq_e.Nil -> nil_es - | Ok (Seq_e.Cons (item, seq)) -> return (Cons (item, of_seqe seq)) + | Ok Seq_e.Nil -> empty () + | Ok (Seq_e.Cons (item, seq)) -> + Lwt_result_syntax.return (Cons (item, of_seqe seq)) | Error _ as e -> Lwt.return e let rec of_seq_s seq () = match seq () with - | Stdlib.Seq.Nil -> nil_es + | Stdlib.Seq.Nil -> empty () | Stdlib.Seq.Cons (p, seq) -> let open Lwt_syntax in let* e = p in @@ -411,14 +132,12 @@ let rec of_seqs seq () = let open Lwt_syntax in let* n = seq () in match n with - | Seq_s.Nil -> nil_es + | Seq_s.Nil -> empty () | Seq_s.Cons (e, seq) -> return_ok (Cons (e, of_seqs seq)) let rec of_seq_es seq () = match seq () with - | Stdlib.Seq.Nil -> nil_es + | Stdlib.Seq.Nil -> empty () | Stdlib.Seq.Cons (p, seq) -> let* e = p in - return (Cons (e, of_seq_es seq)) - -let return x () = return (Cons (x, empty)) + Lwt_result_syntax.return (Cons (e, of_seq_es seq)) diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq_s.ml b/src/lib_lwt_result_stdlib/bare/structs/seq_s.ml index f0ddef4cfa54..45aa1131eea2 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq_s.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_s.ml @@ -29,208 +29,85 @@ open Monad here is the Lwt monad, we open its syntax module for the whole file (and shadow it when needed. *) open Lwt_syntax +include Seqes.Monadic.Make1 (Lwt) -type +'a node = 'a Lwt_seq.node = Nil | Cons of 'a * 'a t +let take ~when_negative_length k seq = + if k < 0 then Error when_negative_length else Ok (take k seq) -and 'a t = unit -> 'a node Lwt.t +let drop ~when_negative_length k seq = + if k < 0 then Error when_negative_length else Ok (drop k seq) -let protect seq () = Lwt.apply seq () - -let nil_s = Lwt.return Nil - -let empty () = nil_s - -(* we define [return] at the end of the file to avoid shadowing the one from the - opened monad syntax *) let return_s p () = Lwt.map (fun x -> Cons (x, empty)) p -let cons item t () = Lwt.return (Cons (item, t)) - let cons_s item t () = let* item in - return (Cons (item, t)) - -let rec append ta tb () = - let* n = ta () in - match n with - | Nil -> tb () - | Cons (item, ta) -> return (Cons (item, append ta tb)) - -let first s = - let* n = s () in - match n with Nil -> return_none | Cons (x, _) -> return_some x - -let rec fold_left f acc seq = - let* n = seq () in - match n with - | Nil -> return acc - | Cons (item, seq) -> fold_left f (f acc item) seq - -let fold_left f acc seq = fold_left f acc @@ protect seq - -let rec fold_left_e f acc seq = - let* n = seq () in - match n with - | Nil -> return_ok acc - | Cons (item, seq) -> ( - match f acc item with - | Error _ as e -> Lwt.return e - | Ok acc -> fold_left_e f acc seq) - -let fold_left_e f acc seq = fold_left_e f acc @@ protect seq - -let rec fold_left_s f acc seq = - let* n = seq () in - match n with - | Nil -> return acc - | Cons (item, seq) -> - let* acc = f acc item in - fold_left_s f acc seq - -let fold_left_s f acc seq = fold_left_s f acc @@ protect seq - -let rec fold_left_es f acc seq = - let* n = seq () in - let open Lwt_result_syntax in - match n with - | Nil -> return acc - | Cons (item, seq) -> - let* acc = f acc item in - fold_left_es f acc seq - -let fold_left_es f acc seq = fold_left_es f acc @@ protect seq - -let rec iter f seq = - let* n = seq () in - match n with - | Nil -> return_unit - | Cons (item, seq) -> - f item ; - iter f seq - -let iter f seq = iter f @@ protect seq - -let rec iter_e f seq = - let* n = seq () in - let open Lwt_result_syntax in - match n with - | Nil -> return_unit - | Cons (item, seq) -> - let*? () = f item in - iter_e f seq - -let iter_e f seq = iter_e f @@ protect seq - -let rec iter_s f seq = - let* n = seq () in - match n with - | Nil -> return_unit - | Cons (item, seq) -> - let* () = f item in - iter_s f seq - -let iter_s f seq = iter_s f @@ protect seq - -let rec iter_es f seq = - let* n = seq () in - let open Lwt_result_syntax in - match n with - | Nil -> return_unit - | Cons (item, seq) -> - let* () = f item in - iter_es f seq - -let iter_es f seq = iter_es f @@ protect seq - -let iter_ep f seq = - let* ps = fold_left (fun acc item -> Lwt.apply f item :: acc) [] seq in - Lwt_result_syntax.join ps + Lwt.return (Cons (item, t)) let iter_p f seq = let* ps = fold_left (fun acc item -> Lwt.apply f item :: acc) [] seq in join ps -let rec map f seq () = - let* n = seq () in - match n with - | Nil -> nil_s - | Cons (item, seq) -> return (Cons (f item, map f seq)) - -let map f seq = map f @@ protect seq - -let rec map_s f seq () = - let* n = seq () in - match n with - | Nil -> nil_s - | Cons (item, seq) -> - let* item = f item in - return (Cons (item, map_s f seq)) - -let map_s f seq = map_s f @@ protect seq - -let rec filter f seq () = - let* n = seq () in - match n with - | Nil -> nil_s - | Cons (item, seq) -> - if f item then return (Cons (item, seq)) else filter f seq () - -let filter f seq = filter f @@ protect seq - -let rec filter_s f seq () = - let* n = seq () in - match n with - | Nil -> nil_s - | Cons (item, seq) -> - let* b = f item in - if b then return (Cons (item, filter_s f seq)) else filter_s f seq () - -let filter_s f seq = filter_s f @@ protect seq - -let rec filter_map f seq () = - let* n = seq () in - match n with - | Nil -> nil_s - | Cons (item, seq) -> ( - match f item with - | None -> filter_map f seq () - | Some item -> return (Cons (item, filter_map f seq))) - -let filter_map f seq = filter_map f @@ protect seq - -let rec filter_map_s f seq () = - let* n = seq () in - match n with - | Nil -> nil_s - | Cons (item, seq) -> ( - let* item_o = f item in - match item_o with - | None -> filter_map_s f seq () - | Some item -> return (Cons (item, filter_map_s f seq))) - -let filter_map_s f seq = filter_map_s f @@ protect seq - -let rec unfold f a () = - match f a with - | None -> nil_s - | Some (item, a) -> Lwt.return (Cons (item, unfold f a)) - -let rec unfold_s f a () = - let* cont = f a in - match cont with - | None -> nil_s - | Some (item, a) -> return (Cons (item, unfold_s f a)) +let iteri_p f seq = + let* ps = fold_lefti (fun acc i item -> lwt_apply2 f i item :: acc) [] seq in + join ps + +module E = + MakeTraversors2 + (struct + type ('a, 'e) t = ('a, 'e) Result.t + + let bind = Result.bind + + let return = Result.ok + end) + (struct + type ('a, 'e) t = ('a, 'e) Lwt_result.t + + let bind = Lwt_result.bind + + let return = Lwt_result.return + end) + (struct + let bind x f = + match x with Error _ as err -> Lwt.return err | Ok x -> f x + end) + (struct + let bind = Lwt.bind + end) + +module S = M + +module ES = + MakeTraversors2 + (struct + type ('a, 'e) t = ('a, 'e) Result.t Lwt.t + + let bind = Lwt_result.bind + + let return = Lwt_result.return + end) + (struct + type ('a, 'e) t = ('a, 'e) Lwt_result.t + + let bind = Lwt_result.bind + + let return = Lwt_result.return + end) + (struct + let bind = Lwt_result.bind + end) + (struct + let bind = Lwt.bind + end) let rec of_seq seq () = match seq () with - | Stdlib.Seq.Nil -> nil_s - | Stdlib.Seq.Cons (e, seq) -> return (Cons (e, of_seq seq)) + | Stdlib.Seq.Nil -> empty () + | Stdlib.Seq.Cons (e, seq) -> Lwt.return (Cons (e, of_seq seq)) let rec of_seq_s seq () = match seq () with - | Stdlib.Seq.Nil -> nil_s + | Stdlib.Seq.Nil -> empty () | Stdlib.Seq.Cons (p, seq) -> let* e = p in - return (Cons (e, of_seq_s seq)) - -let return x () = Lwt.return (Cons (x, empty)) + Lwt.return (Cons (e, of_seq_s seq)) diff --git a/src/lib_lwt_result_stdlib/bare/structs/set.ml b/src/lib_lwt_result_stdlib/bare/structs/set.ml index 31ab24362a4f..146a14d51d9f 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/set.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/set.ml @@ -29,21 +29,21 @@ module Make (Ord : Stdlib.Map.OrderedType) : S with type elt = Ord.t = struct open Seq include Stdlib.Set.Make (Ord) - let iter_e f t = iter_e f (to_seq t) + let iter_e f t = E.iter f (to_seq t) - let iter_s f t = iter_s f (to_seq t) + let iter_s f t = S.iter f (to_seq t) let iter_p f t = iter_p f (to_seq t) - let iter_es f t = iter_es f (to_seq t) + let iter_es f t = ES.iter f (to_seq t) let iter_ep f t = iter_ep f (to_seq t) - let fold_e f t init = fold_left_e (fun acc e -> f e acc) init (to_seq t) + let fold_e f t init = E.fold_left (fun acc e -> f e acc) init (to_seq t) - let fold_s f t init = fold_left_s (fun acc e -> f e acc) init (to_seq t) + let fold_s f t init = S.fold_left (fun acc e -> f e acc) init (to_seq t) - let fold_es f t init = fold_left_es (fun acc e -> f e acc) init (to_seq t) + let fold_es f t init = ES.fold_left (fun acc e -> f e acc) init (to_seq t) let min_elt = min_elt_opt diff --git a/src/lib_lwt_result_stdlib/lwtreslib.mli b/src/lib_lwt_result_stdlib/lwtreslib.mli index e6477304f7d2..8a288ec5a869 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.mli +++ b/src/lib_lwt_result_stdlib/lwtreslib.mli @@ -80,7 +80,9 @@ Functions with the [_s] suffix traverse their underlying collection sequentially, waiting for the promise associated to one element to resolve - before processing to the next element. + before processing to the next element. Note that for the [Seq*] modules (see + below) the sequential traversors are bundled under an [S] submodules rather + than suffixed with [_s]. Functions with the [_p] suffix traverse their underlying collection concurrently, creating promises for all the elements and then waiting for @@ -100,8 +102,10 @@ Functions with the [_e] suffix traverse their underlying collection whilst wrapping the accumulator/result in a [result]. These functions have a - fail-early semantic: if one of the step returns an [Error _], then the whole - traversal is interrupted and returns the same [Error _]. + fail-early semantic: if one of the steps returns an [Error _], then the whole + traversal is interrupted and returns the same [Error _]. Note that for the + [Seq*] modules (see below) the result-aware traversors are bundled under an + [E] submodules rather than suffixed with [_e]. {3 Semantic of Lwt-result-aware functions} @@ -114,7 +118,9 @@ a [result] (like [_e] functions). These functions have a fail-early semantic: if one of the step returns a promise that resolves to an [Error _], then the whole traversal is interrupted and the returned promise - resolves to the same [Error _]. + resolves to the same [Error _]. Note that for the [Seq*] modules (see below) + the Lwt-result-aware traversors are bundled under an [ES] submodules rather + than suffixed with [_es]. Functions with the [_ep] suffix traverse their underlying collection concurrently (like [_p] functions) whilst wrapping the accumulator/result in @@ -134,15 +140,20 @@ the returned promise forces the whole sequence (and never resolves on infinite sequences). - In Lwtreslib, [Seq] does not provide these additional traversors that would + In Lwtreslib, [Seq] does not provide these additional transformers that would force the sequence simply due to the bad interaction of the Monads and the - type of sequences. Instead, Lwtreslib provides variants of [Seq] called - [Seq_e], [Seq_s], and [Seq_es] where the combination with the monad is baked - into the sequence type itself. + type of sequences. Instead, Lwtreslib provides + + - A subset of traversors where the laziness and the monad mix well (e.g., + [iter] but not [map]). These are exported under the modules [S], [E] and + [ES]. + + - Variants of [Seq] called [Seq_e], [Seq_s], and [Seq_es] where the + combination with the monad is baked into the sequence type itself. If you want to map a sequnence using an Lwt-returning function, you should first convert the sequence to an Lwt-aware sequence using [Seq_s.of_seq], - and then map this converted function using [Seq_s.map_s]. + and then map this converted function using [Seq_s.S.map]. Note that this returns a [Seq_s.t] sequence so further transformations will be within [Seq_s] and not within [Seq]. Once in a monad, you stay in the monad. diff --git a/src/lib_lwt_result_stdlib/test/dune b/src/lib_lwt_result_stdlib/test/dune index e157486abf08..ed3cd25aaa74 100644 --- a/src/lib_lwt_result_stdlib/test/dune +++ b/src/lib_lwt_result_stdlib/test/dune @@ -27,10 +27,7 @@ test_list_basic test_list_basic_lwt test_seq_basic - test_fuzzing_helpers test_fuzzing_lib - test_fuzzing_seq_tiered - test_fuzzing_seq_against_stdlib test_fuzzing_list_against_stdlib test_fuzzing_option_against_stdlib test_fuzzing_set_against_stdlib diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml deleted file mode 100644 index 18d289b3b575..000000000000 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml +++ /dev/null @@ -1,205 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open QCheck2.Gen -open Support.Lib.Monad -open Qcheck2_helpers - -(* Generators *) - -(* Function generators *) - -module Fn = struct - let arith = - let open QCheck2 in - fun2 Observable.int Observable.int int -end - -(* Wrappers for generated functions *) - -(* immediate wrappers *) - -module IterOf = struct - let fn r fn y = r := fn !r y -end - -module IteriOf = struct - let fn r fn i y = r := fn !r (fn i y) -end - -(* error-aware wrappers *) - -module IterEOf = struct - open Result_syntax - - let fn r fn y = - r := fn !r y ; - return_unit - - let fn_e r fn y = - let* t = fn !r y in - r := t ; - return_unit -end - -module IteriEOf = struct - open Result_syntax - - let fn r fn i y = - r := fn !r (fn i y) ; - return_unit - - let fn_e r fn i y = - let* z = fn i y in - let* t = fn !r z in - r := t ; - return_unit -end - -(* lwt-aware wrappers *) - -module IterSOf = struct - open Lwt_syntax - - let fn r fn y = - r := fn !r y ; - return_unit - - let monotonous r fn const y = - r := !r + fn const y ; - return_unit - - let fn_s r fn y = - let* t = fn !r y in - r := t ; - return_unit -end - -module IteriSOf = struct - open Lwt_syntax - - let fn r fn i y = - r := fn !r (fn i y) ; - return_unit - - let fn_s r fn i y = - let* z = fn i y in - let* t = fn !r z in - r := t ; - return_unit -end - -(* error-lwt-aware wrappers *) - -module IterESOf = struct - open Lwt_result_syntax - - let fn r fn y = - r := fn !r y ; - return_unit - - let monotonous r fn const y = - r := !r + fn const y ; - return_unit - - let fn_e r fn y = - let* t = Lwt.return @@ fn !r y in - r := t ; - return_unit - - let fn_s r fn y = - let*! t = fn !r y in - r := t ; - return_unit - - let fn_es r fn y = - let* t = fn !r y in - r := t ; - return_unit -end - -module IteriESOf = struct - open Lwt_result_syntax - - let fn r fn i y = - r := fn !r (fn i y) ; - return_unit - - let fn_e r fn i y = - let* z = Lwt.return @@ fn i y in - let* t = Lwt.return @@ fn !r z in - r := t ; - return_unit - - let fn_s r fn i y = - let*! z = fn i y in - let*! t = fn !r z in - r := t ; - return_unit - - let fn_es r fn i y = - let* z = fn i y in - let* t = fn !r z in - r := t ; - return_unit -end - -(* Data generators (we use lists of integers) *) - -let one = int - -let many = list int - -(* equality and lwt/error variants *) - -let eq ?pp a b = qcheck_eq ?pp a b - -let eq_s ?pp a b = - Lwt_main.run - (let open Lwt_syntax in - let+ a and+ b in - eq ?pp a b) - -(** [eq_es] is a duplicate of {!eq_s} for consistency - - example: - {[ - eq_s - Lwt_syntax.( - let acc = ref init in - let+ () = M.iter_s (IterSOf.fn_s acc fn) input in - !acc) - (M.fold_left_s (FoldSOf.fn_s fn) init input) - - eq_es - Lwt_result_syntax.( - let acc = ref init in - let+ () = M.iter_es (IterESOf.fn acc fn) (M.of_list input) in - !acc) - (Lwt.return_ok @@ with_stdlib_iter (fn, init, input)) - ]} -*) -let eq_es ?pp (a : ('a, 'b) result Lwt.t) (b : ('a, 'b) result Lwt.t) = - eq_s ?pp a b diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_against_stdlib.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_against_stdlib.ml deleted file mode 100644 index 19017050b919..000000000000 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_against_stdlib.ml +++ /dev/null @@ -1,132 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Test_fuzzing_lib - -let fold_left = - test_of_ty - "Seq.fold_left" - DSL.([[data; data] @-> monad data; data; seq data] --> monad data) - Stdlib.Seq.fold_left - Support.Lib.Seq.fold_left - Support.Lib.Seq.fold_left_s - Support.Lib.Seq.fold_left_e - Support.Lib.Seq.fold_left_es - -(* NOTE: The testing framework ([Test_fuzzing_lib]) is focused on testing the - return values of a set of functions. [iter] (and friends) always return [()] - (modulo the monad). As a result, in a simple test, all calls would be - equivalent and the simple test would not mean anything. Instead we implement - [fold_left] on top of [iter] and test this. *) -let iter = - test_of_ty_with_p - "Seq.iter" - DSL.([data; [data; data] @-> monad data; seq data] --> monad data) - (fun init f xs -> - let acc = ref init in - let () = - Stdlib.Seq.iter - (fun x -> - let y = f !acc x in - acc := y ; - ()) - xs - in - !acc) - (fun init f xs -> - let acc = ref init in - let () = - Support.Lib.Seq.iter - (fun x -> - let y = f !acc x in - acc := y ; - ()) - xs - in - !acc) - (fun init f xs -> - let open Support.Lib.Monad.Lwt_syntax in - let acc = ref init in - let* () = - Support.Lib.Seq.iter_s - (fun x -> - let* y = f !acc x in - acc := y ; - return ()) - xs - in - return !acc) - (fun init f xs -> - let open Support.Lib.Monad.Lwt_syntax in - let acc = ref init in - let* () = - Support.Lib.Seq.iter_p - (fun x -> - let* y = f !acc x in - acc := y ; - return ()) - xs - in - return !acc) - (fun init f xs -> - let open Support.Lib.Monad.Result_syntax in - let acc = ref init in - let* () = - Support.Lib.Seq.iter_e - (fun x -> - let* y = f !acc x in - acc := y ; - return ()) - xs - in - return !acc) - (fun init f xs -> - let open Support.Lib.Monad.Lwt_result_syntax in - let acc = ref init in - let* () = - Support.Lib.Seq.iter_es - (fun x -> - let* y = f !acc x in - acc := y ; - return ()) - xs - in - return !acc) - (fun init f xs -> - let open Support.Lib.Monad.Lwt_result_syntax in - let acc = ref init in - let* () = - Support.Lib.Seq.iter_ep - (fun x -> - let* y = f !acc x in - acc := y ; - return ()) - xs - in - return !acc) - -let all_seq : unit Alcotest.test_case list = [fold_left; iter] - -let () = Alcotest.run "FuzzRef" [("Seq", all_seq)] diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_tiered.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_tiered.ml deleted file mode 100644 index e403e3804033..000000000000 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_tiered.ml +++ /dev/null @@ -1,244 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Support.Lib -open Test_fuzzing_helpers - -module type TIER = sig - val suffix : string - - type t - - val of_seq : int Seq.t -> t - - val iter : (int -> unit) -> t -> (unit, int) result Lwt.t - - val iter_s : (int -> unit Lwt.t) -> t -> (unit, int) result Lwt.t - - val iter_e : (int -> (unit, int) result) -> t -> (unit, int) result Lwt.t - - val iter_es : - (int -> (unit, int) result Lwt.t) -> t -> (unit, int) result Lwt.t -end - -module TieredSeq : TIER with type t = int Seq.t = struct - let suffix = "XXX" - - include Seq - - type nonrec t = int t - - let of_seq s = s - - open Monad - - let iter f s = - iter f s ; - Lwt_result_syntax.return_unit - - let iter_s f s = Lwt_result.ok @@ iter_s f s - - let iter_e f s = Lwt.return @@ iter_e f s - - let iter_es f s = iter_es f s -end - -module TestIter (Tier : TIER) = struct - open QCheck2 - open Monad - - let test_iter = - Test.make - ~name:(Format.asprintf "Seq{,_%s}.iter" Tier.suffix) - (Gen.triple Test_fuzzing_helpers.Fn.arith one many) - (fun (Fun (_, fn), init, input) -> - let open Lwt_result_syntax in - eq_es - (let acc = ref init in - let* () = TieredSeq.iter (IterOf.fn acc fn) (List.to_seq input) in - return !acc) - (let acc = ref init in - let* () = - Tier.iter (IterOf.fn acc fn) (Tier.of_seq @@ List.to_seq input) - in - return !acc)) - - let test_iter_e = - Test.make - ~name:(Format.asprintf "Seq{,%s}.iter_e" Tier.suffix) - (Gen.triple Test_fuzzing_helpers.Fn.arith one many) - (fun (Fun (_, fn), init, input) -> - let open Lwt_result_syntax in - eq_es - (let acc = ref init in - let* () = TieredSeq.iter_e (IterEOf.fn acc fn) (List.to_seq input) in - return !acc) - (let acc = ref init in - let* () = - Tier.iter_e (IterEOf.fn acc fn) (Tier.of_seq @@ List.to_seq input) - in - return !acc)) - - let test_iter_s = - Test.make - ~name:(Format.asprintf "Seq{,%s}.iter_s" Tier.suffix) - (Gen.triple Test_fuzzing_helpers.Fn.arith one many) - (fun (Fun (_, fn), init, input) -> - let open Lwt_result_syntax in - eq_es - (let acc = ref init in - let* () = TieredSeq.iter_s (IterSOf.fn acc fn) (List.to_seq input) in - return !acc) - (let acc = ref init in - let* () = - Tier.iter_s (IterSOf.fn acc fn) (Tier.of_seq @@ List.to_seq input) - in - return !acc)) - - let test_iter_es = - Test.make - ~name:(Format.asprintf "Seq{,%s}.iter_es" Tier.suffix) - (Gen.triple Test_fuzzing_helpers.Fn.arith one many) - (fun (Fun (_, fn), init, input) -> - let open Lwt_result_syntax in - eq_es - (let acc = ref init in - let* () = - TieredSeq.iter_es (IterESOf.fn acc fn) (List.to_seq input) - in - return !acc) - (let acc = ref init in - let* () = - Tier.iter_es (IterESOf.fn acc fn) (Tier.of_seq @@ List.to_seq input) - in - return !acc)) - - let tests = [test_iter; test_iter_e; test_iter_s; test_iter_es] -end - -module TieredSeq_s : TIER with type t = int Seq_s.t = struct - let suffix = "s" - - include Seq_s - - type nonrec t = int t - - let iter f s = Lwt_result.ok @@ iter f s - - let iter_s f s = Lwt_result.ok @@ iter_s f s -end - -module TestedSeq_s = TestIter (TieredSeq_s) - -module TieredSeq_e : TIER with type t = (int, int) Seq_e.t = struct - let suffix = "e" - - include Seq_e - - type nonrec t = (int, int) t - - let iter f s = Lwt.return @@ iter f s - - let iter_e f s = Lwt.return @@ iter_e f s -end - -module TestedSeq_e = TestIter (TieredSeq_e) - -module TieredSeq_es : TIER with type t = (int, int) Seq_es.t = struct - let suffix = "es" - - include Seq_es - - type nonrec t = (int, int) t -end - -module TestedSeq_es = TestIter (TieredSeq_es) - -(* testing iter_ep is equivalent in two separate tiers - NOTE: only for [Seq_s] *) -let iter_ep = - let open QCheck2 in - Test.make - ~name:(Format.asprintf "Seq{,_s}.iter_ep") - (Gen.quad Test_fuzzing_helpers.Fn.arith one one many) - (fun (Fun (_, fn), const, init, input) -> - let open Monad.Lwt_result_syntax in - eq_es - (let acc = ref init in - let* () = - Seq.iter_ep (IterESOf.monotonous acc fn const) (List.to_seq input) - in - return !acc) - (let acc = ref init in - let* () = - Seq_s.iter_ep - (IterESOf.monotonous acc fn const) - (Seq_s.of_seq @@ List.to_seq input) - in - return !acc)) - -let iter_p = - let open QCheck2 in - Test.make - ~name:(Format.asprintf "Seq{,_s}.iter_p") - (Gen.quad Test_fuzzing_helpers.Fn.arith one one many) - (fun (Fun (_, fn), const, init, input) -> - let open Monad.Lwt_syntax in - eq_es - (let acc = ref init in - let* () = - Seq.iter_p (IterSOf.monotonous acc fn const) (List.to_seq input) - in - return_ok !acc) - (let acc = ref init in - let* () = - Seq_s.iter_p - (IterSOf.monotonous acc fn const) - (Seq_s.of_seq @@ List.to_seq input) - in - return_ok !acc)) - -let wrap (name, (module Tier : TIER)) = - let module M = TestIter (Tier) in - (name, Qcheck2_helpers.qcheck_wrap M.tests) - -let () = - let name = "Test_fuzzing_seq_tiered" in - let tests = - [ - ("TestedSeq_s", (module TieredSeq_s : TIER)); - ("TestedSeq_e", (module TieredSeq_e : TIER)); - ("TestedSeq_es", (module TieredSeq_es : TIER)); - ] - in - let tests = List.map wrap tests in - let tests = - tests - @ [ - ("iter_p", Qcheck2_helpers.qcheck_wrap [iter_p]); - ("iter_ep", Qcheck2_helpers.qcheck_wrap [iter_ep]); - ] - in - Alcotest.run name tests diff --git a/src/lib_lwt_result_stdlib/test/test_seq_basic.ml b/src/lib_lwt_result_stdlib/test/test_seq_basic.ml index e89df76b5f91..63ad8d4f49c1 100644 --- a/src/lib_lwt_result_stdlib/test/test_seq_basic.ml +++ b/src/lib_lwt_result_stdlib/test/test_seq_basic.ml @@ -25,46 +25,217 @@ let ( >>== ) p v = Lwt_main.run (Lwt.map (( = ) v) p) -let () = +let vanilla () = let open Support.Lib.Seq in - assert (first empty = None) ; - assert (first (return 0) = Some 0) ; - assert (first (cons 0 empty) = Some 0) ; - assert (first (append empty empty) = None) ; assert (List.of_seq empty = []) ; assert (List.of_seq (return 0) = [0]) ; assert (List.of_seq (cons 0 empty) = [0]) ; - assert (List.of_seq (append empty empty) = []) + assert (List.of_seq (append empty empty) = []) ; + let onetwothree = List.to_seq [1; 2; 3] in + assert ( + List.of_seq @@ Result.get_ok (drop ~when_negative_length:() 0 empty) = []) ; + assert ( + List.of_seq @@ Result.get_ok (drop ~when_negative_length:() 0 onetwothree) + = [1; 2; 3]) ; + assert ( + List.of_seq @@ Result.get_ok (drop ~when_negative_length:() 1 onetwothree) + = [2; 3]) ; + assert ( + List.of_seq @@ Result.get_ok (drop ~when_negative_length:() 2 onetwothree) + = [3]) ; + assert ( + List.of_seq @@ Result.get_ok (drop ~when_negative_length:() 3 onetwothree) + = []) ; + assert ( + List.of_seq @@ Result.get_ok (drop ~when_negative_length:() 4 onetwothree) + = []) ; + assert (drop ~when_negative_length:() (-1) onetwothree = Error ()) ; + assert (List.of_seq (drop_while (fun _ -> false) empty) = []) ; + assert (List.of_seq (drop_while (fun _ -> false) onetwothree) = [1; 2; 3]) ; + assert (List.of_seq (drop_while (fun _ -> true) onetwothree) = []) ; + assert (List.of_seq (drop_while (fun x -> x <= 1) onetwothree) = [2; 3]) ; + assert (List.of_seq (drop_while (fun x -> x <= 2) onetwothree) = [3]) ; + assert ( + List.of_seq @@ Result.get_ok (take ~when_negative_length:() 1 empty) = []) ; + assert ( + List.of_seq @@ Result.get_ok (take ~when_negative_length:() 0 onetwothree) + = []) ; + assert ( + List.of_seq @@ Result.get_ok (take ~when_negative_length:() 1 onetwothree) + = [1]) ; + assert ( + List.of_seq @@ Result.get_ok (take ~when_negative_length:() 2 onetwothree) + = [1; 2]) ; + assert ( + List.of_seq @@ Result.get_ok (take ~when_negative_length:() 3 onetwothree) + = [1; 2; 3]) ; + assert ( + List.of_seq @@ Result.get_ok (take ~when_negative_length:() 4 onetwothree) + = [1; 2; 3]) ; + assert (List.of_seq (take_while (fun _ -> true) empty) = []) ; + assert (List.of_seq (take_while (fun _ -> true) onetwothree) = [1; 2; 3]) ; + assert (List.of_seq (take_while (fun _ -> false) onetwothree) = []) ; + assert (List.of_seq (take_while (fun x -> x <= 1) onetwothree) = [1]) ; + assert (List.of_seq (take_while (fun x -> x <= 2) onetwothree) = [1; 2]) ; + () -let () = +let seq_e () = let open Support.Lib.Seq_e in - assert (first empty = None) ; - assert (first (return 0) = Some (Ok 0)) ; - assert (first (return_e (Ok 0)) = Some (Ok 0)) ; - assert (first (return_e (Error ())) = Some (Error ())) ; - assert (first (interrupted ()) = Some (Error ())) ; - assert (first (cons 0 empty) = Some (Ok 0)) ; - assert (first (cons_e (Ok 0) empty) = Some (Ok 0)) ; - assert (first (cons_e (Error ()) empty) = Some (Error ())) ; - assert (first (cons_e (Ok 0) (interrupted ())) = Some (Ok 0)) ; - assert (first (append empty empty) = None) + let to_list se = + List.rev @@ Result.get_ok @@ fold_left (fun xs x -> x :: xs) [] se + in + let onetwothree = of_seq @@ List.to_seq [1; 2; 3] in + assert (to_list @@ Result.get_ok (drop ~when_negative_length:() 0 empty) = []) ; + assert ( + to_list @@ Result.get_ok (drop ~when_negative_length:() 0 onetwothree) + = [1; 2; 3]) ; + assert ( + to_list @@ Result.get_ok (drop ~when_negative_length:() 1 onetwothree) + = [2; 3]) ; + assert ( + to_list @@ Result.get_ok (drop ~when_negative_length:() 2 onetwothree) = [3]) ; + assert ( + to_list @@ Result.get_ok (drop ~when_negative_length:() 3 onetwothree) = []) ; + assert ( + to_list @@ Result.get_ok (drop ~when_negative_length:() 4 onetwothree) = []) ; + assert (to_list (drop_while (fun _ -> false) empty) = []) ; + assert (to_list (drop_while (fun _ -> false) onetwothree) = [1; 2; 3]) ; + assert (to_list (drop_while (fun _ -> true) onetwothree) = []) ; + assert (to_list (drop_while (fun x -> x <= 1) onetwothree) = [2; 3]) ; + assert (to_list (drop_while (fun x -> x <= 2) onetwothree) = [3]) ; + assert (to_list @@ Result.get_ok (take ~when_negative_length:() 1 empty) = []) ; + assert ( + to_list @@ Result.get_ok (take ~when_negative_length:() 0 onetwothree) = []) ; + assert ( + to_list @@ Result.get_ok (take ~when_negative_length:() 1 onetwothree) = [1]) ; + assert ( + to_list @@ Result.get_ok (take ~when_negative_length:() 2 onetwothree) + = [1; 2]) ; + assert ( + to_list @@ Result.get_ok (take ~when_negative_length:() 3 onetwothree) + = [1; 2; 3]) ; + assert ( + to_list @@ Result.get_ok (take ~when_negative_length:() 4 onetwothree) + = [1; 2; 3]) ; + assert (to_list (take_while (fun _ -> true) empty) = []) ; + assert (to_list (take_while (fun _ -> true) onetwothree) = [1; 2; 3]) ; + assert (to_list (take_while (fun _ -> false) onetwothree) = []) ; + assert (to_list (take_while (fun x -> x <= 1) onetwothree) = [1]) ; + assert (to_list (take_while (fun x -> x <= 2) onetwothree) = [1; 2]) ; + () -let () = +let seq_s () = let open Support.Lib.Seq_s in - assert (first empty >>== None) ; - assert (first (return 0) >>== Some 0) ; - assert (first (cons 0 empty) >>== Some 0) ; - assert (first (append empty empty) >>== None) + let to_list se = Lwt.map List.rev @@ fold_left (fun xs x -> x :: xs) [] se in + let onetwothree = of_seq @@ List.to_seq [1; 2; 3] in + assert ( + to_list @@ Result.get_ok (drop ~when_negative_length:() 0 empty) >>== []) ; + assert ( + to_list @@ Result.get_ok (drop ~when_negative_length:() 0 onetwothree) + >>== [1; 2; 3]) ; + assert ( + to_list @@ Result.get_ok (drop ~when_negative_length:() 1 onetwothree) + >>== [2; 3]) ; + assert ( + to_list @@ Result.get_ok (drop ~when_negative_length:() 2 onetwothree) + >>== [3]) ; + assert ( + to_list @@ Result.get_ok (drop ~when_negative_length:() 3 onetwothree) + >>== []) ; + assert ( + to_list @@ Result.get_ok (drop ~when_negative_length:() 4 onetwothree) + >>== []) ; + assert (to_list (drop_while (fun _ -> false) empty) >>== []) ; + assert (to_list (drop_while (fun _ -> false) onetwothree) >>== [1; 2; 3]) ; + assert (to_list (drop_while (fun _ -> true) onetwothree) >>== []) ; + assert (to_list (drop_while (fun x -> x <= 1) onetwothree) >>== [2; 3]) ; + assert (to_list (drop_while (fun x -> x <= 2) onetwothree) >>== [3]) ; + assert ( + to_list @@ Result.get_ok (take ~when_negative_length:() 1 empty) >>== []) ; + assert ( + to_list @@ Result.get_ok (take ~when_negative_length:() 0 onetwothree) + >>== []) ; + assert ( + to_list @@ Result.get_ok (take ~when_negative_length:() 1 onetwothree) + >>== [1]) ; + assert ( + to_list @@ Result.get_ok (take ~when_negative_length:() 2 onetwothree) + >>== [1; 2]) ; + assert ( + to_list @@ Result.get_ok (take ~when_negative_length:() 3 onetwothree) + >>== [1; 2; 3]) ; + assert ( + to_list @@ Result.get_ok (take ~when_negative_length:() 4 onetwothree) + >>== [1; 2; 3]) ; + assert (to_list (take_while (fun _ -> true) empty) >>== []) ; + assert (to_list (take_while (fun _ -> true) onetwothree) >>== [1; 2; 3]) ; + assert (to_list (take_while (fun _ -> false) onetwothree) >>== []) ; + assert (to_list (take_while (fun x -> x <= 1) onetwothree) >>== [1]) ; + assert (to_list (take_while (fun x -> x <= 2) onetwothree) >>== [1; 2]) ; + () -let () = +let seq_es () = let open Support.Lib.Seq_es in - assert (first empty >>== None) ; - assert (first (return 0) >>== Some (Ok 0)) ; - assert (first (return_e (Ok 0)) >>== Some (Ok 0)) ; - assert (first (return_e (Error ())) >>== Some (Error ())) ; - assert (first (interrupted ()) >>== Some (Error ())) ; - assert (first (cons 0 empty) >>== Some (Ok 0)) ; - assert (first (cons_e (Ok 0) empty) >>== Some (Ok 0)) ; - assert (first (cons_e (Error ()) empty) >>== Some (Error ())) ; - assert (first (cons_e (Ok 0) (interrupted ())) >>== Some (Ok 0)) ; - assert (first (append empty empty) >>== None) + let to_list se = + Lwt.map List.rev @@ Lwt.map Result.get_ok + @@ fold_left (fun xs x -> x :: xs) [] se + in + let onetwothree = of_seq @@ List.to_seq [1; 2; 3] in + assert ( + to_list @@ Result.get_ok (drop ~when_negative_length:() 0 empty) >>== []) ; + assert ( + to_list @@ Result.get_ok (drop ~when_negative_length:() 0 onetwothree) + >>== [1; 2; 3]) ; + assert ( + to_list @@ Result.get_ok (drop ~when_negative_length:() 1 onetwothree) + >>== [2; 3]) ; + assert ( + to_list @@ Result.get_ok (drop ~when_negative_length:() 2 onetwothree) + >>== [3]) ; + assert ( + to_list @@ Result.get_ok (drop ~when_negative_length:() 3 onetwothree) + >>== []) ; + assert ( + to_list @@ Result.get_ok (drop ~when_negative_length:() 4 onetwothree) + >>== []) ; + assert (to_list (drop_while (fun _ -> false) empty) >>== []) ; + assert (to_list (drop_while (fun _ -> false) onetwothree) >>== [1; 2; 3]) ; + assert (to_list (drop_while (fun _ -> true) onetwothree) >>== []) ; + assert (to_list (drop_while (fun x -> x <= 1) onetwothree) >>== [2; 3]) ; + assert (to_list (drop_while (fun x -> x <= 2) onetwothree) >>== [3]) ; + assert ( + to_list @@ Result.get_ok (take ~when_negative_length:() 1 empty) >>== []) ; + assert ( + to_list @@ Result.get_ok (take ~when_negative_length:() 0 onetwothree) + >>== []) ; + assert ( + to_list @@ Result.get_ok (take ~when_negative_length:() 1 onetwothree) + >>== [1]) ; + assert ( + to_list @@ Result.get_ok (take ~when_negative_length:() 2 onetwothree) + >>== [1; 2]) ; + assert ( + to_list @@ Result.get_ok (take ~when_negative_length:() 3 onetwothree) + >>== [1; 2; 3]) ; + assert ( + to_list @@ Result.get_ok (take ~when_negative_length:() 4 onetwothree) + >>== [1; 2; 3]) ; + assert (to_list (take_while (fun _ -> true) empty) >>== []) ; + assert (to_list (take_while (fun _ -> true) onetwothree) >>== [1; 2; 3]) ; + assert (to_list (take_while (fun _ -> false) onetwothree) >>== []) ; + assert (to_list (take_while (fun x -> x <= 1) onetwothree) >>== [1]) ; + assert (to_list (take_while (fun x -> x <= 2) onetwothree) >>== [1; 2]) ; + () + +let () = + Alcotest.run + "seq" + [ + ( "basic", + [ + Alcotest.test_case "vanilla" `Quick vanilla; + Alcotest.test_case "seq_e" `Quick seq_e; + Alcotest.test_case "seq_s" `Quick seq_s; + Alcotest.test_case "seq_es" `Quick seq_es; + ] ); + ] diff --git a/src/lib_lwt_result_stdlib/traced/sigs/seq.ml b/src/lib_lwt_result_stdlib/traced/sigs/seq.ml index 049a5c5250ee..9ba569174db7 100644 --- a/src/lib_lwt_result_stdlib/traced/sigs/seq.ml +++ b/src/lib_lwt_result_stdlib/traced/sigs/seq.ml @@ -48,4 +48,35 @@ module type S = sig ('a -> (unit, 'error trace) result Lwt.t) -> 'a t -> (unit, 'error trace) result Lwt.t + + (** Similar to {!iteri} but wraps the iteration in [result Lwt.t]. All the + steps of the iteration are started concurrently. The promise [iteri_ep] + resolves once all the promises of the traversal resolve. At this point it + either: + - is rejected if at least one of the promises is, otherwise + - is fulfilled with [Error _] if at least one of the promises is, + otherwise + - is fulfilled with [Ok ()] if all the promises are. *) + val iteri_ep : + (int -> 'a -> (unit, 'error trace) result Lwt.t) -> + 'a t -> + (unit, 'error trace) result Lwt.t + + (** Similar to {!iter2} but wraps the iteration in [result Lwt.t]. All the + steps of the iteration are started concurrently. The promise [iter2_ep] + resolves once all the promises of the traversal resolve. At this point it + either: + - is rejected if at least one of the promises is, otherwise + - is fulfilled with [Error _] if at least one of the promises is, + otherwise + - is fulfilled with [Ok ()] if all the promises are. + + Following the behaviour of the Stdlib, the two-sequence traversors stop as + soon as one of the two sequences ends: the suffix of the longer sequence + is ignored. *) + val iter2_ep : + ('a -> 'b -> (unit, 'error trace) result Lwt.t) -> + 'a t -> + 'b t -> + (unit, 'error trace) result Lwt.t end diff --git a/src/lib_lwt_result_stdlib/traced/structs/seq.ml b/src/lib_lwt_result_stdlib/traced/structs/seq.ml index 1d3afe6e8155..3386920f860a 100644 --- a/src/lib_lwt_result_stdlib/traced/structs/seq.ml +++ b/src/lib_lwt_result_stdlib/traced/structs/seq.ml @@ -34,4 +34,29 @@ module Make (Monad : Traced_sigs.Monad.S) : | Cons (item, seq) -> iter_ep f seq (Lwt.apply f item :: acc) in iter_ep f seq [] + + let iteri_ep f seq = + let rec iteri_ep f i seq (acc : (unit, 'error) result Lwt.t list) = + match seq () with + | Nil -> Monad.Lwt_traced_result_syntax.join acc + | Cons (item, seq) -> + iteri_ep f (i + 1) seq (Bare_structs.Monad.lwt_apply2 f i item :: acc) + in + iteri_ep f 0 seq [] + + let iter2_ep f seqa seqb = + let rec iter2_ep f seqa seqb (acc : (unit, 'error) result Lwt.t list) = + let a = seqa () in + let b = seqb () in + match (a, b) with + | Nil, Nil | Nil, Cons _ | Cons _, Nil -> + Monad.Lwt_traced_result_syntax.join acc + | Cons (itema, seqa), Cons (itemb, seqb) -> + iter2_ep + f + seqa + seqb + (Bare_structs.Monad.lwt_apply2 f itema itemb :: acc) + in + iter2_ep f seqa seqb [] end diff --git a/src/lib_lwt_result_stdlib/traced/structs/seq_es.ml b/src/lib_lwt_result_stdlib/traced/structs/seq_es.ml index 9abe68c295ca..e40e10ecb923 100644 --- a/src/lib_lwt_result_stdlib/traced/structs/seq_es.ml +++ b/src/lib_lwt_result_stdlib/traced/structs/seq_es.ml @@ -34,16 +34,14 @@ module Make and type 'a seq_s_t := 'a Seq_s.t = struct include Bare_structs.Seq_es - let nil_es = Lwt.return (Ok Nil) - let rec of_seqe seq () = match seq () with - | Ok Seq_e.Nil -> nil_es + | Ok Seq_e.Nil -> Lwt.return_ok Nil | Ok (Seq_e.Cons (item, seq)) -> Lwt.return_ok (Cons (item, of_seqe seq)) | Error _ as e -> Lwt.return e let rec of_seqs seq () = Lwt.bind (seq ()) @@ function - | Seq_s.Nil -> nil_es + | Seq_s.Nil -> Lwt.return_ok Nil | Seq_s.Cons (e, seq) -> Lwt.return_ok (Cons (e, of_seqs seq)) end -- GitLab From 84fc2953eca572b9446ea9aa15bcacbd582b00e4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 14 Dec 2022 09:40:30 +0100 Subject: [PATCH 2/4] Environment: update Seqs --- .../environment_V3.ml | 2 +- .../environment_V4.ml | 2 +- .../environment_V5.ml | 2 +- .../environment_V6.ml | 2 +- .../environment_V7.ml | 2 +- .../environment_V8.ml | 2 +- .../environment_V9.ml | 2 +- .../tezos_protocol_environment_structs.ml | 14 ++- .../structs/v3_seq_monad.ml | 40 +++++++ .../structs/v9_seq_monad.ml | 100 ++++++++++++++++++ 10 files changed, 160 insertions(+), 8 deletions(-) create mode 100644 src/lib_protocol_environment/structs/v3_seq_monad.ml create mode 100644 src/lib_protocol_environment/structs/v9_seq_monad.ml diff --git a/src/lib_protocol_environment/environment_V3.ml b/src/lib_protocol_environment/environment_V3.ml index 3ecfe523e539..8f15d63166c4 100644 --- a/src/lib_protocol_environment/environment_V3.ml +++ b/src/lib_protocol_environment/environment_V3.ml @@ -172,7 +172,7 @@ struct end module Compare = Compare - module Seq = Tezos_error_monad.TzLwtreslib.Seq + module Seq = Tezos_protocol_environment_structs.V3.Seq module List = struct include Tezos_error_monad.TzLwtreslib.List diff --git a/src/lib_protocol_environment/environment_V4.ml b/src/lib_protocol_environment/environment_V4.ml index 2a476567f380..6a6341897102 100644 --- a/src/lib_protocol_environment/environment_V4.ml +++ b/src/lib_protocol_environment/environment_V4.ml @@ -172,7 +172,7 @@ struct end module Compare = Compare - module Seq = Tezos_error_monad.TzLwtreslib.Seq + module Seq = Tezos_protocol_environment_structs.V4.Seq module List = struct include Tezos_error_monad.TzLwtreslib.List diff --git a/src/lib_protocol_environment/environment_V5.ml b/src/lib_protocol_environment/environment_V5.ml index 283b0e9922d9..d79764357c8c 100644 --- a/src/lib_protocol_environment/environment_V5.ml +++ b/src/lib_protocol_environment/environment_V5.ml @@ -180,7 +180,7 @@ struct module Compare = Compare module Either = Either - module Seq = Tezos_error_monad.TzLwtreslib.Seq + module Seq = Tezos_protocol_environment_structs.V5.Seq module List = Tezos_error_monad.TzLwtreslib.List module Char = Char module Bytes = Bytes diff --git a/src/lib_protocol_environment/environment_V6.ml b/src/lib_protocol_environment/environment_V6.ml index 085b4416604b..5458baa4644f 100644 --- a/src/lib_protocol_environment/environment_V6.ml +++ b/src/lib_protocol_environment/environment_V6.ml @@ -181,7 +181,7 @@ struct module Compare = Compare module Either = Either - module Seq = Tezos_error_monad.TzLwtreslib.Seq + module Seq = Tezos_protocol_environment_structs.V6.Seq module List = Tezos_error_monad.TzLwtreslib.List module Char = Char module Bytes = Bytes diff --git a/src/lib_protocol_environment/environment_V7.ml b/src/lib_protocol_environment/environment_V7.ml index 097ad3585b26..b0448a9624f4 100644 --- a/src/lib_protocol_environment/environment_V7.ml +++ b/src/lib_protocol_environment/environment_V7.ml @@ -193,7 +193,7 @@ struct module Compare = Compare module Either = Either - module Seq = Tezos_error_monad.TzLwtreslib.Seq + module Seq = Tezos_protocol_environment_structs.V7.Seq module List = Tezos_error_monad.TzLwtreslib.List module Array = Tezos_protocol_environment_structs.V7.Array module Char = Char diff --git a/src/lib_protocol_environment/environment_V8.ml b/src/lib_protocol_environment/environment_V8.ml index 96145abbe2bc..9dee70f1bb64 100644 --- a/src/lib_protocol_environment/environment_V8.ml +++ b/src/lib_protocol_environment/environment_V8.ml @@ -202,7 +202,7 @@ struct module Compare = Compare module Either = Either - module Seq = Tezos_error_monad.TzLwtreslib.Seq + module Seq = Tezos_protocol_environment_structs.V8.Seq module List = Tezos_error_monad.TzLwtreslib.List module Array = Tezos_protocol_environment_structs.V8.Array module Char = Char diff --git a/src/lib_protocol_environment/environment_V9.ml b/src/lib_protocol_environment/environment_V9.ml index 066e5ed17c8a..346dc87a0d66 100644 --- a/src/lib_protocol_environment/environment_V9.ml +++ b/src/lib_protocol_environment/environment_V9.ml @@ -206,7 +206,7 @@ struct module Compare = Compare module Either = Either - module Seq = Tezos_error_monad.TzLwtreslib.Seq + module Seq = Tezos_protocol_environment_structs.V9.Seq module List = Tezos_error_monad.TzLwtreslib.List module Array = Tezos_protocol_environment_structs.V9.Array module Char = Char diff --git a/src/lib_protocol_environment/structs/tezos_protocol_environment_structs.ml b/src/lib_protocol_environment/structs/tezos_protocol_environment_structs.ml index 9c099449db1a..a7151e3de7ac 100644 --- a/src/lib_protocol_environment/structs/tezos_protocol_environment_structs.ml +++ b/src/lib_protocol_environment/structs/tezos_protocol_environment_structs.ml @@ -80,6 +80,7 @@ module V3 = struct module Error_monad_infix_globals = V0_error_monad_infix_globals module Error_monad_trace_eval = V0_error_monad_trace_eval module RPC_directory = V0_RPC_directory + module Seq = V3_seq_monad end module V4 = struct @@ -88,6 +89,7 @@ module V4 = struct module Lwtreslib_list_combine = V3_lwtreslib_list_combine module Error_monad_infix_globals = V0_error_monad_infix_globals module RPC_directory = V0_RPC_directory + module Seq = V3_seq_monad end module V5 = struct @@ -95,6 +97,7 @@ module V5 = struct module Error_monad_infix_globals = V0_error_monad_infix_globals module Bounded = V5_bounded module RPC_directory = V0_RPC_directory + module Seq = V3_seq_monad end module V6 = struct @@ -102,6 +105,7 @@ module V6 = struct module Error_monad_infix_globals = V0_error_monad_infix_globals module Bounded = V5_bounded module RPC_directory = V0_RPC_directory + module Seq = V3_seq_monad end module V7 = struct @@ -109,6 +113,7 @@ module V7 = struct module Error_monad_infix_globals = V0_error_monad_infix_globals module Array = V7_array module Plonk = V7_plonk + module Seq = V3_seq_monad end module V8 = struct @@ -116,6 +121,13 @@ module V8 = struct module Error_monad_infix_globals = V0_error_monad_infix_globals module Array = V7_array module Plonk = V8_plonk + module Seq = V3_seq_monad end -module V9 = V8 +module V9 = struct + module Data_encoding = V8_data_encoding + module Error_monad_infix_globals = V0_error_monad_infix_globals + module Array = V7_array + module Plonk = V8_plonk + module Seq = V9_seq_monad +end diff --git a/src/lib_protocol_environment/structs/v3_seq_monad.ml b/src/lib_protocol_environment/structs/v3_seq_monad.ml new file mode 100644 index 000000000000..dd6f06b7dd87 --- /dev/null +++ b/src/lib_protocol_environment/structs/v3_seq_monad.ml @@ -0,0 +1,40 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +include Tezos_error_monad.TzLwtreslib.Seq + +let first s = find (fun _ -> true) s + +let fold_left_e = E.fold_left + +let fold_left_s = S.fold_left + +let fold_left_es = ES.fold_left + +let iter_e = E.iter + +let iter_s = S.iter + +let iter_es = ES.iter diff --git a/src/lib_protocol_environment/structs/v9_seq_monad.ml b/src/lib_protocol_environment/structs/v9_seq_monad.ml new file mode 100644 index 000000000000..5026e68d5c62 --- /dev/null +++ b/src/lib_protocol_environment/structs/v9_seq_monad.ml @@ -0,0 +1,100 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +include Tezos_error_monad.TzLwtreslib.Seq + +let first s = find (fun _ -> true) s + +let fold_left_e = E.fold_left + +let fold_left_s = S.fold_left + +let fold_left_es = ES.fold_left + +let iter_e = E.iter + +let iter_s = S.iter + +let iter_es = ES.iter + +let iteri_e = E.iteri + +let iteri_s = S.iteri + +let iteri_es = ES.iteri + +let fold_lefti_e = E.fold_lefti + +let fold_lefti_s = S.fold_lefti + +let fold_lefti_es = ES.fold_lefti + +let for_all_e = E.for_all + +let for_all_s = S.for_all + +let for_all_es = ES.for_all + +let exists_e = E.exists + +let exists_s = S.exists + +let exists_es = ES.exists + +let find_e = E.find + +let find_s = S.find + +let find_es = ES.find + +let find_map_e = E.find_map + +let find_map_s = S.find_map + +let find_map_es = ES.find_map + +let iter2_e = E.iter2 + +let iter2_s = S.iter2 + +let iter2_es = ES.iter2 + +let fold_left2_e = E.fold_left2 + +let fold_left2_s = S.fold_left2 + +let fold_left2_es = ES.fold_left2 + +let for_all2_e = E.for_all2 + +let for_all2_s = S.for_all2 + +let for_all2_es = ES.for_all2 + +let exists2_e = E.exists2 + +let exists2_s = S.exists2 + +let exists2_es = ES.exists2 -- GitLab From 525953623d9c435b0b15b61401e5ef09a719896d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 16 Jan 2023 17:22:10 +0100 Subject: [PATCH 3/4] Everywhere: adapt to new Seq interface --- src/bin_node/node_replay_command.ml | 2 +- src/lib_client_base_unix/client_main_run.ml | 2 +- src/lib_context/disk/context.ml | 2 +- src/lib_dal_node/shard_store.ml | 2 +- src/lib_injector/disk_persistence.ml | 2 +- src/lib_shell/node.ml | 2 +- src/lib_shell/p2p_reader.ml | 14 ++++---------- src/lib_shell/prevalidator_internal.ml | 4 ++-- src/lib_shell_benchmarks/io_helpers.ml | 2 +- src/lib_stdlib_unix/key_value_store.ml | 4 ++-- .../test/test_key_value_store_fuzzy.ml | 15 ++++++++------- src/lib_store/unix/cemented_block_store.ml | 2 +- src/lib_store/unix/consistency.ml | 3 +-- src/lib_store/unix/floating_block_store.ml | 2 +- .../lib_injector/disk_persistence.ml | 2 +- 15 files changed, 27 insertions(+), 33 deletions(-) diff --git a/src/bin_node/node_replay_command.ml b/src/bin_node/node_replay_command.ml index d4514c3d157f..7c926e904162 100644 --- a/src/bin_node/node_replay_command.ml +++ b/src/bin_node/node_replay_command.ml @@ -429,7 +429,7 @@ let replay ~singleprocess ~strict (config : Config_file.t) blocks = validator_process (`Level starts) else - Seq.iter_es + Seq.ES.iter (replay_one_block strict main_chain_store validator_process) (Seq.unfold (fun l -> diff --git a/src/lib_client_base_unix/client_main_run.ml b/src/lib_client_base_unix/client_main_run.ml index 989de57b3389..5b1c0f139091 100644 --- a/src/lib_client_base_unix/client_main_run.ml +++ b/src/lib_client_base_unix/client_main_run.ml @@ -38,7 +38,7 @@ let builtin_commands = (fixed ["list"; "understood"; "protocols"]) (fun () (cctxt : #Client_context.full) -> let* () = - Seq.iter_s + Seq.S.iter (fun (ver, _) -> cctxt#message "%a" Protocol_hash.pp_short ver) (Client_commands.get_versions ()) in diff --git a/src/lib_context/disk/context.ml b/src/lib_context/disk/context.ml index aa923f225682..2504c0400d44 100644 --- a/src/lib_context/disk/context.ml +++ b/src/lib_context/disk/context.ml @@ -1103,7 +1103,7 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct | None -> Lwt.return_some (Store.Tree.empty ()) | Some sub_tree -> add_hash batch sub_tree [step] hash in - let* o = Seq_es.fold_left_s add (Some (Store.Tree.empty ())) l in + let* o = Seq_es.S.fold_left add (Some (Store.Tree.empty ())) l in match o with | None -> return_none | Some tree -> diff --git a/src/lib_dal_node/shard_store.ml b/src/lib_dal_node/shard_store.ml index fc03fab839b3..7811749bf985 100644 --- a/src/lib_dal_node/shard_store.ml +++ b/src/lib_dal_node/shard_store.ml @@ -107,7 +107,7 @@ let write_shards store commitment shards = let commitment_dir = commitment_dir store commitment in let*! () = mkdir_if_not_exists commitment_dir in shards - |> Seq.iter_es (fun ({index; share} : Cryptobox.shard) -> + |> Seq.ES.iter (fun ({index; share} : Cryptobox.shard) -> let filepath = Filename.concat commitment_dir (string_of_int index) in if Mutexes.mem store.mutexes filepath then return_unit else diff --git a/src/lib_injector/disk_persistence.ml b/src/lib_injector/disk_persistence.ml index e31f9ca0b66d..6c1cc61f3a9d 100644 --- a/src/lib_injector/disk_persistence.ml +++ b/src/lib_injector/disk_persistence.ml @@ -228,7 +228,7 @@ module Make_table (H : H) = struct let replace_seq t seq = H.replace_seq t.table seq ; - Seq.iter_es + Seq.ES.iter (fun (k, v) -> write_value (filedata t k) H.value_encoding v) seq diff --git a/src/lib_shell/node.ml b/src/lib_shell/node.ml index f3bba45bf454..75eee153fa50 100644 --- a/src/lib_shell/node.ml +++ b/src/lib_shell/node.ml @@ -153,7 +153,7 @@ let test_protocol_hashes = let store_known_protocols store = let open Lwt_syntax in let embedded_protocols = Registered_protocol.seq_embedded () in - Seq.iter_s + Seq.S.iter (fun protocol_hash -> match Store.Protocol.mem store protocol_hash with | true -> Node_event.(emit store_protocol_already_included) protocol_hash diff --git a/src/lib_shell/p2p_reader.ml b/src/lib_shell/p2p_reader.ml index b30090736b7a..8d110494d1f2 100644 --- a/src/lib_shell/p2p_reader.ml +++ b/src/lib_shell/p2p_reader.ml @@ -86,31 +86,26 @@ let may_handle_global state chain_id f = let find_pending_operations {peer_active_chains; _} h i = Chain_id.Table.to_seq_values peer_active_chains - |> Seq.filter (fun chain_db -> + |> Seq.find (fun chain_db -> Distributed_db_requester.Raw_operations.pending chain_db.operations_db (h, i)) - |> Seq.first let find_pending_operation {peer_active_chains; _} h = Chain_id.Table.to_seq_values peer_active_chains - |> Seq.filter (fun chain_db -> + |> Seq.find (fun chain_db -> Distributed_db_requester.Raw_operation.pending chain_db.operation_db h) - |> Seq.first let read_operation state h = - (* Remember that seqs are lazy. The table is only traversed until a match is - found, the rest is not explored. *) let open Lwt_syntax in Seq_s.of_seq (Chain_id.Table.to_seq state.active_chains) - |> Seq_s.filter_map_s (fun (chain_id, chain_db) -> + |> Seq_s.S.find_map (fun (chain_id, chain_db) -> let+ v = Distributed_db_requester.Raw_operation.read_opt chain_db.operation_db h in Option.map (fun bh -> (chain_id, bh)) v) - |> Seq_s.first let read_block {disk; _} h = let open Lwt_syntax in @@ -149,11 +144,10 @@ let read_predecessor_header {disk; _} h offset = let find_pending_block_header {peer_active_chains; _} h = Chain_id.Table.to_seq_values peer_active_chains - |> Seq.filter (fun chain_db -> + |> Seq.find (fun chain_db -> Distributed_db_requester.Raw_block_header.pending chain_db.block_header_db h) - |> Seq.first let deactivate gid chain_db = chain_db.callback.disconnection gid ; diff --git a/src/lib_shell/prevalidator_internal.ml b/src/lib_shell/prevalidator_internal.ml index c6ffc4785f26..f7347e1d8c12 100644 --- a/src/lib_shell/prevalidator_internal.ml +++ b/src/lib_shell/prevalidator_internal.ml @@ -720,7 +720,7 @@ module Make_s let open Lwt_syntax in let may_fetch_operation = may_fetch_operation shell (Some peer) in let* () = List.iter_s may_fetch_operation mempool.Mempool.known_valid in - Seq.iter_s + Seq.S.iter may_fetch_operation (Operation_hash.Set.to_seq mempool.Mempool.pending) @@ -1378,7 +1378,7 @@ module Make } in let*! () = - Seq.iter_s + Seq.S.iter (may_fetch_operation pv.shell None) (Operation_hash.Set.to_seq fetching) in diff --git a/src/lib_shell_benchmarks/io_helpers.ml b/src/lib_shell_benchmarks/io_helpers.ml index eebf86966707..dbbf1c9eeb07 100644 --- a/src/lib_shell_benchmarks/io_helpers.ml +++ b/src/lib_shell_benchmarks/io_helpers.ml @@ -193,7 +193,7 @@ module Key_map = struct let of_seq seq = Seq.fold_left (fun map (k, v) -> insert k v map) empty seq let fold_lwt f m accu = - Seq.fold_left_s (fun acc (k, v) -> f k v acc) accu (to_seq m) + Seq.S.fold_left (fun acc (k, v) -> f k v acc) accu (to_seq m) let sample_uniform map = if is_empty map then None diff --git a/src/lib_stdlib_unix/key_value_store.ml b/src/lib_stdlib_unix/key_value_store.ml index 683a141a7f1e..915faf8cc18d 100644 --- a/src/lib_stdlib_unix/key_value_store.ml +++ b/src/lib_stdlib_unix/key_value_store.ml @@ -149,11 +149,11 @@ let write_value (type value) ?(override = false) return_unit) let write_values ?override t seq = - Seq.iter_es (fun (key, value) -> write_value ?override t key value) seq + Seq.ES.iter (fun (key, value) -> write_value ?override t key value) seq let read_values t seq = let open Lwt_syntax in Seq_s.of_seq seq - |> Seq_s.map_s (fun key -> + |> Seq_s.S.map (fun key -> let* maybe_value = read_value t key in return (key, maybe_value)) diff --git a/src/lib_stdlib_unix/test/test_key_value_store_fuzzy.ml b/src/lib_stdlib_unix/test/test_key_value_store_fuzzy.ml index ad778a73ca0f..c9809f11ec1b 100644 --- a/src/lib_stdlib_unix/test/test_key_value_store_fuzzy.ml +++ b/src/lib_stdlib_unix/test/test_key_value_store_fuzzy.ml @@ -95,7 +95,7 @@ module R : S = struct let read_values t seq = let open Lwt_syntax in seq |> Seq_s.of_seq - |> Seq_s.map_s (fun key -> + |> Seq_s.S.map (fun key -> let* value = read_value t key in Lwt.return (key, value)) end @@ -396,28 +396,29 @@ let run_scenario {pool_size; values; overwritten; number_of_keys; _} scenario = | Read_values seq -> let left_promise = let seq_s = L.read_values left seq in - Seq_s.iter_e (fun _ -> Ok ()) seq_s + Seq_s.E.iter (fun _ -> Ok ()) seq_s in let right_promise = let seq_s = R.read_values right seq in - Seq_s.iter_e (fun _ -> Ok ()) seq_s + Seq_s.E.iter (fun _ -> Ok ()) seq_s in tzjoin [left_promise; right_promise] in let finalize () = let left = L.init ?pool ~lru_size:number_of_keys file_of_key in - Seq.iter_es + Seq.ES.iter (fun key -> let*! left_result = L.read_value left key in let*! right_result = R.read_value right key in compare_result key left_result right_result) - (Seq.init number_of_keys (fun i -> i)) + (WithExceptions.Result.get_ok ~loc:__LOC__ + @@ Seq.init ~when_negative_length:() number_of_keys (fun i -> i)) in match next_actions with | [] -> let* () = promise in let* () = - Seq_s.iter_es + Seq_s.ES.iter (function Ok () -> return_unit | Error err -> fail err) promises_running_seq in @@ -426,7 +427,7 @@ let run_scenario {pool_size; values; overwritten; number_of_keys; _} scenario = | (Sequential, action) :: next_actions -> let* () = promise in let* () = - Seq_s.iter_es + Seq_s.ES.iter (function Ok () -> return_unit | Error err -> fail err) promises_running_seq in diff --git a/src/lib_store/unix/cemented_block_store.ml b/src/lib_store/unix/cemented_block_store.ml index 25d42bfb7cdb..6f769eb4e05d 100644 --- a/src/lib_store/unix/cemented_block_store.ml +++ b/src/lib_store/unix/cemented_block_store.ml @@ -673,7 +673,7 @@ let cement_blocks ?(check_consistency = true) (cemented_store : t) let first_offset = preamble_length in (* Cursor is now at the beginning of the element section *) let*! _ = - Seq.fold_left_es + Seq.ES.fold_left (fun (i, current_offset) block_read -> let* block_hash, total_block_length, block_bytes = block_read in let pruned_block_length = diff --git a/src/lib_store/unix/consistency.ml b/src/lib_store/unix/consistency.ml index 375cbc7ac850..6739b14951d7 100644 --- a/src/lib_store/unix/consistency.ml +++ b/src/lib_store/unix/consistency.ml @@ -411,7 +411,7 @@ let lowest_cemented_metadata cemented_dir = | Some metadata_files -> let*! m = Seq_s.of_seq (Array.to_seq metadata_files) - |> Seq_s.filter_map_s + |> Seq_s.S.find_map (fun {Cemented_block_store.metadata_file; start_level; end_level} -> let*! lowest_metadata_entry = @@ -428,7 +428,6 @@ let lowest_cemented_metadata cemented_dir = emit warning_missing_metadata (start_level, end_level)) in Lwt.return lowest_metadata_entry) - |> Seq_s.first in return m | None -> return_none diff --git a/src/lib_store/unix/floating_block_store.ml b/src/lib_store/unix/floating_block_store.ml index e362c7117500..e9c178f3445b 100644 --- a/src/lib_store/unix/floating_block_store.ml +++ b/src/lib_store/unix/floating_block_store.ml @@ -149,7 +149,7 @@ let append_all floating_store (blocks : (Block_repr.t * info) Seq.t) = Lwt_idle_waiter.force_idle floating_store.scheduler (fun () -> let*! eof_offset = Lwt_unix.lseek floating_store.fd 0 Unix.SEEK_END in let* _last_offset = - Seq.fold_left_es + Seq.ES.fold_left (fun offset (block, ({predecessors; resulting_context_hash} : info)) -> let* written_len = locked_write_block diff --git a/src/proto_015_PtLimaPt/lib_injector/disk_persistence.ml b/src/proto_015_PtLimaPt/lib_injector/disk_persistence.ml index 9941a6928cdd..a7a7d8b38e38 100644 --- a/src/proto_015_PtLimaPt/lib_injector/disk_persistence.ml +++ b/src/proto_015_PtLimaPt/lib_injector/disk_persistence.ml @@ -228,7 +228,7 @@ module Make_table (H : H) = struct let replace_seq t seq = H.replace_seq t.table seq ; - Seq.iter_es + Seq.ES.iter (fun (k, v) -> write_value (filedata t k) H.value_encoding v) seq -- GitLab From 9b920016b64002ba9ab557deab2eb0232d8b1218 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 21 Feb 2023 16:27:39 +0100 Subject: [PATCH 4/4] Build: update opam hash to make seqes available in dependencies --- .gitlab-ci.yml | 2 +- scripts/version.sh | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 5b30b5b53a88..ca87a2a4c349 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -33,7 +33,7 @@ variables: # /!\ CI_REGISTRY is overriden to use a private Docker registry mirror in AWS ECR # in GitLab namespaces `nomadic-labs` and `tezos` ## This value MUST be the same as `opam_repository_tag` in `scripts/version.sh` - build_deps_image_version: a82d70c2926d88ba47d00dd62c940f6d8cb6a166 + build_deps_image_version: 4e0d1c3b0327301a8714660425f852396a3ffdd2 build_deps_image_name: "${CI_REGISTRY}/tezos/opam-repository" GIT_STRATEGY: fetch GIT_DEPTH: "1" diff --git a/scripts/version.sh b/scripts/version.sh index f08d0f561e45..6407f8322426 100755 --- a/scripts/version.sh +++ b/scripts/version.sh @@ -25,7 +25,7 @@ export full_opam_repository_tag=7f0579750a745ea92dc2fe3869d491902e2c29dd ## opam_repository is an additional, tezos-specific opam repository. ## This value MUST be the same as `build_deps_image_version` in `.gitlab/ci/templates.yml export opam_repository_url=https://gitlab.com/tezos/opam-repository -export opam_repository_tag="${OPAM_REPOSITORY_TAG:-a82d70c2926d88ba47d00dd62c940f6d8cb6a166}" +export opam_repository_tag="${OPAM_REPOSITORY_TAG:-4e0d1c3b0327301a8714660425f852396a3ffdd2}" export opam_repository_git="$opam_repository_url.git" export opam_repository="$opam_repository_git"\#"$opam_repository_tag" -- GitLab