From 77e0dbf18cc58f6a89423aad7ac51f72f72ee19a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 15 Mar 2021 11:24:40 +0100 Subject: [PATCH 01/14] Lwtreslib: tiers of seqs rather - Seq: normal seqs - Seq_e: seqs with embedded result - Seq_s: seqs with embedded Lwt - Seq_es: seqs with embedded result-Lwt --- src/lib_lwt_result_stdlib/bare/sigs/seq.ml | 126 +--- src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml | 263 ++++++++ src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml | 145 ++++ src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml | 159 +++++ src/lib_lwt_result_stdlib/bare/structs/seq.ml | 203 +----- .../bare/structs/seq_e.ml | 249 +++++++ .../bare/structs/seq_e.mli | 26 + .../bare/structs/seq_es.ml | 381 +++++++++++ .../bare/structs/seq_es.mli | 29 + .../bare/structs/seq_s.ml | 233 +++++++ .../bare/structs/seq_s.mli | 26 + src/lib_lwt_result_stdlib/lwtreslib.ml | 3 + src/lib_lwt_result_stdlib/lwtreslib.mli | 39 ++ src/lib_lwt_result_stdlib/test/dune | 5 + .../test/test_fuzzing_helpers.ml | 8 + .../test/test_fuzzing_seq.ml | 12 +- .../test/test_fuzzing_seq_tiered.ml | 219 ++++++ .../test/test_generic.ml | 26 +- .../test/traits_tiered.ml | 638 ++++++++++++++++++ src/lib_lwt_result_stdlib/traced/sigs/dune | 8 +- src/lib_lwt_result_stdlib/traced/sigs/seq.ml | 16 - .../traced/sigs/seq_e.ml | 54 ++ .../traced/sigs/seq_es.ml | 40 ++ .../traced/sigs/seq_s.ml | 54 ++ .../traced/structs/seq.ml | 6 - .../traced/structs/seq_e.ml | 26 + .../traced/structs/seq_e.mli | 26 + .../traced/structs/seq_es.ml | 55 ++ .../traced/structs/seq_es.mli | 34 + .../traced/structs/seq_s.ml | 36 + .../traced/structs/seq_s.mli | 30 + .../traced/structs/structs.ml | 3 + 32 files changed, 2830 insertions(+), 348 deletions(-) create mode 100644 src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml create mode 100644 src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml create mode 100644 src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml create mode 100644 src/lib_lwt_result_stdlib/bare/structs/seq_e.ml create mode 100644 src/lib_lwt_result_stdlib/bare/structs/seq_e.mli create mode 100644 src/lib_lwt_result_stdlib/bare/structs/seq_es.ml create mode 100644 src/lib_lwt_result_stdlib/bare/structs/seq_es.mli create mode 100644 src/lib_lwt_result_stdlib/bare/structs/seq_s.ml create mode 100644 src/lib_lwt_result_stdlib/bare/structs/seq_s.mli create mode 100644 src/lib_lwt_result_stdlib/test/test_fuzzing_seq_tiered.ml create mode 100644 src/lib_lwt_result_stdlib/test/traits_tiered.ml create mode 100644 src/lib_lwt_result_stdlib/traced/sigs/seq_e.ml create mode 100644 src/lib_lwt_result_stdlib/traced/sigs/seq_es.ml create mode 100644 src/lib_lwt_result_stdlib/traced/sigs/seq_s.ml create mode 100644 src/lib_lwt_result_stdlib/traced/structs/seq_e.ml create mode 100644 src/lib_lwt_result_stdlib/traced/structs/seq_e.mli create mode 100644 src/lib_lwt_result_stdlib/traced/structs/seq_es.ml create mode 100644 src/lib_lwt_result_stdlib/traced/structs/seq_es.mli create mode 100644 src/lib_lwt_result_stdlib/traced/structs/seq_s.ml create mode 100644 src/lib_lwt_result_stdlib/traced/structs/seq_s.mli diff --git a/src/lib_lwt_result_stdlib/bare/sigs/seq.ml b/src/lib_lwt_result_stdlib/bare/sigs/seq.ml index 4d397fcd4431..01adc1fd9911 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq.ml @@ -69,29 +69,25 @@ Because of the type of {!Stdlib.Seq.t}, some interactions with Lwt are not possible. Specifically, note that the type includes the variant - [Cons of (unit -> ('a * 'a t))] which is not within Lwt. *) + [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 + applied lazily. + + Check-out the [S] variants ({!Seq_s.S}, {!Seq_e.S}, and + {!Seq_es.S}) that integrate the base sequence type better with the monads' + type. It is recommended that you use the variant as appropriate to your + traversal. Note the presence of [of_seq] in each of those variants to + convert from the standard [S.t]. *) module type S = sig - (** including the OCaml's {!Stdlib.Seq} module to share the {!Seq.t} type - (including concrete definition) and to bring the existing functions. *) + (** {3 Common interface with Stdlib} *) + include module type of Stdlib.Seq with type 'a t = 'a Stdlib.Seq.t and type 'a node = 'a Stdlib.Seq.node - (** in-monad, preallocated empty/nil *) - - val empty_e : ('a t, 'trace) result - - val empty_s : 'a t Lwt.t - - val empty_es : ('a t, 'trace) result Lwt.t - - val nil_e : ('a node, 'trace) result - - val nil_s : 'a node Lwt.t - - val nil_es : ('a node, 'trace) result Lwt.t + (** {3 Lwtreslib-specific extensions} *) (** Similar to {!fold_left} but wraps the traversal in {!result}. The traversal is interrupted if one of the step returns an [Error _]. *) @@ -149,104 +145,6 @@ module type S = sig them is. *) val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t - (** Similar to {!map} but wraps the transformation in {!result}. The - traversal is interrupted if any of the application returns an [Error _]. - - Note that, unlike {!map}, [map_e] is not lazy: it applies the - transformation immediately to all the elements of the sequence (unless it - is interrupted by an [Error _]) and does not terminate on infinite - sequences (again, unless interrupted). Moreover [map_e] is not - tail-recursive. *) - val map_e : ('a -> ('b, 'trace) result) -> 'a t -> ('b t, 'trace) result - - (** Similar to {!map} but wraps the transformation in {!Lwt}. Each - transformation is done sequentially, only starting once the previous - one has resolved. The traversal is interrupted if any of the promise is - rejected. - - Note that, unlike {!map}, [map_s] is not lazy: it applies the - transformation eagerly to all the elements of the sequence (unless - interrupted by a rejection) and does not terminate on infinite sequences - (again, unless interrupted). Moreover [map_s] is not tail-recursive. *) - val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t Lwt.t - - (** Similar to {!map} but wraps the transformation in [result Lwt.t]. Each - transformation is done sequentially, only starting once the previous - one has resolved. The traversal is interrupted if any of the promise is - rejected or fulfilled with an [Error _]. - - Note that, unlike {!map}, [map_es] is not lazy: it applies the - transformation eagerly to all the elements of the sequence (unless - interrupted by rejection or an [Error _]) and does not terminate on - infinite sequences (again, unless interrupted). Moreover [map_es] is not - tail-recursive. *) - val map_es : - ('a -> ('b, 'trace) result Lwt.t) -> 'a t -> ('b t, 'trace) result Lwt.t - - (** Similar to {!map} but wraps the transformation in [result Lwt]. All the - transformations are done concurrently. The promise [map_p f s] resolves - once all the promises of the traversal resolve. At this point it is - rejected if any of the promises are, and otherwise it is resolved with - [Error _] if any of the promises are, and otherwise it is fulfilled (if - all the promises are). - - Note that, unlike {!map}, [map_ep] is not lazy: it applies the - transformation eagerly to all the elements of the sequence and does not - terminate on infinite sequences. Moreover [map_p] is not tail-recursive. - *) - val map_ep : - ('a -> ('b, 'trace) result Lwt.t) -> - 'a t -> - ('b t, 'trace list) result Lwt.t - - (** Similar to {!map} but wraps the transformation in {!Lwt}. All the - transformations are done concurrently. The promise [map_p f s] resolves - once all the promises of the traversal resolve. At this point it is - fulfilled if all the promises are, and it is rejected if any of them are. - - Note that, unlike {!map}, [map_p] is not lazy: it applies the - transformation eagerly to all the elements of the sequence and does not - terminate on infinite sequences. Moreover [map_p] is not tail-recursive. - *) - val map_p : ('a -> 'b Lwt.t) -> 'a t -> 'b t Lwt.t - - (** Similar to {!filter} but wraps the transformation in [result]. Note - that, unlike {!filter}, [filter_e] is not lazy: it applies the - transformation immediately and does not terminate on infinite sequences. - Moreover [filter_e] is not tail-recursive. *) - val filter_e : ('a -> (bool, 'trace) result) -> 'a t -> ('a t, 'trace) result - - (** 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. Note that, unlike {!filter}, [filter_s] is not - lazy: it applies the transformation immediately and does not terminate on - infinite sequences. Moreover [filter_s] is not tail-recursive. *) - val filter_s : ('a -> bool Lwt.t) -> 'a t -> 'a t Lwt.t - - (** Similar to {!filter} but wraps the transformation in [result Lwt.t]. - Each test of the predicate is done sequentially, only starting once the - previous one has resolved. Note that, unlike {!filter}, [filter_es] is not - lazy: it applies the transformation immediately and does not terminate on - infinite sequences. Moreover [filter_es] is not tail-recursive. *) - val filter_es : - ('a -> (bool, 'trace) result Lwt.t) -> 'a t -> ('a t, 'trace) result Lwt.t - - (** Similar to {!filter_map} but within [result]. Not lazy and not - tail-recursive. *) - val filter_map_e : - ('a -> ('b option, 'trace) result) -> 'a t -> ('b t, 'trace) result - - (** 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 Lwt.t - - (** Similar to {!filter_map} but within [result Lwt.t]. Not lazy and not - tail-recursive. *) - val filter_map_es : - ('a -> ('b option, 'trace) result Lwt.t) -> - 'a t -> - ('b t, 'trace) result Lwt.t - (** [find f t] is [Some x] where [x] is the first item in [t] such that [f x]. It is [None] if there are no such element. It does not terminate if the sequence is infinite and the predicate is always false. *) diff --git a/src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml b/src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml new file mode 100644 index 000000000000..da5eb21d8e7a --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml @@ -0,0 +1,263 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** 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. + + 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 + + val return : 'a -> ('a, 'e) t + + val return_e : ('a, 'e) result -> ('a, 'e) t + + val interrupted : 'e -> ('a, 'e) t + + val nil : ('a, 'e) node + + (** [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 _]. + + It is the responsibility of the caller to differentiate + between errors from the function and errors from the sequence. The + function {!map_error} may come in handy. E.g., + +{[ +fold_left_e + (fun acc item -> + f acc item |> Result.map_error (fun e -> `Traverse e)) + init + (s |> map_error (fun e -> `Interrupt e)) +]} +*) + val fold_left_e : + ('a -> 'b -> ('a, 'e) result) -> 'a -> ('b, 'e) t -> ('a, 'e) 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. + + See {!fold_left_e} for a warning about traversal and interruption errors + being indistinguishable. *) + val fold_left_es : + ('a -> 'b -> ('a, 'e) result Lwt.t) -> + 'a -> + ('b, 'e) t -> + ('a, 'e) 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_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 + + (** [iter_p f seq] is a promise [p]. + + - If [seq] is a whole sequence, then [p] resolves to [Ok ()] once all the + promises created by [f] on the elements of [seq] have resolved. + - If [seq] is interrupted by [Error e], then [p] resolves to [Error e] + once all the promises created by [f] on the elements of the successful + prefix of [seq] have resolved. + + Note that the behaviour for interrupted sequences is in line with the + 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 + + (** [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 + + (** [find f s] is + + - [Ok (Some x)] if [x] is the first element of [s] or the successful + prefix of [s] for which [f x] holds, or + - [Ok None] if [s] is whole and [f] doesn't hold for any of the elements + of [s], or + - [Error e] if [s] is interrupted by [e]. *) + val find : ('a -> bool) -> ('a, 'e) t -> ('a option, 'e) result + + (** [find_e f s] is + + - [Ok (Some x)] if [x] is the first element of [s] or the successful + prefix of [s] for which [f x] holds, or + - [Ok None] if [s] is whole and [f] doesn't hold for any of the elements + of [s], or + - [Error e] if there is an element of [s] or the successful prefix of [s] + for which [f] returns [Error e], or + - [Error e] if [s] is interrupted by [e]. *) + val find_e : + ('a -> (bool, 'e) result) -> ('a, 'e) t -> ('a option, 'e) result + + (** [find_s] is similar to [find] but it returns a promise. Also note that the + elements are traversed sequentially and that the sequence's node are + unsuspended only when the previous node's predicate has been evaluated. *) + val find_s : ('a -> bool Lwt.t) -> ('a, 'e) t -> ('a option, 'e) result Lwt.t + + (** [find_es] is similar to [find_e] but it returns a promise. Also note that + the elements are traversed sequentially and that the sequence's node are + unsuspended only when the previous node's predicate has been evaluated. *) + val find_es : + ('a -> (bool, 'e) result Lwt.t) -> + ('a, 'e) t -> + ('a option, 'e) result Lwt.t + + val of_seq : 'a Stdlib.Seq.t -> ('a, 'e) t + + val of_seq_e : ('a, 'e) result Stdlib.Seq.t -> ('a, 'e) t +end + +(* Developer notes: + + We could use [Either.t] to distinguish between interruption and traversal + failure. [Either] is introduced only in more recent versions of OCaml that we + use here. We'll update to use [Either.t] later. *) diff --git a/src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml b/src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml new file mode 100644 index 000000000000..e0aeacf10ba8 --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml @@ -0,0 +1,145 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** 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 + lazily. + + The functions [of_seq] and [of_seq_*] allow conversion from vanilla + sequences. *) +module type S = sig + type ('a, 'e) seq_e_t (* For substitution by [Seq_e.t] *) + + type 'a seq_s_t (* For substitution by [Seq_s.t] *) + + (** This is similar to {!Seq.S}[.t] but the suspended node is a promised + result. + + Similarly to [Seq_e], sequences of this module can be interrupted by an + error. In this case, traversal has fully applied to the successful prefix + before the returned promise evaluates to [Error _]. + *) + type (+'a, 'e) node = Nil | Cons of 'a * ('a, 'e) t + + and ('a, 'e) t = unit -> (('a, 'e) node, 'e) result Lwt.t + + val empty : ('a, 'e) t + + val nil : ('a, 'e) node + + val return : 'a -> ('a, 'e) t + + val return_e : ('a, 'e) result -> ('a, 'e) t + + val return_s : 'a Lwt.t -> ('a, 'e) t + + val return_es : ('a, 'e) result Lwt.t -> ('a, 'e) t + + val interrupted : 'e -> ('a, 'e) t + + val interrupted_s : 'e Lwt.t -> ('a, 'e) t + + val fold_left : ('a -> 'b -> 'a) -> 'a -> ('b, 'e) t -> ('a, 'e) result Lwt.t + + (** See {!Seq_e.fold_left_e} for a warning about traversal and interruption + errors being indistinguishable. This applies to all [_e] and [_es] + functions of this module. *) + val fold_left_e : + ('a -> 'b -> ('a, 'e) result) -> 'a -> ('b, 'e) t -> ('a, 'e) 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 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_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 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 find : ('a -> bool) -> ('a, 'e) t -> ('a option, 'e) result Lwt.t + + val find_e : + ('a -> (bool, 'e) result) -> ('a, 'e) t -> ('a option, 'e) result Lwt.t + + val find_s : ('a -> bool Lwt.t) -> ('a, 'e) t -> ('a option, 'e) result Lwt.t + + val find_es : + ('a -> (bool, 'e) result Lwt.t) -> + ('a, 'e) t -> + ('a option, 'e) result Lwt.t + + val of_seq : 'a Stdlib.Seq.t -> ('a, 'e) t + + val of_seq_s : 'a Lwt.t Stdlib.Seq.t -> ('a, 'e) t + + val of_seqs : 'a seq_s_t -> ('a, 'e) t + + val of_seq_e : ('a, 'e) result Stdlib.Seq.t -> ('a, 'e) t + + val of_seqe : ('a, 'e) seq_e_t -> ('a, 'e) t + + val of_seq_es : ('a, 'e) result Lwt.t Stdlib.Seq.t -> ('a, 'e) t +end diff --git a/src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml b/src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml new file mode 100644 index 000000000000..160d6b099b69 --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml @@ -0,0 +1,159 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** 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. + + The functions [of_seq] and [of_seq_s] allow conversion from vanilla + sequences. *) +module type S = sig + (** This is similar to [S.t] but the suspended node is a promise *) + type +'a node = Nil | Cons of 'a * 'a t + + and 'a t = unit -> 'a node Lwt.t + + val empty : 'a t + + val return : 'a -> 'a t + + val return_s : 'a Lwt.t -> 'a 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] + 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 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 + + (** [find f t] is [Some x] where [x] is the first item in [t] such that + [f x]. It is [None] if there are no such element. It does not terminate if + the sequence is infinite and the predicate is always false. *) + val find : ('a -> bool) -> 'a t -> 'a option Lwt.t + + (** [find_e f t] is similar to {!find} but wraps the search within + [result]. Specifically, [find_e f t] is either + - [Ok (Some x)] if forall [y] before [x] [f y = Ok false] and + [f x = Ok true], + - [Error e] if there exists [x] such that forall [y] before [x] + [f y = Ok false] and [f x = Error e], + - [Ok None] otherwise and [t] is finite, + - an expression that never returns otherwise. *) + val find_e : + ('a -> (bool, 'trace) result) -> 'a t -> ('a option, 'trace) result Lwt.t + + (** [find_s f t] is similar to {!find} but wrapped within + [Lwt.t]. The search is identical to [find_e] but each + predicate is applied when the previous one has resolved. *) + val find_s : ('a -> bool Lwt.t) -> 'a t -> 'a option Lwt.t + + (** [find_es f t] is similar to {!find} but wrapped within + [result Lwt.t]. The search is identical to [find_e] but each + predicate is applied when the previous one has resolved. *) + val find_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a t -> + ('a option, 'trace) result Lwt.t + + val of_seq : 'a Stdlib.Seq.t -> 'a t + + val of_seq_s : 'a Lwt.t Stdlib.Seq.t -> 'a t +end diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq.ml b/src/lib_lwt_result_stdlib/bare/structs/seq.ml index 20c7e88f8c89..7ae01b5ccfeb 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq.ml @@ -26,20 +26,8 @@ open Monad include Stdlib.Seq -let nil_e = Ok Nil - -let nil_s = Lwt.return Nil - -let nil_es = Lwt.return nil_e - -let empty_e = Ok empty - -let empty_s = Lwt.return empty - -let empty_es = Lwt.return empty_e - -(* Like Lwt.apply but specialised for three parameters *) -let apply3 f x y = try f x y with exn -> Lwt.fail exn +(* Like Lwt.apply but specialised for two-parameter functions *) +let apply2 f x y = try f x y with exn -> Lwt.fail exn let rec fold_left_e f acc seq = match seq () with @@ -60,7 +48,7 @@ let fold_left_s f acc seq = | Nil -> Lwt.return acc | Cons (item, seq) -> - apply3 f acc item >>= fun acc -> fold_left_s f acc seq + apply2 f acc item >>= fun acc -> fold_left_s f acc seq let rec fold_left_es f acc seq = match seq () with @@ -74,7 +62,7 @@ let fold_left_es f acc seq = | Nil -> Monad.return acc | Cons (item, seq) -> - apply3 f acc item >>=? fun acc -> fold_left_es f acc seq + apply2 f acc item >>=? fun acc -> fold_left_es f acc seq let rec iter_e f seq = match seq () with @@ -131,189 +119,6 @@ let iter_p f seq = in iter_p f seq [] -let rec map_e f seq = - match seq () with - | Nil -> - empty_e - | Cons (item, seq) -> - f item - >>? fun item -> - map_e f seq >>? fun seq -> ok (fun () -> Cons (item, seq)) - -let rec map_s f seq = - match seq () with - | Nil -> - empty_s - | Cons (item, seq) -> - f item - >>= fun item -> - map_s f seq >>= fun seq -> Lwt.return (fun () -> Cons (item, seq)) - -let map_s f seq = - match seq () with - | Nil -> - empty_s - | Cons (item, seq) -> - Lwt.apply f item - >>= fun item -> - map_s f seq >>= fun seq -> Lwt.return (fun () -> Cons (item, seq)) - -let rec map_es f seq = - match seq () with - | Nil -> - empty_es - | Cons (item, seq) -> - f item - >>=? fun item -> - map_es f seq >>=? fun seq -> Monad.return (fun () -> Cons (item, seq)) - -let map_es f seq = - match seq () with - | Nil -> - empty_es - | Cons (item, seq) -> - Lwt.apply f item - >>=? fun item -> - map_es f seq >>=? fun seq -> Monad.return (fun () -> Cons (item, seq)) - -let map_ep f seq = - all_ep (fold_left (fun acc x -> Lwt.apply f x :: acc) [] seq) - >|=? (* this is equivalent to rev |> to_seq but more direct *) - Stdlib.List.fold_left (fun s x () -> Cons (x, s)) empty - -let map_p f seq = - all_p (fold_left (fun acc x -> Lwt.apply f x :: acc) [] seq) - >|= (* this is equivalent to rev |> to_seq but more direct *) - Stdlib.List.fold_left (fun s x () -> Cons (x, s)) empty - -let rec filter_e f seq = - match seq () with - | Nil -> - empty_e - | Cons (item, seq) -> ( - f item - >>? function - | false -> - filter_e f seq - | true -> - filter_e f seq >>? fun seq -> ok (fun () -> Cons (item, seq)) ) - -let rec filter_s f seq = - match seq () with - | Nil -> - empty_s - | Cons (item, seq) -> ( - f item - >>= function - | false -> - filter_s f seq - | true -> - filter_s f seq >>= fun seq -> Lwt.return (fun () -> Cons (item, seq)) - ) - -let filter_s f seq = - match seq () with - | Nil -> - empty_s - | Cons (item, seq) -> ( - Lwt.apply f item - >>= function - | false -> - filter_s f seq - | true -> - filter_s f seq >>= fun seq -> Lwt.return (fun () -> Cons (item, seq)) - ) - -let rec filter_es f seq = - match seq () with - | Nil -> - empty_es - | Cons (item, seq) -> ( - f item - >>=? function - | false -> - filter_es f seq - | true -> - filter_es f seq - >>=? fun seq -> Monad.return (fun () -> Cons (item, seq)) ) - -let filter_es f seq = - match seq () with - | Nil -> - empty_es - | Cons (item, seq) -> ( - Lwt.apply f item - >>=? function - | false -> - filter_es f seq - | true -> - filter_es f seq - >>=? fun seq -> Monad.return (fun () -> Cons (item, seq)) ) - -let rec filter_map_e f seq = - match seq () with - | Nil -> - empty_e - | Cons (item, seq) -> ( - f item - >>? function - | None -> - filter_map_e f seq - | Some item -> - filter_map_e f seq >>? fun seq -> ok (fun () -> Cons (item, seq)) ) - -let rec filter_map_s f seq = - match seq () with - | Nil -> - empty_s - | Cons (item, seq) -> ( - f item - >>= function - | None -> - filter_map_s f seq - | Some item -> - filter_map_s f seq - >>= fun seq -> Lwt.return (fun () -> Cons (item, seq)) ) - -let filter_map_s f seq = - match seq () with - | Nil -> - empty_s - | Cons (item, seq) -> ( - Lwt.apply f item - >>= function - | None -> - filter_map_s f seq - | Some item -> - filter_map_s f seq - >>= fun seq -> Lwt.return (fun () -> Cons (item, seq)) ) - -let rec filter_map_es f seq = - match seq () with - | Nil -> - empty_es - | Cons (item, seq) -> ( - f item - >>=? function - | None -> - filter_map_es f seq - | Some item -> - filter_map_es f seq - >>=? fun seq -> Monad.return (fun () -> Cons (item, seq)) ) - -let filter_map_es f seq = - match seq () with - | Nil -> - empty_es - | Cons (item, seq) -> ( - Lwt.apply f item - >>=? function - | None -> - filter_map_es f seq - | Some item -> - filter_map_es f seq - >>=? fun seq -> Monad.return (fun () -> Cons (item, seq)) ) - let rec find f seq = match seq () with | Nil -> diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml b/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml new file mode 100644 index 000000000000..28df637ed282 --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml @@ -0,0 +1,249 @@ +(*****************************************************************************) +(* *) +(* 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 Monad + +(* Like Lwt.apply but specialised for three parameters *) +let apply3 f x y = try f x y with exn -> Lwt.fail exn + +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)) + +let return_e r () = Result.map (fun x -> Cons (x, empty)) r + +let interrupted e () = Error e + +let rec fold_left f acc seq = + seq () + >>? function + | Nil -> Ok acc | Cons (item, seq) -> fold_left f (f acc item) seq + +let rec fold_left_e f acc seq = + seq () + >>? function + | Nil -> + Ok acc + | Cons (item, seq) -> + f acc item >>? fun acc -> fold_left_e f acc seq + +let rec fold_left_s f acc seq = + seq () + >>?= function + | Nil -> + Monad.return acc + | Cons (item, seq) -> + f acc item >>= fun acc -> fold_left_s f acc seq + +let fold_left_s f acc seq = + seq () + >>?= function + | Nil -> + Monad.return acc + | Cons (item, seq) -> + apply3 f acc item >>= fun acc -> fold_left_s f acc seq + +let rec fold_left_es f acc seq = + seq () + >>?= function + | Nil -> + Monad.return acc + | Cons (item, seq) -> + f acc item >>=? fun acc -> fold_left_es f acc seq + +let fold_left_es f acc seq = + seq () + >>?= function + | Nil -> + Monad.return acc + | Cons (item, seq) -> + apply3 f acc item >>=? fun acc -> fold_left_es f acc seq + +let rec iter f seq = + seq () >>? function Nil -> unit_e | Cons (item, seq) -> f item ; iter f seq + +let rec iter_e f seq = + seq () + >>? function + | Nil -> unit_e | Cons (item, seq) -> f item >>? fun () -> iter_e f seq + +let rec iter_s f seq = + seq () + >>?= function + | Nil -> unit_es | Cons (item, seq) -> f item >>= fun () -> iter_s f seq + +let iter_s f seq = + seq () + >>?= function + | Nil -> + unit_es + | Cons (item, seq) -> + Lwt.apply f item >>= fun () -> iter_s f seq + +let rec iter_es f seq = + seq () + >>?= function + | Nil -> unit_es | Cons (item, seq) -> f item >>=? fun () -> iter_es f seq + +let iter_es f seq = + seq () + >>?= function + | Nil -> + unit_es + | Cons (item, seq) -> + Lwt.apply f item >>=? fun () -> iter_es f seq + +let iter_p f seq = + let rec iter_p acc f seq = + match seq () with + | Error _ as e -> + join_p acc >>= fun () -> Lwt.return e + | Ok Nil -> + join_p acc >>= fun () -> Monad.unit_es + | Ok (Cons (item, seq)) -> + iter_p (Lwt.apply f item :: acc) f seq + in + iter_p [] f seq + +let rec map f seq () = + seq () + >|? function Nil -> Nil | Cons (item, seq) -> Cons (f item, map f seq) + +let rec map_e f seq () = + seq () + >>? function + | Nil -> + nil_e + | Cons (item, seq) -> + f item >>? fun item -> Ok (Cons (item, map_e f seq)) + +let rec map_error (f : 'e -> 'f) (seq : ('a, 'e) t) : ('a, 'f) t = + fun () -> + match seq () with + | Ok Nil -> + Ok Nil + | Ok (Cons (item, seq)) -> + Ok (Cons (item, map_error f seq)) + | Error e -> + Error (f e) + +let rec filter f seq () = + seq () + >>? function + | Nil -> + nil_e + | Cons (item, seq) -> + if f item then Ok (Cons (item, seq)) else filter f seq () + +let rec filter_e f seq () = + seq () + >>? function + | Nil -> + nil_e + | Cons (item, seq) -> ( + f item + >>? function + | true -> Ok (Cons (item, filter_e f seq)) | false -> filter_e f seq () ) + +let rec filter_map f seq () = + seq () + >>? function + | 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 () = + seq () + >>? function + | Nil -> + nil_e + | Cons (item, seq) -> ( + f item + >>? function + | None -> + filter_map_e f seq () + | Some item -> + Ok (Cons (item, filter_map_e f seq)) ) + +let rec find f seq = + seq () + >>? function + | Nil -> + Monad.none_e + | Cons (item, seq) -> + if f item then Ok (Some item) else find f seq + +let rec find_e f seq = + seq () + >>? function + | Nil -> + Monad.none_e + | Cons (item, seq) -> ( + f item >>? function true -> some_e item | false -> find_e f seq ) + +let rec find_s f seq = + seq () + >>?= function + | Nil -> + none_es + | Cons (item, seq) -> ( + f item >>= function true -> some_es item | false -> find_s f seq ) + +let rec find_es f seq = + seq () + >>?= function + | Nil -> + none_es + | Cons (item, seq) -> ( + f item >>=? function true -> some_es item | false -> find_es f seq ) + +let rec of_seq seq () = + match seq () with + | Stdlib.Seq.Nil -> + nil_e + | Stdlib.Seq.Cons (e, seq) -> + Ok (Cons (e, of_seq seq)) + +let rec of_seq_e seq () = + match seq () with + | Stdlib.Seq.Nil -> + nil_e + | 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_e.mli b/src/lib_lwt_result_stdlib/bare/structs/seq_e.mli new file mode 100644 index 000000000000..b0628f175a08 --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_e.mli @@ -0,0 +1,26 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +include Bare_sigs.Seq_e.S diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq_es.ml b/src/lib_lwt_result_stdlib/bare/structs/seq_es.ml new file mode 100644 index 000000000000..66fa144580ed --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_es.ml @@ -0,0 +1,381 @@ +(*****************************************************************************) +(* *) +(* 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 Monad + +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 () = Monad.return Nil + +let return x () = Monad.return (Cons (x, empty)) + +let return_e r () = Monad.( >>?= ) r (fun x -> Monad.return (Cons (x, empty))) + +let return_s p () = Lwt.bind p (fun x -> Monad.return (Cons (x, empty))) + +let return_es p () = Monad.( >>=? ) p (fun x -> Monad.return (Cons (x, empty))) + +let interrupted e () = Lwt.return (Error e) + +let interrupted_s p () = Lwt.bind p Lwt.return_error + +let rec fold_left f acc seq = + seq () + >>=? function + | Nil -> Monad.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 = + seq () + >>=? function + | Nil -> + Monad.return acc + | Cons (item, seq) -> + f acc item >>?= fun 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 = + seq () + >>=? function + | Nil -> + Monad.return acc + | Cons (item, seq) -> + f acc item >>= fun acc -> 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 = + seq () + >>=? function + | Nil -> + Monad.return acc + | Cons (item, seq) -> + f acc item >>=? fun acc -> 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 = + seq () + >>=? function Nil -> unit_es | Cons (item, seq) -> f item ; iter f seq + +let iter f seq = iter f @@ protect seq + +let rec iter_e f seq = + seq () + >>=? function + | Nil -> unit_es | Cons (item, seq) -> f item >>?= fun () -> iter_e f seq + +let iter_e f seq = iter_e f @@ protect seq + +let rec iter_s f seq = + seq () + >>=? function + | Nil -> unit_es | Cons (item, seq) -> f item >>= fun () -> iter_s f seq + +let iter_s f seq = iter_s f @@ protect seq + +let rec iter_es f seq = + seq () + >>=? function + | Nil -> unit_es | Cons (item, seq) -> f item >>=? fun () -> iter_es f seq + +let iter_es f seq = iter_es f @@ protect seq + +let rec map f seq () = + seq () + >>=? function + | Nil -> nil_es | Cons (item, seq) -> Monad.return (Cons (f item, map f seq)) + +let map f seq = map f @@ protect seq + +let rec map_e f seq () = + seq () + >>=? function + | Nil -> + nil_es + | Cons (item, seq) -> + f item >>?= fun item -> Monad.return (Cons (item, map_e f seq)) + +let map_e f seq = map_e f @@ protect seq + +let rec map_s f seq () = + seq () + >>=? function + | Nil -> + nil_es + | Cons (item, seq) -> + f item >>= fun item -> Monad.return (Cons (item, map_s f seq)) + +let map_s f seq = map_s f @@ protect seq + +let rec map_es f seq () = + seq () + >>=? function + | Nil -> + nil_es + | Cons (item, seq) -> + f item >>=? fun item -> Monad.return (Cons (item, map_es f seq)) + +let map_es f seq = map_es f @@ protect seq + +let rec map_error f seq () = + seq () + >>= function + | Ok Nil -> + nil_es + | Ok (Cons (item, seq)) -> + Monad.return (Cons (item, map_error f seq)) + | Error e -> + Lwt.return (Error (f e)) + +let map_error f seq = map_error f @@ protect seq + +let rec map_error_s f seq () = + seq () + >>= function + | Ok Nil -> + nil_es + | Ok (Cons (item, seq)) -> + Monad.return (Cons (item, map_error_s f seq)) + | Error e -> + f e >>= fun e -> Lwt.return (Error e) + +let rec filter f seq () = + seq () + >>=? function + | Nil -> + nil_es + | Cons (item, seq) -> + if f item then Monad.return (Cons (item, seq)) else filter f seq () + +let filter f seq = filter f @@ protect seq + +let rec filter_e f seq () = + seq () + >>=? function + | Nil -> + nil_es + | Cons (item, seq) -> ( + f item + >>?= function + | true -> + Monad.return (Cons (item, filter_e f seq)) + | false -> + filter_e f seq () ) + +let filter_e f seq = filter_e f @@ protect seq + +let rec filter_s f seq () = + seq () + >>=? function + | Nil -> + nil_es + | Cons (item, seq) -> ( + f item + >>= function + | true -> + Monad.return (Cons (item, filter_s f seq)) + | false -> + filter_s f seq () ) + +let filter_s f seq = filter_s f @@ protect seq + +let rec filter_es f seq () = + seq () + >>=? function + | Nil -> + nil_es + | Cons (item, seq) -> ( + f item + >>=? function + | true -> + Monad.return (Cons (item, filter_es f seq)) + | false -> + filter_es f seq () ) + +let filter_es f seq = filter_es f @@ protect seq + +let rec filter_map f seq () = + seq () + >>=? function + | Nil -> + nil_es + | Cons (item, seq) -> ( + match f item with + | None -> + filter_map f seq () + | Some item -> + Monad.return (Cons (item, filter_map f seq)) ) + +let filter_map f seq = filter_map f @@ protect seq + +let rec filter_map_e f seq () = + seq () + >>=? function + | Nil -> + nil_es + | Cons (item, seq) -> ( + f item + >>?= function + | None -> + filter_map_e f seq () + | Some item -> + Monad.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 () = + seq () + >>=? function + | Nil -> + nil_es + | Cons (item, seq) -> ( + f item + >>= function + | None -> + filter_map_s f seq () + | Some item -> + Monad.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 () = + seq () + >>=? function + | Nil -> + nil_es + | Cons (item, seq) -> ( + f item + >>=? function + | None -> + filter_map_es f seq () + | Some item -> + Monad.return (Cons (item, filter_map_es f seq)) ) + +let filter_map_es f seq = filter_map_es f @@ protect seq + +let rec find f seq = + seq () + >>=? function + | Nil -> + Monad.none_es + | Cons (item, seq) -> + if f item then Monad.return (Some item) else find f seq + +let find f seq = find f @@ protect seq + +let rec find_e f seq = + seq () + >>=? function + | Nil -> + Monad.none_es + | Cons (item, seq) -> ( + f item >>?= function true -> some_es item | false -> find_e f seq ) + +let find_e f seq = find_e f @@ protect seq + +let rec find_s f seq = + seq () + >>=? function + | Nil -> + Monad.none_es + | Cons (item, seq) -> ( + f item >>= function true -> some_es item | false -> find_s f seq ) + +let find_s f seq = find_s f @@ protect seq + +let rec find_es f seq = + seq () + >>=? function + | Nil -> + Monad.none_es + | Cons (item, seq) -> ( + f item >>=? function true -> some_es item | false -> find_es f seq ) + +let find_es f seq = find_es f @@ protect seq + +let rec of_seq seq () = + match seq () with + | Stdlib.Seq.Nil -> + nil_es + | Stdlib.Seq.Cons (e, seq) -> + Monad.return (Cons (e, of_seq seq)) + +let rec of_seq_e seq () = + match seq () with + | Stdlib.Seq.Nil -> + nil_es + | Stdlib.Seq.Cons (Ok e, seq) -> + Monad.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)) -> + Monad.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.Cons (p, seq) -> + p >>= fun e -> Monad.return (Cons (e, of_seq_s seq)) + +let rec of_seqs seq () = + seq () + >>= function + | Seq_s.Nil -> + nil_es + | Seq_s.Cons (e, seq) -> + Monad.return (Cons (e, of_seqs seq)) + +let rec of_seq_es seq () = + match seq () with + | Stdlib.Seq.Nil -> + nil_es + | Stdlib.Seq.Cons (p, seq) -> ( + p + >>= function + | Error _ as e -> + Lwt.return e + | Ok e -> + Monad.return (Cons (e, of_seq_es seq)) ) diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq_es.mli b/src/lib_lwt_result_stdlib/bare/structs/seq_es.mli new file mode 100644 index 000000000000..fe1f6a00605c --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_es.mli @@ -0,0 +1,29 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +include + Bare_sigs.Seq_es.S + with type ('a, 'e) seq_e_t := ('a, 'e) Seq_e.t + and type 'a seq_s_t := 'a Seq_s.t diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq_s.ml b/src/lib_lwt_result_stdlib/bare/structs/seq_s.ml new file mode 100644 index 000000000000..e6d0c198537a --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_s.ml @@ -0,0 +1,233 @@ +(*****************************************************************************) +(* *) +(* 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 Monad + +type +'a node = Nil | Cons of 'a * 'a t + +and 'a t = unit -> 'a node Lwt.t + +let protect seq () = Lwt.apply seq () + +let nil_s = Lwt.return Nil + +let empty () = nil_s + +let return x () = Lwt.return (Cons (x, empty)) + +let return_s p () = Lwt.map (fun x -> Cons (x, empty)) p + +let rec fold_left f acc seq = + seq () + >>= function + | Nil -> Lwt.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 = + seq () + >>= function + | Nil -> + Monad.return acc + | Cons (item, seq) -> + Result.bind_s (f acc item) (fun 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 = + seq () + >>= function + | Nil -> + Lwt.return acc + | Cons (item, seq) -> + f acc item >>= fun acc -> 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 = + seq () + >>= function + | Nil -> + Monad.return acc + | Cons (item, seq) -> + f acc item >>=? fun acc -> 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 = + seq () >>= function Nil -> unit_s | Cons (item, seq) -> f item ; iter f seq + +let iter f seq = iter f @@ protect seq + +let rec iter_e f seq = + seq () + >>= function + | Nil -> unit_es | Cons (item, seq) -> f item >>?= fun () -> iter_e f seq + +let iter_e f seq = iter_e f @@ protect seq + +let rec iter_s f seq = + seq () + >>= function + | Nil -> unit_s | Cons (item, seq) -> f item >>= fun () -> iter_s f seq + +let iter_s f seq = iter_s f @@ protect seq + +let rec iter_es f seq = + seq () + >>= function + | Nil -> unit_es | Cons (item, seq) -> f item >>=? fun () -> iter_es f seq + +let iter_es f seq = iter_es f @@ protect seq + +let iter_ep f seq = + fold_left (fun acc item -> Lwt.apply f item :: acc) [] seq >>= join_ep + +let iter_p f seq = + fold_left (fun acc item -> Lwt.apply f item :: acc) [] seq >>= join_p + +let rec map f seq () = + seq () + >|= function Nil -> Nil | Cons (item, seq) -> Cons (f item, map f seq) + +let map f seq = map f @@ protect seq + +let rec map_s f seq () = + seq () + >>= function + | Nil -> + nil_s + | Cons (item, seq) -> + f item >|= fun item -> Cons (item, map_s f seq) + +let map_s f seq = map_s f @@ protect seq + +let rec filter f seq () = + seq () + >>= function + | Nil -> + nil_s + | Cons (item, seq) -> + if f item then Lwt.return (Cons (item, seq)) else filter f seq () + +let filter f seq = filter f @@ protect seq + +let rec filter_s f seq () = + seq () + >>= function + | Nil -> + nil_s + | Cons (item, seq) -> ( + f item + >>= function + | true -> + Lwt.return (Cons (item, filter_s f seq)) + | false -> + filter_s f seq () ) + +let filter_s f seq = filter_s f @@ protect seq + +let rec filter_map f seq () = + seq () + >>= function + | Nil -> + nil_s + | Cons (item, seq) -> ( + match f item with + | None -> + filter_map f seq () + | Some item -> + Lwt.return (Cons (item, filter_map f seq)) ) + +let filter_map f seq = filter_map f @@ protect seq + +let rec filter_map_s f seq () = + seq () + >>= function + | Nil -> + nil_s + | Cons (item, seq) -> ( + f item + >>= function + | None -> + filter_map_s f seq () + | Some item -> + Lwt.return (Cons (item, filter_map_s f seq)) ) + +let filter_map_s f seq = filter_map_s f @@ protect seq + +let rec find f seq = + seq () + >>= function + | Nil -> + Monad.none_s + | Cons (item, seq) -> + if f item then Lwt.return (Some item) else find f seq + +let find f seq = find f @@ protect seq + +let rec find_e f seq = + seq () + >>= function + | Nil -> + Monad.none_es + | Cons (item, seq) -> ( + f item >>?= function true -> some_es item | false -> find_e f seq ) + +let find_e f seq = find_e f @@ protect seq + +let rec find_s f seq = + seq () + >>= function + | Nil -> + none_s + | Cons (item, seq) -> ( + f item >>= function true -> some_s item | false -> find_s f seq ) + +let find_s f seq = find_s f @@ protect seq + +let rec find_es f seq = + seq () + >>= function + | Nil -> + none_es + | Cons (item, seq) -> ( + f item >>=? function true -> some_es item | false -> find_es f seq ) + +let find_es f seq = find_es f @@ protect seq + +let rec of_seq seq () = + match seq () with + | Stdlib.Seq.Nil -> + nil_s + | 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.Cons (p, seq) -> + p >|= fun e -> Cons (e, of_seq_s seq) diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq_s.mli b/src/lib_lwt_result_stdlib/bare/structs/seq_s.mli new file mode 100644 index 000000000000..b149d698c4f8 --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_s.mli @@ -0,0 +1,26 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +include Bare_sigs.Seq_s.S diff --git a/src/lib_lwt_result_stdlib/lwtreslib.ml b/src/lib_lwt_result_stdlib/lwtreslib.ml index 2059073b8b6d..47ba02a6b9b1 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.ml +++ b/src/lib_lwt_result_stdlib/lwtreslib.ml @@ -31,6 +31,9 @@ module Bare = struct module Option = Bare_structs.Option module Result = Bare_structs.Result module Seq = Bare_structs.Seq + module Seq_e = Bare_structs.Seq_e + module Seq_s = Bare_structs.Seq_s + module Seq_es = Bare_structs.Seq_es module Set = Bare_structs.Set module WithExceptions = Bare_structs.WithExceptions end diff --git a/src/lib_lwt_result_stdlib/lwtreslib.mli b/src/lib_lwt_result_stdlib/lwtreslib.mli index 0dd8b1388b57..4981b406c16b 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.mli +++ b/src/lib_lwt_result_stdlib/lwtreslib.mli @@ -125,6 +125,26 @@ carries all the other errors in a list. It is up to the user to convert this list to a more manageable type if needed. + {3 A note on [Seq]} + + The [Seq] module exports a type that suspends nodes under a closure. + Consequently, some interactions with result, Lwt, and result-Lwt is not + possible. E.g., [map]ping can be either lazy or within Lwt but not both: + [Seq.map_s] would have type [('a -> 'b Lwt.t) -> 'a t -> 'b t Lwt.t] where + the returned promise forces the whole sequence (and never resolves on + infinite sequences). + + In Lwtreslib, [Seq] does not provide these additional traversors 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. + + If you want to map a sequnence using an Lwt-returning function, you should + do the following: [Seq_s.map_s f (Seq_s.of_seq s)]. 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. + {3 [Traced]} The {!Traced} module offers a small wrapper around Lwtreslib. This wrapper @@ -242,6 +262,15 @@ module Bare : sig module Seq : Bare_sigs.Seq.S + module Seq_e : Bare_sigs.Seq_e.S + + module Seq_s : Bare_sigs.Seq_s.S + + module Seq_es : + Bare_sigs.Seq_es.S + with type ('a, 'e) seq_e_t := ('a, 'e) Seq_e.t + and type 'a seq_s_t := 'a Seq_s.t + module Set : Bare_sigs.Set.S module WithExceptions : Bare_sigs.WithExceptions.S @@ -292,6 +321,16 @@ module Traced (Trace : Traced_sigs.Trace.S) : sig module Seq : Traced_sigs.Seq.S with type 'error trace := 'error Trace.trace + module Seq_e : Traced_sigs.Seq_e.S + + module Seq_s : + Traced_sigs.Seq_s.S with type 'error trace := 'error Trace.trace + + module Seq_es : + Traced_sigs.Seq_es.S + with type ('a, 'e) seq_e_t := ('a, 'e) Seq_e.t + and type 'a seq_s_t := 'a Seq_s.t + module Set : Traced_sigs.Set.S with type 'error trace := 'error Trace.trace module WithExceptions : Traced_sigs.WithExceptions.S diff --git a/src/lib_lwt_result_stdlib/test/dune b/src/lib_lwt_result_stdlib/test/dune index 8517dbabf9ca..d4eea23096d6 100644 --- a/src/lib_lwt_result_stdlib/test/dune +++ b/src/lib_lwt_result_stdlib/test/dune @@ -6,6 +6,7 @@ test_fuzzing_seq test_fuzzing_list test_fuzzing_set + test_fuzzing_seq_tiered ) (libraries tezos-lwt-result-stdlib @@ -45,6 +46,9 @@ (rule (alias runtest_fuzzing_set) (action (run %{exe:test_fuzzing_set.exe}))) +(rule + (alias runtest_fuzzing_seq_tiered) + (action (run %{exe:test_fuzzing_seq_tiered.exe}))) (rule (alias runtest) @@ -56,6 +60,7 @@ (alias runtest_fuzzing_seq) (alias runtest_fuzzing_list) (alias runtest_fuzzing_set) + (alias runtest_fuzzing_seq_tiered) ) (action (progn)) ) diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml index af282a9cc310..f42d3c267121 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml @@ -192,6 +192,10 @@ module IterSOf = struct r := fn !r y ; Lwt.return_unit + let monotonous r fn const y = + r := !r + fn const y ; + Lwt.return_unit + let fn_s r fn y = fn !r y >|= fun t -> r := t end @@ -262,6 +266,10 @@ module IterESOf = struct r := fn !r y ; unit_es + let monotonous r fn const y = + r := !r + fn const y ; + unit_es + let fn_e r fn y = Lwt.return @@ fn !r y >|=? fun t -> r := t let fn_s r fn y = diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_seq.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_seq.ml index 06368df59574..921ca0a6d026 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_seq.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_seq.ml @@ -50,16 +50,6 @@ let wrap (name, (module Test : F)) = let () = let name = "Test_fuzzing_seq" in - let tests = - [ ("TestSeqIterfold", (module TestIterFold : F)); - ("Filter", (module TestFilterAgainstStdlibList : F)); - ("Filtermap", (module TestFiltermapAgainstStdlibList : F)); - ("Fold", (module TestFoldAgainstStdlibList : F)); - ("Iter", (module TestIterAgainstStdlibList : F)); - ("Iterp", (module TestIterMonotoneAgainstStdlibList : F)); - ("Map", (module TestMapAgainstStdlibList : F)); - ("Mapp", (module TestMappAgainstStdlibList : F)); - ("Find", (module TestFindStdlibList : F)) ] - in + let tests = [("TestSeqIterfold", (module TestIterFold : F))] in let tests = List.map wrap tests in Alcotest.run name tests 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 new file mode 100644 index 000000000000..eec117ea6034 --- /dev/null +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_tiered.ml @@ -0,0 +1,219 @@ +(*****************************************************************************) +(* *) +(* 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 ; unit_es + + let iter_s f s = iter_s f s >>= fun () -> unit_es + + 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 QCheck + open Monad + + let test_iter = + Test.make + ~name:(Format.asprintf "Seq{,_%s}.iter" Tier.suffix) + (triple Test_fuzzing_helpers.Fn.arith one many) + (fun (Fun (_, fn), init, input) -> + eq_es + (let acc = ref init in + TieredSeq.iter (IterOf.fn acc fn) (List.to_seq input) + >>=? fun () -> Monad.return !acc) + (let acc = ref init in + Tier.iter (IterOf.fn acc fn) (Tier.of_seq @@ List.to_seq input) + >>=? fun () -> Monad.return !acc)) + + let test_iter_e = + Test.make + ~name:(Format.asprintf "Seq{,%s}.iter_e" Tier.suffix) + (triple Test_fuzzing_helpers.Fn.arith one many) + (fun (Fun (_, fn), init, input) -> + let open Monad in + eq_es + (let acc = ref init in + TieredSeq.iter_e (IterEOf.fn acc fn) (List.to_seq input) + >>=? fun () -> return !acc) + (let acc = ref init in + Tier.iter_e (IterEOf.fn acc fn) (Tier.of_seq @@ List.to_seq input) + >>=? fun () -> return !acc)) + + let test_iter_s = + Test.make + ~name:(Format.asprintf "Seq{,%s}.iter_s" Tier.suffix) + (triple Test_fuzzing_helpers.Fn.arith one many) + (fun (Fun (_, fn), init, input) -> + eq_es + (let acc = ref init in + TieredSeq.iter_s (IterSOf.fn acc fn) (List.to_seq input) + >>=? fun () -> Monad.return !acc) + (let acc = ref init in + Tier.iter_s (IterSOf.fn acc fn) (Tier.of_seq @@ List.to_seq input) + >>=? fun () -> Monad.return !acc)) + + let test_iter_es = + Test.make + ~name:(Format.asprintf "Seq{,%s}.iter_es" Tier.suffix) + (triple Test_fuzzing_helpers.Fn.arith one many) + (fun (Fun (_, fn), init, input) -> + eq_es + (let acc = ref init in + TieredSeq.iter_es (IterESOf.fn acc fn) (List.to_seq input) + >>=? fun () -> Monad.return !acc) + (let acc = ref init in + Tier.iter_es (IterESOf.fn acc fn) (Tier.of_seq @@ List.to_seq input) + >>=? fun () -> Monad.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 + + open Monad + + let iter f s = iter f s >>= fun () -> unit_es + + let iter_s f s = iter_s f s >>= fun () -> unit_es +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 QCheck in + Test.make + ~name:(Format.asprintf "Seq{,_s}.iter_ep") + (quad Test_fuzzing_helpers.Fn.arith one one many) + (fun (Fun (_, fn), const, init, input) -> + let open Monad in + eq_es + (let acc = ref init in + Seq.iter_ep (IterESOf.monotonous acc fn const) (List.to_seq input) + >>=? fun () -> Monad.return !acc) + (let acc = ref init in + Seq_s.iter_ep + (IterESOf.monotonous acc fn const) + (Seq_s.of_seq @@ List.to_seq input) + >>=? fun () -> Monad.return !acc)) + +let iter_p = + let open QCheck in + Test.make + ~name:(Format.asprintf "Seq{,_s}.iter_p") + (quad Test_fuzzing_helpers.Fn.arith one one many) + (fun (Fun (_, fn), const, init, input) -> + let open Monad in + eq_es + (let acc = ref init in + Seq.iter_p (IterSOf.monotonous acc fn const) (List.to_seq input) + >>= fun () -> Monad.return !acc) + (let acc = ref init in + Seq_s.iter_p + (IterSOf.monotonous acc fn const) + (Seq_s.of_seq @@ List.to_seq input) + >>= fun () -> Monad.return !acc)) + +let wrap (name, (module Tier : TIER)) = + let module M = TestIter (Tier) in + (name, Lib_test.Qcheck_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", Lib_test.Qcheck_helpers.qcheck_wrap [iter_p]); + ("iter_ep", Lib_test.Qcheck_helpers.qcheck_wrap [iter_ep]) ] + in + Alcotest.run name tests diff --git a/src/lib_lwt_result_stdlib/test/test_generic.ml b/src/lib_lwt_result_stdlib/test/test_generic.ml index 3d4cb0470765..1cb2c71f3d7f 100644 --- a/src/lib_lwt_result_stdlib/test/test_generic.ml +++ b/src/lib_lwt_result_stdlib/test/test_generic.ml @@ -288,7 +288,31 @@ struct let tests = [Alcotest_lwt.test_case "fail-early" `Quick test_fail_early] end -module SeqMapTest = MakeMapperTest (SeqGen) +let flip_e seq_e = + let open Support.Lib.Monad in + Support.Lib.Seq_e.fold_left (fun acc item -> item :: acc) [] seq_e + >|? List.rev >|? List.to_seq + +let flip_s seq_s = + let open Support.Lib.Monad in + Support.Lib.Seq_s.fold_left (fun acc item -> item :: acc) [] seq_s + >|= List.rev >|= List.to_seq + +let flip_es seq_es = + let open Support.Lib.Monad in + Support.Lib.Seq_es.fold_left (fun acc item -> item :: acc) [] seq_es + >|=? List.rev >|=? List.to_seq + +module SeqMapTest = MakeMapperTest (struct + include SeqGen + + let map_e f seq = flip_e @@ Support.Lib.Seq_e.(map_e f @@ of_seq seq) + + let map_s f seq = flip_s @@ Support.Lib.Seq_s.(map_s f @@ of_seq seq) + + let map_es f seq = flip_es @@ Support.Lib.Seq_es.(map_es f @@ of_seq seq) +end) + module ListMapTest = MakeMapperTest (ListGen) let () = diff --git a/src/lib_lwt_result_stdlib/test/traits_tiered.ml b/src/lib_lwt_result_stdlib/test/traits_tiered.ml new file mode 100644 index 000000000000..5d295787081b --- /dev/null +++ b/src/lib_lwt_result_stdlib/test/traits_tiered.ml @@ -0,0 +1,638 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +type 'error trace = 'error Support.Lib.Monad.trace + +module type BASE_E = sig + val name : string + + type 'a elt + + type ('a_elt, 'e) t + + val of_list : int list -> (int, 'e) t + + val to_list : (int, 'e) t -> (int list, 'e) result + + val pp : Format.formatter -> (int, 'e) t -> unit +end + +module type BASE_S = sig + val name : string + + type 'a elt + + type 'a_elt t + + val of_list : int list -> int t + + val to_list : int t -> int list Lwt.t + + val pp : Format.formatter -> int t -> unit Lwt.t +end + +module type BASE_ES = sig + val name : string + + type 'a elt + + type ('a_elt, 'e) t + + val of_list : int list -> (int, 'e) t + + val to_list : (int, 'e) t -> (int list, 'e) result Lwt.t + + val pp : Format.formatter -> (int, 'e) t -> unit Lwt.t +end + +module type ITER_VANILLA = sig + type 'a elt + + type 'a t + + val iter : ('a elt -> unit) -> 'a t -> unit +end + +module type ITER_SEQUENTIAL = sig + include ITER_VANILLA + + val iter_e : + ('a elt -> (unit, 'trace) result) -> 'a t -> (unit, 'trace) result + + val iter_s : ('a elt -> unit Lwt.t) -> 'a t -> unit Lwt.t + + val iter_es : + ('a elt -> (unit, 'trace) result Lwt.t) -> + 'a t -> + (unit, 'trace) result Lwt.t +end + +module type ITER_PARALLEL = sig + include ITER_SEQUENTIAL + + val iter_p : ('a elt -> unit Lwt.t) -> 'a t -> unit Lwt.t + + val iter_ep : + ('a elt -> (unit, 'error trace) result Lwt.t) -> + 'a t -> + (unit, 'error trace) result Lwt.t +end + +module type ITERI_VANILLA = sig + type 'a elt + + type 'a t + + val iteri : (int -> 'a elt -> unit) -> 'a t -> unit +end + +module type ITERI_SEQUENTIAL = sig + include ITERI_VANILLA + + val iteri_e : + (int -> 'a elt -> (unit, 'trace) result) -> 'a t -> (unit, 'trace) result + + val iteri_s : (int -> 'a elt -> unit Lwt.t) -> 'a t -> unit Lwt.t + + val iteri_es : + (int -> 'a elt -> (unit, 'trace) result Lwt.t) -> + 'a t -> + (unit, 'trace) result Lwt.t +end + +module type MAP_VANILLA = sig + type 'a t + + val map : ('a -> 'b) -> 'a t -> 'b t +end + +module type MAP_SEQUENTIAL = sig + include MAP_VANILLA + + val map_e : ('a -> ('b, 'trace) result) -> 'a t -> ('b t, 'trace) result + + val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t Lwt.t + + val map_es : + ('a -> ('b, 'trace) result Lwt.t) -> 'a t -> ('b t, 'trace) result Lwt.t +end + +module type MAP_PARALLEL = sig + include MAP_SEQUENTIAL + + val map_p : ('a -> 'b Lwt.t) -> 'a t -> 'b t Lwt.t + + val map_ep : + ('a -> ('b, 'error trace) result Lwt.t) -> + 'a t -> + ('b t, 'error trace) result Lwt.t +end + +module type REVMAP_VANILLA = sig + type 'a t + + val rev : 'a t -> 'a t + + val rev_map : ('a -> 'b) -> 'a t -> 'b t +end + +module type REVMAP_SEQUENTIAL = sig + include REVMAP_VANILLA + + val rev_map_e : ('a -> ('b, 'trace) result) -> 'a t -> ('b t, 'trace) result + + val rev_map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t Lwt.t + + val rev_map_es : + ('a -> ('b, 'trace) result Lwt.t) -> 'a t -> ('b t, 'trace) result Lwt.t +end + +module type REVMAP_PARALLEL = sig + include REVMAP_SEQUENTIAL + + val rev_map_p : ('a -> 'b Lwt.t) -> 'a t -> 'b t Lwt.t + + val rev_map_ep : + ('a -> ('b, 'error trace) result Lwt.t) -> + 'a t -> + ('b t, 'error trace) result Lwt.t +end + +module type FOLDLEFT_VANILLA = sig + type 'a elt + + type 'a t + + val fold_left : ('a -> 'b elt -> 'a) -> 'a -> 'b t -> 'a +end + +module type FOLDLEFT_SEQUENTIAL = sig + include FOLDLEFT_VANILLA + + val fold_left_e : + ('a -> 'b elt -> ('a, 'trace) result) -> 'a -> 'b t -> ('a, 'trace) result + + val fold_left_s : ('a -> 'b elt -> 'a Lwt.t) -> 'a -> 'b t -> 'a Lwt.t + + val fold_left_es : + ('a -> 'b elt -> ('a, 'trace) result Lwt.t) -> + 'a -> + 'b t -> + ('a, 'trace) result Lwt.t +end + +module type FOLDRIGHT_VANILLA = sig + type 'a t + + val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b +end + +module type FOLDRIGHT_SEQUENTIAL = sig + include FOLDRIGHT_VANILLA + + val fold_right_e : + ('a -> 'b -> ('b, 'trace) result) -> 'a t -> 'b -> ('b, 'trace) result + + val fold_right_s : ('a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t + + val fold_right_es : + ('a -> 'b -> ('b, 'trace) result Lwt.t) -> + 'a t -> + 'b -> + ('b, 'trace) result Lwt.t +end + +(* Fold Out-Of-Order (more precisely, in unspecified order) *) +module type FOLDOOO_VANILLA = sig + type 'a elt + + type 'a t + + val fold : ('b elt -> 'a -> 'a) -> 'b t -> 'a -> 'a +end + +module type FOLDOOO_SEQUENTIAL = sig + include FOLDOOO_VANILLA + + val fold_e : + ('b elt -> 'a -> ('a, 'trace) result) -> 'b t -> 'a -> ('a, 'trace) result + + val fold_s : ('b elt -> 'a -> 'a Lwt.t) -> 'b t -> 'a -> 'a Lwt.t + + val fold_es : + ('b elt -> 'a -> ('a, 'trace) result Lwt.t) -> + 'b t -> + 'a -> + ('a, 'trace) result Lwt.t +end + +module type EXISTFORALL_VANILLA = sig + type 'a elt + + type 'a t + + val exists : ('a elt -> bool) -> 'a t -> bool + + val for_all : ('a elt -> bool) -> 'a t -> bool +end + +module type EXISTFORALL_SEQUENTIAL = sig + include EXISTFORALL_VANILLA + + val exists_e : + ('a elt -> (bool, 'trace) result) -> 'a t -> (bool, 'trace) result + + val exists_s : ('a elt -> bool Lwt.t) -> 'a t -> bool Lwt.t + + val exists_es : + ('a elt -> (bool, 'trace) result Lwt.t) -> + 'a t -> + (bool, 'trace) result Lwt.t + + val for_all_e : + ('a elt -> (bool, 'trace) result) -> 'a t -> (bool, 'trace) result + + val for_all_s : ('a elt -> bool Lwt.t) -> 'a t -> bool Lwt.t + + val for_all_es : + ('a elt -> (bool, 'trace) result Lwt.t) -> + 'a t -> + (bool, 'trace) result Lwt.t +end + +module type EXISTFORALL_PARALLEL = sig + include EXISTFORALL_SEQUENTIAL + + val exists_p : ('a elt -> bool Lwt.t) -> 'a t -> bool Lwt.t + + val exists_ep : + ('a elt -> (bool, 'error trace) result Lwt.t) -> + 'a t -> + (bool, 'error trace) result Lwt.t + + val for_all_p : ('a elt -> bool Lwt.t) -> 'a t -> bool Lwt.t + + val for_all_ep : + ('a elt -> (bool, 'error trace) result Lwt.t) -> + 'a t -> + (bool, 'error trace) result Lwt.t +end + +module type FILTER_VANILLA = sig + type 'a elt + + type 'a t + + val filter : ('a -> bool) -> 'a t -> 'a t +end + +module type FILTER_SEQUENTIAL = sig + include FILTER_VANILLA + + val filter_e : ('a -> (bool, 'trace) result) -> 'a t -> ('a t, 'trace) result + + val filter_s : ('a -> bool Lwt.t) -> 'a t -> 'a t Lwt.t + + val filter_es : + ('a -> (bool, 'trace) result Lwt.t) -> 'a t -> ('a t, 'trace) result Lwt.t +end + +module type FILTER_PARALLEL = sig + type 'a t + + val filter_p : ('a -> bool Lwt.t) -> 'a t -> 'a t Lwt.t + + val filter_ep : + ('a -> (bool, 'error trace) result Lwt.t) -> + 'a t -> + ('a t, 'error trace) result Lwt.t +end + +module type FILTERMAP_VANILLA = sig + type 'a t + + val filter_map : ('a -> 'b option) -> 'a t -> 'b t +end + +module type FILTERMAP_SEQUENTIAL = sig + include FILTERMAP_VANILLA + + val filter_map_e : + ('a -> ('b option, 'trace) result) -> 'a t -> ('b t, 'trace) result + + val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t Lwt.t + + val filter_map_es : + ('a -> ('b option, 'trace) result Lwt.t) -> + 'a t -> + ('b t, 'trace) result Lwt.t +end + +module type FILTERMAP_PARALLEL = sig + type 'a t + + val filter_map_p : ('a -> 'b option Lwt.t) -> 'a t -> 'b t Lwt.t + + val filter_map_ep : + ('a -> ('b option, 'error trace) result Lwt.t) -> + 'a t -> + ('b t, 'error trace) result Lwt.t +end + +module type FIND_VANILLA = sig + type 'a t + + val find : ('a -> bool) -> 'a t -> 'a option +end + +module type FIND_SEQUENTIAL = sig + include FIND_VANILLA + + val find_e : + ('a -> (bool, 'trace) result) -> 'a t -> ('a option, 'trace) result + + val find_s : ('a -> bool Lwt.t) -> 'a t -> 'a option Lwt.t + + val find_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a t -> + ('a option, 'trace) result Lwt.t +end + +module type PARTITION_VANILLA = sig + type 'a t + + val partition : ('a -> bool) -> 'a t -> 'a t * 'a t +end + +module type PARTITION_SEQUENTIAL = sig + include PARTITION_VANILLA + + val partition_e : + ('a -> (bool, 'trace) result) -> 'a t -> ('a t * 'a t, 'trace) result + + val partition_s : ('a -> bool Lwt.t) -> 'a t -> ('a t * 'a t) Lwt.t + + val partition_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a t -> + ('a t * 'a t, 'trace) result Lwt.t +end + +module type PARTITION_PARALLEL = sig + include PARTITION_SEQUENTIAL + + val partition_p : ('a -> bool Lwt.t) -> 'a t -> ('a t * 'a t) Lwt.t + + val partition_ep : + ('a -> (bool, 'error trace) result Lwt.t) -> + 'a t -> + ('a t * 'a t, 'error trace) result Lwt.t +end + +module type COMBINE_VANILLA = sig + type 'a t + + val combine : + when_different_lengths:'trace -> + 'a t -> + 'b t -> + (('a * 'b) t, 'trace) result + + val combine_with_leftovers : + 'a t -> 'b t -> ('a * 'b) t * [`Left of 'a t | `Right of 'b t] option +end + +module type ALLDOUBLE_VANILLA = sig + type 'a t + + val iter2 : + when_different_lengths:'trace -> + ('a -> 'b -> unit) -> + 'a t -> + 'b t -> + (unit, 'trace) result + + val map2 : + when_different_lengths:'trace -> + ('a -> 'b -> 'c) -> + 'a t -> + 'b t -> + ('c t, 'trace) result + + val rev_map2 : + when_different_lengths:'trace -> + ('a -> 'b -> 'c) -> + 'a t -> + 'b t -> + ('c t, 'trace) result + + val fold_left2 : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> 'a) -> + 'a -> + 'b t -> + 'c t -> + ('a, 'trace) result + + val fold_right2 : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> 'c) -> + 'a t -> + 'b t -> + 'c -> + ('c, 'trace) result + + val for_all2 : + when_different_lengths:'trace -> + ('a -> 'b -> bool) -> + 'a t -> + 'b t -> + (bool, 'trace) result + + val exists2 : + when_different_lengths:'trace -> + ('a -> 'b -> bool) -> + 'a t -> + 'b t -> + (bool, 'trace) result +end + +module type ALLDOUBLE_SEQENTIAL = sig + include ALLDOUBLE_VANILLA + + val iter2_e : + when_different_lengths:'trace -> + ('a -> 'b -> (unit, 'trace) result) -> + 'a t -> + 'b t -> + (unit, 'trace) result + + val iter2_s : + when_different_lengths:'trace -> + ('a -> 'b -> unit Lwt.t) -> + 'a t -> + 'b t -> + (unit, 'trace) result Lwt.t + + val iter2_es : + when_different_lengths:'trace -> + ('a -> 'b -> (unit, 'trace) result Lwt.t) -> + 'a t -> + 'b t -> + (unit, 'trace) result Lwt.t + + val map2_e : + when_different_lengths:'trace -> + ('a -> 'b -> ('c, 'trace) result) -> + 'a t -> + 'b t -> + ('c t, 'trace) result + + val map2_s : + when_different_lengths:'trace -> + ('a -> 'b -> 'c Lwt.t) -> + 'a t -> + 'b t -> + ('c t, 'trace) result Lwt.t + + val map2_es : + when_different_lengths:'trace -> + ('a -> 'b -> ('c, 'trace) result Lwt.t) -> + 'a t -> + 'b t -> + ('c t, 'trace) result Lwt.t + + val rev_map2_e : + when_different_lengths:'trace -> + ('a -> 'b -> ('c, 'trace) result) -> + 'a t -> + 'b t -> + ('c t, 'trace) result + + val rev_map2_s : + when_different_lengths:'trace -> + ('a -> 'b -> 'c Lwt.t) -> + 'a t -> + 'b t -> + ('c t, 'trace) result Lwt.t + + val rev_map2_es : + when_different_lengths:'trace -> + ('a -> 'b -> ('c, 'trace) result Lwt.t) -> + 'a t -> + 'b t -> + ('c t, 'trace) result Lwt.t + + val fold_left2_e : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> ('a, 'trace) result) -> + 'a -> + 'b t -> + 'c t -> + ('a, 'trace) result + + val fold_left2_s : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> 'a Lwt.t) -> + 'a -> + 'b t -> + 'c t -> + ('a, 'trace) result Lwt.t + + val fold_left2_es : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> ('a, 'trace) result Lwt.t) -> + 'a -> + 'b t -> + 'c t -> + ('a, 'trace) result Lwt.t + + val fold_right2_e : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> ('c, 'trace) result) -> + 'a t -> + 'b t -> + 'c -> + ('c, 'trace) result + + val fold_right2_s : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> 'c Lwt.t) -> + 'a t -> + 'b t -> + 'c -> + ('c, 'trace) result Lwt.t + + val fold_right2_es : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> ('c, 'trace) result Lwt.t) -> + 'a t -> + 'b t -> + 'c -> + ('c, 'trace) result Lwt.t + + val for_all2_e : + when_different_lengths:'trace -> + ('a -> 'b -> (bool, 'trace) result) -> + 'a t -> + 'b t -> + (bool, 'trace) result + + val for_all2_s : + when_different_lengths:'trace -> + ('a -> 'b -> bool Lwt.t) -> + 'a t -> + 'b t -> + (bool, 'trace) result Lwt.t + + val for_all2_es : + when_different_lengths:'trace -> + ('a -> 'b -> (bool, 'trace) result Lwt.t) -> + 'a t -> + 'b t -> + (bool, 'trace) result Lwt.t + + val exists2_e : + when_different_lengths:'trace -> + ('a -> 'b -> (bool, 'trace) result) -> + 'a t -> + 'b t -> + (bool, 'trace) result + + val exists2_s : + when_different_lengths:'trace -> + ('a -> 'b -> bool Lwt.t) -> + 'a t -> + 'b t -> + (bool, 'trace) result Lwt.t + + val exists2_es : + when_different_lengths:'trace -> + ('a -> 'b -> (bool, 'trace) result Lwt.t) -> + 'a t -> + 'b t -> + (bool, 'trace) result Lwt.t +end diff --git a/src/lib_lwt_result_stdlib/traced/sigs/dune b/src/lib_lwt_result_stdlib/traced/sigs/dune index 6948983e2b1f..0ff7f6232606 100644 --- a/src/lib_lwt_result_stdlib/traced/sigs/dune +++ b/src/lib_lwt_result_stdlib/traced/sigs/dune @@ -1,7 +1,13 @@ (library (name traced_sigs) (public_name tezos-lwt-result-stdlib.traced.sigs) - (libraries lwt tezos-lwt-result-stdlib.bare.sigs tezos-lwt-result-stdlib.traced.functor-outputs)) + (libraries + lwt + tezos-lwt-result-stdlib.bare.sigs + tezos-lwt-result-stdlib.bare.structs + tezos-lwt-result-stdlib.traced.functor-outputs + ) +) (rule (alias runtest_lint) diff --git a/src/lib_lwt_result_stdlib/traced/sigs/seq.ml b/src/lib_lwt_result_stdlib/traced/sigs/seq.ml index 1f15ff6d6398..049a5c5250ee 100644 --- a/src/lib_lwt_result_stdlib/traced/sigs/seq.ml +++ b/src/lib_lwt_result_stdlib/traced/sigs/seq.ml @@ -48,20 +48,4 @@ module type S = sig ('a -> (unit, 'error trace) result Lwt.t) -> 'a t -> (unit, 'error trace) result Lwt.t - - (** Similar to {!map} but wraps the transformation in [result Lwt]. All the - transformations are done concurrently. The promise [map_ep f s] resolves - once all the promises of the traversal resolve. At this point it is - rejected if any of the promises are, and otherwise it is resolved with - [Error _] if any of the promises are, and otherwise it is fulfilled (if - all the promises are). - - Note that, unlike {!map}, [map_ep] is not lazy: it applies the - transformation eagerly to all the elements of the sequence and does not - terminate on infinite sequences. Moreover [map_ep] is not tail-recursive. - *) - val map_ep : - ('a -> ('b, 'error trace) result Lwt.t) -> - 'a t -> - ('b t, 'error trace) result Lwt.t end diff --git a/src/lib_lwt_result_stdlib/traced/sigs/seq_e.ml b/src/lib_lwt_result_stdlib/traced/sigs/seq_e.ml new file mode 100644 index 000000000000..8e267bea458b --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/sigs/seq_e.ml @@ -0,0 +1,54 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** The [S] signature is similar to [Seq.S] except that suspended nodes are + wrapped in a result. + + This allows some additional traversors to be applied lazily. + + The functions [of_seq] and [of_seq_e] allow conversion from vanilla + sequences. *) +module type S = + Bare_sigs.Seq_e.S + with type ('a, 'e) node = ('a, 'e) Bare_structs.Seq_e.node + and type ('a, 'e) t = ('a, 'e) Bare_structs.Seq_e.t + +(* Developer note: + + Due to the type of sequences and the availability of traces, we can add the + following traversors that are not supported in the [Bare] version. We will + add those in future versions. + + - [iter_p] which returns a [Trace.cons] of the sequence-interruption and the + [Trace.conp_list] of the iterator errors. We need to decide on a semantic: + which error is consed "above" the other? + + - [stitch] which "concatenates" multiple sequences, stacking the interrupting + errors for the end. + + - [recover] which feeds the interruption error into an unfold to continue the + sequence. + + Also note that those can be made available in [Seq_es] too. *) diff --git a/src/lib_lwt_result_stdlib/traced/sigs/seq_es.ml b/src/lib_lwt_result_stdlib/traced/sigs/seq_es.ml new file mode 100644 index 000000000000..81cb3f8ec87f --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/sigs/seq_es.ml @@ -0,0 +1,40 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** The [S] signature is similar to [Seq.S] except that suspended nodes are + wrapped in a result-Lwt. + + This allows some additional traversors to be applied lazily. + + The functions [of_seq] and [of_seq_*] allow conversion from vanilla + sequences. *) +module type S = + Bare_sigs.Seq_es.S + with type ('a, 'e) node = ('a, 'e) Bare_structs.Seq_es.node + and type ('a, 'e) t = ('a, 'e) Bare_structs.Seq_es.t + +(* Developer note: + + See {!Traced_sigs.Seq_e} for developer note. *) diff --git a/src/lib_lwt_result_stdlib/traced/sigs/seq_s.ml b/src/lib_lwt_result_stdlib/traced/sigs/seq_s.ml new file mode 100644 index 000000000000..83c96feba099 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/sigs/seq_s.ml @@ -0,0 +1,54 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** The [S] signature is similar to [Seq.S] except that suspended nodes are + wrapped in a promise. + + This allows some additional traversors to be applied lazily. + + The functions [of_seq] and [of_seq_s] allow conversion from vanilla + sequences. *) +module type S = sig + include + Bare_sigs.Seq_s.S + with type 'a node = 'a Bare_structs.Seq_s.node + and type 'a t = 'a Bare_structs.Seq_s.t + + (** ['error trace] is intended to be substituted by a type provided by a + [Trace] module ([with type 'error trace := 'error Trace.trace]) *) + type 'error trace + + (** Similar to {!iter} but wraps the iteration in [result Lwt.t]. All the + steps of the iteration are started concurrently. The promise [iter_ep] + resolves once all the promises of the traversal resolve. At this point it + is either: + - rejected if at least one of the promises is, or + - fulfilled with [Error _] if at least one of the promises is, or + - fulfilled with [Ok ()] if all the promises are. *) + val iter_ep : + ('a -> (unit, 'error trace) result Lwt.t) -> + 'a 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 f60fba120a96..4f996dead4d6 100644 --- a/src/lib_lwt_result_stdlib/traced/structs/seq.ml +++ b/src/lib_lwt_result_stdlib/traced/structs/seq.ml @@ -36,10 +36,4 @@ module Make (Monad : Traced_sigs.Monad.S) : iter_ep f seq (Lwt.apply f item :: acc) in iter_ep f seq [] - - let map_ep f seq = - let open Monad in - all_ep (fold_left (fun acc x -> Lwt.apply f x :: acc) [] seq) - >|=? (* this is equivalent to rev |> to_seq but more direct *) - Stdlib.List.fold_left (fun s x () -> Cons (x, s)) empty end diff --git a/src/lib_lwt_result_stdlib/traced/structs/seq_e.ml b/src/lib_lwt_result_stdlib/traced/structs/seq_e.ml new file mode 100644 index 000000000000..03b4dda2b67d --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/structs/seq_e.ml @@ -0,0 +1,26 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +include Bare_structs.Seq_e diff --git a/src/lib_lwt_result_stdlib/traced/structs/seq_e.mli b/src/lib_lwt_result_stdlib/traced/structs/seq_e.mli new file mode 100644 index 000000000000..6b913ce77d5a --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/structs/seq_e.mli @@ -0,0 +1,26 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +include Traced_sigs.Seq_e.S diff --git a/src/lib_lwt_result_stdlib/traced/structs/seq_es.ml b/src/lib_lwt_result_stdlib/traced/structs/seq_es.ml new file mode 100644 index 000000000000..09057388b806 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/structs/seq_es.ml @@ -0,0 +1,55 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +module Make + (Monad : Traced_sigs.Monad.S) + (Seq_e : Traced_sigs.Seq_e.S) + (Seq_s : Traced_sigs.Seq_s.S with type 'error trace := 'error Monad.trace) : + Traced_sigs.Seq_es.S + with type ('a, 'e) node = ('a, 'e) Bare_structs.Seq_es.node + and type ('a, 'e) t = ('a, 'e) Bare_structs.Seq_es.t + and type ('a, 'e) seq_e_t := ('a, 'e) Seq_e.t + 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.Cons (item, seq)) -> + Monad.return (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.Cons (e, seq) -> + Monad.return (Cons (e, of_seqs seq)) +end diff --git a/src/lib_lwt_result_stdlib/traced/structs/seq_es.mli b/src/lib_lwt_result_stdlib/traced/structs/seq_es.mli new file mode 100644 index 000000000000..b0792e090570 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/structs/seq_es.mli @@ -0,0 +1,34 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +module Make + (Monad : Traced_sigs.Monad.S) + (Seq_e : Traced_sigs.Seq_e.S) + (Seq_s : Traced_sigs.Seq_s.S with type 'error trace := 'error Monad.trace) : + Traced_sigs.Seq_es.S + with type ('a, 'e) node = ('a, 'e) Bare_structs.Seq_es.node + and type ('a, 'e) t = ('a, 'e) Bare_structs.Seq_es.t + and type ('a, 'e) seq_e_t := ('a, 'e) Seq_e.t + and type 'a seq_s_t := 'a Seq_s.t diff --git a/src/lib_lwt_result_stdlib/traced/structs/seq_s.ml b/src/lib_lwt_result_stdlib/traced/structs/seq_s.ml new file mode 100644 index 000000000000..f43f1393fcc7 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/structs/seq_s.ml @@ -0,0 +1,36 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +module Make (Monad : Traced_sigs.Monad.S) : + Traced_sigs.Seq_s.S + with type 'error trace := 'error Monad.trace + and type 'a node = 'a Bare_structs.Seq_s.node + and type 'a t = 'a Bare_structs.Seq_s.t = struct + include Bare_structs.Seq_s + + let iter_ep f seq = + let open Monad in + fold_left (fun acc x -> Lwt.apply f x :: acc) [] seq >>= join_ep +end diff --git a/src/lib_lwt_result_stdlib/traced/structs/seq_s.mli b/src/lib_lwt_result_stdlib/traced/structs/seq_s.mli new file mode 100644 index 000000000000..e75359a73d38 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/structs/seq_s.mli @@ -0,0 +1,30 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +module Make (Monad : Traced_sigs.Monad.S) : + Traced_sigs.Seq_s.S + with type 'error trace := 'error Monad.trace + and type 'a node = 'a Bare_structs.Seq_s.node + and type 'a t = 'a Bare_structs.Seq_s.t diff --git a/src/lib_lwt_result_stdlib/traced/structs/structs.ml b/src/lib_lwt_result_stdlib/traced/structs/structs.ml index 688d887fef4c..e54611e500f1 100644 --- a/src/lib_lwt_result_stdlib/traced/structs/structs.ml +++ b/src/lib_lwt_result_stdlib/traced/structs/structs.ml @@ -34,5 +34,8 @@ module Make (Trace : Traced_sigs.Trace.S) = struct module Option = Bare_structs.Option module Result = Bare_structs.Result module Set = Set.Make (Monad) (Seq) + module Seq_e = Seq_e + module Seq_s = Seq_s.Make (Monad) + module Seq_es = Seq_es.Make (Monad) (Seq_e) (Seq_s) module WithExceptions = Bare_structs.WithExceptions end -- GitLab From 6bd94479ebde8b1977d2da2df881702a87bfcb91 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Thu, 25 Mar 2021 15:14:10 +0100 Subject: [PATCH 02/14] Shell: use now-lazy lwt seq traversal for earlier return --- src/lib_shell/p2p_reader.ml | 30 +++++++++++++----------------- 1 file changed, 13 insertions(+), 17 deletions(-) diff --git a/src/lib_shell/p2p_reader.ml b/src/lib_shell/p2p_reader.ml index 42ce37122fc4..a05680ee482e 100644 --- a/src/lib_shell/p2p_reader.ml +++ b/src/lib_shell/p2p_reader.ml @@ -96,23 +96,19 @@ let find_pending_operation {peer_active_chains; _} h = Distributed_db_requester.Raw_operation.pending chain_db.operation_db h) let read_operation state h = - (* NOTE: to optimise this into an early-return map-and-search we need either a - special [Seq.find_map : ('a -> 'b option) -> 'a Seq.t -> 'b option] - or we need a [Seq.map_s] that is lazy. *) - Chain_id.Table.fold_s - (fun chain_id chain_db acc -> - match acc with - | Some _ -> - Lwt.return acc - | None -> ( - Distributed_db_requester.Raw_operation.read_opt - chain_db.operation_db - h - >>= function - | None -> Lwt.return_none | Some bh -> Lwt.return_some (chain_id, bh) - )) - state.active_chains - None + (* Remember that seqs are lazy. The table is only traversed until a match is + found, the rest is not explored. *) + let id_db_seq = Seq_s.of_seq (Chain_id.Table.to_seq state.active_chains) in + let id_bh_seq = + Seq_s.filter_map_s + (fun (chain_id, chain_db) -> + Distributed_db_requester.Raw_operation.read_opt chain_db.operation_db h + >|= Option.map (fun bh -> (chain_id, bh))) + id_db_seq + in + id_bh_seq () + >>= function + | Seq_s.Nil -> Lwt.return_none | Seq_s.Cons (item, _) -> Lwt.return_some item let read_block {disk; _} h = Store.all_chain_stores disk -- GitLab From b4d7b6c57941e0b648e681a004a5639cb5618f6f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 17 Mar 2021 09:20:54 +0100 Subject: [PATCH 03/14] Lwtreslib: require explicit ~equal to avoid polymorphic equality --- src/lib_lwt_result_stdlib/bare/sigs/list.ml | 41 +++++++++++++--- .../bare/structs/list.ml | 47 ++++++++++++++++++- src/lib_lwt_result_stdlib/lwtreslib.mli | 12 +++++ 3 files changed, 93 insertions(+), 7 deletions(-) diff --git a/src/lib_lwt_result_stdlib/bare/sigs/list.ml b/src/lib_lwt_result_stdlib/bare/sigs/list.ml index b5ee561c6ad9..867606853b53 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/list.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/list.ml @@ -144,15 +144,38 @@ module type S = sig [predicate x] is [true] or [None] if the list [xs] has no such element. *) val find : ('a -> bool) -> 'a list -> 'a option - (** [assoc k kvs] is [v] such that [(k', v)] is the first pair in the list - such that [k' = k] (uses the polymorphic equality) or [None] if the list - contains no such pair. *) - val assoc : 'a -> ('a * 'b) list -> 'b option + (** [mem ~equal a l] is [true] iff there is an element [e] of [l] such that + [equal a e]. *) + val mem : equal:('a -> 'a -> bool) -> 'a -> 'a list -> bool - (** [assq k kvs] is the same as [assoc k kvs] but it uses the physical - equality. *) + (** [assoc ~equal k kvs] is [Some v] such that [(k', v)] is the first pair in + the list such that [equal k' k] or [None] if the list contains no such + pair. *) + val assoc : equal:('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> 'b option + + val assoc_opt : equal:('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> 'b option + + (** [assq k kvs] is the same as [assoc ~equal:Stdlib.( == ) k kvs]: it uses + the physical equality. *) val assq : 'a -> ('a * 'b) list -> 'b option + val assq_opt : 'a -> ('a * 'b) list -> 'b option + + (** [mem_assoc ~equal k l] is equivalent to + [Option.is_some @@ assoc ~equal k l]. *) + val mem_assoc : equal:('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> bool + + (** [mem_assq k l] is [mem_assoc ~equal:Stdlib.( == ) k l]. *) + val mem_assq : 'a -> ('a * 'b) list -> bool + + (** [remove_assoc ~equal k l] is [l] without the first element [(k', _)] such + that [equal k k']. *) + val remove_assoc : + equal:('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> ('a * 'b) list + + (** [remove_assoq k l] is [remove_assoc ~equal:Stdlib.( == ) k l]. *) + val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list + (** {4 Initialisation} *) (** [init ~when_negative_length n f] is [Error when_negative_length] if [n] is @@ -776,4 +799,10 @@ module type S = sig 'a list -> 'b list -> ('a * 'b) list * [`Left of 'a list | `Right of 'b list] option + + (** {3 compare / equal} *) + + val compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int + + val equal : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool end diff --git a/src/lib_lwt_result_stdlib/bare/structs/list.ml b/src/lib_lwt_result_stdlib/bare/structs/list.ml index 0782db25703f..133aadbc0162 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/list.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/list.ml @@ -156,10 +156,34 @@ let exists2 ~when_different_lengths f xs ys = in aux xs ys -let assoc = assoc_opt +let rec mem ~equal x = function + | [] -> + false + | y :: ys -> + equal x y || mem ~equal x ys + +let rec assoc ~equal k = function + | [] -> + None + | (kk, v) :: kvs -> + if equal k kk then Some v else assoc ~equal k kvs + +let assoc_opt = assoc let assq = assq_opt +let rec mem_assoc ~equal k = function + | [] -> + false + | (kk, _) :: kvs -> + equal k kk || mem_assoc ~equal k kvs + +let rec remove_assoc ~equal k = function + | [] -> + [] + | ((kk, _) as kv) :: kvs -> + if equal k kk then kvs else kv :: remove_assoc ~equal k kvs + let init ~when_negative_length l f = if l < 0 then Error when_negative_length else if l = 0 then nil_e @@ -1136,3 +1160,24 @@ let combine_drop xs ys = rev rev_combined in aux [] xs ys + +let rec compare ecomp xs ys = + match (xs, ys) with + | ([], []) -> + 0 + | ([], _ :: _) -> + -1 + | (_ :: _, []) -> + 1 + | (x :: xs, y :: ys) -> + let ec = ecomp x y in + if ec = 0 then compare ecomp xs ys else ec + +let rec equal eeq xs ys = + match (xs, ys) with + | ([], []) -> + true + | ([], _ :: _) | (_ :: _, []) -> + false + | (x :: xs, y :: ys) -> + eeq x y && equal eeq xs ys diff --git a/src/lib_lwt_result_stdlib/lwtreslib.mli b/src/lib_lwt_result_stdlib/lwtreslib.mli index 4981b406c16b..04ff73518838 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.mli +++ b/src/lib_lwt_result_stdlib/lwtreslib.mli @@ -246,6 +246,18 @@ List.iter_ep The module [WithExceptions] provides some exception-raising helpers to reduce the boilerplate that the library imposes. + + {2 Comparison, Equality, etc.} + + When a function requires a comparison function, it takes a [compare] named + parameter. This must define a total order as described in + {!Stdlib.Map.OrderedType}. + + Note that the polymorphic structural comparison {!Stdlib.compare} is unsound + for comparing some values; notably, it may fail when comparing + data-structures that include functions or closures. + + Similarly and for the same reason, some functions take an [equal] function. *) module Bare : sig module Hashtbl : Bare_sigs.Hashtbl.S -- GitLab From 46bf756b5117bded32d2033a0162c66a0a61a528 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 6 Apr 2021 16:02:24 +0200 Subject: [PATCH 04/14] Everywhere: adapt to LWtreslib's required equal/compare --- src/bin_client/client_rpc_commands.ml | 7 +++- src/bin_node/node_shared_arg.ml | 1 + src/bin_signer/handler.ml | 9 +++-- src/bin_snoop/dep_graph.ml | 4 +- src/bin_snoop/display.ml | 3 +- src/bin_snoop/main_snoop.ml | 2 +- src/bin_snoop/report.ml | 4 +- src/lib_base/block_header.ml | 5 ++- src/lib_base/distributed_db_version.ml | 4 ++ src/lib_base/distributed_db_version.mli | 4 ++ src/lib_base/network_version.ml | 18 +++++++-- src/lib_base/operation.ml | 2 + src/lib_base/operation.mli | 2 + src/lib_base/p2p_version.ml | 4 ++ src/lib_base/p2p_version.mli | 4 ++ src/lib_benchmark/example/blake2b.ml | 2 +- src/lib_benchmark/registration.ml | 8 +++- src/lib_benchmark/test/test_blake2b.ml | 4 +- src/lib_benchmark/test/test_costlang.ml | 14 ++++++- src/lib_benchmark/test/test_inference.ml | 6 ++- src/lib_clic/clic.ml | 4 +- src/lib_client_base/client_aliases.ml | 31 ++++++++------ src/lib_client_base/client_aliases.mli | 2 + src/lib_client_base/client_keys.ml | 40 +++++++++++++++---- src/lib_client_base_unix/client_config.ml | 2 +- src/lib_client_base_unix/client_main_run.ml | 5 ++- src/lib_context/context_dump.ml | 2 +- src/lib_crypto/ed25519.ml | 4 +- src/lib_crypto/p256.ml | 4 +- src/lib_crypto/signature.ml | 10 ++++- src/lib_event_logging/internal_event.ml | 15 ++++++- src/lib_event_logging/internal_event.mli | 4 +- src/lib_micheline/micheline_parser.ml | 5 +++ src/lib_micheline/micheline_parser.mli | 3 ++ src/lib_mockup/local_services.ml | 17 +++++++- src/lib_p2p/test/process.ml | 20 ++++++---- src/lib_protocol_compiler/replace.ml | 2 +- .../test/test_mem_context_array_theory.ml | 8 +++- src/lib_proxy/test/test_fuzzing_light.ml | 7 ++-- src/lib_rpc/RPC_arg.ml | 3 ++ src/lib_rpc/RPC_arg.mli | 2 + src/lib_sapling/core.ml | 2 + src/lib_sapling/core_sig.ml | 2 + src/lib_sapling/rustzcash.ml | 2 + src/lib_sapling/rustzcash_sig.ml | 2 + src/lib_shell/chain_validator.ml | 7 +++- src/lib_shell/node.ml | 9 ++++- src/lib_shell/worker_directory.ml | 18 +++++++-- src/lib_shell_services/block_services.ml | 3 +- src/lib_signer_backends/encrypted.ml | 2 +- src/lib_signer_backends/unix/socket.ml | 5 ++- src/lib_stdlib/compare.ml | 2 + src/lib_stdlib/compare.mli | 12 ++++++ src/lib_stdlib_unix/file_event_sink.ml | 8 ++-- src/lib_store/legacy.ml | 2 +- src/lib_store/snapshots.ml | 3 +- src/lib_store/test/alpha_utils.ml | 2 +- src/lib_store/test/test_snapshots.ml | 3 +- src/lib_validation/block_validation.ml | 2 +- src/lib_workers/worker.ml | 5 ++- .../lib_client/client_proto_contracts.ml | 2 + .../lib_client/client_proto_programs.ml | 6 +++ .../lib_client/michelson_v1_emacs.ml | 21 ++++++---- .../lib_client/michelson_v1_error_reporter.ml | 8 +++- .../lib_client/michelson_v1_parser.ml | 8 ++-- .../lib_client/michelson_v1_parser.mli | 2 + .../lib_client/michelson_v1_printer.ml | 11 +++-- .../lib_client/client_proto_contracts.ml | 2 + .../lib_client/client_proto_programs.ml | 6 +++ .../lib_client/michelson_v1_emacs.ml | 21 ++++++---- .../lib_client/michelson_v1_error_reporter.ml | 8 +++- .../lib_client/michelson_v1_parser.ml | 8 ++-- .../lib_client/michelson_v1_parser.mli | 2 + .../lib_client/michelson_v1_printer.ml | 11 +++-- .../lib_client/client_proto_contracts.ml | 2 + .../lib_client/client_proto_programs.ml | 6 +++ .../lib_client/michelson_v1_emacs.ml | 21 ++++++---- .../lib_client/michelson_v1_error_reporter.ml | 8 +++- .../lib_client/michelson_v1_parser.ml | 8 ++-- .../lib_client/michelson_v1_parser.mli | 2 + .../lib_client/michelson_v1_printer.ml | 11 +++-- .../client_proto_context_commands.ml | 4 +- .../lib_client/client_proto_contracts.ml | 2 + .../lib_client/client_proto_programs.ml | 6 +++ .../lib_client/michelson_v1_emacs.ml | 21 ++++++---- .../lib_client/michelson_v1_error_reporter.ml | 8 +++- .../lib_client/michelson_v1_parser.ml | 8 ++-- .../lib_client/michelson_v1_parser.mli | 2 + .../lib_client/michelson_v1_printer.ml | 11 +++-- .../client_proto_context_commands.ml | 4 +- .../lib_client/client_proto_contracts.ml | 2 + .../lib_client/client_proto_programs.ml | 6 +++ .../lib_client/michelson_v1_emacs.ml | 21 ++++++---- .../lib_client/michelson_v1_entrypoints.ml | 4 +- .../lib_client/michelson_v1_error_reporter.ml | 8 +++- .../lib_client/michelson_v1_parser.ml | 8 ++-- .../lib_client/michelson_v1_parser.mli | 2 + .../lib_client/michelson_v1_printer.ml | 11 +++-- .../client_proto_context_commands.ml | 4 +- .../lib_client/client_proto_contracts.ml | 2 + .../lib_client/client_proto_programs.ml | 6 +++ .../lib_client/michelson_v1_emacs.ml | 21 ++++++---- .../lib_client/michelson_v1_entrypoints.ml | 4 +- .../lib_client/michelson_v1_error_reporter.ml | 8 +++- .../lib_client/michelson_v1_parser.ml | 8 ++-- .../lib_client/michelson_v1_parser.mli | 2 + .../lib_client/michelson_v1_printer.ml | 11 +++-- .../client_proto_context_commands.ml | 7 +++- .../lib_client/client_proto_contracts.ml | 2 + .../lib_client/client_proto_programs.ml | 6 +++ .../lib_client/michelson_v1_emacs.ml | 21 ++++++---- .../lib_client/michelson_v1_entrypoints.ml | 4 +- .../lib_client/michelson_v1_error_reporter.ml | 8 +++- .../lib_client/michelson_v1_parser.ml | 8 ++-- .../lib_client/michelson_v1_parser.mli | 2 + .../lib_client/michelson_v1_printer.ml | 11 +++-- .../client_proto_context_commands.ml | 4 +- .../lib_client/client_proto_contracts.ml | 2 + .../lib_client/client_proto_programs.ml | 6 +++ .../lib_client/michelson_v1_emacs.ml | 21 ++++++---- .../lib_client/michelson_v1_entrypoints.ml | 4 +- .../lib_client/michelson_v1_error_reporter.ml | 8 +++- .../lib_client/michelson_v1_parser.ml | 8 ++-- .../lib_client/michelson_v1_parser.mli | 2 + .../lib_client/michelson_v1_printer.ml | 11 +++-- .../client_proto_context_commands.ml | 7 +++- .../client_baking_highwatermarks.ml | 2 +- .../lib_protocol/test/gas_costs.ml | 4 +- .../lib_protocol/test/helpers/block.ml | 3 +- .../lib_protocol/test/interpretation.ml | 5 ++- .../lib_protocol/test/typechecking.ml | 6 ++- .../lib_client/client_proto_contracts.ml | 2 + .../lib_client/client_proto_programs.ml | 6 +++ .../lib_client/michelson_v1_emacs.ml | 21 ++++++---- .../lib_client/michelson_v1_entrypoints.ml | 4 +- .../lib_client/michelson_v1_error_reporter.ml | 8 +++- .../lib_client/michelson_v1_parser.ml | 8 ++-- .../lib_client/michelson_v1_parser.mli | 2 + .../lib_client/michelson_v1_printer.ml | 11 +++-- .../client_proto_context_commands.ml | 10 ++++- .../client_baking_highwatermarks.ml | 2 +- .../lib_protocol/test/helpers/block.ml | 3 +- .../lib_protocol/test/test_gas_costs.ml | 4 +- .../lib_protocol/test/test_typechecking.ml | 1 + .../lib_client/client_proto_contracts.ml | 4 +- .../lib_client/client_proto_programs.ml | 6 +++ .../lib_client/michelson_v1_emacs.ml | 21 ++++++---- .../lib_client/michelson_v1_entrypoints.ml | 4 +- .../lib_client/michelson_v1_error_reporter.ml | 8 +++- .../lib_client/michelson_v1_parser.ml | 8 ++-- .../lib_client/michelson_v1_parser.mli | 2 + .../lib_client/michelson_v1_printer.ml | 11 +++-- .../client_proto_context_commands.ml | 10 ++++- .../client_baking_highwatermarks.ml | 2 +- .../lib_protocol/test/helpers/block.ml | 3 +- .../lib_protocol/test/test_gas_costs.ml | 4 +- .../lib_protocol/test/test_typechecking.ml | 1 + vendors/ocaml-uecc/src/uecc.ml | 6 +++ vendors/ocaml-uecc/src/uecc.mli | 2 + 159 files changed, 803 insertions(+), 289 deletions(-) diff --git a/src/bin_client/client_rpc_commands.ml b/src/bin_client/client_rpc_commands.ml index ffa15bd5e7d8..d03b0bf655ef 100644 --- a/src/bin_client/client_rpc_commands.ml +++ b/src/bin_client/client_rpc_commands.ml @@ -237,8 +237,11 @@ let list url (cctxt : #Client_context.full) = let open RPC_description in let collected_args = ref [] in let collect arg = - if not (arg.RPC_arg.descr <> None && List.mem arg !collected_args) then - collected_args := arg :: !collected_args + if + not + ( arg.RPC_arg.descr <> None + && List.mem ~equal:RPC_arg.eq_descr arg !collected_args ) + then collected_args := arg :: !collected_args in let display_paragraph ppf description = Format.fprintf diff --git a/src/bin_node/node_shared_arg.ml b/src/bin_node/node_shared_arg.ml index 5dc247755e5d..1a07be49d8e8 100644 --- a/src/bin_node/node_shared_arg.ml +++ b/src/bin_node/node_shared_arg.ml @@ -255,6 +255,7 @@ module Term = struct let network_parser = let parse_network_name s = List.assoc_opt + ~equal:String.equal (String.lowercase_ascii s) Node_config_file.builtin_blockchain_networks |> Option.map (fun net -> Result.ok (BuiltIn net)) diff --git a/src/bin_signer/handler.ml b/src/bin_signer/handler.ml index 1f1178a09ee6..19f01b044a32 100644 --- a/src/bin_signer/handler.ml +++ b/src/bin_signer/handler.ml @@ -59,11 +59,13 @@ module High_watermark = struct let hash = Blake2B.hash_bytes [bytes] in let chain_id = Chain_id.of_bytes_exn (Bytes.sub bytes 1 4) in let level = get_level () in - ( match List.assoc_opt chain_id all with + ( match List.assoc_opt ~equal:Chain_id.equal chain_id all with | None -> return_none | Some marks -> ( - match List.assoc_opt pkh marks with + match + List.assoc_opt ~equal:Signature.Public_key_hash.equal pkh marks + with | None -> return_none | Some (previous_level, _, None) -> @@ -134,7 +136,8 @@ let check_magic_byte magic_bytes data = return_unit | Some magic_bytes -> let byte = TzEndian.get_uint8 data 0 in - if Bytes.length data > 1 && List.mem byte magic_bytes then return_unit + if Bytes.length data > 1 && List.mem ~equal:Int.equal byte magic_bytes + then return_unit else failwith "magic byte 0x%02X not allowed" byte let check_authorization cctxt pkh data require_auth signature = diff --git a/src/bin_snoop/dep_graph.ml b/src/bin_snoop/dep_graph.ml index 442cdd542e25..1c51f2d7c715 100644 --- a/src/bin_snoop/dep_graph.ml +++ b/src/bin_snoop/dep_graph.ml @@ -381,9 +381,9 @@ let to_graph (solved : string Solver.solved list) = g let find_model_or_generic model_name model_list = - match List.assoc_opt model_name model_list with + match List.assoc_opt ~equal:String.equal model_name model_list with | None -> - List.assoc_opt "*" model_list + List.assoc_opt ~equal:String.equal "*" model_list | res -> res diff --git a/src/bin_snoop/display.ml b/src/bin_snoop/display.ml index 1980356cb829..68436b4cbd3b 100644 --- a/src/bin_snoop/display.ml +++ b/src/bin_snoop/display.ml @@ -269,7 +269,8 @@ let validator_empirical workload_data (problem : Inference.problem) (int * (col:int -> unit Plot.t), string) result = let {Inference.mapping; _} = solution in let valuation name = - WithExceptions.Option.get ~loc:__LOC__ @@ List.assoc name mapping + WithExceptions.Option.get ~loc:__LOC__ + @@ List.assoc ~equal:Free_variable.equal name mapping in let predicted = match problem with diff --git a/src/bin_snoop/main_snoop.ml b/src/bin_snoop/main_snoop.ml index f1543f3f155e..27ccdae2ce0d 100644 --- a/src/bin_snoop/main_snoop.ml +++ b/src/bin_snoop/main_snoop.ml @@ -101,7 +101,7 @@ and infer_cmd_one_shot model_name workload_data solver | Measure.Measurement ((module Bench), {bench_opts = _; workload_data; date = _}) -> let model = - match List.assoc_opt model_name Bench.models with + match List.assoc_opt ~equal:String.equal model_name Bench.models with | Some m -> m | None -> diff --git a/src/bin_snoop/report.ml b/src/bin_snoop/report.ml index 2ce86226a1a2..199ab3f313ff 100644 --- a/src/bin_snoop/report.ml +++ b/src/bin_snoop/report.ml @@ -40,12 +40,14 @@ type context = | If_cond | If_branch +let equal_context : context -> context -> bool = Stdlib.( = ) + type printed = Format.formatter -> context -> unit let pp c fmtr printed = Format.fprintf fmtr (printed c) let unprotect_in_context ctxts f fmtr c = - if List.mem c ctxts then Format.fprintf fmtr "%a" f () + if List.mem ~equal:equal_context c ctxts then Format.fprintf fmtr "%a" f () else Format.fprintf fmtr "(%a)" f () let to_string (x : printed) = Format.asprintf "%a" x Lam_body diff --git a/src/lib_base/block_header.ml b/src/lib_base/block_header.ml index 47d170a3aa41..5311506eecc6 100644 --- a/src/lib_base/block_header.ml +++ b/src/lib_base/block_header.ml @@ -176,7 +176,10 @@ let get_forced_protocol_upgrade ~user_activated_upgrades = let get_voted_protocol_overrides ~user_activated_protocol_overrides proto_hash = - List.assoc_opt proto_hash user_activated_protocol_overrides + List.assoc_opt + ~equal:Protocol_hash.equal + proto_hash + user_activated_protocol_overrides let () = Data_encoding.Registration.register shell_header_encoding ; diff --git a/src/lib_base/distributed_db_version.ml b/src/lib_base/distributed_db_version.ml index 407fd74c5470..200b5f207f87 100644 --- a/src/lib_base/distributed_db_version.ml +++ b/src/lib_base/distributed_db_version.ml @@ -47,6 +47,10 @@ end type t = int +let equal = Int.equal + +let compare = Int.compare + let pp = Format.pp_print_int let encoding = diff --git a/src/lib_base/distributed_db_version.mli b/src/lib_base/distributed_db_version.mli index 0d734bd2123e..a6d07e2e2f24 100644 --- a/src/lib_base/distributed_db_version.mli +++ b/src/lib_base/distributed_db_version.mli @@ -43,6 +43,10 @@ end (** An abstract version number for the high-level [Distributed_db] messages. *) type t = private int +val equal : t -> t -> bool + +val compare : t -> t -> int + val pp : Format.formatter -> t -> unit val encoding : t Data_encoding.t diff --git a/src/lib_base/network_version.ml b/src/lib_base/network_version.ml index 7f1cec34ae0a..f53ffe08c334 100644 --- a/src/lib_base/network_version.ml +++ b/src/lib_base/network_version.ml @@ -73,11 +73,16 @@ let announced ~chain_name ~distributed_db_versions ~p2p_versions = p2p_version = greatest p2p_versions; } -let may_select_version accepted_versions remote_version motive = +let may_select_version ~compare accepted_versions remote_version motive = let open Error_monad in let best_local_version = greatest accepted_versions in - if best_local_version <= remote_version then ok best_local_version - else if List.mem remote_version accepted_versions then ok remote_version + if compare best_local_version remote_version <= 0 then ok best_local_version + else if + List.mem + ~equal:(fun a b -> compare a b = 0) + remote_version + accepted_versions + then ok remote_version else P2p_rejection.rejecting motive let select ~chain_name ~distributed_db_versions ~p2p_versions remote = @@ -88,11 +93,16 @@ let select ~chain_name ~distributed_db_versions ~p2p_versions remote = else let open Error_monad in may_select_version + ~compare:Distributed_db_version.compare distributed_db_versions remote.distributed_db_version Deprecated_distributed_db_version >>? fun distributed_db_version -> - may_select_version p2p_versions remote.p2p_version Deprecated_p2p_version + may_select_version + ~compare:P2p_version.compare + p2p_versions + remote.p2p_version + Deprecated_p2p_version >>? fun p2p_version -> ok {chain_name; distributed_db_version; p2p_version} let () = Data_encoding.Registration.register ~pp encoding diff --git a/src/lib_base/operation.ml b/src/lib_base/operation.ml index 9833114fc53c..04b85ba44ed4 100644 --- a/src/lib_base/operation.ml +++ b/src/lib_base/operation.ml @@ -25,6 +25,8 @@ type shell_header = {branch : Block_hash.t} +let equal_shell_header {branch = b1} {branch = b2} = Block_hash.equal b1 b2 + let shell_header_encoding = let open Data_encoding in def "operation.shell_header" ~description:"An operation's shell header." diff --git a/src/lib_base/operation.mli b/src/lib_base/operation.mli index 50f8e79478b2..e80583583438 100644 --- a/src/lib_base/operation.mli +++ b/src/lib_base/operation.mli @@ -25,6 +25,8 @@ type shell_header = {branch : Block_hash.t} +val equal_shell_header : shell_header -> shell_header -> bool + val shell_header_encoding : shell_header Data_encoding.t type t = {shell : shell_header; proto : Bytes.t} diff --git a/src/lib_base/p2p_version.ml b/src/lib_base/p2p_version.ml index 52f6c72112d3..3dfef663f422 100644 --- a/src/lib_base/p2p_version.ml +++ b/src/lib_base/p2p_version.ml @@ -26,6 +26,10 @@ type t = int +let equal = Int.equal + +let compare = Int.compare + let pp = Format.pp_print_int let encoding = diff --git a/src/lib_base/p2p_version.mli b/src/lib_base/p2p_version.mli index 88907326caf3..351073fbc3c8 100644 --- a/src/lib_base/p2p_version.mli +++ b/src/lib_base/p2p_version.mli @@ -29,6 +29,10 @@ (** An abstract version number for the low-level P2P layer. *) type t = private int +val equal : t -> t -> bool + +val compare : t -> t -> int + val pp : Format.formatter -> t -> unit val encoding : t Data_encoding.t diff --git a/src/lib_benchmark/example/blake2b.ml b/src/lib_benchmark/example/blake2b.ml index eaaa6f3fb226..6983e968a371 100644 --- a/src/lib_benchmark/example/blake2b.ml +++ b/src/lib_benchmark/example/blake2b.ml @@ -104,4 +104,4 @@ let () = "blake2b_codegen" (Model.For_codegen ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc "blake2b" Blake2b_bench.models )) + @@ List.assoc ~equal:String.equal "blake2b" Blake2b_bench.models )) diff --git a/src/lib_benchmark/registration.ml b/src/lib_benchmark/registration.ml index 52964c4db5ee..7aca2b04f067 100644 --- a/src/lib_benchmark/registration.ml +++ b/src/lib_benchmark/registration.ml @@ -64,7 +64,9 @@ let all_benchmarks_with_all_of (tags : string list) : Benchmark.t list = String_table.to_seq bench_table |> Seq.map snd |> List.of_seq |> List.filter (fun b -> - List.for_all (fun tag -> List.mem tag (Benchmark.tags b)) tags) + List.for_all + (fun tag -> List.mem ~equal:String.equal tag (Benchmark.tags b)) + tags) |> List.sort (fun b1 b2 -> String.compare (Benchmark.name b1) (Benchmark.name b2)) @@ -91,7 +93,9 @@ let all_benchmarks_with_any_of (tags : string list) : Benchmark.t list = String_table.to_seq bench_table |> Seq.map snd |> List.of_seq |> List.filter (fun b -> - List.exists (fun tag -> List.mem tag (Benchmark.tags b)) tags) + List.exists + (fun tag -> List.mem ~equal:String.equal tag (Benchmark.tags b)) + tags) |> List.sort (fun b1 b2 -> String.compare (Benchmark.name b1) (Benchmark.name b2)) diff --git a/src/lib_benchmark/test/test_blake2b.ml b/src/lib_benchmark/test/test_blake2b.ml index c7eaaaa046de..078cda1ae15b 100644 --- a/src/lib_benchmark/test/test_blake2b.ml +++ b/src/lib_benchmark/test/test_blake2b.ml @@ -70,7 +70,7 @@ let solution = match measurement with | Measure.Measurement ((module Bench), {workload_data; _}) -> let model = - List.assoc "blake2b" Bench.models + List.assoc ~equal:String.equal "blake2b" Bench.models |> WithExceptions.Option.get ~loc:__LOC__ in let problem = @@ -93,7 +93,7 @@ let () = match measurement with | Measure.Measurement ((module Bench), _) -> ( let model = - List.assoc "blake2b" Bench.models + List.assoc ~equal:String.equal "blake2b" Bench.models |> WithExceptions.Option.get ~loc:__LOC__ in let solution = Free_variable.Map.of_seq (List.to_seq solution.mapping) in diff --git a/src/lib_benchmark/test/test_costlang.ml b/src/lib_benchmark/test/test_costlang.ml index cf8d4cccceac..122d42e83760 100644 --- a/src/lib_benchmark/test/test_costlang.ml +++ b/src/lib_benchmark/test/test_costlang.ml @@ -78,7 +78,12 @@ let test_eval1 () = Subst (struct let subst x = - match List.assoc x [(fv_v1, 88.); (fv_v2, 4.); (fv_const, -10.)] with + match + List.assoc + ~equal:Free_variable.equal + x + [(fv_v1, 88.); (fv_v2, 4.); (fv_const, -10.)] + with | Some v -> v | None -> @@ -96,7 +101,12 @@ let test_eval2 () = Subst (struct let subst x = - match List.assoc x [(fv_v1, 2.); (fv_v2, 4.); (fv_const, -10.)] with + match + List.assoc + ~equal:Free_variable.equal + x + [(fv_v1, 2.); (fv_v2, 4.); (fv_const, -10.)] + with | Some v -> v | None -> diff --git a/src/lib_benchmark/test/test_inference.ml b/src/lib_benchmark/test/test_inference.ml index 84cb9380cb28..035485969b15 100644 --- a/src/lib_benchmark/test/test_inference.ml +++ b/src/lib_benchmark/test/test_inference.ml @@ -95,10 +95,12 @@ module T () = struct (Inference.Lasso {alpha = 1.0; normalize = false; positive = false}) let const = - List.assoc fv_const mapping |> WithExceptions.Option.get ~loc:__LOC__ + List.assoc ~equal:Free_variable.equal fv_const mapping + |> WithExceptions.Option.get ~loc:__LOC__ let quadratic_term = - List.assoc fv_quad mapping |> WithExceptions.Option.get ~loc:__LOC__ + List.assoc ~equal:Free_variable.equal fv_quad mapping + |> WithExceptions.Option.get ~loc:__LOC__ end (* ------------------------------------------------------------------------- *) diff --git a/src/lib_clic/clic.ml b/src/lib_clic/clic.ml index b716877bf29e..2baf00f13247 100644 --- a/src/lib_clic/clic.ml +++ b/src/lib_clic/clic.ml @@ -1893,7 +1893,7 @@ let find_command tree initial_arguments = | (TPrefix {stop = None; prefix}, ([] | ("-h" | "--help") :: _)) -> fail (Unterminated_command (initial_arguments, gather_assoc prefix)) | (TPrefix {prefix; _}, hd_arg :: tl) -> ( - match List.assoc hd_arg prefix with + match List.assoc ~equal:String.equal hd_arg prefix with | None -> fail (Command_not_found (List.rev acc, gather_assoc prefix)) | Some tree' -> @@ -2069,7 +2069,7 @@ let complete_tree cctxt tree index args = | _ -> complete_next_tree cctxt this_tree ) | (TPrefix {prefix; _}, hd :: tl) -> ( - match List.assoc hd prefix with + match List.assoc ~equal:String.equal hd prefix with | None -> return_nil | Some p -> diff --git a/src/lib_client_base/client_aliases.ml b/src/lib_client_base/client_aliases.ml index 80d26cefe2f3..a2215a8dfc97 100644 --- a/src/lib_client_base/client_aliases.ml +++ b/src/lib_client_base/client_aliases.ml @@ -38,6 +38,8 @@ module type Entity = sig val to_source : t -> string tzresult Lwt.t val name : string + + include Compare.S with type t := t end module type Alias = sig @@ -129,12 +131,12 @@ module Alias (Entity : Entity) = struct | Error _ -> return_nil | Ok list -> return (List.map fst list) let find_opt (wallet : #wallet) name = - load wallet >|=? fun list -> List.assoc name list + load wallet >|=? fun list -> List.assoc ~equal:String.equal name list let find (wallet : #wallet) name = load wallet >>=? fun list -> - match List.assoc name list with + match List.assoc ~equal:String.equal name list with | Some v -> return v | None -> @@ -142,16 +144,19 @@ module Alias (Entity : Entity) = struct let rev_find (wallet : #wallet) v = load wallet - >|=? fun list -> Option.map fst @@ List.find (fun (_, v') -> v = v') list + >|=? fun list -> + Option.map fst @@ List.find (fun (_, v') -> Entity.(v = v')) list let rev_find_all (wallet : #wallet) v = load wallet >>=? fun list -> return - (List.filter_map (fun (n, v') -> if v = v' then Some n else None) list) + (List.filter_map + (fun (n, v') -> if Entity.(v = v') then Some n else None) + list) let mem (wallet : #wallet) name = - load wallet >|=? fun list -> List.mem_assoc name list + load wallet >|=? fun list -> List.mem_assoc ~equal:String.equal name list let add ~force (wallet : #wallet) name value = let keep = ref false in @@ -161,15 +166,15 @@ module Alias (Entity : Entity) = struct else List.iter_es (fun (n, v) -> - if n = name && v = value then ( + if Compare.String.(n = name) && Entity.(v = value) then ( keep := true ; return_unit ) - else if n = name && v <> value then + else if Compare.String.(n = name) && Entity.(v <> value) then failwith "another %s is already aliased as %s, use --force to update" Entity.name n - else if n <> name && v = value then + else if Compare.String.(n <> name) && Entity.(v = value) then failwith "this %s is already aliased as %s, use --force to insert \ duplicate" @@ -178,7 +183,7 @@ module Alias (Entity : Entity) = struct else return_unit) list ) >>=? fun () -> - let list = List.filter (fun (n, _) -> n <> name) list in + let list = List.filter (fun (n, _) -> not (String.equal n name)) list in let list = (name, value) :: list in if !keep then return_unit else wallet#write Entity.name list wallet_encoding @@ -186,14 +191,16 @@ module Alias (Entity : Entity) = struct let del (wallet : #wallet) name = load wallet >>=? fun list -> - let list = List.filter (fun (n, _) -> n <> name) list in + let list = List.filter (fun (n, _) -> not (String.equal n name)) list in wallet#write Entity.name list wallet_encoding let update (wallet : #wallet) name value = load wallet >>=? fun list -> let list = - List.map (fun (n, v) -> (n, if n = name then value else v)) list + List.map + (fun (n, v) -> (n, if String.equal n name then value else v)) + list in wallet#write Entity.name list wallet_encoding @@ -216,7 +223,7 @@ module Alias (Entity : Entity) = struct else List.iter_es (fun (n, v) -> - if n = s then + if String.equal n s then Entity.to_source v >>=? fun value -> failwith diff --git a/src/lib_client_base/client_aliases.mli b/src/lib_client_base/client_aliases.mli index 80610a5184c5..6833bdb4a638 100644 --- a/src/lib_client_base/client_aliases.mli +++ b/src/lib_client_base/client_aliases.mli @@ -33,6 +33,8 @@ module type Entity = sig val to_source : t -> string tzresult Lwt.t val name : string + + include Compare.S with type t := t end module type Alias = sig diff --git a/src/lib_client_base/client_keys.ml b/src/lib_client_base/client_keys.ml index 1833485d9527..c04f5fd72809 100644 --- a/src/lib_client_base/client_keys.ml +++ b/src/lib_client_base/client_keys.ml @@ -52,9 +52,8 @@ let () = module Public_key_hash = struct include Client_aliases.Alias (struct - type t = Signature.Public_key_hash.t - - let encoding = Signature.Public_key_hash.encoding + (* includes t, Compare, encoding *) + include Signature.Public_key_hash let of_source s = Lwt.return (Signature.Public_key_hash.of_b58check s) @@ -98,6 +97,12 @@ let make_pk_uri (x : Uri.t) : pk_uri tzresult Lwt.t = type sk_uri = Uri.t +module CompareUri = Compare.Make (struct + type t = Uri.t + + let compare = Uri.compare +end) + let make_sk_uri (x : Uri.t) : sk_uri tzresult Lwt.t = match Uri.scheme x with | None -> @@ -158,6 +163,8 @@ module Secret_key = Client_aliases.Alias (struct type t = sk_uri + include (CompareUri : Compare.S with type t := t) + let of_source s = make_sk_uri @@ Uri.of_string s let to_source t = return (Uri.to_string t) @@ -170,6 +177,14 @@ module Public_key = Client_aliases.Alias (struct type t = pk_uri * Signature.Public_key.t option + include Compare.Make (struct + type nonrec t = t + + let compare (apk, aso) (bpk, bso) = + Compare.or_else (CompareUri.compare apk bpk) (fun () -> + Option.compare Signature.Public_key.compare aso bso) + end) + let of_source s = make_pk_uri @@ Uri.of_string s >>=? fun pk_uri -> return (pk_uri, None) @@ -209,6 +224,17 @@ module Sapling_key = Client_aliases.Alias (struct type t = sapling_key + include Compare.Make (struct + type nonrec t = t + + let compare a b = + Compare.or_else (CompareUri.compare a.sk b.sk) (fun () -> + Compare.or_else (Stdlib.compare a.path b.path) (fun () -> + Tezos_sapling.Core.Client.Viewing_key.compare_index + a.address_index + b.address_index)) + end) + let encoding = let open Data_encoding in conv @@ -233,11 +259,9 @@ module Sapling_key = Client_aliases.Alias (struct end) module PVSS_public_key = Client_aliases.Alias (struct - let name = "PVSS public key" + include Pvss_secp256k1.Public_key (* t, Compare, encoding *) - type t = Pvss_secp256k1.Public_key.t - - let encoding = Pvss_secp256k1.Public_key.encoding + let name = "PVSS public key" let of_source s = Lwt.return (Pvss_secp256k1.Public_key.of_b58check s) @@ -249,6 +273,8 @@ module PVSS_secret_key = Client_aliases.Alias (struct type t = pvss_sk_uri + include CompareUri + let encoding = uri_encoding let of_source s = make_pvss_sk_uri @@ Uri.of_string s diff --git a/src/lib_client_base_unix/client_config.ml b/src/lib_client_base_unix/client_config.ml index a910886785f4..014838fe9f78 100644 --- a/src/lib_client_base_unix/client_config.ml +++ b/src/lib_client_base_unix/client_config.ml @@ -535,7 +535,7 @@ let client_mode_arg () = mode_strings all_modes >>?= fun modes_and_strings -> - match List.assoc_opt str modes_and_strings with + match List.assoc_opt ~equal:String.equal str modes_and_strings with | None -> fail @@ Invalid_mode_arg str | Some mode -> diff --git a/src/lib_client_base_unix/client_main_run.ml b/src/lib_client_base_unix/client_main_run.ml index a236b396b7b7..8bd8f25a4746 100644 --- a/src/lib_client_base_unix/client_main_run.ml +++ b/src/lib_client_base_unix/client_main_run.ml @@ -210,8 +210,9 @@ let setup_default_proxy_client_config parsed_args base_dir rpc_config mode = failwith "--sources MUST be specified when --mode light is specified" | (`Mode_light, Some sources_config) -> - ( if List.mem rpc_config.endpoint sources_config.uris then - return_unit + ( if + List.mem ~equal:Uri.equal rpc_config.endpoint sources_config.uris + then return_unit else failwith "Value of --endpoint is %a. Therefore, this URI MUST be in \ diff --git a/src/lib_context/context_dump.ml b/src/lib_context/context_dump.ml index dfb7487bcafb..c021ace6c5c8 100644 --- a/src/lib_context/context_dump.ml +++ b/src/lib_context/context_dump.ml @@ -735,7 +735,7 @@ module Make_legacy (I : Dump_interface_legacy) = struct let check_version v = fail_when - (List.mem v.version compatible_versions |> not) + (List.mem ~equal:String.equal v.version compatible_versions |> not) (Invalid_snapshot_version (v.version, compatible_versions)) let serialize_tree ~maybe_flush ~written buf = diff --git a/src/lib_crypto/ed25519.ml b/src/lib_crypto/ed25519.ml index 82e8c8472f21..3067179baa29 100644 --- a/src/lib_crypto/ed25519.ml +++ b/src/lib_crypto/ed25519.ml @@ -49,7 +49,7 @@ let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz1" 36 open Hacl.Ed25519 module Public_key = struct - type t = Hacl.public key + type t = Hacl.public Hacl.Ed25519.key let name = "Ed25519.Public_key" @@ -84,7 +84,7 @@ module Public_key = struct include Compare.Make (struct type nonrec t = t - let compare = compare + let compare = Hacl.Ed25519.compare end) include Helpers.MakeRaw (struct diff --git a/src/lib_crypto/p256.ml b/src/lib_crypto/p256.ml index 04d4749cfc01..41046cc64ae4 100644 --- a/src/lib_crypto/p256.ml +++ b/src/lib_crypto/p256.ml @@ -47,7 +47,7 @@ let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz3" 36 open Uecc module Public_key = struct - type t = public key + type t = Uecc.public Uecc.key let name = "P256.Public_key" @@ -82,7 +82,7 @@ module Public_key = struct include Compare.Make (struct type nonrec t = t - let compare = compare + let compare = Uecc.compare end) include Helpers.MakeRaw (struct diff --git a/src/lib_crypto/signature.ml b/src/lib_crypto/signature.ml index c27f28764718..52a51abaca5a 100644 --- a/src/lib_crypto/signature.ml +++ b/src/lib_crypto/signature.ml @@ -305,8 +305,14 @@ module Public_key = struct Secp256k1.Public_key.compare x y | (P256 x, P256 y) -> P256.Public_key.compare x y - | _ -> - Stdlib.compare a b + | (Ed25519 _, (Secp256k1 _ | P256 _)) -> + -1 + | (Secp256k1 _, P256 _) -> + -1 + | (P256 _, (Secp256k1 _ | Ed25519 _)) -> + 1 + | (Secp256k1 _, Ed25519 _) -> + 1 end) type Base58.data += Data of t (* unused *) diff --git a/src/lib_event_logging/internal_event.ml b/src/lib_event_logging/internal_event.ml index 5494a5d99a1e..82cd2263d8e3 100644 --- a/src/lib_event_logging/internal_event.ml +++ b/src/lib_event_logging/internal_event.ml @@ -2,6 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* 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"),*) @@ -82,12 +83,18 @@ module Level = struct (fun l -> (to_string l, l)) [Debug; Info; Notice; Warning; Error; Fatal]) - let compare = compare + include Compare.Make (struct + type nonrec t = t + + let compare = Stdlib.compare + end) end module Section : sig type t + include Compare.S with type t := t + val empty : t val make : string list -> t @@ -104,6 +111,12 @@ module Section : sig end = struct type t = {path : string list; lwt_log_section : Lwt_log_core.section} + include Compare.Make (struct + type nonrec t = t + + let compare = Stdlib.compare + end) + let empty = {path = []; lwt_log_section = Lwt_log_core.Section.make ""} let make sl = diff --git a/src/lib_event_logging/internal_event.mli b/src/lib_event_logging/internal_event.mli index 1daa780f1695..1a8bc041ed16 100644 --- a/src/lib_event_logging/internal_event.mli +++ b/src/lib_event_logging/internal_event.mli @@ -66,7 +66,7 @@ module Level : sig val encoding : t Data_encoding.t - val compare : t -> t -> int + include Compare.S with type t := t end (** Sections are a simple way of classifying events at the time of @@ -87,6 +87,8 @@ module Section : sig val to_string_list : t -> string list val pp : Format.formatter -> t -> unit + + include Compare.S with type t := t end (** All the section that has been registered. Currently, sections are registered diff --git a/src/lib_micheline/micheline_parser.ml b/src/lib_micheline/micheline_parser.ml index 7fe64222fd20..21998bbad60d 100644 --- a/src/lib_micheline/micheline_parser.ml +++ b/src/lib_micheline/micheline_parser.ml @@ -29,6 +29,11 @@ open Micheline type 'a parsing_result = 'a * error list +let compare compare (aa, ael) (ba, bel) = + Compare.or_else (compare aa ba) (fun () -> + (* FIXME: we need error comparison *) + Stdlib.compare ael bel) + type point = {point : int; byte : int; line : int; column : int} let point_zero = {point = 0; byte = 0; line = 0; column = 0} diff --git a/src/lib_micheline/micheline_parser.mli b/src/lib_micheline/micheline_parser.mli index 5a339856e8a0..94e1f5abc634 100644 --- a/src/lib_micheline/micheline_parser.mli +++ b/src/lib_micheline/micheline_parser.mli @@ -27,6 +27,9 @@ open Error_monad type 'a parsing_result = 'a * error list +val compare : + ('a -> 'a -> int) -> 'a parsing_result -> 'a parsing_result -> int + val no_parsing_error : 'a parsing_result -> 'a tzresult type point = {point : int; byte : int; line : int; column : int} diff --git a/src/lib_mockup/local_services.ml b/src/lib_mockup/local_services.ml index e4711bb071a4..6229a76b08f8 100644 --- a/src/lib_mockup/local_services.ml +++ b/src/lib_mockup/local_services.ml @@ -470,11 +470,26 @@ module Make (E : MENV) = struct | Error errs -> RPC_answer.fail errs))) + let equal_op (a_shell_header, a_operation_data) + (b_shell_header, b_operation_data) = + Block_hash.equal + a_shell_header.Operation.branch + b_shell_header.Operation.branch + && (* FIXME: the protocol should export equality/comparison functions for its + abstract types such as operation_data. + + + WARNING: the following expression causes an exception to be raised, + complaining about functional values + Stdlib.( = ) a_operation_data b_operation_data + *) + Stdlib.compare a_operation_data b_operation_data = 0 + let need_operation shell_header operation_data = Mempool.read () >>=? fun mempool_operations -> let op = (shell_header, operation_data) in - if List.mem op mempool_operations then return_false + if List.mem ~equal:equal_op op mempool_operations then return_false else let operations = op :: mempool_operations in begin_construction () diff --git a/src/lib_p2p/test/process.ml b/src/lib_p2p/test/process.ml index 995f86d3b4f0..9bf1b7ec55e9 100644 --- a/src/lib_p2p/test/process.ml +++ b/src/lib_p2p/test/process.ml @@ -312,25 +312,29 @@ let signal_names = (Sys.sigxcpu, "SIGXCPU"); (Sys.sigxfsz, "SIGXFSZ") ] -let signal_name n = List.assoc n signal_names +let signal_name n = List.assoc ~equal:Int.equal n signal_names (* Associate a value to a list of values *) module Assoc = struct - let add k v t = - match List.assoc_opt k t with + let add ~equal k v t = + match List.assoc ~equal k t with | None -> (k, [v]) :: t | Some l -> - (k, v :: l) :: List.remove_assoc k t + (k, v :: l) :: List.remove_assoc ~equal k t let iter f t = List.iter f t end (* [group_by f h l] for all elements [e] of [l] groups all [g e] that have the same value for [f e] *) -let group_by f g l = +let group_by ~equal f g l = let rec aux l res = - match l with [] -> res | h :: t -> aux t (Assoc.add (f h) (g h) res) + match l with + | [] -> + res + | h :: t -> + aux t (Assoc.add ~equal (f h) (g h) res) in aux l [] @@ -369,7 +373,9 @@ let pp_trace plural ppf err = (* Print the trace of multiple detached process, grouped by identical traces *) let pp_grouped ppf plist pp_trace = - let grouped = group_by (fun (_, _, res) -> res) (fun p -> p) plist in + let grouped = + group_by ~equal:Stdlib.( = ) (fun (_, _, res) -> res) (fun p -> p) plist + in Assoc.iter (fun (err, plist) -> Format.fprintf diff --git a/src/lib_protocol_compiler/replace.ml b/src/lib_protocol_compiler/replace.ml index 8a521b2092bc..74e2baea2e47 100644 --- a/src/lib_protocol_compiler/replace.ml +++ b/src/lib_protocol_compiler/replace.ml @@ -137,7 +137,7 @@ let read_proto destination final_protocol_file = | Ok (None, proto) -> (Protocol.hash proto, proto, false) | Ok (Some hash, proto) -> - (hash, proto, List.mem hash final_protocol) + (hash, proto, List.mem ~equal:Protocol_hash.equal hash final_protocol) | Error err -> Format.kasprintf Stdlib.failwith diff --git a/src/lib_protocol_environment/test/test_mem_context_array_theory.ml b/src/lib_protocol_environment/test/test_mem_context_array_theory.ml index 84e605c0574d..242d42cf0817 100644 --- a/src/lib_protocol_environment/test/test_mem_context_array_theory.ml +++ b/src/lib_protocol_environment/test/test_mem_context_array_theory.ml @@ -51,6 +51,9 @@ open Lib_test.Qcheck_helpers type key = Context.key +let equal_key : key -> key -> bool = + fun (a : string list) (b : string list) -> Stdlib.( = ) a b + type value = Context.value (** Using [QCheck.small_list] for performance reasons: using [QCheck.list] here @@ -110,7 +113,7 @@ let test_domain_spec (ctxt, k) = qcheck_eq ~pp:Format.pp_print_bool (Lwt_main.run @@ Context.mem ctxt k) - (List.mem k domain) + (List.mem ~equal:equal_key k domain) (* Tests that (get (set m k v) k) equals v. This is the first axiom of array theory *) @@ -147,7 +150,8 @@ let test_set_domain (ctxt, (k, v)) = let ctxt' = Lwt_main.run @@ Context.add ctxt k v in let domain' = Lwt_main.run @@ Test_mem_context.domain ctxt' in List.for_all - (fun in_domain' -> in_domain' = k || List.mem in_domain' domain) + (fun in_domain' -> + equal_key in_domain' k || List.mem ~equal:equal_key in_domain' domain) domain' let () = diff --git a/src/lib_proxy/test/test_fuzzing_light.ml b/src/lib_proxy/test/test_fuzzing_light.ml index a44afcb54d9f..fd58468af537 100644 --- a/src/lib_proxy/test/test_fuzzing_light.ml +++ b/src/lib_proxy/test/test_fuzzing_light.ml @@ -600,13 +600,14 @@ module Consensus = struct let trial = if random = 0 then "a" else Char.chr (random mod 256) |> String.make 1 in - if List.mem trial siblings || trial = key then String.concat "" siblings + if List.mem ~equal:String.equal trial siblings || trial = key then + String.concat "" siblings else trial let mk_rogue_key siblings key random = - assert (not (List.mem key siblings)) ; + assert (not (List.mem ~equal:String.equal key siblings)) ; let res = mk_rogue_key siblings key random in - assert (not (List.mem res siblings)) ; + assert (not (List.mem ~equal:String.equal res siblings)) ; assert (res <> key) ; res diff --git a/src/lib_rpc/RPC_arg.ml b/src/lib_rpc/RPC_arg.ml index ee946afe5a30..c730138281e7 100644 --- a/src/lib_rpc/RPC_arg.ml +++ b/src/lib_rpc/RPC_arg.ml @@ -26,3 +26,6 @@ type ('i, 'j) eq = ('i, 'j) Resto.eq = Eq : ('a, 'a) eq include Resto.Arg + +let eq_descr a b = + String.equal a.name b.name && Option.equal String.equal a.descr b.descr diff --git a/src/lib_rpc/RPC_arg.mli b/src/lib_rpc/RPC_arg.mli index 0118407f4a6c..7d2eb6f1293e 100644 --- a/src/lib_rpc/RPC_arg.mli +++ b/src/lib_rpc/RPC_arg.mli @@ -28,3 +28,5 @@ type ('i, 'j) eq = ('i, 'j) Resto.eq = Eq : ('a, 'a) eq include module type of struct include Resto.Arg end + +val eq_descr : descr -> descr -> bool diff --git a/src/lib_sapling/core.ml b/src/lib_sapling/core.ml index 5de8a019f12c..c2f9257ee1cc 100644 --- a/src/lib_sapling/core.ml +++ b/src/lib_sapling/core.ml @@ -221,6 +221,8 @@ module Raw = struct (* diversifier_index is 11 bytes long but we treat is as 8 byte long int64 *) type index = R.diversifier_index + let compare_index = R.compare_diversifier_index + (* partial function to convert an 11 byte index to a 8 byte int64 *) let index_to_int64 idx = let b = R.of_diversifier_index idx in diff --git a/src/lib_sapling/core_sig.ml b/src/lib_sapling/core_sig.ml index 58ea8100cbc9..4b85731e25e8 100644 --- a/src/lib_sapling/core_sig.ml +++ b/src/lib_sapling/core_sig.ml @@ -101,6 +101,8 @@ module type Viewing_key = sig the following addresses can be derived with [index_succ] **) type index + val compare_index : index -> index -> int + val default_index : index val index_succ : index -> index diff --git a/src/lib_sapling/rustzcash.ml b/src/lib_sapling/rustzcash.ml index ba3f46c25545..3a3477bc51c3 100644 --- a/src/lib_sapling/rustzcash.ml +++ b/src/lib_sapling/rustzcash.ml @@ -84,6 +84,8 @@ module T : Rustzcash_sig.T = struct type diversifier_index = Bytes.t + let compare_diversifier_index = Bytes.compare + (* 96 bytes *) type expanded_spending_key = {ask : ask; nsk : nsk; ovk : ovk} diff --git a/src/lib_sapling/rustzcash_sig.ml b/src/lib_sapling/rustzcash_sig.ml index 59a5e421dbfd..5cc0be4d979b 100644 --- a/src/lib_sapling/rustzcash_sig.ml +++ b/src/lib_sapling/rustzcash_sig.ml @@ -70,6 +70,8 @@ module type T = sig type diversifier_index (* 11 *) + val compare_diversifier_index : diversifier_index -> diversifier_index -> int + (*96 bytes*) type expanded_spending_key = {ask : ask; nsk : nsk; ovk : ovk} diff --git a/src/lib_shell/chain_validator.ml b/src/lib_shell/chain_validator.ml index e6dc939563aa..8faadc974df7 100644 --- a/src/lib_shell/chain_validator.ml +++ b/src/lib_shell/chain_validator.ml @@ -192,7 +192,7 @@ let notify_new_block w block = let nv = Worker.state w in Option.iter (fun id -> - List.assoc id (Worker.list table) + List.assoc ~equal:Chain_id.equal id (Worker.list table) |> Option.iter (fun w -> let nv = Worker.state w in Lwt_watcher.notify nv.valid_block_input block)) @@ -784,7 +784,10 @@ let child w = Option.bind (Worker.state w).child (fun ({parameters = {chain_store; _}; _}, _) -> - List.assoc (Store.Chain.chain_id chain_store) (Worker.list table)) + List.assoc + ~equal:Chain_id.equal + (Store.Chain.chain_id chain_store) + (Worker.list table)) let assert_fitness_increases ?(force = false) w distant_header = let pv = Worker.state w in diff --git a/src/lib_shell/node.ml b/src/lib_shell/node.ml index 24b961d84ede..49f9dd058553 100644 --- a/src/lib_shell/node.ml +++ b/src/lib_shell/node.ml @@ -168,8 +168,13 @@ let store_known_protocols store = | Some protocol -> ( let hash = Protocol.hash protocol in if not (Protocol_hash.equal hash protocol_hash) then - if List.mem protocol_hash test_protocol_hashes then - Lwt.return_unit (* noop. test protocol should not be stored *) + if + List.mem + ~equal:Protocol_hash.equal + protocol_hash + test_protocol_hashes + then Lwt.return_unit + (* noop. test protocol should not be stored *) else Node_event.(emit store_protocol_incorrect_hash) protocol_hash else diff --git a/src/lib_shell/worker_directory.ml b/src/lib_shell/worker_directory.ml index d65b4a2f42ff..7448bdca89ad 100644 --- a/src/lib_shell/worker_directory.ml +++ b/src/lib_shell/worker_directory.ml @@ -92,9 +92,15 @@ let build_rpc_directory state = register2 Worker_services.Peer_validators.S.state (fun chain peer_id () () -> Chain_directory.get_chain_id state chain >>= fun chain_id -> + let equal (acid, apid) (bcid, bpid) = + Chain_id.equal acid bcid && P2p_peer.Id.equal apid bpid + in let w = WithExceptions.Option.to_exn ~none:Not_found - @@ List.assoc (chain_id, peer_id) (Peer_validator.running_workers ()) + @@ List.assoc + ~equal + (chain_id, peer_id) + (Peer_validator.running_workers ()) in return { @@ -118,7 +124,10 @@ let build_rpc_directory state = >>= fun chain_id -> let w = WithExceptions.Option.to_exn ~none:Not_found - @@ List.assoc chain_id (Chain_validator.running_workers ()) + @@ List.assoc + ~equal:Chain_id.equal + chain_id + (Chain_validator.running_workers ()) in return { @@ -133,7 +142,10 @@ let build_rpc_directory state = >>= fun chain_id -> let w = WithExceptions.Option.to_exn ~none:Not_found - @@ List.assoc chain_id (Chain_validator.running_workers ()) + @@ List.assoc + ~equal:Chain_id.equal + chain_id + (Chain_validator.running_workers ()) in return (Chain_validator.ddb_information w)) ; !dir diff --git a/src/lib_shell_services/block_services.ml b/src/lib_shell_services/block_services.ml index cbb6bbdfa717..6d0d04ecf35d 100644 --- a/src/lib_shell_services/block_services.ml +++ b/src/lib_shell_services/block_services.ml @@ -78,7 +78,8 @@ let parse_block s = ([s], ' ') | 1 -> let delim = - WithExceptions.Option.get ~loc:__LOC__ @@ List.assoc 1 counts + WithExceptions.Option.get ~loc:__LOC__ + @@ List.assoc ~equal:Int.equal 1 counts in (String.split delim s, delim) | _ -> diff --git a/src/lib_signer_backends/encrypted.ml b/src/lib_signer_backends/encrypted.ml index db55c6220b0a..32395c195d05 100644 --- a/src/lib_signer_backends/encrypted.ml +++ b/src/lib_signer_backends/encrypted.ml @@ -248,7 +248,7 @@ let decrypt_list (cctxt : #Client_context.io_wallet) keys = (fun (name, sk_uri) -> if Uri.scheme (sk_uri : sk_uri :> Uri.t) = Some scheme - && (keys = [] || List.mem name keys) + && (keys = [] || List.mem ~equal:String.equal name keys) then decrypt cctxt ~name sk_uri >>=? fun _ -> return_unit else return_unit) sks diff --git a/src/lib_signer_backends/unix/socket.ml b/src/lib_signer_backends/unix/socket.ml index 0e8113be0361..4240a2179e77 100644 --- a/src/lib_signer_backends/unix/socket.ml +++ b/src/lib_signer_backends/unix/socket.ml @@ -80,7 +80,10 @@ struct let rec loop n = protect (fun () -> f ()) >>= function - | Error trace as e when List.mem (Exn Lwt_unix.Timeout) trace -> + | Error trace as e + when List.exists + (function Exn Lwt_unix.Timeout -> true | _ -> false) + trace -> if n = 0 then Lwt.return e else Events.(emit signer_timeout) (pred n) >>= fun () -> loop (pred n) diff --git a/src/lib_stdlib/compare.ml b/src/lib_stdlib/compare.ml index 1769259c2fbe..d12e46bfc7b9 100644 --- a/src/lib_stdlib/compare.ml +++ b/src/lib_stdlib/compare.ml @@ -241,3 +241,5 @@ end) module String = Make (String) module Bytes = Make (Bytes) module Z = Make (Z) + +let or_else c f = if c <> 0 then c else f () diff --git a/src/lib_stdlib/compare.mli b/src/lib_stdlib/compare.mli index adaef49607dc..b3e64db3383e 100644 --- a/src/lib_stdlib/compare.mli +++ b/src/lib_stdlib/compare.mli @@ -135,3 +135,15 @@ module Option (P : COMPARABLE) : S with type t = P.t option module Result (Ok : COMPARABLE) (Error : COMPARABLE) : S with type t = (Ok.t, Error.t) result + +(** {2 Building blocks} *) + +(** [or_else c f] is [c] if [c <> 0] or [f ()] otherwise. + + The intended use is +{[ +let compare (foo_a, bar_a) (foo_b, bar_b) = + or_else (Foo.compare foo_a foo_b) (fun () -> Bar.compare bar_a bar_b) +]} +*) +val or_else : int -> (unit -> int) -> int diff --git a/src/lib_stdlib_unix/file_event_sink.ml b/src/lib_stdlib_unix/file_event_sink.ml index 4142ae9e8760..6519bd99aca6 100644 --- a/src/lib_stdlib_unix/file_event_sink.ml +++ b/src/lib_stdlib_unix/file_event_sink.ml @@ -91,9 +91,9 @@ module Event_filter = struct | Name_matches re -> Re.execp re name | Level_in l -> - List.mem level l + List.mem ~equal:Internal_event.Level.equal level l | Section_in l -> - List.mem section l + List.mem ~equal:Internal_event.Section.equal section l let rec pp fmt filter = let open Format in @@ -588,14 +588,14 @@ module Query = struct | None -> fun _ -> true | Some l -> - fun name -> List.mem name l + fun name -> List.mem ~equal:String.equal name l in let section_matches = match only_sections with | None -> fun _ -> true | Some l -> - fun name -> List.mem name l + fun name -> List.mem ~equal:(Option.equal String.equal) name l in configure uri >>=? fun {path = sink_path; _} -> diff --git a/src/lib_store/legacy.ml b/src/lib_store/legacy.ml index 310ea199b61b..a8c56088c9c2 100644 --- a/src/lib_store/legacy.ml +++ b/src/lib_store/legacy.ml @@ -211,7 +211,7 @@ let may_update_protocol_table legacy_chain_store chain_store ~prev_block ~block >>= fun protocol_table -> let (proto_hash, transition_level) : Legacy_store.Chain.Protocol_info.value = - List.assoc proto_level protocol_table + List.assoc ~equal:Int.equal proto_level protocol_table |> WithExceptions.Option.get ~loc:__LOC__ in assert (Int32.equal transition_level block_level) ; diff --git a/src/lib_store/snapshots.ml b/src/lib_store/snapshots.ml index a991894cd1a6..5706db09cd64 100644 --- a/src/lib_store/snapshots.ml +++ b/src/lib_store/snapshots.ml @@ -1912,7 +1912,8 @@ struct let src_protocol_file = Naming.protocol_file protocol_store_dir ph in - ( if List.mem ph proto_to_export then + ( if List.mem ~equal:Protocol_hash.equal ph proto_to_export + then Exporter.copy_protocol snapshot_exporter ~src:(Naming.file_path src_protocol_file) diff --git a/src/lib_store/test/alpha_utils.ml b/src/lib_store/test/alpha_utils.ml index 786aa16cf679..6eb6b0e5cf55 100644 --- a/src/lib_store/test/alpha_utils.ml +++ b/src/lib_store/test/alpha_utils.ml @@ -196,7 +196,7 @@ let get_next_baker_excluding ctxt excludes block = _ } = List.find (fun {Alpha_services.Delegate.Baking_rights.delegate; _} -> - not (List.mem delegate excludes)) + not (List.mem ~equal:Signature.Public_key_hash.equal delegate excludes)) bakers |> WithExceptions.Option.get ~loc:__LOC__ in diff --git a/src/lib_store/test/test_snapshots.ml b/src/lib_store/test/test_snapshots.ml index fd618255de28..99c2c53b18bb 100644 --- a/src/lib_store/test/test_snapshots.ml +++ b/src/lib_store/test/test_snapshots.ml @@ -426,7 +426,8 @@ let make_tests speed genesis_parameters = (product nb_initial_blocks_list ( map export_blocks_levels nb_initial_blocks_list - |> flatten |> List.sort_uniq compare )) + |> flatten + |> List.sort_uniq Stdlib.compare )) (product exporter_history_modes [false; true])) |> List.map (fun ((a, b), (c, d)) -> (a, b, c, d)) in diff --git a/src/lib_validation/block_validation.ml b/src/lib_validation/block_validation.ml index b4f22973db5a..0a3511957eec 100644 --- a/src/lib_validation/block_validation.ml +++ b/src/lib_validation/block_validation.ml @@ -265,7 +265,7 @@ module Make (Proto : Registered_protocol.T) = struct let op = {Proto.shell = op.shell; protocol_data} in let allowed_pass = Proto.acceptable_passes op in fail_unless - (List.mem pass allowed_pass) + (List.mem ~equal:Int.equal pass allowed_pass) (invalid_block (Unallowed_pass {operation = op_hash; pass; allowed_pass})) >>=? fun () -> return op)) diff --git a/src/lib_workers/worker.ml b/src/lib_workers/worker.ml index b8a23607ea7a..384d1aa83275 100644 --- a/src/lib_workers/worker.ml +++ b/src/lib_workers/worker.ml @@ -518,7 +518,10 @@ struct lwt_emit w (Logger.WorkerEvent (evt, Event.level evt)) >>= fun () -> if Event.level evt >= w.limits.backlog_level then - List.assoc (Event.level evt) w.event_log + List.assoc + ~equal:Internal_event.Level.equal + (Event.level evt) + w.event_log |> Option.iter (fun ring -> Ringo.Ring.add ring evt) ; Lwt.return_unit diff --git a/src/proto_001_PtCJ7pwo/lib_client/client_proto_contracts.ml b/src/proto_001_PtCJ7pwo/lib_client/client_proto_contracts.ml index 57db198aaba2..e2d13528491b 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/client_proto_contracts.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/client_proto_contracts.ml @@ -29,6 +29,8 @@ open Alpha_context module ContractEntity = struct type t = Contract.t + include (Contract : Compare.S with type t := t) + let encoding = Contract.encoding let of_source s = diff --git a/src/proto_001_PtCJ7pwo/lib_client/client_proto_programs.ml b/src/proto_001_PtCJ7pwo/lib_client/client_proto_programs.ml index 35f1b7a83e0a..e21750bdb624 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/client_proto_programs.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/client_proto_programs.ml @@ -31,6 +31,12 @@ open Michelson_v1_printer module Program = Client_aliases.Alias (struct type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result + include Compare.Make (struct + type nonrec t = t + + let compare = Micheline_parser.compare Michelson_v1_parser.compare_parsed + end) + let encoding = Data_encoding.conv (fun ({Michelson_v1_parser.source}, _) -> source) diff --git a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_emacs.ml b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_emacs.ml index c38da89cfca7..3eb22045e1b3 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_emacs.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_emacs.ml @@ -90,12 +90,13 @@ let print_type_map ppf (parsed, type_map) = items and print_item ppf loc = (let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc ~equal:Int.equal loc parsed.Michelson_v1_parser.expansion_table >?? fun ({start = {point = s}; stop = {point = e}}, locs) -> - let locs = List.sort compare locs in + let locs = List.sort Stdlib.compare locs in List.hd locs >?? fun hd_loc -> - List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + List.assoc ~equal:Int.equal hd_loc type_map + >?? fun (bef, aft) -> Some (s, e, bef, aft)) |> Option.iter (fun (s, e, bef, aft) -> Format.fprintf ppf @@ -153,11 +154,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in match errs with | top :: errs -> @@ -196,11 +200,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in let loc = match err with diff --git a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_error_reporter.ml b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_error_reporter.ml index 4272efc72a24..7789bf246df0 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_error_reporter.ml @@ -138,9 +138,13 @@ let report_errors ~details ~show_source ?parsed ppf errs = in let parsed_locations parsed loc = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table >?? fun oloc -> - List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc + List.assoc ~equal:Int.equal oloc parsed.expansion_table + >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = diff --git a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_parser.ml b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_parser.ml index fcfc8a3d6fa3..b4f9489bf9e1 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_parser.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_parser.ml @@ -36,6 +36,8 @@ type parsed = { unexpansion_table : (int * int) list; } +let compare_parsed = Stdlib.compare + (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = let (unexpanded, loc_table) = extract_locations ast in @@ -45,7 +47,7 @@ let expand_all source ast errors = let (expanded, unexpansion_table) = extract_locations expanded in let expansion_table = let sorted = - List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table + List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function @@ -65,8 +67,8 @@ let expand_all source ast errors = (fun (l, ploc) (l', elocs) -> assert (l = l') ; (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + (List.sort Stdlib.compare loc_table) + (List.sort Stdlib.compare grouped) with | Ok v -> v diff --git a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_parser.mli b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_parser.mli index 4f55e20943fa..6aa29676741a 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_parser.mli +++ b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_parser.mli @@ -41,6 +41,8 @@ type parsed = { expression. *) } +val compare_parsed : parsed -> parsed -> int + val parse_toplevel : ?check:bool -> string -> parsed Micheline_parser.parsing_result diff --git a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_printer.ml b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_printer.ml index e31345a9fa8c..403b85e783b5 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_printer.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_printer.ml @@ -93,12 +93,15 @@ let inject_types type_map parsed = and inject_loc which loc = let comment = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.expansion_table >?? fun (_, locs) -> let locs = List.sort compare locs in List.hd locs >?? fun head_loc -> - List.assoc head_loc type_map + List.assoc ~equal:Int.equal head_loc type_map >?? fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) @@ -130,9 +133,9 @@ let unparse ?type_map parse expanded = and inject_loc which loc = let comment = let ( >?? ) = Option.bind in - List.assoc loc unexpansion_table + List.assoc ~equal:Int.equal loc unexpansion_table >?? fun loc -> - List.assoc loc type_map + List.assoc ~equal:Int.equal loc type_map >?? fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) diff --git a/src/proto_002_PsYLVpVv/lib_client/client_proto_contracts.ml b/src/proto_002_PsYLVpVv/lib_client/client_proto_contracts.ml index 57db198aaba2..e2d13528491b 100644 --- a/src/proto_002_PsYLVpVv/lib_client/client_proto_contracts.ml +++ b/src/proto_002_PsYLVpVv/lib_client/client_proto_contracts.ml @@ -29,6 +29,8 @@ open Alpha_context module ContractEntity = struct type t = Contract.t + include (Contract : Compare.S with type t := t) + let encoding = Contract.encoding let of_source s = diff --git a/src/proto_002_PsYLVpVv/lib_client/client_proto_programs.ml b/src/proto_002_PsYLVpVv/lib_client/client_proto_programs.ml index 53784f846fb9..2ae9bb49981d 100644 --- a/src/proto_002_PsYLVpVv/lib_client/client_proto_programs.ml +++ b/src/proto_002_PsYLVpVv/lib_client/client_proto_programs.ml @@ -31,6 +31,12 @@ open Michelson_v1_printer module Program = Client_aliases.Alias (struct type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result + include Compare.Make (struct + type nonrec t = t + + let compare = Micheline_parser.compare Michelson_v1_parser.compare_parsed + end) + let encoding = Data_encoding.conv (fun ({Michelson_v1_parser.source}, _) -> source) diff --git a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_emacs.ml b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_emacs.ml index c38da89cfca7..3eb22045e1b3 100644 --- a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_emacs.ml +++ b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_emacs.ml @@ -90,12 +90,13 @@ let print_type_map ppf (parsed, type_map) = items and print_item ppf loc = (let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc ~equal:Int.equal loc parsed.Michelson_v1_parser.expansion_table >?? fun ({start = {point = s}; stop = {point = e}}, locs) -> - let locs = List.sort compare locs in + let locs = List.sort Stdlib.compare locs in List.hd locs >?? fun hd_loc -> - List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + List.assoc ~equal:Int.equal hd_loc type_map + >?? fun (bef, aft) -> Some (s, e, bef, aft)) |> Option.iter (fun (s, e, bef, aft) -> Format.fprintf ppf @@ -153,11 +154,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in match errs with | top :: errs -> @@ -196,11 +200,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in let loc = match err with diff --git a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_error_reporter.ml b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_error_reporter.ml index 4272efc72a24..7789bf246df0 100644 --- a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_error_reporter.ml @@ -138,9 +138,13 @@ let report_errors ~details ~show_source ?parsed ppf errs = in let parsed_locations parsed loc = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table >?? fun oloc -> - List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc + List.assoc ~equal:Int.equal oloc parsed.expansion_table + >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = diff --git a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_parser.ml b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_parser.ml index fcfc8a3d6fa3..b4f9489bf9e1 100644 --- a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_parser.ml +++ b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_parser.ml @@ -36,6 +36,8 @@ type parsed = { unexpansion_table : (int * int) list; } +let compare_parsed = Stdlib.compare + (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = let (unexpanded, loc_table) = extract_locations ast in @@ -45,7 +47,7 @@ let expand_all source ast errors = let (expanded, unexpansion_table) = extract_locations expanded in let expansion_table = let sorted = - List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table + List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function @@ -65,8 +67,8 @@ let expand_all source ast errors = (fun (l, ploc) (l', elocs) -> assert (l = l') ; (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + (List.sort Stdlib.compare loc_table) + (List.sort Stdlib.compare grouped) with | Ok v -> v diff --git a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_parser.mli b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_parser.mli index 4f55e20943fa..6aa29676741a 100644 --- a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_parser.mli +++ b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_parser.mli @@ -41,6 +41,8 @@ type parsed = { expression. *) } +val compare_parsed : parsed -> parsed -> int + val parse_toplevel : ?check:bool -> string -> parsed Micheline_parser.parsing_result diff --git a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_printer.ml b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_printer.ml index e31345a9fa8c..403b85e783b5 100644 --- a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_printer.ml +++ b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_printer.ml @@ -93,12 +93,15 @@ let inject_types type_map parsed = and inject_loc which loc = let comment = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.expansion_table >?? fun (_, locs) -> let locs = List.sort compare locs in List.hd locs >?? fun head_loc -> - List.assoc head_loc type_map + List.assoc ~equal:Int.equal head_loc type_map >?? fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) @@ -130,9 +133,9 @@ let unparse ?type_map parse expanded = and inject_loc which loc = let comment = let ( >?? ) = Option.bind in - List.assoc loc unexpansion_table + List.assoc ~equal:Int.equal loc unexpansion_table >?? fun loc -> - List.assoc loc type_map + List.assoc ~equal:Int.equal loc type_map >?? fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) diff --git a/src/proto_003_PsddFKi3/lib_client/client_proto_contracts.ml b/src/proto_003_PsddFKi3/lib_client/client_proto_contracts.ml index ccb3d4f2424c..bded30793118 100644 --- a/src/proto_003_PsddFKi3/lib_client/client_proto_contracts.ml +++ b/src/proto_003_PsddFKi3/lib_client/client_proto_contracts.ml @@ -29,6 +29,8 @@ open Alpha_context module ContractEntity = struct type t = Contract.t + include (Contract : Compare.S with type t := t) + let encoding = Contract.encoding let of_source s = diff --git a/src/proto_003_PsddFKi3/lib_client/client_proto_programs.ml b/src/proto_003_PsddFKi3/lib_client/client_proto_programs.ml index c0e2a4039320..d6e4616a4c4b 100644 --- a/src/proto_003_PsddFKi3/lib_client/client_proto_programs.ml +++ b/src/proto_003_PsddFKi3/lib_client/client_proto_programs.ml @@ -31,6 +31,12 @@ open Michelson_v1_printer module Program = Client_aliases.Alias (struct type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result + include Compare.Make (struct + type nonrec t = t + + let compare = Micheline_parser.compare Michelson_v1_parser.compare_parsed + end) + let encoding = Data_encoding.conv (fun ({Michelson_v1_parser.source; _}, _) -> source) diff --git a/src/proto_003_PsddFKi3/lib_client/michelson_v1_emacs.ml b/src/proto_003_PsddFKi3/lib_client/michelson_v1_emacs.ml index ffa47378f1c5..f39ab51bc599 100644 --- a/src/proto_003_PsddFKi3/lib_client/michelson_v1_emacs.ml +++ b/src/proto_003_PsddFKi3/lib_client/michelson_v1_emacs.ml @@ -90,12 +90,13 @@ let print_type_map ppf (parsed, type_map) = items and print_item ppf loc = (let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc ~equal:Int.equal loc parsed.Michelson_v1_parser.expansion_table >?? fun ({start = {point = s; _}; stop = {point = e; _}}, locs) -> - let locs = List.sort compare locs in + let locs = List.sort Stdlib.compare locs in List.hd locs >?? fun hd_loc -> - List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + List.assoc ~equal:Int.equal hd_loc type_map + >?? fun (bef, aft) -> Some (s, e, bef, aft)) |> Option.iter (fun (s, e, bef, aft) -> Format.fprintf ppf @@ -153,11 +154,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in match errs with | top :: errs -> @@ -196,11 +200,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in let loc = match err with diff --git a/src/proto_003_PsddFKi3/lib_client/michelson_v1_error_reporter.ml b/src/proto_003_PsddFKi3/lib_client/michelson_v1_error_reporter.ml index 4272efc72a24..7789bf246df0 100644 --- a/src/proto_003_PsddFKi3/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_003_PsddFKi3/lib_client/michelson_v1_error_reporter.ml @@ -138,9 +138,13 @@ let report_errors ~details ~show_source ?parsed ppf errs = in let parsed_locations parsed loc = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table >?? fun oloc -> - List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc + List.assoc ~equal:Int.equal oloc parsed.expansion_table + >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = diff --git a/src/proto_003_PsddFKi3/lib_client/michelson_v1_parser.ml b/src/proto_003_PsddFKi3/lib_client/michelson_v1_parser.ml index fcfc8a3d6fa3..b4f9489bf9e1 100644 --- a/src/proto_003_PsddFKi3/lib_client/michelson_v1_parser.ml +++ b/src/proto_003_PsddFKi3/lib_client/michelson_v1_parser.ml @@ -36,6 +36,8 @@ type parsed = { unexpansion_table : (int * int) list; } +let compare_parsed = Stdlib.compare + (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = let (unexpanded, loc_table) = extract_locations ast in @@ -45,7 +47,7 @@ let expand_all source ast errors = let (expanded, unexpansion_table) = extract_locations expanded in let expansion_table = let sorted = - List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table + List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function @@ -65,8 +67,8 @@ let expand_all source ast errors = (fun (l, ploc) (l', elocs) -> assert (l = l') ; (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + (List.sort Stdlib.compare loc_table) + (List.sort Stdlib.compare grouped) with | Ok v -> v diff --git a/src/proto_003_PsddFKi3/lib_client/michelson_v1_parser.mli b/src/proto_003_PsddFKi3/lib_client/michelson_v1_parser.mli index 4f55e20943fa..6aa29676741a 100644 --- a/src/proto_003_PsddFKi3/lib_client/michelson_v1_parser.mli +++ b/src/proto_003_PsddFKi3/lib_client/michelson_v1_parser.mli @@ -41,6 +41,8 @@ type parsed = { expression. *) } +val compare_parsed : parsed -> parsed -> int + val parse_toplevel : ?check:bool -> string -> parsed Micheline_parser.parsing_result diff --git a/src/proto_003_PsddFKi3/lib_client/michelson_v1_printer.ml b/src/proto_003_PsddFKi3/lib_client/michelson_v1_printer.ml index e31345a9fa8c..403b85e783b5 100644 --- a/src/proto_003_PsddFKi3/lib_client/michelson_v1_printer.ml +++ b/src/proto_003_PsddFKi3/lib_client/michelson_v1_printer.ml @@ -93,12 +93,15 @@ let inject_types type_map parsed = and inject_loc which loc = let comment = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.expansion_table >?? fun (_, locs) -> let locs = List.sort compare locs in List.hd locs >?? fun head_loc -> - List.assoc head_loc type_map + List.assoc ~equal:Int.equal head_loc type_map >?? fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) @@ -130,9 +133,9 @@ let unparse ?type_map parse expanded = and inject_loc which loc = let comment = let ( >?? ) = Option.bind in - List.assoc loc unexpansion_table + List.assoc ~equal:Int.equal loc unexpansion_table >?? fun loc -> - List.assoc loc type_map + List.assoc ~equal:Int.equal loc type_map >?? fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) diff --git a/src/proto_003_PsddFKi3/lib_client_commands/client_proto_context_commands.ml b/src/proto_003_PsddFKi3/lib_client_commands/client_proto_context_commands.ml index 7e4c308c1fb0..e0d1db882b12 100644 --- a/src/proto_003_PsddFKi3/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_003_PsddFKi3/lib_client_commands/client_proto_context_commands.ml @@ -322,7 +322,9 @@ let commands () = Protocol_hash.pp p w - (if List.mem p known_protos then "" else "not ")) + ( if List.mem ~equal:Protocol_hash.equal p known_protos + then "" + else "not " )) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_004_Pt24m4xi/lib_client/client_proto_contracts.ml b/src/proto_004_Pt24m4xi/lib_client/client_proto_contracts.ml index 1980f7736ae1..c86daee8d56c 100644 --- a/src/proto_004_Pt24m4xi/lib_client/client_proto_contracts.ml +++ b/src/proto_004_Pt24m4xi/lib_client/client_proto_contracts.ml @@ -29,6 +29,8 @@ open Alpha_context module ContractEntity = struct type t = Contract.t + include (Contract : Compare.S with type t := t) + let encoding = Contract.encoding let of_source s = diff --git a/src/proto_004_Pt24m4xi/lib_client/client_proto_programs.ml b/src/proto_004_Pt24m4xi/lib_client/client_proto_programs.ml index a9516e581423..eac758020a70 100644 --- a/src/proto_004_Pt24m4xi/lib_client/client_proto_programs.ml +++ b/src/proto_004_Pt24m4xi/lib_client/client_proto_programs.ml @@ -31,6 +31,12 @@ open Michelson_v1_printer module Program = Client_aliases.Alias (struct type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result + include Compare.Make (struct + type nonrec t = t + + let compare = Micheline_parser.compare Michelson_v1_parser.compare_parsed + end) + let encoding = Data_encoding.conv (fun ({Michelson_v1_parser.source; _}, _) -> source) diff --git a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_emacs.ml b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_emacs.ml index ffa47378f1c5..f39ab51bc599 100644 --- a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_emacs.ml +++ b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_emacs.ml @@ -90,12 +90,13 @@ let print_type_map ppf (parsed, type_map) = items and print_item ppf loc = (let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc ~equal:Int.equal loc parsed.Michelson_v1_parser.expansion_table >?? fun ({start = {point = s; _}; stop = {point = e; _}}, locs) -> - let locs = List.sort compare locs in + let locs = List.sort Stdlib.compare locs in List.hd locs >?? fun hd_loc -> - List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + List.assoc ~equal:Int.equal hd_loc type_map + >?? fun (bef, aft) -> Some (s, e, bef, aft)) |> Option.iter (fun (s, e, bef, aft) -> Format.fprintf ppf @@ -153,11 +154,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in match errs with | top :: errs -> @@ -196,11 +200,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in let loc = match err with diff --git a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_error_reporter.ml b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_error_reporter.ml index 4272efc72a24..7789bf246df0 100644 --- a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_error_reporter.ml @@ -138,9 +138,13 @@ let report_errors ~details ~show_source ?parsed ppf errs = in let parsed_locations parsed loc = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table >?? fun oloc -> - List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc + List.assoc ~equal:Int.equal oloc parsed.expansion_table + >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = diff --git a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_parser.ml b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_parser.ml index fcfc8a3d6fa3..b4f9489bf9e1 100644 --- a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_parser.ml +++ b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_parser.ml @@ -36,6 +36,8 @@ type parsed = { unexpansion_table : (int * int) list; } +let compare_parsed = Stdlib.compare + (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = let (unexpanded, loc_table) = extract_locations ast in @@ -45,7 +47,7 @@ let expand_all source ast errors = let (expanded, unexpansion_table) = extract_locations expanded in let expansion_table = let sorted = - List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table + List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function @@ -65,8 +67,8 @@ let expand_all source ast errors = (fun (l, ploc) (l', elocs) -> assert (l = l') ; (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + (List.sort Stdlib.compare loc_table) + (List.sort Stdlib.compare grouped) with | Ok v -> v diff --git a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_parser.mli b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_parser.mli index 4f55e20943fa..6aa29676741a 100644 --- a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_parser.mli +++ b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_parser.mli @@ -41,6 +41,8 @@ type parsed = { expression. *) } +val compare_parsed : parsed -> parsed -> int + val parse_toplevel : ?check:bool -> string -> parsed Micheline_parser.parsing_result diff --git a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_printer.ml b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_printer.ml index e31345a9fa8c..403b85e783b5 100644 --- a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_printer.ml +++ b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_printer.ml @@ -93,12 +93,15 @@ let inject_types type_map parsed = and inject_loc which loc = let comment = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.expansion_table >?? fun (_, locs) -> let locs = List.sort compare locs in List.hd locs >?? fun head_loc -> - List.assoc head_loc type_map + List.assoc ~equal:Int.equal head_loc type_map >?? fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) @@ -130,9 +133,9 @@ let unparse ?type_map parse expanded = and inject_loc which loc = let comment = let ( >?? ) = Option.bind in - List.assoc loc unexpansion_table + List.assoc ~equal:Int.equal loc unexpansion_table >?? fun loc -> - List.assoc loc type_map + List.assoc ~equal:Int.equal loc type_map >?? fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) diff --git a/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_context_commands.ml b/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_context_commands.ml index 7e4c308c1fb0..e0d1db882b12 100644 --- a/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_context_commands.ml @@ -322,7 +322,9 @@ let commands () = Protocol_hash.pp p w - (if List.mem p known_protos then "" else "not ")) + ( if List.mem ~equal:Protocol_hash.equal p known_protos + then "" + else "not " )) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_005_PsBabyM1/lib_client/client_proto_contracts.ml b/src/proto_005_PsBabyM1/lib_client/client_proto_contracts.ml index d84a979fd05d..1f6346d679fd 100644 --- a/src/proto_005_PsBabyM1/lib_client/client_proto_contracts.ml +++ b/src/proto_005_PsBabyM1/lib_client/client_proto_contracts.ml @@ -29,6 +29,8 @@ open Alpha_context module ContractEntity = struct type t = Contract.t + include (Contract : Compare.S with type t := t) + let encoding = Contract.encoding let of_source s = diff --git a/src/proto_005_PsBabyM1/lib_client/client_proto_programs.ml b/src/proto_005_PsBabyM1/lib_client/client_proto_programs.ml index 4cb6854bb88c..ddd585623fe1 100644 --- a/src/proto_005_PsBabyM1/lib_client/client_proto_programs.ml +++ b/src/proto_005_PsBabyM1/lib_client/client_proto_programs.ml @@ -32,6 +32,12 @@ open Michelson_v1_printer module Program = Client_aliases.Alias (struct type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result + include Compare.Make (struct + type nonrec t = t + + let compare = Micheline_parser.compare Michelson_v1_parser.compare_parsed + end) + let encoding = Data_encoding.conv (fun ({Michelson_v1_parser.source; _}, _) -> source) diff --git a/src/proto_005_PsBabyM1/lib_client/michelson_v1_emacs.ml b/src/proto_005_PsBabyM1/lib_client/michelson_v1_emacs.ml index 7b41fb168dba..3c0c897aea66 100644 --- a/src/proto_005_PsBabyM1/lib_client/michelson_v1_emacs.ml +++ b/src/proto_005_PsBabyM1/lib_client/michelson_v1_emacs.ml @@ -90,12 +90,13 @@ let print_type_map ppf (parsed, type_map) = items and print_item ppf loc = (let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc ~equal:Int.equal loc parsed.Michelson_v1_parser.expansion_table >?? fun ({start = {point = s; _}; stop = {point = e; _}}, locs) -> - let locs = List.sort compare locs in + let locs = List.sort Stdlib.compare locs in List.hd locs >?? fun hd_loc -> - List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + List.assoc ~equal:Int.equal hd_loc type_map + >?? fun (bef, aft) -> Some (s, e, bef, aft)) |> Option.iter (fun (s, e, bef, aft) -> Format.fprintf ppf @@ -154,11 +155,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in match errs with | top :: errs -> @@ -197,11 +201,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in let loc = match err with diff --git a/src/proto_005_PsBabyM1/lib_client/michelson_v1_entrypoints.ml b/src/proto_005_PsBabyM1/lib_client/michelson_v1_entrypoints.ml index 9b436a87d9e6..24c0f0eb6b61 100644 --- a/src/proto_005_PsBabyM1/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_005_PsBabyM1/lib_client/michelson_v1_entrypoints.ml @@ -118,7 +118,7 @@ let list_contract_unreachables cctxt ~chain ~block ~contract = let list_contract_entrypoints cctxt ~chain ~block ~contract = list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract >>=? fun (_, entrypoints) -> - if not @@ List.mem_assoc "default" entrypoints then + if not @@ List.mem_assoc ~equal:String.equal "default" entrypoints then contract_entrypoint_type cctxt ~chain @@ -139,7 +139,7 @@ let list_unreachables cctxt ~chain ~block (program : Script.expr) = let list_entrypoints cctxt ~chain ~block (program : Script.expr) = Alpha_services.Helpers.Scripts.list_entrypoints cctxt (chain, block) program >>=? fun (_, entrypoints) -> - if not @@ List.mem_assoc "default" entrypoints then + if not @@ List.mem_assoc ~equal:String.equal "default" entrypoints then script_entrypoint_type cctxt ~chain ~block program ~entrypoint:"default" >>= function | Ok (Some ty) -> diff --git a/src/proto_005_PsBabyM1/lib_client/michelson_v1_error_reporter.ml b/src/proto_005_PsBabyM1/lib_client/michelson_v1_error_reporter.ml index 2f85546ffe5c..16a0adfd0014 100644 --- a/src/proto_005_PsBabyM1/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_005_PsBabyM1/lib_client/michelson_v1_error_reporter.ml @@ -142,9 +142,13 @@ let report_errors ~details ~show_source ?parsed ppf errs = in let parsed_locations parsed loc = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table >?? fun oloc -> - List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc + List.assoc ~equal:Int.equal oloc parsed.expansion_table + >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = diff --git a/src/proto_005_PsBabyM1/lib_client/michelson_v1_parser.ml b/src/proto_005_PsBabyM1/lib_client/michelson_v1_parser.ml index fcfc8a3d6fa3..b4f9489bf9e1 100644 --- a/src/proto_005_PsBabyM1/lib_client/michelson_v1_parser.ml +++ b/src/proto_005_PsBabyM1/lib_client/michelson_v1_parser.ml @@ -36,6 +36,8 @@ type parsed = { unexpansion_table : (int * int) list; } +let compare_parsed = Stdlib.compare + (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = let (unexpanded, loc_table) = extract_locations ast in @@ -45,7 +47,7 @@ let expand_all source ast errors = let (expanded, unexpansion_table) = extract_locations expanded in let expansion_table = let sorted = - List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table + List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function @@ -65,8 +67,8 @@ let expand_all source ast errors = (fun (l, ploc) (l', elocs) -> assert (l = l') ; (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + (List.sort Stdlib.compare loc_table) + (List.sort Stdlib.compare grouped) with | Ok v -> v diff --git a/src/proto_005_PsBabyM1/lib_client/michelson_v1_parser.mli b/src/proto_005_PsBabyM1/lib_client/michelson_v1_parser.mli index 4f55e20943fa..6aa29676741a 100644 --- a/src/proto_005_PsBabyM1/lib_client/michelson_v1_parser.mli +++ b/src/proto_005_PsBabyM1/lib_client/michelson_v1_parser.mli @@ -41,6 +41,8 @@ type parsed = { expression. *) } +val compare_parsed : parsed -> parsed -> int + val parse_toplevel : ?check:bool -> string -> parsed Micheline_parser.parsing_result diff --git a/src/proto_005_PsBabyM1/lib_client/michelson_v1_printer.ml b/src/proto_005_PsBabyM1/lib_client/michelson_v1_printer.ml index aeef79d341fb..cda8522a3ea7 100644 --- a/src/proto_005_PsBabyM1/lib_client/michelson_v1_printer.ml +++ b/src/proto_005_PsBabyM1/lib_client/michelson_v1_printer.ml @@ -132,12 +132,15 @@ let inject_types type_map parsed = and inject_loc which loc = let comment = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.expansion_table >?? fun (_, locs) -> let locs = List.sort compare locs in List.hd locs >?? fun head_loc -> - List.assoc head_loc type_map + List.assoc ~equal:Int.equal head_loc type_map >?? fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) @@ -169,9 +172,9 @@ let unparse ?type_map parse expanded = and inject_loc which loc = let comment = let ( >?? ) = Option.bind in - List.assoc loc unexpansion_table + List.assoc ~equal:Int.equal loc unexpansion_table >?? fun loc -> - List.assoc loc type_map + List.assoc ~equal:Int.equal loc type_map >?? fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) diff --git a/src/proto_005_PsBabyM1/lib_client_commands/client_proto_context_commands.ml b/src/proto_005_PsBabyM1/lib_client_commands/client_proto_context_commands.ml index a147a47ed82e..974c848cdaaf 100644 --- a/src/proto_005_PsBabyM1/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_005_PsBabyM1/lib_client_commands/client_proto_context_commands.ml @@ -384,7 +384,9 @@ let commands () = Protocol_hash.pp p w - (if List.mem p known_protos then "" else "not ")) + ( if List.mem ~equal:Protocol_hash.equal p known_protos + then "" + else "not " )) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_006_PsCARTHA/lib_client/client_proto_contracts.ml b/src/proto_006_PsCARTHA/lib_client/client_proto_contracts.ml index d84a979fd05d..1f6346d679fd 100644 --- a/src/proto_006_PsCARTHA/lib_client/client_proto_contracts.ml +++ b/src/proto_006_PsCARTHA/lib_client/client_proto_contracts.ml @@ -29,6 +29,8 @@ open Alpha_context module ContractEntity = struct type t = Contract.t + include (Contract : Compare.S with type t := t) + let encoding = Contract.encoding let of_source s = diff --git a/src/proto_006_PsCARTHA/lib_client/client_proto_programs.ml b/src/proto_006_PsCARTHA/lib_client/client_proto_programs.ml index 89aa45c48360..ad3f01ca7163 100644 --- a/src/proto_006_PsCARTHA/lib_client/client_proto_programs.ml +++ b/src/proto_006_PsCARTHA/lib_client/client_proto_programs.ml @@ -32,6 +32,12 @@ open Michelson_v1_printer module Program = Client_aliases.Alias (struct type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result + include Compare.Make (struct + type nonrec t = t + + let compare = Micheline_parser.compare Michelson_v1_parser.compare_parsed + end) + let encoding = Data_encoding.conv (fun ({Michelson_v1_parser.source; _}, _) -> source) diff --git a/src/proto_006_PsCARTHA/lib_client/michelson_v1_emacs.ml b/src/proto_006_PsCARTHA/lib_client/michelson_v1_emacs.ml index 7b41fb168dba..3c0c897aea66 100644 --- a/src/proto_006_PsCARTHA/lib_client/michelson_v1_emacs.ml +++ b/src/proto_006_PsCARTHA/lib_client/michelson_v1_emacs.ml @@ -90,12 +90,13 @@ let print_type_map ppf (parsed, type_map) = items and print_item ppf loc = (let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc ~equal:Int.equal loc parsed.Michelson_v1_parser.expansion_table >?? fun ({start = {point = s; _}; stop = {point = e; _}}, locs) -> - let locs = List.sort compare locs in + let locs = List.sort Stdlib.compare locs in List.hd locs >?? fun hd_loc -> - List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + List.assoc ~equal:Int.equal hd_loc type_map + >?? fun (bef, aft) -> Some (s, e, bef, aft)) |> Option.iter (fun (s, e, bef, aft) -> Format.fprintf ppf @@ -154,11 +155,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in match errs with | top :: errs -> @@ -197,11 +201,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in let loc = match err with diff --git a/src/proto_006_PsCARTHA/lib_client/michelson_v1_entrypoints.ml b/src/proto_006_PsCARTHA/lib_client/michelson_v1_entrypoints.ml index 73c2af021aef..e0a421f714f3 100644 --- a/src/proto_006_PsCARTHA/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_006_PsCARTHA/lib_client/michelson_v1_entrypoints.ml @@ -118,7 +118,7 @@ let list_contract_unreachables cctxt ~chain ~block ~contract = let list_contract_entrypoints cctxt ~chain ~block ~contract = list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract >>=? fun (_, entrypoints) -> - if not @@ List.mem_assoc "default" entrypoints then + if not @@ List.mem_assoc ~equal:String.equal "default" entrypoints then contract_entrypoint_type cctxt ~chain @@ -141,7 +141,7 @@ let list_unreachables cctxt ~chain ~block (program : Script.expr) = let list_entrypoints cctxt ~chain ~block (program : Script.expr) = Alpha_services.Helpers.Scripts.list_entrypoints cctxt (chain, block) program >>=? fun (_, entrypoints) -> - if not @@ List.mem_assoc "default" entrypoints then + if not @@ List.mem_assoc ~equal:String.equal "default" entrypoints then script_entrypoint_type cctxt ~chain ~block program ~entrypoint:"default" >>= function | Ok (Some ty) -> diff --git a/src/proto_006_PsCARTHA/lib_client/michelson_v1_error_reporter.ml b/src/proto_006_PsCARTHA/lib_client/michelson_v1_error_reporter.ml index 38065ade1340..ece465b0d581 100644 --- a/src/proto_006_PsCARTHA/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_006_PsCARTHA/lib_client/michelson_v1_error_reporter.ml @@ -142,9 +142,13 @@ let report_errors ~details ~show_source ?parsed ppf errs = in let parsed_locations parsed loc = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table >?? fun oloc -> - List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc + List.assoc ~equal:Int.equal oloc parsed.expansion_table + >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = diff --git a/src/proto_006_PsCARTHA/lib_client/michelson_v1_parser.ml b/src/proto_006_PsCARTHA/lib_client/michelson_v1_parser.ml index fcfc8a3d6fa3..b4f9489bf9e1 100644 --- a/src/proto_006_PsCARTHA/lib_client/michelson_v1_parser.ml +++ b/src/proto_006_PsCARTHA/lib_client/michelson_v1_parser.ml @@ -36,6 +36,8 @@ type parsed = { unexpansion_table : (int * int) list; } +let compare_parsed = Stdlib.compare + (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = let (unexpanded, loc_table) = extract_locations ast in @@ -45,7 +47,7 @@ let expand_all source ast errors = let (expanded, unexpansion_table) = extract_locations expanded in let expansion_table = let sorted = - List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table + List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function @@ -65,8 +67,8 @@ let expand_all source ast errors = (fun (l, ploc) (l', elocs) -> assert (l = l') ; (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + (List.sort Stdlib.compare loc_table) + (List.sort Stdlib.compare grouped) with | Ok v -> v diff --git a/src/proto_006_PsCARTHA/lib_client/michelson_v1_parser.mli b/src/proto_006_PsCARTHA/lib_client/michelson_v1_parser.mli index 4f55e20943fa..6aa29676741a 100644 --- a/src/proto_006_PsCARTHA/lib_client/michelson_v1_parser.mli +++ b/src/proto_006_PsCARTHA/lib_client/michelson_v1_parser.mli @@ -41,6 +41,8 @@ type parsed = { expression. *) } +val compare_parsed : parsed -> parsed -> int + val parse_toplevel : ?check:bool -> string -> parsed Micheline_parser.parsing_result diff --git a/src/proto_006_PsCARTHA/lib_client/michelson_v1_printer.ml b/src/proto_006_PsCARTHA/lib_client/michelson_v1_printer.ml index aeef79d341fb..cda8522a3ea7 100644 --- a/src/proto_006_PsCARTHA/lib_client/michelson_v1_printer.ml +++ b/src/proto_006_PsCARTHA/lib_client/michelson_v1_printer.ml @@ -132,12 +132,15 @@ let inject_types type_map parsed = and inject_loc which loc = let comment = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.expansion_table >?? fun (_, locs) -> let locs = List.sort compare locs in List.hd locs >?? fun head_loc -> - List.assoc head_loc type_map + List.assoc ~equal:Int.equal head_loc type_map >?? fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) @@ -169,9 +172,9 @@ let unparse ?type_map parse expanded = and inject_loc which loc = let comment = let ( >?? ) = Option.bind in - List.assoc loc unexpansion_table + List.assoc ~equal:Int.equal loc unexpansion_table >?? fun loc -> - List.assoc loc type_map + List.assoc ~equal:Int.equal loc type_map >?? fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) diff --git a/src/proto_006_PsCARTHA/lib_client_commands/client_proto_context_commands.ml b/src/proto_006_PsCARTHA/lib_client_commands/client_proto_context_commands.ml index a6323f059444..d87b74b188dd 100644 --- a/src/proto_006_PsCARTHA/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_006_PsCARTHA/lib_client_commands/client_proto_context_commands.ml @@ -1197,7 +1197,7 @@ let commands network () = List.iter (fun (p : Protocol_hash.t) -> if - List.mem p known_protos + List.mem ~equal:Protocol_hash.equal p known_protos || Environment.Protocol_hash.Map.mem p known_proposals then () else @@ -1393,7 +1393,10 @@ let commands network () = Protocol_hash.pp p w - (if List.mem p known_protos then "" else "not ")) + ( if + List.mem ~equal:Protocol_hash.equal p known_protos + then "" + else "not " )) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_007_PsDELPH1/lib_client/client_proto_contracts.ml b/src/proto_007_PsDELPH1/lib_client/client_proto_contracts.ml index f32dfe165ef5..41cccac2dce5 100644 --- a/src/proto_007_PsDELPH1/lib_client/client_proto_contracts.ml +++ b/src/proto_007_PsDELPH1/lib_client/client_proto_contracts.ml @@ -29,6 +29,8 @@ open Alpha_context module ContractEntity = struct type t = Contract.t + include (Contract : Compare.S with type t := t) + let encoding = Contract.encoding let of_source s = diff --git a/src/proto_007_PsDELPH1/lib_client/client_proto_programs.ml b/src/proto_007_PsDELPH1/lib_client/client_proto_programs.ml index ce875749478a..58a743ad88b2 100644 --- a/src/proto_007_PsDELPH1/lib_client/client_proto_programs.ml +++ b/src/proto_007_PsDELPH1/lib_client/client_proto_programs.ml @@ -31,6 +31,12 @@ open Tezos_micheline module Program = Client_aliases.Alias (struct type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result + include Compare.Make (struct + type nonrec t = t + + let compare = Micheline_parser.compare Michelson_v1_parser.compare_parsed + end) + let encoding = Data_encoding.conv (fun ({Michelson_v1_parser.source; _}, _) -> source) diff --git a/src/proto_007_PsDELPH1/lib_client/michelson_v1_emacs.ml b/src/proto_007_PsDELPH1/lib_client/michelson_v1_emacs.ml index 7b41fb168dba..3c0c897aea66 100644 --- a/src/proto_007_PsDELPH1/lib_client/michelson_v1_emacs.ml +++ b/src/proto_007_PsDELPH1/lib_client/michelson_v1_emacs.ml @@ -90,12 +90,13 @@ let print_type_map ppf (parsed, type_map) = items and print_item ppf loc = (let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc ~equal:Int.equal loc parsed.Michelson_v1_parser.expansion_table >?? fun ({start = {point = s; _}; stop = {point = e; _}}, locs) -> - let locs = List.sort compare locs in + let locs = List.sort Stdlib.compare locs in List.hd locs >?? fun hd_loc -> - List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + List.assoc ~equal:Int.equal hd_loc type_map + >?? fun (bef, aft) -> Some (s, e, bef, aft)) |> Option.iter (fun (s, e, bef, aft) -> Format.fprintf ppf @@ -154,11 +155,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in match errs with | top :: errs -> @@ -197,11 +201,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in let loc = match err with diff --git a/src/proto_007_PsDELPH1/lib_client/michelson_v1_entrypoints.ml b/src/proto_007_PsDELPH1/lib_client/michelson_v1_entrypoints.ml index 73c2af021aef..e0a421f714f3 100644 --- a/src/proto_007_PsDELPH1/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_007_PsDELPH1/lib_client/michelson_v1_entrypoints.ml @@ -118,7 +118,7 @@ let list_contract_unreachables cctxt ~chain ~block ~contract = let list_contract_entrypoints cctxt ~chain ~block ~contract = list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract >>=? fun (_, entrypoints) -> - if not @@ List.mem_assoc "default" entrypoints then + if not @@ List.mem_assoc ~equal:String.equal "default" entrypoints then contract_entrypoint_type cctxt ~chain @@ -141,7 +141,7 @@ let list_unreachables cctxt ~chain ~block (program : Script.expr) = let list_entrypoints cctxt ~chain ~block (program : Script.expr) = Alpha_services.Helpers.Scripts.list_entrypoints cctxt (chain, block) program >>=? fun (_, entrypoints) -> - if not @@ List.mem_assoc "default" entrypoints then + if not @@ List.mem_assoc ~equal:String.equal "default" entrypoints then script_entrypoint_type cctxt ~chain ~block program ~entrypoint:"default" >>= function | Ok (Some ty) -> diff --git a/src/proto_007_PsDELPH1/lib_client/michelson_v1_error_reporter.ml b/src/proto_007_PsDELPH1/lib_client/michelson_v1_error_reporter.ml index f2cf26ee5dbb..d5c30a89f687 100644 --- a/src/proto_007_PsDELPH1/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_007_PsDELPH1/lib_client/michelson_v1_error_reporter.ml @@ -142,9 +142,13 @@ let report_errors ~details ~show_source ?parsed ppf errs = in let parsed_locations parsed loc = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table >?? fun oloc -> - List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc + List.assoc ~equal:Int.equal oloc parsed.expansion_table + >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = diff --git a/src/proto_007_PsDELPH1/lib_client/michelson_v1_parser.ml b/src/proto_007_PsDELPH1/lib_client/michelson_v1_parser.ml index fcfc8a3d6fa3..b4f9489bf9e1 100644 --- a/src/proto_007_PsDELPH1/lib_client/michelson_v1_parser.ml +++ b/src/proto_007_PsDELPH1/lib_client/michelson_v1_parser.ml @@ -36,6 +36,8 @@ type parsed = { unexpansion_table : (int * int) list; } +let compare_parsed = Stdlib.compare + (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = let (unexpanded, loc_table) = extract_locations ast in @@ -45,7 +47,7 @@ let expand_all source ast errors = let (expanded, unexpansion_table) = extract_locations expanded in let expansion_table = let sorted = - List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table + List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function @@ -65,8 +67,8 @@ let expand_all source ast errors = (fun (l, ploc) (l', elocs) -> assert (l = l') ; (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + (List.sort Stdlib.compare loc_table) + (List.sort Stdlib.compare grouped) with | Ok v -> v diff --git a/src/proto_007_PsDELPH1/lib_client/michelson_v1_parser.mli b/src/proto_007_PsDELPH1/lib_client/michelson_v1_parser.mli index 4f55e20943fa..6aa29676741a 100644 --- a/src/proto_007_PsDELPH1/lib_client/michelson_v1_parser.mli +++ b/src/proto_007_PsDELPH1/lib_client/michelson_v1_parser.mli @@ -41,6 +41,8 @@ type parsed = { expression. *) } +val compare_parsed : parsed -> parsed -> int + val parse_toplevel : ?check:bool -> string -> parsed Micheline_parser.parsing_result diff --git a/src/proto_007_PsDELPH1/lib_client/michelson_v1_printer.ml b/src/proto_007_PsDELPH1/lib_client/michelson_v1_printer.ml index 6f329e53e3ae..a2af21e4c09d 100644 --- a/src/proto_007_PsDELPH1/lib_client/michelson_v1_printer.ml +++ b/src/proto_007_PsDELPH1/lib_client/michelson_v1_printer.ml @@ -132,12 +132,15 @@ let inject_types type_map parsed = and inject_loc which loc = let comment = let ( >>= ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.expansion_table >>= fun (_, locs) -> let locs = List.sort compare locs in List.hd locs >>= fun head_loc -> - List.assoc head_loc type_map + List.assoc ~equal:Int.equal head_loc type_map >>= fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) @@ -169,9 +172,9 @@ let unparse ?type_map parse expanded = and inject_loc which loc = let comment = let ( >>= ) = Option.bind in - List.assoc loc unexpansion_table + List.assoc ~equal:Int.equal loc unexpansion_table >>= fun loc -> - List.assoc loc type_map + List.assoc ~equal:Int.equal loc type_map >>= fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) diff --git a/src/proto_007_PsDELPH1/lib_client_commands/client_proto_context_commands.ml b/src/proto_007_PsDELPH1/lib_client_commands/client_proto_context_commands.ml index 9b417ed5c232..705ab1bdc5fd 100644 --- a/src/proto_007_PsDELPH1/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_007_PsDELPH1/lib_client_commands/client_proto_context_commands.ml @@ -368,7 +368,9 @@ let commands () = Protocol_hash.pp p w - (if List.mem p known_protos then "" else "not ")) + ( if List.mem ~equal:Protocol_hash.equal p known_protos + then "" + else "not " )) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_008_PtEdo2Zk/lib_client/client_proto_contracts.ml b/src/proto_008_PtEdo2Zk/lib_client/client_proto_contracts.ml index f32dfe165ef5..41cccac2dce5 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/client_proto_contracts.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/client_proto_contracts.ml @@ -29,6 +29,8 @@ open Alpha_context module ContractEntity = struct type t = Contract.t + include (Contract : Compare.S with type t := t) + let encoding = Contract.encoding let of_source s = diff --git a/src/proto_008_PtEdo2Zk/lib_client/client_proto_programs.ml b/src/proto_008_PtEdo2Zk/lib_client/client_proto_programs.ml index 5bcab5a47ae9..54994ae0dfcc 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/client_proto_programs.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/client_proto_programs.ml @@ -32,6 +32,12 @@ open Michelson_v1_printer module Program = Client_aliases.Alias (struct type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result + include Compare.Make (struct + type nonrec t = t + + let compare = Micheline_parser.compare Michelson_v1_parser.compare_parsed + end) + let encoding = Data_encoding.conv (fun ({Michelson_v1_parser.source; _}, _) -> source) diff --git a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_emacs.ml b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_emacs.ml index 3a1612a77f88..85e6050d20e3 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_emacs.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_emacs.ml @@ -90,12 +90,13 @@ let print_type_map ppf (parsed, type_map) = items and print_item ppf loc = (let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc ~equal:Int.equal loc parsed.Michelson_v1_parser.expansion_table >?? fun ({start = {point = s; _}; stop = {point = e; _}}, locs) -> - let locs = List.sort compare locs in + let locs = List.sort Stdlib.compare locs in List.hd locs >?? fun hd_loc -> - List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + List.assoc ~equal:Int.equal hd_loc type_map + >?? fun (bef, aft) -> Some (s, e, bef, aft)) |> Option.iter (fun (s, e, bef, aft) -> Format.fprintf ppf @@ -156,11 +157,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in match errs with | top :: errs -> @@ -199,11 +203,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in let loc = match err with diff --git a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_entrypoints.ml b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_entrypoints.ml index 2aeeb65a6652..bec2855cb0d5 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_entrypoints.ml @@ -119,7 +119,7 @@ let list_contract_unreachables cctxt ~chain ~block ~contract = let list_contract_entrypoints cctxt ~chain ~block ~contract = list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract >>=? fun (_, entrypoints) -> - if not @@ List.mem_assoc "default" entrypoints then + if not @@ List.mem_assoc ~equal:String.equal "default" entrypoints then contract_entrypoint_type cctxt ~chain @@ -148,7 +148,7 @@ let list_entrypoints cctxt ~chain ~block (program : Script.expr) = (chain, block) ~script:program >>=? fun (_, entrypoints) -> - if not @@ List.mem_assoc "default" entrypoints then + if not @@ List.mem_assoc ~equal:String.equal "default" entrypoints then script_entrypoint_type cctxt ~chain ~block program ~entrypoint:"default" >>= function | Ok (Some ty) -> diff --git a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_error_reporter.ml b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_error_reporter.ml index cf723f405df9..757d2a2a8c8c 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_error_reporter.ml @@ -147,9 +147,13 @@ let report_errors ~details ~show_source ?parsed ppf errs = in let parsed_locations parsed loc = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table >?? fun oloc -> - List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc + List.assoc ~equal:Int.equal oloc parsed.expansion_table + >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = diff --git a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_parser.ml b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_parser.ml index fcfc8a3d6fa3..b4f9489bf9e1 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_parser.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_parser.ml @@ -36,6 +36,8 @@ type parsed = { unexpansion_table : (int * int) list; } +let compare_parsed = Stdlib.compare + (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = let (unexpanded, loc_table) = extract_locations ast in @@ -45,7 +47,7 @@ let expand_all source ast errors = let (expanded, unexpansion_table) = extract_locations expanded in let expansion_table = let sorted = - List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table + List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function @@ -65,8 +67,8 @@ let expand_all source ast errors = (fun (l, ploc) (l', elocs) -> assert (l = l') ; (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + (List.sort Stdlib.compare loc_table) + (List.sort Stdlib.compare grouped) with | Ok v -> v diff --git a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_parser.mli b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_parser.mli index 4f55e20943fa..6aa29676741a 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_parser.mli +++ b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_parser.mli @@ -41,6 +41,8 @@ type parsed = { expression. *) } +val compare_parsed : parsed -> parsed -> int + val parse_toplevel : ?check:bool -> string -> parsed Micheline_parser.parsing_result diff --git a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_printer.ml b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_printer.ml index 4065060a5d9f..210328722e5e 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_printer.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_printer.ml @@ -136,12 +136,15 @@ let inject_types type_map parsed = and inject_loc which loc = let comment = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.expansion_table >?? fun (_, locs) -> let locs = List.sort compare locs in List.hd locs >?? fun head_loc -> - List.assoc head_loc type_map + List.assoc ~equal:Int.equal head_loc type_map >?? fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) @@ -173,9 +176,9 @@ let unparse ?type_map parse expanded = and inject_loc which loc = let comment = let ( >?? ) = Option.bind in - List.assoc loc unexpansion_table + List.assoc ~equal:Int.equal loc unexpansion_table >?? fun loc -> - List.assoc loc type_map + List.assoc ~equal:Int.equal loc type_map >?? fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) diff --git a/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml index 84e68832f4a1..9642a64a4580 100644 --- a/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml @@ -1446,7 +1446,7 @@ let commands network () = List.iter (fun (p : Protocol_hash.t) -> if - List.mem p known_protos + List.mem ~equal:Protocol_hash.equal p known_protos || Environment.Protocol_hash.Map.mem p known_proposals then () else @@ -1648,7 +1648,10 @@ let commands network () = Protocol_hash.pp p w - (if List.mem p known_protos then "" else "not ")) + ( if + List.mem ~equal:Protocol_hash.equal p known_protos + then "" + else "not " )) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_highwatermarks.ml b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_highwatermarks.ml index c2b8c4068fcb..bbab3f4c3ef6 100644 --- a/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_highwatermarks.ml +++ b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_highwatermarks.ml @@ -98,7 +98,7 @@ let record (cctxt : #Protocol_client_context.full) location ~delegate level = load_highwatermarks cctxt filename >>=? fun highwatermarks -> let level = - match List.assoc_opt delegate highwatermarks with + match List.assoc_opt ~equal:String.equal delegate highwatermarks with | None -> level | Some lower_prev_level when level >= lower_prev_level -> diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/test/gas_costs.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/gas_costs.ml index 358208c67f66..ff755e36afc6 100644 --- a/src/proto_008_PtEdo2Zk/lib_protocol/test/gas_costs.ml +++ b/src/proto_008_PtEdo2Zk/lib_protocol/test/gas_costs.ml @@ -232,7 +232,9 @@ let check_cost_reprs_are_all_positive list () = List.iter_es (fun (cost_name, cost) -> if Z.gt cost Z.zero then return_unit - else if Z.equal cost Z.zero && List.mem cost_name free then return_unit + else if + Z.equal cost Z.zero && List.mem ~equal:String.equal cost_name free + then return_unit else fail (Exn diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/block.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/block.ml index a93cd570f0ee..6144aef2b1a7 100644 --- a/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/block.ml +++ b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/block.ml @@ -101,7 +101,8 @@ let get_next_baker_excluding excludes block = WithExceptions.Option.get ~loc:__LOC__ @@ List.find (fun {Alpha_services.Delegate.Baking_rights.delegate; _} -> - not (List.mem delegate excludes)) + not + (List.mem ~equal:Signature.Public_key_hash.equal delegate excludes)) bakers in (pkh, priority, WithExceptions.Option.to_exn ~none:(Failure "") timestamp) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/test/interpretation.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/interpretation.ml index 91d6294c2dd2..128e480c7667 100644 --- a/src/proto_008_PtEdo2Zk/lib_protocol/test/interpretation.ml +++ b/src/proto_008_PtEdo2Zk/lib_protocol/test/interpretation.ml @@ -114,7 +114,10 @@ let test_stack_overflow () = | Ok _ -> Alcotest.fail "expected an error" | Error lst - when List.mem Script_interpreter.Michelson_too_many_recursive_calls lst -> + when List.mem + ~equal:( = ) + Script_interpreter.Michelson_too_many_recursive_calls + lst -> return () | Error _ -> Alcotest.failf "Unexpected error (%s)" __LOC__ diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/test/typechecking.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/typechecking.ml index a13b829197b1..bf9336c0006a 100644 --- a/src/proto_008_PtEdo2Zk/lib_protocol/test/typechecking.ml +++ b/src/proto_008_PtEdo2Zk/lib_protocol/test/typechecking.ml @@ -114,6 +114,7 @@ let test_typecheck_stack_overflow () = Alcotest.fail "expected an error" | Error lst when List.mem + ~equal:( = ) (Environment.Ecoproto_error Script_tc_errors.Typechecking_too_many_recursive_calls) lst -> @@ -134,7 +135,10 @@ let test_unparse_stack_overflow () = | Ok _ -> Alcotest.fail "expected an error" | Error lst - when List.mem Script_tc_errors.Unparsing_too_many_recursive_calls lst -> + when List.mem + ~equal:( = ) + Script_tc_errors.Unparsing_too_many_recursive_calls + lst -> return () | Error _ -> Alcotest.failf "Unexpected error: %s" __LOC__ diff --git a/src/proto_009_PsFLoren/lib_client/client_proto_contracts.ml b/src/proto_009_PsFLoren/lib_client/client_proto_contracts.ml index 0bcf748a89ed..c512b749a6ec 100644 --- a/src/proto_009_PsFLoren/lib_client/client_proto_contracts.ml +++ b/src/proto_009_PsFLoren/lib_client/client_proto_contracts.ml @@ -29,6 +29,8 @@ open Alpha_context module ContractEntity = struct type t = Contract.t + include (Contract : Compare.S with type t := t) + let encoding = Contract.encoding let of_source s = diff --git a/src/proto_009_PsFLoren/lib_client/client_proto_programs.ml b/src/proto_009_PsFLoren/lib_client/client_proto_programs.ml index d00adc93c493..6910e290e784 100644 --- a/src/proto_009_PsFLoren/lib_client/client_proto_programs.ml +++ b/src/proto_009_PsFLoren/lib_client/client_proto_programs.ml @@ -32,6 +32,12 @@ open Michelson_v1_printer module Program = Client_aliases.Alias (struct type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result + include Compare.Make (struct + type nonrec t = t + + let compare = Micheline_parser.compare Michelson_v1_parser.compare_parsed + end) + let encoding = Data_encoding.conv (fun ({Michelson_v1_parser.source; _}, _) -> source) diff --git a/src/proto_009_PsFLoren/lib_client/michelson_v1_emacs.ml b/src/proto_009_PsFLoren/lib_client/michelson_v1_emacs.ml index 3a1612a77f88..85e6050d20e3 100644 --- a/src/proto_009_PsFLoren/lib_client/michelson_v1_emacs.ml +++ b/src/proto_009_PsFLoren/lib_client/michelson_v1_emacs.ml @@ -90,12 +90,13 @@ let print_type_map ppf (parsed, type_map) = items and print_item ppf loc = (let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc ~equal:Int.equal loc parsed.Michelson_v1_parser.expansion_table >?? fun ({start = {point = s; _}; stop = {point = e; _}}, locs) -> - let locs = List.sort compare locs in + let locs = List.sort Stdlib.compare locs in List.hd locs >?? fun hd_loc -> - List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + List.assoc ~equal:Int.equal hd_loc type_map + >?? fun (bef, aft) -> Some (s, e, bef, aft)) |> Option.iter (fun (s, e, bef, aft) -> Format.fprintf ppf @@ -156,11 +157,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in match errs with | top :: errs -> @@ -199,11 +203,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in let loc = match err with diff --git a/src/proto_009_PsFLoren/lib_client/michelson_v1_entrypoints.ml b/src/proto_009_PsFLoren/lib_client/michelson_v1_entrypoints.ml index 2aeeb65a6652..bec2855cb0d5 100644 --- a/src/proto_009_PsFLoren/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_009_PsFLoren/lib_client/michelson_v1_entrypoints.ml @@ -119,7 +119,7 @@ let list_contract_unreachables cctxt ~chain ~block ~contract = let list_contract_entrypoints cctxt ~chain ~block ~contract = list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract >>=? fun (_, entrypoints) -> - if not @@ List.mem_assoc "default" entrypoints then + if not @@ List.mem_assoc ~equal:String.equal "default" entrypoints then contract_entrypoint_type cctxt ~chain @@ -148,7 +148,7 @@ let list_entrypoints cctxt ~chain ~block (program : Script.expr) = (chain, block) ~script:program >>=? fun (_, entrypoints) -> - if not @@ List.mem_assoc "default" entrypoints then + if not @@ List.mem_assoc ~equal:String.equal "default" entrypoints then script_entrypoint_type cctxt ~chain ~block program ~entrypoint:"default" >>= function | Ok (Some ty) -> diff --git a/src/proto_009_PsFLoren/lib_client/michelson_v1_error_reporter.ml b/src/proto_009_PsFLoren/lib_client/michelson_v1_error_reporter.ml index cf723f405df9..757d2a2a8c8c 100644 --- a/src/proto_009_PsFLoren/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_009_PsFLoren/lib_client/michelson_v1_error_reporter.ml @@ -147,9 +147,13 @@ let report_errors ~details ~show_source ?parsed ppf errs = in let parsed_locations parsed loc = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table >?? fun oloc -> - List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc + List.assoc ~equal:Int.equal oloc parsed.expansion_table + >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = diff --git a/src/proto_009_PsFLoren/lib_client/michelson_v1_parser.ml b/src/proto_009_PsFLoren/lib_client/michelson_v1_parser.ml index 8d7dafcb083c..75e4de9af9b1 100644 --- a/src/proto_009_PsFLoren/lib_client/michelson_v1_parser.ml +++ b/src/proto_009_PsFLoren/lib_client/michelson_v1_parser.ml @@ -36,6 +36,8 @@ type parsed = { unexpansion_table : (int * int) list; } +let compare_parsed = Stdlib.compare + (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = let (unexpanded, loc_table) = extract_locations ast in @@ -45,7 +47,7 @@ let expand_all source ast errors = let (expanded, unexpansion_table) = extract_locations expanded in let expansion_table = let sorted = - List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table + List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function @@ -65,8 +67,8 @@ let expand_all source ast errors = (fun (l, ploc) (l', elocs) -> assert (l = l') ; (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + (List.sort Stdlib.compare loc_table) + (List.sort Stdlib.compare grouped) with | Ok v -> v diff --git a/src/proto_009_PsFLoren/lib_client/michelson_v1_parser.mli b/src/proto_009_PsFLoren/lib_client/michelson_v1_parser.mli index 4f55e20943fa..6aa29676741a 100644 --- a/src/proto_009_PsFLoren/lib_client/michelson_v1_parser.mli +++ b/src/proto_009_PsFLoren/lib_client/michelson_v1_parser.mli @@ -41,6 +41,8 @@ type parsed = { expression. *) } +val compare_parsed : parsed -> parsed -> int + val parse_toplevel : ?check:bool -> string -> parsed Micheline_parser.parsing_result diff --git a/src/proto_009_PsFLoren/lib_client/michelson_v1_printer.ml b/src/proto_009_PsFLoren/lib_client/michelson_v1_printer.ml index 4065060a5d9f..210328722e5e 100644 --- a/src/proto_009_PsFLoren/lib_client/michelson_v1_printer.ml +++ b/src/proto_009_PsFLoren/lib_client/michelson_v1_printer.ml @@ -136,12 +136,15 @@ let inject_types type_map parsed = and inject_loc which loc = let comment = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.expansion_table >?? fun (_, locs) -> let locs = List.sort compare locs in List.hd locs >?? fun head_loc -> - List.assoc head_loc type_map + List.assoc ~equal:Int.equal head_loc type_map >?? fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) @@ -173,9 +176,9 @@ let unparse ?type_map parse expanded = and inject_loc which loc = let comment = let ( >?? ) = Option.bind in - List.assoc loc unexpansion_table + List.assoc ~equal:Int.equal loc unexpansion_table >?? fun loc -> - List.assoc loc type_map + List.assoc ~equal:Int.equal loc type_map >?? fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) diff --git a/src/proto_009_PsFLoren/lib_client_commands/client_proto_context_commands.ml b/src/proto_009_PsFLoren/lib_client_commands/client_proto_context_commands.ml index 487d1e130e45..b279afdda657 100644 --- a/src/proto_009_PsFLoren/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_009_PsFLoren/lib_client_commands/client_proto_context_commands.ml @@ -1429,7 +1429,7 @@ let commands network () = List.iter (fun (p : Protocol_hash.t) -> if - List.mem p known_protos + List.mem ~equal:Protocol_hash.equal p known_protos || Environment.Protocol_hash.Map.mem p known_proposals then () else @@ -1636,7 +1636,13 @@ let commands network () = Protocol_hash.pp p w - (if List.mem p known_protos then "" else "not ")) + ( if + List.mem + ~equal:Protocol_hash.equal + p + known_protos + then "" + else "not " )) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_009_PsFLoren/lib_delegate/client_baking_highwatermarks.ml b/src/proto_009_PsFLoren/lib_delegate/client_baking_highwatermarks.ml index c2b8c4068fcb..bbab3f4c3ef6 100644 --- a/src/proto_009_PsFLoren/lib_delegate/client_baking_highwatermarks.ml +++ b/src/proto_009_PsFLoren/lib_delegate/client_baking_highwatermarks.ml @@ -98,7 +98,7 @@ let record (cctxt : #Protocol_client_context.full) location ~delegate level = load_highwatermarks cctxt filename >>=? fun highwatermarks -> let level = - match List.assoc_opt delegate highwatermarks with + match List.assoc_opt ~equal:String.equal delegate highwatermarks with | None -> level | Some lower_prev_level when level >= lower_prev_level -> diff --git a/src/proto_009_PsFLoren/lib_protocol/test/helpers/block.ml b/src/proto_009_PsFLoren/lib_protocol/test/helpers/block.ml index be8f56092131..897338b5bc7c 100644 --- a/src/proto_009_PsFLoren/lib_protocol/test/helpers/block.ml +++ b/src/proto_009_PsFLoren/lib_protocol/test/helpers/block.ml @@ -101,7 +101,8 @@ let get_next_baker_excluding excludes block = WithExceptions.Option.get ~loc:__LOC__ @@ List.find (fun {Alpha_services.Delegate.Baking_rights.delegate; _} -> - not (List.mem delegate excludes)) + not + (List.mem ~equal:Signature.Public_key_hash.equal delegate excludes)) bakers in (pkh, priority, WithExceptions.Option.to_exn ~none:(Failure "") timestamp) diff --git a/src/proto_009_PsFLoren/lib_protocol/test/test_gas_costs.ml b/src/proto_009_PsFLoren/lib_protocol/test/test_gas_costs.ml index c0c46af4e7a0..7010ec497401 100644 --- a/src/proto_009_PsFLoren/lib_protocol/test/test_gas_costs.ml +++ b/src/proto_009_PsFLoren/lib_protocol/test/test_gas_costs.ml @@ -239,7 +239,9 @@ let test_cost_reprs_are_all_positive list () = List.iter_es (fun (cost_name, cost) -> if S.(cost > S.zero) then return_unit - else if S.equal cost S.zero && List.mem cost_name free then return_unit + else if + S.equal cost S.zero && List.mem ~equal:String.equal cost_name free + then return_unit else fail (Exn diff --git a/src/proto_009_PsFLoren/lib_protocol/test/test_typechecking.ml b/src/proto_009_PsFLoren/lib_protocol/test/test_typechecking.ml index d59c4d322611..b66a9b75426d 100644 --- a/src/proto_009_PsFLoren/lib_protocol/test/test_typechecking.ml +++ b/src/proto_009_PsFLoren/lib_protocol/test/test_typechecking.ml @@ -122,6 +122,7 @@ let test_typecheck_stack_overflow () = Alcotest.fail "expected an error" | Error lst when List.mem + ~equal:( = ) (Environment.Ecoproto_error Script_tc_errors.Typechecking_too_many_recursive_calls) lst -> diff --git a/src/proto_alpha/lib_client/client_proto_contracts.ml b/src/proto_alpha/lib_client/client_proto_contracts.ml index 0bcf748a89ed..38b5882dd95b 100644 --- a/src/proto_alpha/lib_client/client_proto_contracts.ml +++ b/src/proto_alpha/lib_client/client_proto_contracts.ml @@ -27,9 +27,7 @@ open Protocol open Alpha_context module ContractEntity = struct - type t = Contract.t - - let encoding = Contract.encoding + include Contract (* t, Compare, encoding *) let of_source s = Contract.of_b58check s |> Environment.wrap_tzresult diff --git a/src/proto_alpha/lib_client/client_proto_programs.ml b/src/proto_alpha/lib_client/client_proto_programs.ml index 5f8a9f8d4cfc..dff69feb907a 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.ml +++ b/src/proto_alpha/lib_client/client_proto_programs.ml @@ -32,6 +32,12 @@ open Michelson_v1_printer module Program = Client_aliases.Alias (struct type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result + include Compare.Make (struct + type nonrec t = t + + let compare = Micheline_parser.compare Michelson_v1_parser.compare_parsed + end) + let encoding = Data_encoding.conv (fun ({Michelson_v1_parser.source; _}, _) -> source) diff --git a/src/proto_alpha/lib_client/michelson_v1_emacs.ml b/src/proto_alpha/lib_client/michelson_v1_emacs.ml index 3a1612a77f88..85e6050d20e3 100644 --- a/src/proto_alpha/lib_client/michelson_v1_emacs.ml +++ b/src/proto_alpha/lib_client/michelson_v1_emacs.ml @@ -90,12 +90,13 @@ let print_type_map ppf (parsed, type_map) = items and print_item ppf loc = (let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc ~equal:Int.equal loc parsed.Michelson_v1_parser.expansion_table >?? fun ({start = {point = s; _}; stop = {point = e; _}}, locs) -> - let locs = List.sort compare locs in + let locs = List.sort Stdlib.compare locs in List.hd locs >?? fun hd_loc -> - List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + List.assoc ~equal:Int.equal hd_loc type_map + >?? fun (bef, aft) -> Some (s, e, bef, aft)) |> Option.iter (fun (s, e, bef, aft) -> Format.fprintf ppf @@ -156,11 +157,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in match errs with | top :: errs -> @@ -199,11 +203,14 @@ let report_errors ppf (parsed, errs) = let find_location loc = let oloc = WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + @@ List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table in fst ( WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc oloc parsed.expansion_table ) + @@ List.assoc ~equal:Int.equal oloc parsed.expansion_table ) in let loc = match err with diff --git a/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml b/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml index 581116aef3e4..99cb56e6c09f 100644 --- a/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml @@ -119,7 +119,7 @@ let list_contract_unreachables cctxt ~chain ~block ~contract = let list_contract_entrypoints cctxt ~chain ~block ~contract = list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract >>=? fun (_, entrypoints) -> - if not @@ List.mem_assoc "default" entrypoints then + if not @@ List.mem_assoc ~equal:String.equal "default" entrypoints then contract_entrypoint_type cctxt ~chain @@ -142,7 +142,7 @@ let list_unreachables cctxt ~chain ~block (program : Script.expr) = let list_entrypoints cctxt ~chain ~block (program : Script.expr) = Plugin.RPC.Scripts.list_entrypoints cctxt (chain, block) ~script:program >>=? fun (_, entrypoints) -> - if not @@ List.mem_assoc "default" entrypoints then + if not @@ List.mem_assoc ~equal:String.equal "default" entrypoints then script_entrypoint_type cctxt ~chain ~block program ~entrypoint:"default" >>= function | Ok (Some ty) -> diff --git a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml index cf723f405df9..757d2a2a8c8c 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -147,9 +147,13 @@ let report_errors ~details ~show_source ?parsed ppf errs = in let parsed_locations parsed loc = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.unexpansion_table >?? fun oloc -> - List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc + List.assoc ~equal:Int.equal oloc parsed.expansion_table + >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = diff --git a/src/proto_alpha/lib_client/michelson_v1_parser.ml b/src/proto_alpha/lib_client/michelson_v1_parser.ml index 8d7dafcb083c..75e4de9af9b1 100644 --- a/src/proto_alpha/lib_client/michelson_v1_parser.ml +++ b/src/proto_alpha/lib_client/michelson_v1_parser.ml @@ -36,6 +36,8 @@ type parsed = { unexpansion_table : (int * int) list; } +let compare_parsed = Stdlib.compare + (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = let (unexpanded, loc_table) = extract_locations ast in @@ -45,7 +47,7 @@ let expand_all source ast errors = let (expanded, unexpansion_table) = extract_locations expanded in let expansion_table = let sorted = - List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table + List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function @@ -65,8 +67,8 @@ let expand_all source ast errors = (fun (l, ploc) (l', elocs) -> assert (l = l') ; (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + (List.sort Stdlib.compare loc_table) + (List.sort Stdlib.compare grouped) with | Ok v -> v diff --git a/src/proto_alpha/lib_client/michelson_v1_parser.mli b/src/proto_alpha/lib_client/michelson_v1_parser.mli index 4f55e20943fa..6aa29676741a 100644 --- a/src/proto_alpha/lib_client/michelson_v1_parser.mli +++ b/src/proto_alpha/lib_client/michelson_v1_parser.mli @@ -41,6 +41,8 @@ type parsed = { expression. *) } +val compare_parsed : parsed -> parsed -> int + val parse_toplevel : ?check:bool -> string -> parsed Micheline_parser.parsing_result diff --git a/src/proto_alpha/lib_client/michelson_v1_printer.ml b/src/proto_alpha/lib_client/michelson_v1_printer.ml index 4065060a5d9f..210328722e5e 100644 --- a/src/proto_alpha/lib_client/michelson_v1_printer.ml +++ b/src/proto_alpha/lib_client/michelson_v1_printer.ml @@ -136,12 +136,15 @@ let inject_types type_map parsed = and inject_loc which loc = let comment = let ( >?? ) = Option.bind in - List.assoc loc parsed.Michelson_v1_parser.expansion_table + List.assoc + ~equal:Int.equal + loc + parsed.Michelson_v1_parser.expansion_table >?? fun (_, locs) -> let locs = List.sort compare locs in List.hd locs >?? fun head_loc -> - List.assoc head_loc type_map + List.assoc ~equal:Int.equal head_loc type_map >?? fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) @@ -173,9 +176,9 @@ let unparse ?type_map parse expanded = and inject_loc which loc = let comment = let ( >?? ) = Option.bind in - List.assoc loc unexpansion_table + List.assoc ~equal:Int.equal loc unexpansion_table >?? fun loc -> - List.assoc loc type_map + List.assoc ~equal:Int.equal loc type_map >?? fun (bef, aft) -> let stack = match which with `before -> bef | `after -> aft in Some (Format.asprintf "%a" print_stack stack) diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index f7553bf422a3..cc1f4d126bb2 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -1434,7 +1434,7 @@ let commands network () = List.iter (fun (p : Protocol_hash.t) -> if - List.mem p known_protos + List.mem ~equal:Protocol_hash.equal p known_protos || Environment.Protocol_hash.Map.mem p known_proposals then () else @@ -1641,7 +1641,13 @@ let commands network () = Protocol_hash.pp p w - (if List.mem p known_protos then "" else "not ")) + ( if + List.mem + ~equal:Protocol_hash.equal + p + known_protos + then "" + else "not " )) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_alpha/lib_delegate/client_baking_highwatermarks.ml b/src/proto_alpha/lib_delegate/client_baking_highwatermarks.ml index c2b8c4068fcb..bbab3f4c3ef6 100644 --- a/src/proto_alpha/lib_delegate/client_baking_highwatermarks.ml +++ b/src/proto_alpha/lib_delegate/client_baking_highwatermarks.ml @@ -98,7 +98,7 @@ let record (cctxt : #Protocol_client_context.full) location ~delegate level = load_highwatermarks cctxt filename >>=? fun highwatermarks -> let level = - match List.assoc_opt delegate highwatermarks with + match List.assoc_opt ~equal:String.equal delegate highwatermarks with | None -> level | Some lower_prev_level when level >= lower_prev_level -> diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.ml b/src/proto_alpha/lib_protocol/test/helpers/block.ml index e41f158b180a..ff6472946721 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/block.ml @@ -103,7 +103,8 @@ let get_next_baker_excluding excludes block = WithExceptions.Option.get ~loc:__LOC__ @@ List.find (fun {Alpha_services.Delegate.Baking_rights.delegate; _} -> - not (List.mem delegate excludes)) + not + (List.mem ~equal:Signature.Public_key_hash.equal delegate excludes)) bakers in (pkh, priority, WithExceptions.Option.to_exn ~none:(Failure "") timestamp) diff --git a/src/proto_alpha/lib_protocol/test/test_gas_costs.ml b/src/proto_alpha/lib_protocol/test/test_gas_costs.ml index c0c46af4e7a0..7010ec497401 100644 --- a/src/proto_alpha/lib_protocol/test/test_gas_costs.ml +++ b/src/proto_alpha/lib_protocol/test/test_gas_costs.ml @@ -239,7 +239,9 @@ let test_cost_reprs_are_all_positive list () = List.iter_es (fun (cost_name, cost) -> if S.(cost > S.zero) then return_unit - else if S.equal cost S.zero && List.mem cost_name free then return_unit + else if + S.equal cost S.zero && List.mem ~equal:String.equal cost_name free + then return_unit else fail (Exn diff --git a/src/proto_alpha/lib_protocol/test/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/test_typechecking.ml index d59c4d322611..b66a9b75426d 100644 --- a/src/proto_alpha/lib_protocol/test/test_typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/test_typechecking.ml @@ -122,6 +122,7 @@ let test_typecheck_stack_overflow () = Alcotest.fail "expected an error" | Error lst when List.mem + ~equal:( = ) (Environment.Ecoproto_error Script_tc_errors.Typechecking_too_many_recursive_calls) lst -> diff --git a/vendors/ocaml-uecc/src/uecc.ml b/vendors/ocaml-uecc/src/uecc.ml index 80e2151926fd..e858f2b3c181 100644 --- a/vendors/ocaml-uecc/src/uecc.ml +++ b/vendors/ocaml-uecc/src/uecc.ml @@ -69,6 +69,12 @@ let equal : type a. a key -> a key -> bool = fun k1 k2 -> | Pk pk, Pk pk2 -> Bytes.equal pk pk2 +let compare : type a. a key -> a key -> int = fun k1 k2 -> + match k1, k2 with + | Sk sk, Sk sk2 -> Bytes.compare sk sk2 + | Pk pk, Pk pk2 -> + Bytes.compare pk pk2 + let neuterize : type a. a key -> public key = function | Pk pk -> Pk pk | Sk sk -> diff --git a/vendors/ocaml-uecc/src/uecc.mli b/vendors/ocaml-uecc/src/uecc.mli index 7af6287f71f2..e6de2899e69d 100644 --- a/vendors/ocaml-uecc/src/uecc.mli +++ b/vendors/ocaml-uecc/src/uecc.mli @@ -34,6 +34,8 @@ val equal : 'a key -> 'a key -> bool (** [equal k1 k2] is [true] if [k1] is represented by the same bytes as [k2], and [false] otherwise. *) +val compare : 'a key -> 'a key -> int + val neuterize : 'a key -> public key (** [neuterize k] is [k] if [k] is public, or is the associated public key of [k] if [k] is secret. *) -- GitLab From 226b4247b646a47d10d517e29eb253ae50522d5e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 19 Mar 2021 18:42:28 +0100 Subject: [PATCH 05/14] Lwtreslib: remove Seq*.find* (easily acheivable with filter) --- src/lib_lwt_result_stdlib/bare/sigs/seq.ml | 29 ------------ src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml | 34 -------------- src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml | 12 ----- src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml | 29 ------------ src/lib_lwt_result_stdlib/bare/structs/seq.ml | 44 ------------------- .../bare/structs/seq_e.ml | 32 -------------- .../bare/structs/seq_es.ml | 40 ----------------- .../bare/structs/seq_s.ml | 40 ----------------- 8 files changed, 260 deletions(-) diff --git a/src/lib_lwt_result_stdlib/bare/sigs/seq.ml b/src/lib_lwt_result_stdlib/bare/sigs/seq.ml index 01adc1fd9911..710a92b7abfe 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq.ml @@ -144,33 +144,4 @@ module type S = sig it is either fulfilled if all promises are, or rejected if at least one of them is. *) val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t - - (** [find f t] is [Some x] where [x] is the first item in [t] such that - [f x]. It is [None] if there are no such element. It does not terminate if - the sequence is infinite and the predicate is always false. *) - val find : ('a -> bool) -> 'a t -> 'a option - - (** [find_e f t] is similar to {!find} but wraps the search within - [result]. Specifically, [find_e f t] is either - - [Ok (Some x)] if forall [y] before [x] [f y = Ok false] and - [f x = Ok true], - - [Error e] if there exists [x] such that forall [y] before [x] - [f y = Ok false] and [f x = Error e], - - [Ok None] otherwise and [t] is finite, - - an expression that never returns otherwise. *) - val find_e : - ('a -> (bool, 'trace) result) -> 'a t -> ('a option, 'trace) result - - (** [find_s f t] is similar to {!find} but wrapped within - [Lwt.t]. The search is identical to [find_e] but each - predicate is applied when the previous one has resolved. *) - val find_s : ('a -> bool Lwt.t) -> 'a t -> 'a option Lwt.t - - (** [find_es f t] is similar to {!find} but wrapped within - [result Lwt.t]. The search is identical to [find_e] but each - predicate is applied when the previous one has resolved. *) - val find_es : - ('a -> (bool, 'trace) result Lwt.t) -> - 'a t -> - ('a option, 'trace) result 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 da5eb21d8e7a..e9434282681f 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml @@ -217,40 +217,6 @@ fold_left_e [Some _]) or dropped (when it returns [None]). *) val filter_map_e : ('a -> ('b option, 'e) result) -> ('a, 'e) t -> ('b, 'e) t - (** [find f s] is - - - [Ok (Some x)] if [x] is the first element of [s] or the successful - prefix of [s] for which [f x] holds, or - - [Ok None] if [s] is whole and [f] doesn't hold for any of the elements - of [s], or - - [Error e] if [s] is interrupted by [e]. *) - val find : ('a -> bool) -> ('a, 'e) t -> ('a option, 'e) result - - (** [find_e f s] is - - - [Ok (Some x)] if [x] is the first element of [s] or the successful - prefix of [s] for which [f x] holds, or - - [Ok None] if [s] is whole and [f] doesn't hold for any of the elements - of [s], or - - [Error e] if there is an element of [s] or the successful prefix of [s] - for which [f] returns [Error e], or - - [Error e] if [s] is interrupted by [e]. *) - val find_e : - ('a -> (bool, 'e) result) -> ('a, 'e) t -> ('a option, 'e) result - - (** [find_s] is similar to [find] but it returns a promise. Also note that the - elements are traversed sequentially and that the sequence's node are - unsuspended only when the previous node's predicate has been evaluated. *) - val find_s : ('a -> bool Lwt.t) -> ('a, 'e) t -> ('a option, 'e) result Lwt.t - - (** [find_es] is similar to [find_e] but it returns a promise. Also note that - the elements are traversed sequentially and that the sequence's node are - unsuspended only when the previous node's predicate has been evaluated. *) - val find_es : - ('a -> (bool, 'e) result Lwt.t) -> - ('a, 'e) t -> - ('a option, 'e) result Lwt.t - val of_seq : 'a Stdlib.Seq.t -> ('a, 'e) t val of_seq_e : ('a, 'e) result Stdlib.Seq.t -> ('a, 'e) t 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 e0aeacf10ba8..fbc905f776f4 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml @@ -119,18 +119,6 @@ module type S = sig val filter_map_es : ('a -> ('b option, 'e) result Lwt.t) -> ('a, 'e) t -> ('b, 'e) t - val find : ('a -> bool) -> ('a, 'e) t -> ('a option, 'e) result Lwt.t - - val find_e : - ('a -> (bool, 'e) result) -> ('a, 'e) t -> ('a option, 'e) result Lwt.t - - val find_s : ('a -> bool Lwt.t) -> ('a, 'e) t -> ('a option, 'e) result Lwt.t - - val find_es : - ('a -> (bool, 'e) result Lwt.t) -> - ('a, 'e) t -> - ('a option, 'e) result Lwt.t - val of_seq : 'a Stdlib.Seq.t -> ('a, 'e) t val of_seq_s : 'a Lwt.t 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 160d6b099b69..e08fc47670c2 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml @@ -124,35 +124,6 @@ module type S = sig tail-recursive. *) val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t - (** [find f t] is [Some x] where [x] is the first item in [t] such that - [f x]. It is [None] if there are no such element. It does not terminate if - the sequence is infinite and the predicate is always false. *) - val find : ('a -> bool) -> 'a t -> 'a option Lwt.t - - (** [find_e f t] is similar to {!find} but wraps the search within - [result]. Specifically, [find_e f t] is either - - [Ok (Some x)] if forall [y] before [x] [f y = Ok false] and - [f x = Ok true], - - [Error e] if there exists [x] such that forall [y] before [x] - [f y = Ok false] and [f x = Error e], - - [Ok None] otherwise and [t] is finite, - - an expression that never returns otherwise. *) - val find_e : - ('a -> (bool, 'trace) result) -> 'a t -> ('a option, 'trace) result Lwt.t - - (** [find_s f t] is similar to {!find} but wrapped within - [Lwt.t]. The search is identical to [find_e] but each - predicate is applied when the previous one has resolved. *) - val find_s : ('a -> bool Lwt.t) -> 'a t -> 'a option Lwt.t - - (** [find_es f t] is similar to {!find} but wrapped within - [result Lwt.t]. The search is identical to [find_e] but each - predicate is applied when the previous one has resolved. *) - val find_es : - ('a -> (bool, 'trace) result Lwt.t) -> - 'a t -> - ('a option, 'trace) result Lwt.t - val of_seq : 'a Stdlib.Seq.t -> 'a t val of_seq_s : 'a Lwt.t Stdlib.Seq.t -> 'a t diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq.ml b/src/lib_lwt_result_stdlib/bare/structs/seq.ml index 7ae01b5ccfeb..bd8901586095 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq.ml @@ -118,47 +118,3 @@ let iter_p f seq = iter_p f seq (Lwt.apply f item :: acc) in iter_p f seq [] - -let rec find f seq = - match seq () with - | Nil -> - None - | Cons (item, seq) -> - if f item then Some item else find f seq - -let rec find_e f seq = - match seq () with - | Nil -> - none_e - | Cons (item, seq) -> ( - f item >>? function true -> some_e item | false -> find_e f seq ) - -let rec find_s f seq = - match seq () with - | Nil -> - none_s - | Cons (item, seq) -> ( - f item >>= function true -> some_s item | false -> find_s f seq ) - -let find_s f seq = - match seq () with - | Nil -> - none_s - | Cons (item, seq) -> ( - Lwt.apply f item - >>= function true -> some_s item | false -> find_s f seq ) - -let rec find_es f seq = - match seq () with - | Nil -> - none_es - | Cons (item, seq) -> ( - f item >>=? function true -> some_es item | false -> find_es f seq ) - -let find_es f seq = - match seq () with - | Nil -> - none_es - | Cons (item, seq) -> ( - Lwt.apply f item - >>=? function true -> some_es item | false -> find_es f seq ) 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 28df637ed282..56e83e6ffa94 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml @@ -200,38 +200,6 @@ let rec filter_map_e f seq () = | Some item -> Ok (Cons (item, filter_map_e f seq)) ) -let rec find f seq = - seq () - >>? function - | Nil -> - Monad.none_e - | Cons (item, seq) -> - if f item then Ok (Some item) else find f seq - -let rec find_e f seq = - seq () - >>? function - | Nil -> - Monad.none_e - | Cons (item, seq) -> ( - f item >>? function true -> some_e item | false -> find_e f seq ) - -let rec find_s f seq = - seq () - >>?= function - | Nil -> - none_es - | Cons (item, seq) -> ( - f item >>= function true -> some_es item | false -> find_s f seq ) - -let rec find_es f seq = - seq () - >>?= function - | Nil -> - none_es - | Cons (item, seq) -> ( - f item >>=? function true -> some_es item | false -> find_es f seq ) - let rec of_seq seq () = match seq () with | Stdlib.Seq.Nil -> 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 66fa144580ed..47afeff2fa56 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq_es.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_es.ml @@ -288,46 +288,6 @@ let rec filter_map_es f seq () = let filter_map_es f seq = filter_map_es f @@ protect seq -let rec find f seq = - seq () - >>=? function - | Nil -> - Monad.none_es - | Cons (item, seq) -> - if f item then Monad.return (Some item) else find f seq - -let find f seq = find f @@ protect seq - -let rec find_e f seq = - seq () - >>=? function - | Nil -> - Monad.none_es - | Cons (item, seq) -> ( - f item >>?= function true -> some_es item | false -> find_e f seq ) - -let find_e f seq = find_e f @@ protect seq - -let rec find_s f seq = - seq () - >>=? function - | Nil -> - Monad.none_es - | Cons (item, seq) -> ( - f item >>= function true -> some_es item | false -> find_s f seq ) - -let find_s f seq = find_s f @@ protect seq - -let rec find_es f seq = - seq () - >>=? function - | Nil -> - Monad.none_es - | Cons (item, seq) -> ( - f item >>=? function true -> some_es item | false -> find_es f seq ) - -let find_es f seq = find_es f @@ protect seq - let rec of_seq seq () = match seq () with | Stdlib.Seq.Nil -> 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 e6d0c198537a..6f60a5feab4a 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq_s.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_s.ml @@ -178,46 +178,6 @@ let rec filter_map_s f seq () = let filter_map_s f seq = filter_map_s f @@ protect seq -let rec find f seq = - seq () - >>= function - | Nil -> - Monad.none_s - | Cons (item, seq) -> - if f item then Lwt.return (Some item) else find f seq - -let find f seq = find f @@ protect seq - -let rec find_e f seq = - seq () - >>= function - | Nil -> - Monad.none_es - | Cons (item, seq) -> ( - f item >>?= function true -> some_es item | false -> find_e f seq ) - -let find_e f seq = find_e f @@ protect seq - -let rec find_s f seq = - seq () - >>= function - | Nil -> - none_s - | Cons (item, seq) -> ( - f item >>= function true -> some_s item | false -> find_s f seq ) - -let find_s f seq = find_s f @@ protect seq - -let rec find_es f seq = - seq () - >>= function - | Nil -> - none_es - | Cons (item, seq) -> ( - f item >>=? function true -> some_es item | false -> find_es f seq ) - -let find_es f seq = find_es f @@ protect seq - let rec of_seq seq () = match seq () with | Stdlib.Seq.Nil -> -- GitLab From 4f7cf2ace6910b9f2495ea9969a65c91685d7513 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 19 Mar 2021 19:15:38 +0100 Subject: [PATCH 06/14] Lwtreslib: Seq*.unfold* and Seq*.append These are more recent OCaml Stdlib additions, but they are interesting to have anyway. --- src/lib_lwt_result_stdlib/bare/sigs/seq.ml | 8 +++ src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml | 10 ++++ src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml | 19 +++++++ src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml | 10 ++++ src/lib_lwt_result_stdlib/bare/structs/seq.ml | 8 +++ .../bare/structs/seq_e.ml | 21 ++++++++ .../bare/structs/seq_es.ml | 49 +++++++++++++++++++ .../bare/structs/seq_s.ml | 21 ++++++++ 8 files changed, 146 insertions(+) diff --git a/src/lib_lwt_result_stdlib/bare/sigs/seq.ml b/src/lib_lwt_result_stdlib/bare/sigs/seq.ml index 710a92b7abfe..7e21ac90a6aa 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq.ml @@ -87,6 +87,12 @@ module type S = sig with type 'a t = 'a Stdlib.Seq.t and type 'a node = 'a Stdlib.Seq.node + (** {3 Some values that made it to Stdlib's Seq since} *) + + val cons : 'a -> 'a t -> 'a t + + val append : 'a t -> 'a t -> 'a t + (** {3 Lwtreslib-specific extensions} *) (** Similar to {!fold_left} but wraps the traversal in {!result}. The @@ -144,4 +150,6 @@ module type S = sig it is either fulfilled if all promises are, or rejected if at least one of them is. *) val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t + + val unfold : ('b -> ('a * 'b) option) -> 'b -> 'a 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 e9434282681f..33ae87c89091 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml @@ -69,6 +69,12 @@ module type S = sig val nil : ('a, 'e) node + val cons : 'a -> ('a, 'e) t -> ('a, 'e) t + + val cons_e : ('a, 'e) result -> ('a, 'e) t -> ('a, 'e) t + + val append : ('a, 'e) t -> ('a, 'e) t -> ('a, 'e) t + (** [fold_left f init seq] is - if [seq] is a whole sequence, then [Ok x] where [x] is the result of @@ -217,6 +223,10 @@ fold_left_e [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 + + val unfold_e : ('b -> (('a * 'b) option, 'e) result) -> 'b -> ('a, 'e) t + val of_seq : 'a Stdlib.Seq.t -> ('a, 'e) t val of_seq_e : ('a, 'e) result Stdlib.Seq.t -> ('a, 'e) t 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 fbc905f776f4..39d0a800640c 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml @@ -51,6 +51,16 @@ module type S = sig val nil : ('a, 'e) node + val cons : 'a -> ('a, 'e) t -> ('a, 'e) t + + val cons_s : 'a Lwt.t -> ('a, 'e) t -> ('a, 'e) t + + val cons_e : ('a, 'e) result -> ('a, 'e) t -> ('a, 'e) t + + 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 @@ -119,6 +129,15 @@ module type S = sig 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 unfold_es : + ('b -> (('a * 'b) option, 'e) result Lwt.t) -> 'b -> ('a, 'e) t + val of_seq : 'a Stdlib.Seq.t -> ('a, 'e) t val of_seq_s : 'a Lwt.t 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 e08fc47670c2..a9761d4f6765 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml @@ -42,6 +42,12 @@ module type S = sig val return_s : 'a Lwt.t -> 'a t + val cons : 'a -> 'a t -> 'a t + + val cons_s : 'a Lwt.t -> 'a t -> 'a t + + val append : 'a t -> 'a t -> 'a 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. *) @@ -124,6 +130,10 @@ module type S = sig tail-recursive. *) val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t + val unfold : ('b -> ('a * 'b) option) -> 'b -> 'a t + + val unfold_s : ('b -> ('a * 'b) option Lwt.t) -> 'b -> 'a t + val of_seq : 'a Stdlib.Seq.t -> 'a t val of_seq_s : 'a Lwt.t Stdlib.Seq.t -> 'a t diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq.ml b/src/lib_lwt_result_stdlib/bare/structs/seq.ml index bd8901586095..df5e88e19032 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq.ml @@ -26,6 +26,11 @@ open Monad include Stdlib.Seq +let cons item t () = Cons (item, t) + +let rec append ta tb () = + match ta () with Nil -> tb () | Cons (item, ta) -> Cons (item, append ta tb) + (* Like Lwt.apply but specialised for two-parameter functions *) let apply2 f x y = try f x y with exn -> Lwt.fail exn @@ -118,3 +123,6 @@ let iter_p f seq = iter_p f seq (Lwt.apply f item :: acc) in iter_p f seq [] + +let rec unfold f a () = + match f a with None -> Nil | Some (item, a) -> Cons (item, unfold f a) 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 56e83e6ffa94..5d8fc67488b0 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml @@ -44,6 +44,15 @@ let return_e r () = Result.map (fun x -> Cons (x, empty)) r let interrupted e () = Error e +let cons item t () = Ok (Cons (item, t)) + +let cons_e item t () = item >|? fun item -> Cons (item, t) + +let rec append ta tb () = + ta () + >>? function + | Nil -> tb () | Cons (item, ta) -> Ok (Cons (item, append ta tb)) + let rec fold_left f acc seq = seq () >>? function @@ -200,6 +209,18 @@ let rec 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 () = + f a + >>? function + | None -> nil_e | Some (item, a) -> Ok (Cons (item, unfold_e f a)) + let rec of_seq seq () = match seq () with | Stdlib.Seq.Nil -> 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 47afeff2fa56..e49aa1e2a195 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq_es.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_es.ml @@ -51,6 +51,24 @@ let interrupted e () = Lwt.return (Error e) let interrupted_s p () = Lwt.bind p Lwt.return_error +let cons item t () = Monad.return (Cons (item, t)) + +let cons_e item t () = + match item with + | Error _ as e -> + Lwt.return e + | Ok item -> + Monad.return (Cons (item, t)) + +let cons_s item t () = item >>= fun item -> Monad.return (Cons (item, t)) + +let cons_es item t () = item >>=? fun item -> Monad.return (Cons (item, t)) + +let rec append ta tb () = + ta () + >>=? function + | Nil -> tb () | Cons (item, ta) -> Monad.return (Cons (item, append ta tb)) + let rec fold_left f acc seq = seq () >>=? function @@ -288,6 +306,37 @@ let rec 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) -> + Monad.return (Cons (item, unfold f a)) + +let rec unfold_s f a () = + f a + >>= function + | None -> nil_es | Some (item, a) -> Monad.return (Cons (item, unfold_s f a)) + +let rec unfold_e f a () = + match f a with + | Error _ as e -> + Lwt.return e + | Ok None -> + nil_es + | Ok (Some (item, a)) -> + Monad.return (Cons (item, unfold_e f a)) + +let rec unfold_es f a () = + f a + >>= function + | Error _ as e -> + Lwt.return e + | Ok None -> + nil_es + | Ok (Some (item, a)) -> + Monad.return (Cons (item, unfold_es f a)) + let rec of_seq seq () = match seq () with | Stdlib.Seq.Nil -> 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 6f60a5feab4a..a52c5714ce2c 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq_s.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_s.ml @@ -39,6 +39,15 @@ let return x () = Lwt.return (Cons (x, empty)) 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 () = item >|= fun item -> Cons (item, t) + +let rec append ta tb () = + ta () + >>= function + | Nil -> tb () | Cons (item, ta) -> Lwt.return (Cons (item, append ta tb)) + let rec fold_left f acc seq = seq () >>= function @@ -178,6 +187,18 @@ let rec 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 () = + f a + >>= function + | None -> nil_s | Some (item, a) -> Lwt.return (Cons (item, unfold_s f a)) + let rec of_seq seq () = match seq () with | Stdlib.Seq.Nil -> -- GitLab From 07a85378be9f671238135304f0bf85f8cb74915b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 19 Mar 2021 19:48:19 +0100 Subject: [PATCH 07/14] Everywhere: adapt to Lwtreslib changes --- src/lib_client_base_unix/client_config.ml | 7 ++++--- src/lib_event_logging/internal_event.ml | 2 ++ src/lib_shell/p2p_reader.ml | 9 ++++++--- 3 files changed, 12 insertions(+), 6 deletions(-) diff --git a/src/lib_client_base_unix/client_config.ml b/src/lib_client_base_unix/client_config.ml index 014838fe9f78..90eb03eeb43e 100644 --- a/src/lib_client_base_unix/client_config.ml +++ b/src/lib_client_base_unix/client_config.ml @@ -378,14 +378,15 @@ let wait_parameter () = let protocol_parameter () = parameter (fun _ arg -> match - Seq.find + Seq.filter (fun (hash, _commands) -> String.has_prefix ~prefix:arg (Protocol_hash.to_b58check hash)) (Client_commands.get_versions ()) + @@ () with - | Some (hash, _commands) -> + | Cons ((hash, _commands), _) -> return_some hash - | None -> + | Nil -> fail (Invalid_protocol_argument arg)) (* Command-line only args (not in config file) *) diff --git a/src/lib_event_logging/internal_event.ml b/src/lib_event_logging/internal_event.ml index 82cd2263d8e3..b764e82e9e05 100644 --- a/src/lib_event_logging/internal_event.ml +++ b/src/lib_event_logging/internal_event.ml @@ -108,6 +108,8 @@ module Section : sig val to_string_list : t -> string list val pp : Format.formatter -> t -> unit + + val equal : t -> t -> bool end = struct type t = {path : string list; lwt_log_section : Lwt_log_core.section} diff --git a/src/lib_shell/p2p_reader.ml b/src/lib_shell/p2p_reader.ml index a05680ee482e..8375c3dcd967 100644 --- a/src/lib_shell/p2p_reader.ml +++ b/src/lib_shell/p2p_reader.ml @@ -85,15 +85,17 @@ 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.find (fun chain_db -> + |> Seq.filter (fun chain_db -> Distributed_db_requester.Raw_operations.pending chain_db.operations_db (h, i)) + |> fun s -> match s () with Cons (item, _) -> Some item | Nil -> None let find_pending_operation {peer_active_chains; _} h = Chain_id.Table.to_seq_values peer_active_chains - |> Seq.find (fun chain_db -> + |> Seq.filter (fun chain_db -> Distributed_db_requester.Raw_operation.pending chain_db.operation_db h) + |> fun s -> match s () with Cons (item, _) -> Some item | Nil -> None let read_operation state h = (* Remember that seqs are lazy. The table is only traversed until a match is @@ -150,10 +152,11 @@ 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.find (fun chain_db -> + |> Seq.filter (fun chain_db -> Distributed_db_requester.Raw_block_header.pending chain_db.block_header_db h) + |> fun s -> match s () with Cons (item, _) -> Some item | Nil -> None let deactivate gid chain_db = chain_db.callback.disconnection gid ; -- GitLab From aaf6fca9778f523885d32231b19a174f492376fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 22 Mar 2021 17:31:05 +0100 Subject: [PATCH 08/14] Lwtreslib: factor multiple definitions of lwt_apply[23] --- src/lib_lwt_result_stdlib/bare/structs/list.ml | 4 ---- src/lib_lwt_result_stdlib/bare/structs/monad.ml | 9 +++++++++ src/lib_lwt_result_stdlib/bare/structs/monad.mli | 6 ++++++ src/lib_lwt_result_stdlib/bare/structs/seq.ml | 7 ++----- src/lib_lwt_result_stdlib/bare/structs/seq_e.ml | 7 ++----- src/lib_lwt_result_stdlib/traced/structs/list.ml | 2 +- 6 files changed, 20 insertions(+), 15 deletions(-) diff --git a/src/lib_lwt_result_stdlib/bare/structs/list.ml b/src/lib_lwt_result_stdlib/bare/structs/list.ml index 133aadbc0162..216466a7103d 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/list.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/list.ml @@ -428,8 +428,6 @@ let iteri_e f l = in aux 0 l -let lwt_apply2 f x y = try f x y with exc -> Lwt.fail exc - let iteri_s f l = let rec aux i = function | [] -> @@ -779,8 +777,6 @@ let fold_left2_e ~when_different_lengths f init xs ys = in aux init xs ys -let lwt_apply3 f a x y = try f a x y with exc -> Lwt.fail exc - let fold_left2_s ~when_different_lengths f init xs ys = let rec aux acc xs ys = match (xs, ys) with diff --git a/src/lib_lwt_result_stdlib/bare/structs/monad.ml b/src/lib_lwt_result_stdlib/bare/structs/monad.ml index 3ed5b2701f38..270b191d4fa7 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/monad.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/monad.ml @@ -161,3 +161,12 @@ let join_ep ts = all_p ts >|= join_e let all_ep ts = all_p ts >|= all_e let both_ep a b = both_p a b >|= fun (a, b) -> both_e a b + +(**/**) + +(* For internal use only, not advertised *) + +(* Like Lwt.apply but specialised for two-parameters functions *) +let lwt_apply2 f x y = try f x y with exn -> Lwt.fail exn + +let lwt_apply3 f a x y = try f a x y with exn -> Lwt.fail exn diff --git a/src/lib_lwt_result_stdlib/bare/structs/monad.mli b/src/lib_lwt_result_stdlib/bare/structs/monad.mli index d0603b9fa6d4..80dfc822e756 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/monad.mli +++ b/src/lib_lwt_result_stdlib/bare/structs/monad.mli @@ -24,3 +24,9 @@ (*****************************************************************************) include Bare_sigs.Monad.S + +(**/**) + +val lwt_apply2 : ('a -> 'b -> 'c Lwt.t) -> 'a -> 'b -> 'c Lwt.t + +val lwt_apply3 : ('a -> 'b -> 'c -> 'd Lwt.t) -> 'a -> 'b -> 'c -> 'd Lwt.t diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq.ml b/src/lib_lwt_result_stdlib/bare/structs/seq.ml index df5e88e19032..17d8c3fb7919 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq.ml @@ -31,9 +31,6 @@ let cons item t () = Cons (item, t) let rec append ta tb () = match ta () with Nil -> tb () | Cons (item, ta) -> Cons (item, append ta tb) -(* Like Lwt.apply but specialised for two-parameter functions *) -let apply2 f x y = try f x y with exn -> Lwt.fail exn - let rec fold_left_e f acc seq = match seq () with | Nil -> @@ -53,7 +50,7 @@ let fold_left_s f acc seq = | Nil -> Lwt.return acc | Cons (item, seq) -> - apply2 f acc item >>= fun acc -> fold_left_s f acc seq + lwt_apply2 f acc item >>= fun acc -> fold_left_s f acc seq let rec fold_left_es f acc seq = match seq () with @@ -67,7 +64,7 @@ let fold_left_es f acc seq = | Nil -> Monad.return acc | Cons (item, seq) -> - apply2 f acc item >>=? fun acc -> fold_left_es f acc seq + lwt_apply2 f acc item >>=? fun acc -> fold_left_es f acc seq let rec iter_e f seq = match seq () with 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 5d8fc67488b0..3e43896e7f5b 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml @@ -25,9 +25,6 @@ open Monad -(* Like Lwt.apply but specialised for three parameters *) -let apply3 f x y = try f x y with exn -> Lwt.fail exn - type (+'a, 'e) node = Nil | Cons of 'a * ('a, 'e) t and ('a, 'e) t = unit -> (('a, 'e) node, 'e) result @@ -80,7 +77,7 @@ let fold_left_s f acc seq = | Nil -> Monad.return acc | Cons (item, seq) -> - apply3 f acc item >>= fun acc -> fold_left_s f acc seq + lwt_apply2 f acc item >>= fun acc -> fold_left_s f acc seq let rec fold_left_es f acc seq = seq () @@ -96,7 +93,7 @@ let fold_left_es f acc seq = | Nil -> Monad.return acc | Cons (item, seq) -> - apply3 f acc item >>=? fun acc -> fold_left_es f acc seq + lwt_apply2 f acc item >>=? fun acc -> fold_left_es f acc seq let rec iter f seq = seq () >>? function Nil -> unit_e | Cons (item, seq) -> f item ; iter f seq diff --git a/src/lib_lwt_result_stdlib/traced/structs/list.ml b/src/lib_lwt_result_stdlib/traced/structs/list.ml index 9c3e3e71e625..31382a74d892 100644 --- a/src/lib_lwt_result_stdlib/traced/structs/list.ml +++ b/src/lib_lwt_result_stdlib/traced/structs/list.ml @@ -39,7 +39,7 @@ module Make (Monad : Traced_sigs.Monad.S) : let iter_ep f l = join_ep (rev_map (Lwt.apply f) l) - let lwt_apply2 f x y = try f x y with exc -> Lwt.fail exc + let lwt_apply2 f x y = try f x y with exn -> Lwt.fail exn let iteri_ep f l = join_ep (mapi (lwt_apply2 f) l) -- GitLab From dc8fa04429489465b894b6b2e250e489e0f1b24e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Hurlin?= Date: Fri, 30 Apr 2021 11:58:36 +0000 Subject: [PATCH 09/14] Lwtreslib: fix docstring formatting error --- src/lib_lwt_result_stdlib/lwtreslib.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lib_lwt_result_stdlib/lwtreslib.mli b/src/lib_lwt_result_stdlib/lwtreslib.mli index 04ff73518838..cb368cee564b 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.mli +++ b/src/lib_lwt_result_stdlib/lwtreslib.mli @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -(** {1 Lwtreslib: the Lwt- and result-aware Stdlib complement. +(** {1 Lwtreslib: the Lwt- and result-aware Stdlib complement} Lwtreslib (or Lwt-result-stdlib) is a library to complement the OCaml's Stdlib in software projects that make heavy use of Lwt and the result type. -- GitLab From 9081f745bce97524a762285656325d54fe37182d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 30 Apr 2021 14:31:06 +0200 Subject: [PATCH 10/14] Lwtreslib: minor documentation improvement --- src/lib_lwt_result_stdlib/bare/sigs/seq.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/lib_lwt_result_stdlib/bare/sigs/seq.ml b/src/lib_lwt_result_stdlib/bare/sigs/seq.ml index 7e21ac90a6aa..9e1f8ccdff0e 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq.ml @@ -34,8 +34,8 @@ All traversal functions that are suffixed with [_e] are within the result monad. Note that these functions have a "fail-early" behaviour: the - traversal is interrupted as when any of the intermediate application fails - (i.e., returns an [Error _]). + 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 monad. These functions traverse the elements sequentially: the promise for a -- GitLab From df06f74e56945f25ad29b9afa7d3c7e1fd9fcf71 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 3 May 2021 18:11:04 +0200 Subject: [PATCH 11/14] Lwtreslib/List: explicit, extensive signature --- src/lib_lwt_result_stdlib/bare/sigs/list.ml | 75 +++++++++++++++++-- .../bare/structs/list.ml | 13 ++++ 2 files changed, 81 insertions(+), 7 deletions(-) diff --git a/src/lib_lwt_result_stdlib/bare/sigs/list.ml b/src/lib_lwt_result_stdlib/bare/sigs/list.ml index 867606853b53..3a098e735888 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/list.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/list.ml @@ -82,15 +82,10 @@ *) module type S = sig - (** {3 Boilerplate} *) - - (** Include the legacy list. Functions that raise exceptions are shadowed - below. *) - include - module type of Stdlib.List with type 'a t = 'a Stdlib.List.t - (** {3 Trivial values} *) + type 'a t = 'a Stdlib.List.t = [] | ( :: ) of 'a * 'a list + (** in-monad, preallocated nil *) (** [nil] is [[]] *) @@ -128,6 +123,9 @@ module type S = sig [nth xs 0 = tl xs] *) val nth : 'a list -> int -> 'a option + (** [nth_opt] is an alias for [nth] provided for backwards compatibility. *) + val nth_opt : 'a list -> int -> 'a option + (** [last x xs] is the last element of the list [xs] or [x] if [xs] is empty. The primary intended use for [last] is after destructing a list: @@ -144,6 +142,9 @@ module type S = sig [predicate x] is [true] or [None] if the list [xs] has no such element. *) val find : ('a -> bool) -> 'a list -> 'a option + (** [find_opt] is an alias for [find] provided for backwards compatibility. *) + val find_opt : ('a -> bool) -> 'a list -> 'a option + (** [mem ~equal a l] is [true] iff there is an element [e] of [l] such that [equal a e]. *) val mem : equal:('a -> 'a -> bool) -> 'a -> 'a list -> bool @@ -153,12 +154,14 @@ module type S = sig pair. *) val assoc : equal:('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> 'b option + (** [assoc_opt] is an alias for [assoc] provided for backwards compatibility. *) val assoc_opt : equal:('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> 'b option (** [assq k kvs] is the same as [assoc ~equal:Stdlib.( == ) k kvs]: it uses the physical equality. *) val assq : 'a -> ('a * 'b) list -> 'b option + (** [assq_opt] is an alias for [assq] provided for backwards compatibility. *) val assq_opt : 'a -> ('a * 'b) list -> 'b option (** [mem_assoc ~equal k l] is equivalent to @@ -186,6 +189,20 @@ module type S = sig (int -> 'a) -> ('a list, 'trace) result + (** {4 Basic traversal} *) + + val length : 'a list -> int + + val rev : 'a list -> 'a list + + val concat : 'a list list -> 'a list + + val append : 'a list -> 'a list -> 'a list + + val rev_append : 'a list -> 'a list -> 'a list + + val flatten : 'a list list -> 'a list + (** {4 Double-list traversals} These safe-wrappers take an explicit value to handle the case of lists of @@ -223,6 +240,8 @@ module type S = sig 'b list -> (('a * 'b) list, 'trace) result + val split : ('a * 'b) list -> 'a list * 'b list + val iter2 : when_different_lengths:'trace -> ('a -> 'b -> unit) -> @@ -329,6 +348,8 @@ module type S = sig 'a list -> ('a option, 'trace) result Lwt.t + val filter : ('a -> bool) -> 'a list -> 'a list + (** [rev_filter f l] is [rev (filter f l)] but more efficient. *) val rev_filter : ('a -> bool) -> 'a list -> 'a list @@ -371,6 +392,10 @@ module type S = sig val filter_p : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t + val rev_partition : ('a -> bool) -> 'a list -> 'a list * 'a list + + val partition : ('a -> bool) -> 'a list -> 'a list * 'a list + val rev_partition_result : ('a, 'b) result list -> 'a list * 'b list val partition_result : ('a, 'b) result list -> 'a list * 'b list @@ -408,6 +433,7 @@ module type S = sig val partition_p : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t (** {4 Traversal variants} *) + val iter : ('a -> unit) -> 'a list -> unit val iter_e : ('a -> (unit, 'trace) result) -> 'a list -> (unit, 'trace) result @@ -426,6 +452,8 @@ module type S = sig val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t + val iteri : (int -> 'a -> unit) -> 'a list -> unit + val iteri_e : (int -> 'a -> (unit, 'trace) result) -> 'a list -> (unit, 'trace) result @@ -443,6 +471,8 @@ module type S = sig val iteri_p : (int -> 'a -> unit Lwt.t) -> 'a list -> unit Lwt.t + val map : ('a -> 'b) -> 'a list -> 'b list + val map_e : ('a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result @@ -460,6 +490,8 @@ module type S = sig val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list + val mapi_e : (int -> 'a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result @@ -477,6 +509,8 @@ module type S = sig val mapi_p : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + val rev_map : ('a -> 'b) -> 'a list -> 'b list + val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list val rev_map_e : @@ -523,6 +557,8 @@ module type S = sig val rev_filter_map_s : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t + val filter_map : ('a -> 'b option) -> 'a list -> 'b list + val filter_map_s : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t val rev_filter_map_es : @@ -542,6 +578,8 @@ module type S = sig val filter_map_p : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t + val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + val fold_left_e : ('a -> 'b -> ('a, 'trace) result) -> 'a -> 'b list -> ('a, 'trace) result @@ -553,6 +591,9 @@ module type S = sig 'b list -> ('a, 'trace) result Lwt.t + (** This function is not tail-recursive *) + val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b + (** This function is not tail-recursive *) val fold_right_e : ('a -> 'b -> ('b, 'trace) result) -> 'a list -> 'b -> ('b, 'trace) result @@ -688,6 +729,8 @@ module type S = sig (** {4 Scanning variants} *) + val for_all : ('a -> bool) -> 'a list -> bool + val for_all_e : ('a -> (bool, 'trace) result) -> 'a list -> (bool, 'trace) result @@ -705,6 +748,8 @@ module type S = sig val for_all_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t + val exists : ('a -> bool) -> 'a list -> bool + val exists_e : ('a -> (bool, 'trace) result) -> 'a list -> (bool, 'trace) result @@ -805,4 +850,20 @@ module type S = sig val compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int val equal : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool + + (** {3 Sorting} *) + + val sort : ('a -> 'a -> int) -> 'a list -> 'a list + + val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list + + val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list + + val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list + + (** {3 conversion} *) + + val to_seq : 'a t -> 'a Stdlib.Seq.t + + val of_seq : 'a Stdlib.Seq.t -> 'a list end diff --git a/src/lib_lwt_result_stdlib/bare/structs/list.ml b/src/lib_lwt_result_stdlib/bare/structs/list.ml index 216466a7103d..46e4bde3ad70 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/list.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/list.ml @@ -1041,6 +1041,19 @@ let exists2_es ~when_different_lengths f xs ys = | (x :: xs, y :: ys) -> ( lwt_apply2 f x y >>=? function false -> aux xs ys | true -> true_es ) +let rev_partition f xs = + let rec aux trues falses = function + | [] -> + (trues, falses) + | x :: xs -> + if f x then (aux [@ocaml.tailcall]) (x :: trues) falses xs + else (aux [@ocaml.tailcall]) trues (x :: falses) xs + in + aux [] [] xs + +let partition f xs = + rev_partition f xs |> fun (trues, falses) -> (rev trues, rev falses) + let rev_partition_result xs = let rec aux oks errors = function | [] -> -- GitLab From 553d6c00cfef8e55d8b0dbea3a519b7056415ca4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 4 May 2021 11:17:48 +0200 Subject: [PATCH 12/14] Lwtreslib/Seq*: add `first` --- src/lib_lwt_result_stdlib/bare/sigs/seq.ml | 9 +++ src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml | 10 +++ src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml | 2 + src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml | 10 +++ src/lib_lwt_result_stdlib/bare/structs/seq.ml | 2 + .../bare/structs/seq_e.ml | 9 +++ .../bare/structs/seq_es.ml | 10 +++ .../bare/structs/seq_s.ml | 2 + src/lib_lwt_result_stdlib/test/dune | 6 ++ .../test/test_seq_basic.ml | 72 +++++++++++++++++++ 10 files changed, 132 insertions(+) create mode 100644 src/lib_lwt_result_stdlib/test/test_seq_basic.ml diff --git a/src/lib_lwt_result_stdlib/bare/sigs/seq.ml b/src/lib_lwt_result_stdlib/bare/sigs/seq.ml index 9e1f8ccdff0e..a7a549ba3312 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq.ml @@ -95,6 +95,15 @@ module type S = sig (** {3 Lwtreslib-specific extensions} *) + (** [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 : 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 33ae87c89091..5dbfbe0c3026 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml @@ -75,6 +75,16 @@ module type S = sig 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 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 39d0a800640c..2329eb8ed0c0 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq_es.ml @@ -73,6 +73,8 @@ 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 (** See {!Seq_e.fold_left_e} for a warning about traversal and interruption 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 a9761d4f6765..47d6e6dd586d 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml @@ -48,6 +48,16 @@ module type S = sig 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. *) diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq.ml b/src/lib_lwt_result_stdlib/bare/structs/seq.ml index 17d8c3fb7919..721896ad1513 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq.ml @@ -31,6 +31,8 @@ let cons item t () = Cons (item, t) let rec append ta tb () = match ta () with Nil -> tb () | Cons (item, ta) -> Cons (item, append ta tb) +let first s = match s () with Nil -> None | Cons (x, _) -> Some x + let rec fold_left_e f acc seq = match seq () with | Nil -> 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 3e43896e7f5b..2ec936d786b5 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml @@ -50,6 +50,15 @@ let rec append ta tb () = >>? function | 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 = seq () >>? function 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 e49aa1e2a195..c0f400843b4f 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq_es.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_es.ml @@ -69,6 +69,16 @@ let rec append ta tb () = >>=? function | Nil -> tb () | Cons (item, ta) -> Monad.return (Cons (item, append ta tb)) +let first s = + s () + >>= function + | Ok Nil -> + Lwt.return_none + | Ok (Cons (x, _)) -> + Lwt.return_some (Ok x) + | Error _ as error -> + Lwt.return_some error + let rec fold_left f acc seq = seq () >>=? function 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 a52c5714ce2c..cae881fb6648 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq_s.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_s.ml @@ -48,6 +48,8 @@ let rec append ta tb () = >>= function | Nil -> tb () | Cons (item, ta) -> Lwt.return (Cons (item, append ta tb)) +let first s = s () >|= function Nil -> None | Cons (x, _) -> Some x + let rec fold_left f acc seq = seq () >>= function diff --git a/src/lib_lwt_result_stdlib/test/dune b/src/lib_lwt_result_stdlib/test/dune index d4eea23096d6..b1c6ce8cd863 100644 --- a/src/lib_lwt_result_stdlib/test/dune +++ b/src/lib_lwt_result_stdlib/test/dune @@ -2,6 +2,7 @@ (names test_hashtbl test_list_basic + test_seq_basic test_generic test_fuzzing_seq test_fuzzing_list @@ -23,6 +24,7 @@ test_hashtbl.exe test_generic.exe test_list_basic.exe + test_seq_basic.exe test_fuzzing_seq.exe test_fuzzing_list.exe test_fuzzing_set.exe @@ -37,6 +39,9 @@ (rule (alias runtest_list_basic) (action (run %{exe:test_list_basic.exe}))) +(rule + (alias runtest_seq_basic) + (action (run %{exe:test_seq_basic.exe}))) (rule (alias runtest_fuzzing_seq) (action (run %{exe:test_fuzzing_seq.exe}))) @@ -57,6 +62,7 @@ (alias runtest_hashtbl) (alias runtest_generic) (alias runtest_list_basic) + (alias runtest_seq_basic) (alias runtest_fuzzing_seq) (alias runtest_fuzzing_list) (alias runtest_fuzzing_set) diff --git a/src/lib_lwt_result_stdlib/test/test_seq_basic.ml b/src/lib_lwt_result_stdlib/test/test_seq_basic.ml new file mode 100644 index 000000000000..919713280444 --- /dev/null +++ b/src/lib_lwt_result_stdlib/test/test_seq_basic.ml @@ -0,0 +1,72 @@ +(*****************************************************************************) +(* *) +(* 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.Monad + +let ( >>== ) p v = Lwt_main.run (p >|= ( = ) v) + +let () = + 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) = []) + +let () = + 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 () = + 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 () = + 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) -- GitLab From 7c4326a4b6bd9bf65bee0be4cb09116e9af08d39 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 4 May 2021 11:24:14 +0200 Subject: [PATCH 13/14] Everywhere: use new Seq.first --- src/lib_shell/p2p_reader.ml | 24 ++++++++++-------------- 1 file changed, 10 insertions(+), 14 deletions(-) diff --git a/src/lib_shell/p2p_reader.ml b/src/lib_shell/p2p_reader.ml index 8375c3dcd967..7f6d39adbd9d 100644 --- a/src/lib_shell/p2p_reader.ml +++ b/src/lib_shell/p2p_reader.ml @@ -89,28 +89,24 @@ let find_pending_operations {peer_active_chains; _} h i = Distributed_db_requester.Raw_operations.pending chain_db.operations_db (h, i)) - |> fun s -> match s () with Cons (item, _) -> Some item | Nil -> None + |> Seq.first let find_pending_operation {peer_active_chains; _} h = Chain_id.Table.to_seq_values peer_active_chains |> Seq.filter (fun chain_db -> Distributed_db_requester.Raw_operation.pending chain_db.operation_db h) - |> fun s -> match s () with Cons (item, _) -> Some item | Nil -> None + |> 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 id_db_seq = Seq_s.of_seq (Chain_id.Table.to_seq state.active_chains) in - let id_bh_seq = - Seq_s.filter_map_s - (fun (chain_id, chain_db) -> - Distributed_db_requester.Raw_operation.read_opt chain_db.operation_db h - >|= Option.map (fun bh -> (chain_id, bh))) - id_db_seq - in - id_bh_seq () - >>= function - | Seq_s.Nil -> Lwt.return_none | Seq_s.Cons (item, _) -> Lwt.return_some item + Seq_s.of_seq (Chain_id.Table.to_seq state.active_chains) + |> Seq_s.filter_map_s (fun (chain_id, chain_db) -> + Distributed_db_requester.Raw_operation.read_opt + chain_db.operation_db + h + >|= Option.map (fun bh -> (chain_id, bh))) + |> Seq_s.first let read_block {disk; _} h = Store.all_chain_stores disk @@ -156,7 +152,7 @@ let find_pending_block_header {peer_active_chains; _} h = Distributed_db_requester.Raw_block_header.pending chain_db.block_header_db h) - |> fun s -> match s () with Cons (item, _) -> Some item | Nil -> None + |> Seq.first let deactivate gid chain_db = chain_db.callback.disconnection gid ; -- GitLab From b420da13d2cbfaf8fcdece7f8f3c0c2f3a94384f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 4 May 2021 11:24:36 +0200 Subject: [PATCH 14/14] Lwtreslib: improve documentation of Seq* --- src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml | 19 +++++++++++++++++++ src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml | 12 +++++++++++- 2 files changed, 30 insertions(+), 1 deletion(-) 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 5dbfbe0c3026..fb254a3a25b7 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq_e.ml @@ -61,18 +61,37 @@ module type S = sig (** 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 + (** [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 + [e]. *) val return_e : ('a, 'e) result -> ('a, 'e) t + (** [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 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 47d6e6dd586d..658b98832443 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq_s.ml @@ -31,21 +31,31 @@ The functions [of_seq] and [of_seq_s] allow conversion from vanilla sequences. *) module type S = sig - (** This is similar to [S.t] but the suspended node is a promise *) + (** This is similar to [S.t] but the suspended node is a promise. *) type +'a node = Nil | Cons of 'a * 'a t and 'a t = unit -> 'a node Lwt.t + (** [empty] is a sequence with no elements. *) val empty : 'a t + (** [return x] is a sequence with the single element [x]. *) val return : 'a -> '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 -- GitLab