diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index c3d176493b04a3d9a675bb49706afeca85288903..b52dcd9daab7e0683b955973ad87921cb052f29f 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1491,7 +1491,7 @@ test_coverage: # We exclude from coverage old protocols and code that can't be # instrumented because of current limitations of bisect_ppx. OLD_PROTOCOLS: "src/proto_000_Ps9mPmXa src/proto_001_PtCJ7pwo src/proto_002_PsYLVpVv src/proto_003_PsddFKi3 src/proto_004_Pt24m4xi src/proto_005_PsBABY5H src/proto_005_PsBabyM1 src/proto_006_PsCARTHA" - NOT_INSTRUMENTABLE: "src/proto_007_PsDELPH1" + NOT_INSTRUMENTABLE: "src/proto_007_PsDELPH1 src/proto_alpha" COVERAGE_EXCLUDE: "$OLD_PROTOCOLS $NOT_INSTRUMENTABLE" script: - scripts/instrument_dune_bisect.sh src/ --except $COVERAGE_EXCLUDE diff --git a/src/lib_client_base_unix/client_config.ml b/src/lib_client_base_unix/client_config.ml index 1d92ed798cee37db35d3fdf293728e7d4f6e9694..fc153fd757927875fb14ecb3178064145dcd593b 100644 --- a/src/lib_client_base_unix/client_config.ml +++ b/src/lib_client_base_unix/client_config.ml @@ -333,7 +333,7 @@ let wait_parameter () = let protocol_parameter () = parameter (fun _ arg -> match - Seq.find_first + Seq.find (fun (hash, _commands) -> String.has_prefix ~prefix:arg (Protocol_hash.to_b58check hash)) (Client_commands.get_versions ()) diff --git a/src/lib_lwt_result_stdlib/functors/seq.ml b/src/lib_lwt_result_stdlib/functors/seq.ml index c0ea1c04b5a27699917fe5630178d32c8f0c5026..74843ba6657e7a495b9dae9cdd6db7439669a6e3 100644 --- a/src/lib_lwt_result_stdlib/functors/seq.ml +++ b/src/lib_lwt_result_stdlib/functors/seq.ml @@ -40,6 +40,9 @@ struct let lwt_empty = Lwt.return empty + (* Like Lwt.apply but specialised for three parameters *) + let apply3 f x y = try f x y with exn -> Lwt.fail exn + let rec fold_left_e f acc seq = match seq () with | Nil -> @@ -54,6 +57,13 @@ struct | Cons (item, seq) -> f acc item >>= fun acc -> fold_left_s f acc seq + let fold_left_s f acc seq = + match seq () with + | Nil -> + Lwt.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 = match seq () with | Nil -> @@ -61,6 +71,13 @@ struct | Cons (item, seq) -> f acc item >>=? fun acc -> fold_left_es f acc seq + let fold_left_es f acc seq = + match seq () with + | Nil -> + Monad.return acc + | Cons (item, seq) -> + apply3 f acc item >>=? fun acc -> fold_left_es f acc seq + let rec iter_e f seq = match seq () with | Nil -> @@ -75,6 +92,13 @@ struct | Cons (item, seq) -> f item >>= fun () -> iter_s f seq + let iter_s f seq = + match seq () with + | Nil -> + Lwt.return_unit + | Cons (item, seq) -> + Lwt.apply f item >>= fun () -> iter_s f seq + let rec iter_es f seq = match seq () with | Nil -> @@ -82,13 +106,20 @@ struct | Cons (item, seq) -> f item >>=? fun () -> iter_es f seq + let iter_es f seq = + match seq () with + | Nil -> + return_unit + | Cons (item, seq) -> + Lwt.apply f item >>=? fun () -> iter_es f seq + let iter_p f seq = let rec iter_p f seq acc = match seq () with | Nil -> join_p acc | Cons (item, seq) -> - iter_p f seq (f item :: acc) + iter_p f seq (Lwt.apply f item :: acc) in iter_p f seq [] @@ -98,7 +129,7 @@ struct | Nil -> join_ep acc | Cons (item, seq) -> - iter_ep f seq (f item :: acc) + iter_ep f seq (Lwt.apply f item :: acc) in iter_ep f seq [] @@ -120,6 +151,15 @@ struct >>= fun item -> map_s f seq >>= fun seq -> Lwt.return (fun () -> Cons (item, seq)) + let map_s f seq = + match seq () with + | Nil -> + lwt_empty + | 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 -> @@ -129,11 +169,24 @@ struct >>=? fun item -> map_es f seq >>=? fun seq -> Monad.return (fun () -> Cons (item, seq)) + let map_es f seq = + match seq () with + | Nil -> + return_empty + | Cons (item, seq) -> + Lwt.apply f item + >>=? fun item -> + map_es f seq >>=? fun seq -> Monad.return (fun () -> Cons (item, seq)) + let map_p f seq = - all_p (fold_left (fun acc x -> f x :: acc) [] seq) >|= List.to_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 map_ep f seq = - all_ep (fold_left (fun acc x -> f x :: acc) [] seq) >|=? List.to_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 rec filter_e f seq = match seq () with @@ -160,6 +213,19 @@ struct filter_s f seq >>= fun seq -> Lwt.return (fun () -> Cons (item, seq)) ) + let filter_s f seq = + match seq () with + | Nil -> + lwt_empty + | 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 -> @@ -173,6 +239,19 @@ struct filter_es f seq >>=? fun seq -> Monad.return (fun () -> Cons (item, seq)) ) + let filter_es f seq = + match seq () with + | Nil -> + return_empty + | 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 -> @@ -198,6 +277,19 @@ struct filter_map_s f seq >>= fun seq -> Lwt.return (fun () -> Cons (item, seq)) ) + let filter_map_s f seq = + match seq () with + | Nil -> + lwt_empty + | 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 -> @@ -211,35 +303,62 @@ struct filter_map_es f seq >>=? fun seq -> Monad.return (fun () -> Cons (item, seq)) ) - let rec find_first f seq = + let filter_map_es f seq = + match seq () with + | Nil -> + return_empty + | 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 -> None | Cons (item, seq) -> - if f item then Some item else find_first f seq + if f item then Some item else find f seq - let rec find_first_e f seq = + let rec find_e f seq = match seq () with | Nil -> ok_none | Cons (item, seq) -> ( - f item - >>? function true -> ok_some item | false -> find_first_e f seq ) + f item >>? function true -> ok_some item | false -> find_e f seq ) - let rec find_first_s f seq = + let rec find_s f seq = match seq () with | Nil -> Lwt.return_none | Cons (item, seq) -> ( f item - >>= function - | true -> Lwt.return_some item | false -> find_first_s f seq ) + >>= function true -> Lwt.return_some item | false -> find_s f seq ) + + let find_s f seq = + match seq () with + | Nil -> + Lwt.return_none + | Cons (item, seq) -> ( + Lwt.apply f item + >>= function true -> Lwt.return_some item | false -> find_s f seq ) - let rec find_first_es f seq = + let rec find_es f seq = match seq () with | Nil -> return_none | Cons (item, seq) -> ( f item - >>=? function true -> return_some item | false -> find_first_es f seq ) + >>=? function true -> return_some item | false -> find_es f seq ) + + let find_es f seq = + match seq () with + | Nil -> + return_none + | Cons (item, seq) -> ( + Lwt.apply f item + >>=? function true -> return_some item | false -> find_es f seq ) end diff --git a/src/lib_lwt_result_stdlib/sigs/seq.ml b/src/lib_lwt_result_stdlib/sigs/seq.ml index 3cd7384eefd3291795d67ae448be4e2b598121d1..02d3cd2d888e31135ea5ad1543779255043ed37c 100644 --- a/src/lib_lwt_result_stdlib/sigs/seq.ml +++ b/src/lib_lwt_result_stdlib/sigs/seq.ml @@ -233,31 +233,31 @@ module type S = sig 'a t -> ('b t, 'trace) result Lwt.t - (** [find_first f t] is [Some x] where [x] is the first item in [t] such that + (** [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_first : ('a -> bool) -> 'a t -> 'a option + val find : ('a -> bool) -> 'a t -> 'a option - (** [find_first_e f t] is similar to {!find_first} but wraps the search within - [result]. Specifically, [find_first_e f t] is either + (** [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_first_e : + val find_e : ('a -> (bool, 'trace) result) -> 'a t -> ('a option, 'trace) result - (** [find_first_s f t] is similar to {!find_first} but wrapped within - [Lwt.t]. The search is identical to [find_first_e] but each + (** [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_first_s : ('a -> bool Lwt.t) -> 'a t -> 'a option Lwt.t + val find_s : ('a -> bool Lwt.t) -> 'a t -> 'a option Lwt.t - (** [find_first_es f t] is similar to {!find_first} but wrapped within - [result Lwt.t]. The search is identical to [find_first_e] but each + (** [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_first_es : + val find_es : ('a -> (bool, 'trace) result Lwt.t) -> 'a t -> ('a option, 'trace) result Lwt.t diff --git a/src/lib_lwt_result_stdlib/test/dune b/src/lib_lwt_result_stdlib/test/dune index f763639f1e5cf8b05a8db71bd86f7e24f7c465ad..bef7149d741c985749f7b8e7489db037b272cf25 100644 --- a/src/lib_lwt_result_stdlib/test/dune +++ b/src/lib_lwt_result_stdlib/test/dune @@ -1,22 +1,47 @@ (executables - (names test_hashtbl) + (names + test_hashtbl + test_generic + test_fuzzing_seq + test_fuzzing_set + ) (libraries tezos-lwt-result-stdlib tezos-error-monad lwt.unix - alcotest-lwt) + alcotest-lwt + crowbar) (flags (:standard -open Tezos_lwt_result_stdlib))) -(rule - (alias buildtest) - (deps test_hashtbl.exe) - (action (progn))) +(alias + (name buildtest) + (deps + test_hashtbl.exe + test_generic.exe + test_fuzzing_seq.exe + test_fuzzing_set.exe + )) (rule (alias runtest_hashtbl) (action (run %{exe:test_hashtbl.exe}))) +(rule + (alias runtest_generic) + (action (run %{exe:test_generic.exe}))) +(rule + (alias runtest_fuzzing_seq) + (action (run %{exe:test_fuzzing_seq.exe}))) +(rule + (alias runtest_fuzzing_set) + (action (run %{exe:test_fuzzing_set.exe}))) (rule (alias runtest) (package tezos-lwt-result-stdlib) - (deps (alias runtest_hashtbl)) - (action (progn))) + (deps + (alias runtest_hashtbl) + (alias runtest_generic) + (alias runtest_fuzzing_seq) + (alias runtest_fuzzing_set) + ) + (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 new file mode 100644 index 0000000000000000000000000000000000000000..bb8f9a90dae3364c5d41148d92103e5fcd592290 --- /dev/null +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml @@ -0,0 +1,382 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Lwt.Infix +open Lwtreslib.Seq.Monad + +let rec log_pause n = + if n <= 0 then Lwt.return_unit + else Lwt.pause () >>= fun () -> log_pause (n / 8) + +(* Generators *) + +(* Function generators *) + +module Fn = struct + let pred = + let open Crowbar in + choose + [ const (fun x _ -> x > 0); + const (fun _ y -> y < 0); + const (fun _ _ -> false); + const (fun _ _ -> true); + const (fun x y -> x < y) ] + + let arith = + let open Crowbar in + choose + [ const (fun x _ -> x); + const (fun _ y -> y); + const (fun x _ -> 2 * x); + const (fun _ _ -> 0); + map [int] (fun n _ _ -> n); + const (fun x y -> x + y); + const (fun _ y -> 2 * y); + const (fun _ y -> y + 1); + const (fun x y -> min x y); + const (fun x y -> max x y); + const (fun x y -> (5 * x) + (112 * y)) ] + + (* combinators *) + let e cond ok error x y = if cond x y then Ok (ok x y) else Error (error x y) + + let arith_e = Crowbar.map [pred; arith; arith] e + + let s pauses fn x y = log_pause (pauses x y) >|= fun () -> fn x y + + let arith_s = Crowbar.map [arith; arith] s + + let es cond pauses ok error x y = + log_pause (pauses x y) + >|= fun () -> if cond x y then Ok (ok x y) else Error (error x y) + + let arith_es = Crowbar.map [pred; arith; arith; arith] es +end + +(* Wrappers for generated functions *) + +(* immediate wrappers *) + +module Apply = struct + let fn fn x y = fn x y +end + +module Apply2 = struct + let fn fn x y z = fn x (fn y z) +end + +module IterOf = struct + let fn r fn y = r := fn !r y +end + +module Iter2Of = struct + let fn r fn x y = r := fn !r (fn x y) +end + +module FoldOf = Apply +module Fold2Of = Apply2 + +module MapOf = struct + let fn const fn elt = fn const elt +end + +module Map2Of = Apply +module CondOf = Apply +module Cond2Of = Apply + +module FilterMapOf = struct + let fns cond fn const elt = + if cond const elt then Some (fn const elt) else None +end + +(* error-aware wrappers *) + +module IterEOf = struct + let fn r fn y = + r := fn !r y ; + Ok () + + let fn_e r fn y = fn !r y >|? fun t -> r := t +end + +module Iter2EOf = struct + let fn r fn x y = + r := fn x y ; + Ok () + + let fn_e r fn x y = fn x y >|? fun t -> r := t +end + +module FoldEOf = struct + let fn fn acc elt = Ok (fn acc elt) + + let fn_e fn acc elt = fn acc elt +end + +module Fold2EOf = struct + let fn fn acc x y = Ok (fn acc (fn x y)) + + let fn_e fn acc x y = fn x y >>? fn acc +end + +module MapEOf = struct + let fn const fn elt = Ok (fn const elt) + + let fn_e const fn elt = fn const elt +end + +module Map2EOf = struct + let fn fn x y = Ok (fn x y) + + let fn_e fn x y = fn x y +end + +module CondEOf = struct + let fn fn const elt = Ok (fn const elt) + + let fn_e fn const elt = fn const elt +end + +module Cond2EOf = struct + let fn fn x y = Ok (fn x y) + + let fn_e fn x y = fn x y +end + +module FilterMapEOf = struct + let fns cond fn const elt = + Ok (if cond const elt then Some (fn const elt) else None) + + let fns_e cond fn const elt = + cond const elt >|? fun b -> if b then Some (fn const elt) else None +end + +(* lwt-aware wrappers *) + +module IterSOf = struct + let fn r fn y = + r := fn !r y ; + Lwt.return_unit + + let fn_s r fn y = fn !r y >|= fun t -> r := t +end + +module Iter2SOf = struct + let fn r fn x y = + r := fn x y ; + Lwt.return_unit + + let fn_s r fn x y = fn x y >|= fun t -> r := t +end + +module FoldSOf = struct + let fn fn acc elt = Lwt.return (fn acc elt) + + let fn_s fn acc elt = fn acc elt +end + +module Fold2SOf = struct + let fn fn acc x y = Lwt.return (fn acc (fn x y)) + + let fn_s fn acc x y = fn x y >>= fn acc +end + +module MapSOf = struct + let fn const fn elt = Lwt.return (fn const elt) + + let fn_s const fn elt = fn const elt +end + +module Map2SOf = struct + let fn fn x y = Lwt.return (fn x y) + + let fn_s fn x y = fn x y +end + +module CondSOf = struct + let fn fn const elt = Lwt.return (fn const elt) + + let fn_s fn const elt = fn const elt +end + +module Cond2SOf = struct + let fn fn x y = Lwt.return (fn x y) + + let fn_s fn x y = fn x y +end + +module FilterMapSOf = struct + let fns cond fn const elt = + Lwt.return (if cond const elt then Some (fn const elt) else None) + + let fns_s cond fn const elt = + cond const elt >|= fun b -> if b then Some (fn const elt) else None +end + +(* error-lwt-aware wrappers *) + +module IterESOf = struct + let fn r fn y = + r := fn !r y ; + return_unit + + let fn_e r fn y = Lwt.return @@ fn !r y >|=? fun t -> r := t + + let fn_s r fn y = + fn !r y + >|= fun t -> + r := t ; + Ok () + + let fn_es r fn y = fn !r y >|=? fun t -> r := t +end + +module Iter2ESOf = struct + let fn r fn x y = + r := fn x y ; + return_unit + + let fn_e r fn x y = Lwt.return @@ fn x y >|=? fun t -> r := t + + let fn_s r fn x y = + fn x y + >|= fun t -> + r := t ; + Ok () + + let fn_es r fn x y = fn x y >|=? fun t -> r := t +end + +module FoldESOf = struct + let fn fn acc elt = return (fn acc elt) + + let fn_e fn acc elt = Lwt.return @@ fn acc elt + + let fn_s fn acc elt = fn acc elt >>= Lwt.return_ok + + let fn_es fn acc elt = fn acc elt +end + +module Fold2ESOf = struct + let fn fn acc x y = return (fn acc (fn x y)) + + let fn_e fn acc x y = Lwt.return @@ (fn x y >>? fn acc) + + let fn_s fn acc x y = fn x y >>= fn acc >>= Lwt.return_ok + + let fn_es fn acc x y = fn x y >>=? fn acc +end + +module MapESOf = struct + let fn const fn elt = return (fn const elt) + + let fn_e const fn elt = Lwt.return @@ fn const elt + + let fn_s const fn elt = fn const elt >>= Lwt.return_ok + + let fn_es const fn elt = fn const elt +end + +module MapEPOf = struct + let fn const fn elt = return (fn const elt) + + let fn_e const fn elt = + match fn const elt with + | Ok _ as ok -> + Lwt.return ok + | Error err -> + fail err + + let fn_s const fn elt = fn const elt >>= Lwt.return_ok + + let fn_es const fn elt = + fn const elt >>= function Ok ok -> return ok | Error err -> fail err +end + +module Map2ESOf = struct + let fn fn x y = return (fn x y) + + let fn_e fn x y = Lwt.return @@ fn x y + + let fn_s fn x y = fn x y >>= Lwt.return_ok + + let fn_es fn x y = fn x y +end + +module CondESOf = struct + let fn fn const elt = return (fn const elt) + + let fn_es fn const elt = fn const elt +end + +module Cond2ESOf = struct + let fn fn x y = return (fn x y) + + let fn_es fn x y = fn x y +end + +module FilterMapESOf = struct + let fns cond fn const elt = + return (if cond const elt then Some (fn const elt) else None) + + let fns_es cond fn const elt = + cond const elt >|=? fun b -> if b then Some (fn const elt) else None +end + +(* Data generators (we use lists of integers) *) + +let one = Crowbar.int + +let many = Crowbar.(list int) + +let manymany = + let open Crowbar in + choose + [ map [list int] (fun input -> (input, input)); + map [list int; list int] (fun l r -> (l, r)) ] + +(* equality and lwt/error variants *) + +let eq ?pp a b = Crowbar.check_eq ?pp a b + +let eq_e ?pp a b = Crowbar.check_eq ?pp a b + +let eq_s ?pp a b = + Lwt_main.run (a >>= fun a -> b >|= fun b -> Crowbar.check_eq ?pp a b) + +let eq_es ?pp a b = + Lwt_main.run (a >>= fun a -> b >|= fun b -> Crowbar.check_eq ?pp a b) + +module PP = struct + let int = Format.pp_print_int + + let res ok error = Format.pp_print_result ~ok ~error + + let str = Format.pp_print_string + + let list elt = Format.pp_print_list ~pp_sep:Format.pp_print_space elt + + let bool = Format.pp_print_bool +end diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_seq.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_seq.ml new file mode 100644 index 0000000000000000000000000000000000000000..6c86580ccd461e46eb07ea41d474e266d6c99259 --- /dev/null +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_seq.ml @@ -0,0 +1,51 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Test_fuzzing_tests + +module SeqWithBase = struct + type 'a elt = 'a + + include Lwtreslib.Seq + + let of_list = List.to_seq + + let to_list = List.of_seq + + let name = "Seq" +end + +(* Internal consistency *) +module TestSeqIterFold = TestIterFold (SeqWithBase) + +(* consistency w.r.t. Stdlib *) +module Filter = TestFilterAgainstStdlibList (SeqWithBase) +module Filtermap = TestFiltermapAgainstStdlibList (SeqWithBase) +module Fold = TestFoldAgainstStdlibList (SeqWithBase) +module Iter = TestIterAgainstStdlibList (SeqWithBase) +module Iterp = TestIterMonotoneAgainstStdlibList (SeqWithBase) +module Map = TestMapAgainstStdlibList (SeqWithBase) +module Mapp = TestMappAgainstStdlibList (SeqWithBase) +module Find = TestFindStdlibList (SeqWithBase) diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_set.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_set.ml new file mode 100644 index 0000000000000000000000000000000000000000..a35f686fddb5b7e03e2fe75c4954db71293fc32c --- /dev/null +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_set.ml @@ -0,0 +1,56 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Test_fuzzing_tests + +module IntSet : Lwtreslib.Set.S with type elt = int = struct + include Lwtreslib.Set.Make (Int) +end + +module SetWithBase = struct + let name = "Set" + + type 'a elt = IntSet.elt + + type _alias_elt = IntSet.elt + + type 'a t = IntSet.t + + type _alias_t = IntSet.t + + module IntSet : + Lwtreslib.Set.S with type elt := _alias_elt and type t := _alias_t = struct + include IntSet + end + + include IntSet + + let of_list : int list -> _alias_t = of_list + + let to_list : _alias_t -> int list = elements +end + +module Iterp = TestIterMonotoneAgainstStdlibList (SetWithBase) +module Fold = TestFoldMonotonicAgainstStdlibList (SetWithBase) diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml new file mode 100644 index 0000000000000000000000000000000000000000..a70023eb9270fba46525e0f9670e7f0aa05b6380 --- /dev/null +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml @@ -0,0 +1,1550 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Traits +open Test_fuzzing_helpers +open Lwt.Infix +open Lwtreslib.Seq.Monad + +(* In the following, in order to reduce the time, output and complexity and + testing, we only test for the most general case (i.e., when testing an + error-aware traversor, we do not make distinct tests for + always-successful stepper, always-failing stepper, and sometimes-successful + stepper). + + This offers as much coverage (because the generic steppers may + be generated to be always-successful or always-failing or + sometimes-successful) and thus as much assurance as to the correction of the + traversors. + + It does mean that, should a test fail, it would be more difficult to + pin-point the origin of the failure. If that were to happen, we invite the + person debugging the code to write additional specialised tests. *) + +module TestIterFold (M : sig + include BASE with type 'a elt := int + + include Traits.ITER_SEQUENTIAL with type 'a elt := int and type 'a t := int t + + include FOLDLEFT_SEQUENTIAL with type 'a elt := int and type 'a t := int t +end) = +struct + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.{iter,fold_left}" M.name) + [Fn.arith; one; many] + (fun fn init input -> + let input = M.of_list input in + eq + (let acc = ref init in + M.iter (IterOf.fn acc fn) input ; + !acc) + (M.fold_left (FoldOf.fn fn) init input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.{iter,fold_left}_e" M.name) + [Fn.arith_e; one; many] + (fun fn init input -> + let input = M.of_list input in + eq_e + (let acc = ref init in + M.iter_e (IterEOf.fn_e acc fn) input >|? fun () -> !acc) + (M.fold_left_e (FoldEOf.fn_e fn) init input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.{iter,fold_left}_s" M.name) + [Fn.arith_s; one; many] + (fun fn init input -> + let input = M.of_list input in + eq_s + (let acc = ref init in + M.iter_s (IterSOf.fn_s acc fn) input >|= fun () -> !acc) + (M.fold_left_s (FoldSOf.fn_s fn) init input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.{iter,fold_left}_es" M.name) + [Fn.arith_es; one; many] + (fun fn init input -> + let input = M.of_list input in + eq_es + (let acc = ref init in + M.iter_es (IterESOf.fn_es acc fn) input >|=? fun () -> !acc) + (M.fold_left_es (FoldESOf.fn_es fn) init input)) +end + +module TestRevMapRevMap (M : sig + include BASE + + include Traits.MAP_PARALLEL with type 'a t := 'a t + + include Traits.REVMAP_PARALLEL with type 'a t := 'a t +end) = +struct + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.{rev map,rev_map}" M.name) + [Fn.arith; one; many] + (fun fn const input -> + let input = M.of_list input in + let fn = MapOf.fn const fn in + eq (M.map fn input |> M.rev) (M.rev_map fn input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.{rev map,rev_map}_e" M.name) + [Fn.arith_e; one; many] + (fun fn const input -> + let input = M.of_list input in + let fn = MapEOf.fn_e const fn in + eq_e (M.map_e fn input >|? M.rev) (M.rev_map_e fn input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.{rev map,rev_map}_s" M.name) + [Fn.arith_s; one; many] + (fun fn const input -> + let input = M.of_list input in + let fn = MapSOf.fn_s const fn in + eq_s (M.map_s fn input >|= M.rev) (M.rev_map_s fn input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.{rev map,rev_map}_es" M.name) + [Fn.arith_es; one; many] + (fun fn const input -> + let input = M.of_list input in + let fn = MapESOf.fn_es const fn in + eq_es (M.map_es fn input >|=? M.rev) (M.rev_map_es fn input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.{rev map,rev_map}_p" M.name) + [Fn.arith_s; one; many] + (fun fn const input -> + let input = M.of_list input in + let fn = MapSOf.fn_s const fn in + eq_s (M.map_p fn input >|= M.rev) (M.rev_map_p fn input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.{rev map,rev_map}_ep" M.name) + [Fn.arith_es; one; many] + (fun fn const input -> + let input = M.of_list input in + let fn = MapEPOf.fn_es const fn in + eq_es (M.map_ep fn input >|=? M.rev) (M.rev_map_ep fn input)) +end + +module TestIterAgainstStdlibList (M : sig + include BASE with type 'a elt := int + + include Traits.ITER_SEQUENTIAL with type 'a elt := int and type 'a t := int t +end) = +struct + let with_stdlib_iter fn init input = + let acc = ref init in + Stdlib.List.iter (IterOf.fn acc fn) input ; + !acc + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iter, Stdlib.List.iter" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq + (let acc = ref init in + M.iter (IterOf.fn acc fn) (M.of_list input) ; + !acc) + (with_stdlib_iter fn init input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iter_e, Stdlib.List.iter" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq_e + (let acc = ref init in + M.iter_e (IterEOf.fn acc fn) (M.of_list input) >|? fun () -> !acc) + (Ok (with_stdlib_iter fn init input))) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iter_s, Stdlib.List.iter" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq_s + (let acc = ref init in + M.iter_s (IterSOf.fn acc fn) (M.of_list input) >|= fun () -> !acc) + (Lwt.return @@ with_stdlib_iter fn init input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iter_es, Stdlib.List.iter" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq_es + (let acc = ref init in + M.iter_es (IterESOf.fn acc fn) (M.of_list input) >|=? fun () -> !acc) + (Lwt.return_ok @@ with_stdlib_iter fn init input)) +end + +module TestIterMonotoneAgainstStdlibList (M : sig + include BASE with type 'a elt := int + + include Traits.ITER_PARALLEL with type 'a elt := int and type 'a t := int t +end) = +struct + (* For collections without a specified ordering, or for out-of-order traversal + we can only test iteration if the accumulator moves monotonically and the + stepper doesn't depend on the accumulator. We do this here with a custom + stepper. *) + + let with_stdlib_iter init fn const input = + let acc = ref init in + Stdlib.List.iter (fun elt -> acc := !acc + MapOf.fn const fn elt) input ; + !acc + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iter, Stdlib.List.iter" M.name) + [one; Fn.arith; one; many] + (fun init fn const input -> + eq + (let acc = ref init in + M.iter + (fun elt -> + MapOf.fn const fn elt |> fun delta -> acc := !acc + delta) + (M.of_list input) + |> fun () -> !acc) + (with_stdlib_iter init fn const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iter_s, Stdlib.List.iter" M.name) + [one; Fn.arith; one; many] + (fun init fn const input -> + eq_s + (let acc = ref init in + M.iter_s + (fun elt -> + MapSOf.fn const fn elt >|= fun delta -> acc := !acc + delta) + (M.of_list input) + >|= fun () -> !acc) + (Lwt.return @@ with_stdlib_iter init fn const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iter_es, Stdlib.List.iter" M.name) + [one; Fn.arith; one; many] + (fun init fn const input -> + eq_es + (let acc = ref init in + M.iter_es + (fun elt -> + MapESOf.fn const fn elt >|=? fun delta -> acc := !acc + delta) + (M.of_list input) + >|=? fun () -> !acc) + (Lwt.return_ok @@ with_stdlib_iter init fn const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iter_p, Stdlib.List.iter" M.name) + [one; Fn.arith; one; many] + (fun init fn const input -> + eq_s + (let acc = ref init in + M.iter_p + (fun elt -> + MapSOf.fn const fn elt >|= fun delta -> acc := !acc + delta) + (M.of_list input) + >|= fun () -> !acc) + (Lwt.return @@ with_stdlib_iter init fn const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iter_ep, Stdlib.List.iter" M.name) + [one; Fn.arith; one; many] + (fun init fn const input -> + eq_es + (let acc = ref init in + M.iter_ep + (fun elt -> + MapESOf.fn const fn elt >|=? fun delta -> acc := !acc + delta) + (M.of_list input) + >|=? fun () -> !acc) + (Lwt.return_ok @@ with_stdlib_iter init fn const input)) +end + +module TestMapAgainstStdlibList (M : sig + include BASE + + include Traits.MAP_SEQUENTIAL with type 'a t := 'a t +end) = +struct + let with_stdlib_map fn const input = + Stdlib.List.map (MapOf.fn const fn) input + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.map, Stdlib.List.map" M.name) + [Fn.arith; one; many] + (fun fn const input -> + eq + (M.to_list @@ M.map (MapOf.fn const fn) (M.of_list input)) + (with_stdlib_map fn const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.map_e, Stdlib.List.map" M.name) + [Fn.arith; one; many] + (fun fn const input -> + eq_e + (M.map_e (MapEOf.fn const fn) (M.of_list input) >|? M.to_list) + (Ok (with_stdlib_map fn const input))) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.map_s, Stdlib.List.map" M.name) + [Fn.arith; one; many] + (fun fn const input -> + eq_s + (M.map_s (MapSOf.fn const fn) (M.of_list input) >|= M.to_list) + (Lwt.return @@ with_stdlib_map fn const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.map_es, Stdlib.List.map" M.name) + [Fn.arith; one; many] + (fun fn const input -> + eq_es + (M.map_es (MapESOf.fn const fn) (M.of_list input) >|=? M.to_list) + (Lwt.return_ok @@ with_stdlib_map fn const input)) +end + +module TestMappAgainstStdlibList (M : sig + include BASE + + include Traits.MAP_PARALLEL with type 'a t := 'a t +end) = +struct + let with_stdlib_map fn const input = + Stdlib.List.map (MapOf.fn const fn) input + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.map_p, Stdlib.List.map" M.name) + [Fn.arith; one; many] + (fun fn const input -> + eq_s + (M.map_p (MapSOf.fn const fn) (M.of_list input) >|= M.to_list) + (Lwt.return @@ with_stdlib_map fn const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.map_ep, Stdlib.List.map" M.name) + [Fn.arith; one; many] + (fun fn const input -> + eq_es + (M.map_ep (MapESOf.fn const fn) (M.of_list input) >|=? M.to_list) + (Lwt.return_ok @@ with_stdlib_map fn const input)) +end + +module TestFoldAgainstStdlibList (M : sig + include BASE with type 'a elt := int + + include FOLDLEFT_SEQUENTIAL with type 'a elt := int and type 'a t := int t +end) = +struct + let with_stdlib_fold_left fn init input = + Stdlib.List.fold_left (FoldOf.fn fn) init input + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_left, Stdlib.List.fold_left" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq + (M.fold_left (FoldOf.fn fn) init (M.of_list input)) + (with_stdlib_fold_left fn init input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_left_e, Stdlib.List.fold_left" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq_e + (M.fold_left_e (FoldEOf.fn fn) init (M.of_list input)) + (Ok (with_stdlib_fold_left fn init input))) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_left_s, Stdlib.List.fold_left" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq_s + (M.fold_left_s (FoldSOf.fn fn) init (M.of_list input)) + (Lwt.return @@ with_stdlib_fold_left fn init input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_left_es, Stdlib.List.fold_left" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq_es + (M.fold_left_es (FoldESOf.fn fn) init (M.of_list input)) + (Lwt.return_ok @@ with_stdlib_fold_left fn init input)) +end + +module TestFoldMonotonicAgainstStdlibList (M : sig + include BASE with type 'a elt := int + + include FOLDOOO_SEQUENTIAL with type 'a elt := int and type 'a t := int t +end) = +struct + let with_stdlib_fold_left const fn init input = + Stdlib.List.fold_left (fun acc x -> acc + FoldOf.fn fn const x) init input + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold, Stdlib.List.fold_left" M.name) + [one; Fn.arith; one; many] + (fun const fn init input -> + eq + (M.fold + (fun x acc -> FoldOf.fn fn const x |> fun delta -> acc + delta) + (M.of_list input) + init) + (with_stdlib_fold_left const fn init input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_e, Stdlib.List.fold_left" M.name) + [one; Fn.arith; one; many] + (fun const fn init input -> + eq_e + (M.fold_e + (fun x acc -> FoldEOf.fn fn const x >|? fun delta -> acc + delta) + (M.of_list input) + init) + (Ok (with_stdlib_fold_left const fn init input))) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_s, Stdlib.List.fold_left" M.name) + [one; Fn.arith; one; many] + (fun const fn init input -> + eq_s + (M.fold_s + (fun x acc -> FoldSOf.fn fn const x >|= fun delta -> acc + delta) + (M.of_list input) + init) + (Lwt.return @@ with_stdlib_fold_left const fn init input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_es, Stdlib.List.fold_left" M.name) + [one; Fn.arith; one; many] + (fun const fn init input -> + eq_es + (M.fold_es + (fun x acc -> + FoldESOf.fn fn const x >|=? fun delta -> acc + delta) + (M.of_list input) + init) + (Lwt.return_ok @@ with_stdlib_fold_left const fn init input)) +end + +module TestFoldRightAgainstStdlibList (M : sig + include BASE + + include Traits.FOLDRIGHT_SEQUENTIAL with type 'a t := 'a t +end) = +struct + let with_stdlib_fold_right fn init input = + Stdlib.List.fold_right (FoldOf.fn fn) input init + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_right, Stdlib.List.fold_right" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq + (M.fold_right (FoldOf.fn fn) (M.of_list input) init) + (with_stdlib_fold_right fn init input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_right_e, Stdlib.List.fold_right" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq_e + (M.fold_right_e (FoldEOf.fn fn) (M.of_list input) init) + (Ok (with_stdlib_fold_right fn init input))) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_right_s, Stdlib.List.fold_right" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq_s + (M.fold_right_s (FoldSOf.fn fn) (M.of_list input) init) + (Lwt.return @@ with_stdlib_fold_right fn init input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_right_es, Stdlib.List.fold_right" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq_es + (M.fold_right_es (FoldESOf.fn fn) (M.of_list input) init) + (Lwt.return_ok @@ with_stdlib_fold_right fn init input)) +end + +module TestExistForallAgainstStdlibList (M : sig + include BASE with type 'a elt := int + + include + Traits.EXISTFORALL_PARALLEL with type 'a elt := int and type 'a t := int t +end) = +struct + let with_stdlib_exists fn const input = + Stdlib.List.exists (CondOf.fn fn const) input + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.exists, Stdlib.List.exists" M.name) + [Fn.pred; one; many] + (fun fn const input -> + eq + (M.exists (CondOf.fn fn const) (M.of_list input)) + (with_stdlib_exists fn const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.exists_e, Stdlib.List.exists" M.name) + [Fn.pred; one; many] + (fun fn const input -> + eq_e + (M.exists_e (CondEOf.fn fn const) (M.of_list input)) + (Ok (with_stdlib_exists fn const input))) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.exists_s, Stdlib.List.exists" M.name) + [Fn.pred; one; many] + (fun fn const input -> + eq_s + (M.exists_s (CondSOf.fn fn const) (M.of_list input)) + (Lwt.return @@ with_stdlib_exists fn const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.exists_es, Stdlib.List.exists" M.name) + [Fn.pred; one; many] + (fun fn const input -> + eq_es + (M.exists_es (CondESOf.fn fn const) (M.of_list input)) + (Lwt.return_ok @@ with_stdlib_exists fn const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.exists_s, Stdlib.List.exists" M.name) + [Fn.pred; one; many] + (fun fn const input -> + eq_s + (M.exists_p (CondSOf.fn fn const) (M.of_list input)) + (Lwt.return @@ with_stdlib_exists fn const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.exists_es, Stdlib.List.exists" M.name) + [Fn.pred; one; many] + (fun fn const input -> + eq_es + (M.exists_ep (CondESOf.fn fn const) (M.of_list input)) + (Lwt.return_ok @@ with_stdlib_exists fn const input)) + + let with_stdlib_for_all fn const input = + Stdlib.List.for_all (CondOf.fn fn const) input + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.for_all, Stdlib.List.for_all" M.name) + [Fn.pred; one; many] + (fun fn const input -> + eq + (M.for_all (CondOf.fn fn const) (M.of_list input)) + (with_stdlib_for_all fn const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.for_all_e, Stdlib.List.for_all" M.name) + [Fn.pred; one; many] + (fun fn const input -> + eq_e + (M.for_all_e (CondEOf.fn fn const) (M.of_list input)) + (Ok (with_stdlib_for_all fn const input))) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.for_all_s, Stdlib.List.for_all" M.name) + [Fn.pred; one; many] + (fun fn const input -> + eq_s + (M.for_all_s (CondSOf.fn fn const) (M.of_list input)) + (Lwt.return @@ with_stdlib_for_all fn const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.for_all_es, Stdlib.List.for_all" M.name) + [Fn.pred; one; many] + (fun fn const input -> + eq_es + (M.for_all_es (CondESOf.fn fn const) (M.of_list input)) + (Lwt.return_ok @@ with_stdlib_for_all fn const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.for_all_s, Stdlib.List.for_all" M.name) + [Fn.pred; one; many] + (fun fn const input -> + eq_s + (M.for_all_p (CondSOf.fn fn const) (M.of_list input)) + (Lwt.return @@ with_stdlib_for_all fn const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.for_all_es, Stdlib.List.for_all" M.name) + [Fn.pred; one; many] + (fun fn const input -> + eq_es + (M.for_all_ep (CondESOf.fn fn const) (M.of_list input)) + (Lwt.return_ok @@ with_stdlib_for_all fn const input)) +end + +module TestFilterAgainstStdlibList (M : sig + include BASE + + include Traits.FILTER_SEQUENTIAL with type 'a t := 'a t +end) = +struct + let with_stdlib_filter fn const input = + Stdlib.List.filter (CondOf.fn fn const) input + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.filter, Stdlib.List.filter" M.name) + [Fn.pred; one; many] + (fun fn const input -> + eq + (M.filter (CondOf.fn fn const) (M.of_list input) |> M.to_list) + (with_stdlib_filter fn const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.filter_e, Stdlib.List.filter" M.name) + [Fn.pred; one; many] + (fun fn const input -> + eq_e + (M.filter_e (CondEOf.fn fn const) (M.of_list input) >|? M.to_list) + (Ok (with_stdlib_filter fn const input))) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.filter_s, Stdlib.List.filter" M.name) + [Fn.pred; one; many] + (fun fn const input -> + eq_s + (M.filter_s (CondSOf.fn fn const) (M.of_list input) >|= M.to_list) + (Lwt.return @@ with_stdlib_filter fn const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.filter_es, Stdlib.List.filter" M.name) + [Fn.pred; one; many] + (fun fn const input -> + eq_es + (M.filter_es (CondESOf.fn fn const) (M.of_list input) >|=? M.to_list) + (Lwt.return_ok @@ with_stdlib_filter fn const input)) +end + +module TestFilterpAgainstStdlibList (M : sig + include BASE + + include Traits.FILTER_PARALLEL with type 'a t := 'a t +end) = +struct + let with_stdlib_filter fn const input = + Stdlib.List.filter (CondOf.fn fn const) input + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.filter_p, Stdlib.List.filter" M.name) + [Fn.pred; one; many] + (fun fn const input -> + eq_s + (M.filter_p (CondSOf.fn fn const) (M.of_list input) >|= M.to_list) + (Lwt.return @@ with_stdlib_filter fn const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.filter_ep, Stdlib.List.filter" M.name) + [Fn.pred; one; many] + (fun fn const input -> + eq_es + (M.filter_ep (CondESOf.fn fn const) (M.of_list input) >|=? M.to_list) + (Lwt.return_ok @@ with_stdlib_filter fn const input)) +end + +module TestFiltermapAgainstStdlibList (M : sig + include BASE + + include Traits.FILTERMAP_SEQUENTIAL with type 'a t := 'a t +end) = +struct + let with_stdlib_filter_map pred arith const input = + Stdlib.List.filter_map (FilterMapOf.fns pred arith const) input + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.filter_map, Stdlib.List.filter_map" M.name) + [Fn.pred; Fn.arith; one; many] + (fun pred arith const input -> + eq + ( M.filter_map (FilterMapOf.fns pred arith const) (M.of_list input) + |> M.to_list ) + (with_stdlib_filter_map pred arith const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.filter_map_e, Stdlib.List.filter_map" M.name) + [Fn.pred; Fn.arith; one; many] + (fun pred arith const input -> + eq_e + ( M.filter_map_e (FilterMapEOf.fns pred arith const) (M.of_list input) + >|? M.to_list ) + (Ok (with_stdlib_filter_map pred arith const input))) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.filter_map_s, Stdlib.List.filter_map" M.name) + [Fn.pred; Fn.arith; one; many] + (fun pred arith const input -> + eq_s + ( M.filter_map_s (FilterMapSOf.fns pred arith const) (M.of_list input) + >|= M.to_list ) + (Lwt.return @@ with_stdlib_filter_map pred arith const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.filter_map_es, Stdlib.List.filter_map" M.name) + [Fn.pred; Fn.arith; one; many] + (fun pred arith const input -> + eq_es + ( M.filter_map_es + (FilterMapESOf.fns pred arith const) + (M.of_list input) + >|=? M.to_list ) + (Lwt.return_ok @@ with_stdlib_filter_map pred arith const input)) +end + +module TestFiltermappAgainstStdlibList (M : sig + include BASE + + include Traits.FILTERMAP_PARALLEL with type 'a t := 'a t +end) = +struct + let with_stdlib_filter_map pred arith const input = + Stdlib.List.filter_map (FilterMapOf.fns pred arith const) input + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.filter_map_p, Stdlib.List.filter_map" M.name) + [Fn.pred; Fn.arith; one; many] + (fun pred arith const input -> + eq_s + ( M.filter_map_p (FilterMapSOf.fns pred arith const) (M.of_list input) + >|= M.to_list ) + (Lwt.return @@ with_stdlib_filter_map pred arith const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.filter_map_ep, Stdlib.List.filter_map" M.name) + [Fn.pred; Fn.arith; one; many] + (fun pred arith const input -> + eq_es + ( M.filter_map_ep + (FilterMapESOf.fns pred arith const) + (M.of_list input) + >|=? M.to_list ) + (Lwt.return_ok @@ with_stdlib_filter_map pred arith const input)) +end + +module TestFindStdlibList (M : sig + include BASE + + include Traits.FIND_SEQUENTIAL with type 'a t := 'a t +end) = +struct + let with_stdlib_find pred const input = + Stdlib.List.find_opt (CondOf.fn pred const) input + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.find, Stdlib.List.find_opt" M.name) + [Fn.pred; one; many] + (fun pred const input -> + eq + (M.find (CondOf.fn pred const) (M.of_list input)) + (with_stdlib_find pred const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.find_e, Stdlib.List.find_opt" M.name) + [Fn.pred; one; many] + (fun pred const input -> + eq + (M.find_e (CondEOf.fn pred const) (M.of_list input)) + (Ok (with_stdlib_find pred const input))) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.find_s, Stdlib.List.find_opt" M.name) + [Fn.pred; one; many] + (fun pred const input -> + eq_s + (M.find_s (CondSOf.fn pred const) (M.of_list input)) + (Lwt.return @@ with_stdlib_find pred const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.find_es, Stdlib.List.find_opt" M.name) + [Fn.pred; one; many] + (fun pred const input -> + eq_s + (M.find_es (CondESOf.fn pred const) (M.of_list input)) + (Lwt.return_ok @@ with_stdlib_find pred const input)) +end + +module TestPartitionStdlibList (M : sig + include BASE + + include Traits.PARTITION_PARALLEL with type 'a t := 'a t +end) = +struct + let with_stdlib_partition pred const input = + Stdlib.List.partition (CondOf.fn pred const) input + + let to_list_pair (a, b) = (M.to_list a, M.to_list b) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.partition, Stdlib.List.partition" M.name) + [Fn.pred; one; many] + (fun pred const input -> + eq + (M.partition (CondOf.fn pred const) (M.of_list input) |> to_list_pair) + (with_stdlib_partition pred const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.partition_e, Stdlib.List.partition" M.name) + [Fn.pred; one; many] + (fun pred const input -> + eq + ( M.partition_e (CondEOf.fn pred const) (M.of_list input) + >|? to_list_pair ) + (Ok (with_stdlib_partition pred const input))) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.partition_s, Stdlib.List.partition" M.name) + [Fn.pred; one; many] + (fun pred const input -> + eq_s + ( M.partition_s (CondSOf.fn pred const) (M.of_list input) + >|= to_list_pair ) + (Lwt.return @@ with_stdlib_partition pred const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.partition_es, Stdlib.List.partition" M.name) + [Fn.pred; one; many] + (fun pred const input -> + eq_s + ( M.partition_es (CondESOf.fn pred const) (M.of_list input) + >|=? to_list_pair ) + (Lwt.return_ok @@ with_stdlib_partition pred const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.partition_p, Stdlib.List.partition" M.name) + [Fn.pred; one; many] + (fun pred const input -> + eq_s + ( M.partition_p (CondSOf.fn pred const) (M.of_list input) + >|= to_list_pair ) + (Lwt.return @@ with_stdlib_partition pred const input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.partition_ep, Stdlib.List.partition" M.name) + [Fn.pred; one; many] + (fun pred const input -> + eq_s + ( M.partition_ep (CondESOf.fn pred const) (M.of_list input) + >|=? to_list_pair ) + (Lwt.return_ok @@ with_stdlib_partition pred const input)) +end + +module TestDoubleTraversorsStdlibList (M : sig + include BASE + + include Traits.COMBINE_VANILLA with type 'a t := 'a t + + include Traits.ITER_PARALLEL with type 'a elt := 'a and type 'a t := 'a t + + include Traits.MAP_PARALLEL with type 'a t := 'a t + + include Traits.REVMAP_PARALLEL with type 'a t := 'a t + + include + Traits.FOLDLEFT_SEQUENTIAL with type 'a elt := 'a and type 'a t := 'a t + + include Traits.FOLDRIGHT_SEQUENTIAL with type 'a t := 'a t + + include + Traits.EXISTFORALL_PARALLEL with type 'a elt := 'a and type 'a t := 'a t + + include Traits.ALLDOUBLE_SEQENTIAL with type 'a t := 'a t +end) = +struct + let uncurry f (x, y) = f x y + + let uncurry_l f acc (x, y) = f acc x y + + let uncurry_r f (x, y) acc = f x y acc + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iter{2,}" M.name) + [Fn.arith; one; manymany] + (fun fn init (left, right) -> + eq_e + (let acc = ref init in + M.iter2 + ~when_different_lengths:101 + (Iter2Of.fn acc fn) + (M.of_list left) + (M.of_list right) + >|? fun () -> !acc) + (let acc = ref init in + let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.iter (uncurry @@ Iter2Of.fn acc fn) leftright ; + match leftovers with None -> Ok !acc | Some _ -> Error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iter{2,}_e" M.name) + [Fn.arith_e; one; manymany] + (fun fn init (left, right) -> + eq_e + (let acc = ref init in + M.iter2_e + ~when_different_lengths:101 + (Iter2EOf.fn_e acc fn) + (M.of_list left) + (M.of_list right) + >|? fun () -> !acc) + (let acc = ref init in + let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.iter_e (uncurry @@ Iter2EOf.fn_e acc fn) leftright + >>? fun () -> + match leftovers with None -> Ok !acc | Some _ -> Error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iter{2,}_s" M.name) + [Fn.arith_s; one; manymany] + (fun fn init (left, right) -> + eq_s + (let acc = ref init in + M.iter2_s + ~when_different_lengths:101 + (Iter2SOf.fn_s acc fn) + (M.of_list left) + (M.of_list right) + >|=? fun () -> !acc) + (let acc = ref init in + let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.iter_s (uncurry @@ Iter2SOf.fn_s acc fn) leftright + >>= fun () -> + match leftovers with + | None -> + Lwt.return_ok !acc + | Some _ -> + Lwt.return_error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iter{2,}_es" M.name) + [Fn.arith_e; one; manymany] + (fun fn init (left, right) -> + eq_es + (let acc = ref init in + M.iter2_es + ~when_different_lengths:101 + (Iter2ESOf.fn_e acc fn) + (M.of_list left) + (M.of_list right) + >|=? fun () -> !acc) + (let acc = ref init in + let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.iter_es (uncurry @@ Iter2ESOf.fn_e acc fn) leftright + >>=? fun () -> + match leftovers with + | None -> + Lwt.return_ok !acc + | Some _ -> + Lwt.return_error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.map{2,}" M.name) + [Fn.arith; manymany] + (fun fn (left, right) -> + eq_e + (M.map2 + ~when_different_lengths:101 + (Map2Of.fn fn) + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + let t = M.map (uncurry @@ Map2Of.fn fn) leftright in + match leftovers with None -> Ok t | Some _ -> Error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.map{2,}_e" M.name) + [Fn.arith_e; manymany] + (fun fn (left, right) -> + eq_e + (M.map2_e + ~when_different_lengths:101 + (Map2EOf.fn_e fn) + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.map_e (uncurry @@ Map2EOf.fn_e fn) leftright + >>? fun t -> + match leftovers with None -> Ok t | Some _ -> Error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.map{2,}_s" M.name) + [Fn.arith; manymany] + (fun fn (left, right) -> + eq_s + (M.map2_s + ~when_different_lengths:101 + (Map2SOf.fn fn) + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.map_s (uncurry @@ Map2SOf.fn fn) leftright + >|= fun t -> + match leftovers with None -> Ok t | Some _ -> Error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.map{2,}_es" M.name) + [Fn.arith_e; manymany] + (fun fn (left, right) -> + eq_es + (M.map2_es + ~when_different_lengths:101 + (Map2ESOf.fn_e fn) + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.map_es (uncurry @@ Map2ESOf.fn_e fn) leftright + >>=? fun t -> + match leftovers with + | None -> + Lwt.return_ok t + | Some _ -> + Lwt.return_error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.rev_map{2,}" M.name) + [Fn.arith; manymany] + (fun fn (left, right) -> + eq_e + (M.rev_map2 + ~when_different_lengths:101 + (Map2Of.fn fn) + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + let t = M.rev_map (uncurry @@ Map2Of.fn fn) leftright in + match leftovers with None -> Ok t | Some _ -> Error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.rev_map{2,}_e" M.name) + [Fn.arith_e; manymany] + (fun fn (left, right) -> + eq_e + (M.rev_map2_e + ~when_different_lengths:101 + (Map2EOf.fn_e fn) + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.rev_map_e (uncurry @@ Map2EOf.fn_e fn) leftright + >>? fun t -> + match leftovers with None -> Ok t | Some _ -> Error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.rev_map{2,}_s" M.name) + [Fn.arith; manymany] + (fun fn (left, right) -> + eq_s + (M.rev_map2_s + ~when_different_lengths:101 + (Map2SOf.fn fn) + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.rev_map_s (uncurry @@ Map2SOf.fn fn) leftright + >|= fun t -> + match leftovers with None -> Ok t | Some _ -> Error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.rev_map{2,}_es" M.name) + [Fn.arith_e; manymany] + (fun fn (left, right) -> + eq_es + (M.rev_map2_es + ~when_different_lengths:101 + (Map2ESOf.fn_e fn) + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.rev_map_es (uncurry @@ Map2ESOf.fn_e fn) leftright + >>=? fun t -> + match leftovers with + | None -> + Lwt.return_ok t + | Some _ -> + Lwt.return_error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_left{2,}" M.name) + [Fn.arith; one; manymany] + (fun fn init (left, right) -> + eq_e + (M.fold_left2 + ~when_different_lengths:101 + (Fold2Of.fn fn) + init + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + let t = M.fold_left (uncurry_l @@ Fold2Of.fn fn) init leftright in + match leftovers with None -> Ok t | Some _ -> Error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_left{2,}_e" M.name) + [Fn.arith_e; one; manymany] + (fun fn init (left, right) -> + eq_e + (M.fold_left2_e + ~when_different_lengths:101 + (Fold2EOf.fn_e fn) + init + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.fold_left_e (uncurry_l @@ Fold2EOf.fn_e fn) init leftright + >>? fun t -> + match leftovers with None -> Ok t | Some _ -> Error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_left{2,}_s" M.name) + [Fn.arith; one; manymany] + (fun fn init (left, right) -> + eq_s + (M.fold_left2_s + ~when_different_lengths:101 + (Fold2SOf.fn fn) + init + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.fold_left_s (uncurry_l @@ Fold2SOf.fn fn) init leftright + >|= fun t -> + match leftovers with None -> Ok t | Some _ -> Error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_left{2,}_es" M.name) + [Fn.arith_e; one; manymany] + (fun fn init (left, right) -> + eq_es + (M.fold_left2_es + ~when_different_lengths:101 + (Fold2ESOf.fn_e fn) + init + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.fold_left_es (uncurry_l @@ Fold2ESOf.fn_e fn) init leftright + >>=? fun t -> + match leftovers with + | None -> + Lwt.return_ok t + | Some _ -> + Lwt.return_error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_right{2,}" M.name) + [Fn.arith; one; manymany] + (fun fn init (left, right) -> + eq_e + (M.fold_right2 + ~when_different_lengths:101 + (Fold2Of.fn fn) + (M.of_list left) + (M.of_list right) + init) + ( M.combine + ~when_different_lengths:101 + (M.of_list left) + (M.of_list right) + >|? fun leftright -> + M.fold_right (uncurry_r @@ Fold2Of.fn fn) leftright init )) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_right{2,}_e" M.name) + [Fn.arith_e; one; manymany] + (fun fn init (left, right) -> + eq_e + (M.fold_right2_e + ~when_different_lengths:101 + (Fold2EOf.fn_e fn) + (M.of_list left) + (M.of_list right) + init) + ( M.combine + ~when_different_lengths:101 + (M.of_list left) + (M.of_list right) + >>? fun leftright -> + M.fold_right_e (uncurry_r @@ Fold2EOf.fn_e fn) leftright init )) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_right{2,}_s" M.name) + [Fn.arith; one; manymany] + (fun fn init (left, right) -> + eq_s + (M.fold_right2_s + ~when_different_lengths:101 + (Fold2SOf.fn fn) + (M.of_list left) + (M.of_list right) + init) + ( match + M.combine + ~when_different_lengths:101 + (M.of_list left) + (M.of_list right) + with + | Ok leftright -> + M.fold_right_s (uncurry_r @@ Fold2SOf.fn fn) leftright init + >>= Lwt.return_ok + | Error _ as err -> + Lwt.return err )) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.fold_right{2,}_es" M.name) + [Fn.arith_es; one; manymany] + (fun fn init (left, right) -> + eq_es + (M.fold_right2_es + ~when_different_lengths:101 + (Fold2ESOf.fn_es fn) + (M.of_list left) + (M.of_list right) + init) + ( Lwt.return + @@ M.combine + ~when_different_lengths:101 + (M.of_list left) + (M.of_list right) + >>=? fun leftright -> + M.fold_right_es (uncurry_r @@ Fold2ESOf.fn_es fn) leftright init )) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.for_all{2,}" M.name) + [Fn.pred; manymany] + (fun pred (left, right) -> + eq_e + ~pp:PP.(res bool int) + (M.for_all2 + ~when_different_lengths:101 + (Cond2Of.fn pred) + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + let t = M.for_all (uncurry @@ Cond2Of.fn pred) leftright in + match (t, leftovers) with + | (false, _) -> + Ok false + | (true, None) -> + Ok true + | (true, Some _) -> + Error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.for_all{2,}_e" M.name) + [Fn.pred; manymany] + (fun pred (left, right) -> + eq_e + ~pp:PP.(res bool int) + (M.for_all2_e + ~when_different_lengths:101 + (Cond2EOf.fn pred) + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.for_all_e (uncurry @@ Cond2EOf.fn pred) leftright + >>? fun t -> + match (t, leftovers) with + | (false, _) -> + Ok false + | (true, None) -> + Ok true + | (true, Some _) -> + Error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.for_all{2,}_s" M.name) + [Fn.pred; manymany] + (fun pred (left, right) -> + eq_s + ~pp:PP.(res bool int) + (M.for_all2_s + ~when_different_lengths:101 + (Cond2SOf.fn pred) + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.for_all_s (uncurry @@ Cond2SOf.fn pred) leftright + >|= fun t -> + match (t, leftovers) with + | (false, _) -> + Ok false + | (true, None) -> + Ok true + | (true, Some _) -> + Error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.for_all{2,}_es" M.name) + [Fn.pred; manymany] + (fun pred (left, right) -> + eq_es + (M.for_all2_es + ~when_different_lengths:101 + (Cond2ESOf.fn pred) + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.for_all_es (uncurry @@ Cond2ESOf.fn pred) leftright + >>=? fun t -> + match (t, leftovers) with + | (false, _) -> + Lwt.return_ok false + | (true, None) -> + Lwt.return_ok true + | (true, Some _) -> + Lwt.return_error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.exists{2,}" M.name) + [Fn.pred; manymany] + (fun pred (left, right) -> + eq_e + ~pp:PP.(res bool int) + (M.exists2 + ~when_different_lengths:101 + (Cond2Of.fn pred) + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + let t = M.exists (uncurry @@ Cond2Of.fn pred) leftright in + match (t, leftovers) with + | (true, _) -> + Ok true + | (false, None) -> + Ok false + | (false, Some _) -> + Error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.exists{2,}_e" M.name) + [Fn.pred; manymany] + (fun pred (left, right) -> + eq_e + ~pp:PP.(res bool int) + (M.exists2_e + ~when_different_lengths:101 + (Cond2EOf.fn pred) + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.exists_e (uncurry @@ Cond2EOf.fn pred) leftright + >>? fun t -> + match (t, leftovers) with + | (true, _) -> + Ok true + | (false, None) -> + Ok false + | (false, Some _) -> + Error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.exists{2,}_s" M.name) + [Fn.pred; manymany] + (fun pred (left, right) -> + eq_s + ~pp:PP.(res bool int) + (M.exists2_s + ~when_different_lengths:101 + (Cond2SOf.fn pred) + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.exists_s (uncurry @@ Cond2SOf.fn pred) leftright + >|= fun t -> + match (t, leftovers) with + | (true, _) -> + Ok true + | (false, None) -> + Ok false + | (false, Some _) -> + Error 101)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.exists{2,}_es" M.name) + [Fn.pred; manymany] + (fun pred (left, right) -> + eq_es + (M.exists2_es + ~when_different_lengths:101 + (Cond2ESOf.fn pred) + (M.of_list left) + (M.of_list right)) + (let (leftright, leftovers) = + M.combine_with_leftovers (M.of_list left) (M.of_list right) + in + M.exists_es (uncurry @@ Cond2ESOf.fn pred) leftright + >>=? fun t -> + match (t, leftovers) with + | (true, _) -> + Lwt.return_ok true + | (false, None) -> + Lwt.return_ok false + | (false, Some _) -> + Lwt.return_error 101)) +end diff --git a/src/lib_lwt_result_stdlib/test/test_generic.ml b/src/lib_lwt_result_stdlib/test/test_generic.ml new file mode 100644 index 0000000000000000000000000000000000000000..49fd33c579ea03045fd9487bc1ae9dc8f853e217 --- /dev/null +++ b/src/lib_lwt_result_stdlib/test/test_generic.ml @@ -0,0 +1,287 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Lwt.Infix + +module type GEN = sig + type 'a t + + val up : int -> int t + + val down : int -> int t +end + +module SeqGen = struct + include Lwtreslib.Seq + + let rec down n : int t = + fun () -> if n < 0 then Nil else Cons (n, down (pred n)) + + let rec up n i : int t = + fun () -> if i > n then Nil else Cons (i, up n (succ i)) + + let up n = up n 0 +end + +module Testing = struct + exception Nope of int + + module Prn = struct + let int = string_of_int + + let res f g = function + | Ok o -> + "ok(" ^ f o ^ ")" + | Error e -> + "error(" ^ g e ^ ")" + + let str = Fun.id + + let unit _ = "()" + + let t _ _ = "T" + end + + module Iter = struct + let e n m = if n = m then Error m else Ok () + + let es n m = Lwt.return @@ if n = m then Error m else Ok () + + let exn n m = if n = m then raise (Nope m) else () + + let exn_s n m = Lwt.return @@ if n = m then raise (Nope m) else () + + let exn_es n m = Lwt.return_ok @@ if n = m then raise (Nope m) else () + + let exn_now _ = raise (Nope 2048) + + let prn = Prn.(res unit int) + + let eq a b = Assert.equal ~prn a b + + let eq_s a b = b >|= fun b -> Assert.equal ~prn a b + + let eq_s_catch a b = + Lwt.catch + (fun () -> b () >>= Lwt.return_ok) + (function Nope d -> Lwt.return_error d | exc -> raise exc) + >|= fun rb -> Assert.equal ~prn:Prn.(res prn int) a rb + end + + module Folder = struct + let e n _acc m = if n = m then Error m else Ok m + + let es n _acc m = Lwt.return @@ if n = m then Error m else Ok m + + let exn n m = if n = m then raise (Nope m) else m + + let exn_s n _acc m = Lwt.return @@ if n = m then raise (Nope m) else m + + let exn_es n _acc m = Lwt.return_ok @@ if n = m then raise (Nope m) else m + + let exn_now _ _ = raise (Nope 2048) + + let prn = Prn.(res int int) + + let eq a b = Assert.equal ~prn a b + + let eq_s a b = b >|= fun b -> Assert.equal ~prn a b + + let eq_s_catch a b = + Lwt.catch + (fun () -> b () >>= Lwt.return_ok) + (function Nope d -> Lwt.return_error d | exc -> raise exc) + >|= fun rb -> Assert.equal ~prn:Prn.(res prn int) a rb + end + + (* NOTE: the functor is necessary to avoid a type escaping its scope latter on *) + module Mapper (G : GEN) = struct + let e n m = if n = m then Error m else Ok (m + 1000) + + let es n m = Lwt.return @@ if n = m then Error m else Ok (m + 1000) + + let exn n m = if n = m then raise (Nope m) else m + 1000 + + let exn_s n m = Lwt.return @@ if n = m then raise (Nope m) else m + 1000 + + let exn_es n m = + Lwt.return_ok @@ if n = m then raise (Nope m) else m + 1000 + + let exn_now _ = raise (Nope 2048) + + let prn : ('a G.t, int) result -> string = Prn.(res (t int) int) + + let eq a b = Assert.equal ~prn a b + + let eq_s a b = b >|= fun b -> Assert.equal ~prn a b + + let eq_s_catch a b = + Lwt.catch + (fun () -> b () >>= Lwt.return_ok) + (function Nope d -> Lwt.return_error d | exc -> raise exc) + >|= fun rb -> Assert.equal ~prn:Prn.(res prn int) a rb + end +end + +module MakeItererTest (M : sig + include GEN + + include Traits.ITER_SEQUENTIAL with type 'a elt := 'a and type 'a t := 'a t +end) = +struct + open M + open Testing.Iter + + let test_fail_early _ _ = + (* error with error *) + eq (Error 3) @@ iter_e (e 3) (up 100) ; + (* lwt with exception *) + (eq_s_catch (Error 4) @@ fun () -> iter_es (exn_es 4) (up 100)) + >>= fun () -> + (* lwt with immediate exception *) + (eq_s_catch (Error 2048) @@ fun () -> iter_es exn_now (up 100)) + >>= fun () -> + (* error-lwt with exception *) + (eq_s_catch (Error 5) @@ fun () -> iter_es (exn_es 5) (up 100)) + >>= fun () -> + (* error-lwt with immediate exception *) + (eq_s_catch (Error 2048) @@ fun () -> iter_es exn_now (up 100)) + >>= fun () -> + (* error-lwt with error *) + eq_s (Error 6) @@ iter_es (es 6) (up 100) >>= fun () -> Lwt.return_unit + + let test_has_side_effects _ _ = + let witness = ref 0 in + (* vanilla, uninterrupted iter *) + iter (fun _ -> incr witness) (up 10) ; + Assert.equal ~msg:"vanilla iter" ~prn:Testing.Prn.int 11 !witness ; + (* error interrupted iter *) + let ie = iter_e (fun m -> incr witness ; e 10 m) (up 23) in + ( match ie with + | Error n -> + Assert.equal + ~msg:"unexpected error in result iter" + ~prn:Testing.Prn.int + 10 + n ; + Assert.equal ~msg:"result iter" ~prn:Testing.Prn.int 22 !witness + | Ok () -> + Assert.equal ~msg:"unexpected success in result iter" true false ) ; + (* lwt-error interrupted iter *) + iter_es (fun m -> incr witness ; es 10 m) (up 29) + >|= function + | Error n -> + Assert.equal + ~msg:"unexpected error in lwt-result iter" + ~prn:Testing.Prn.int + 10 + n ; + Assert.equal ~msg:"lwt-result iter" ~prn:Testing.Prn.int 33 !witness + | Ok () -> + Assert.equal ~msg:"unexpected success in lwt-result iter" true false + + let tests = + [ Alcotest_lwt.test_case "fail-early" `Quick test_fail_early; + Alcotest_lwt.test_case "has-side-effects" `Quick test_has_side_effects ] +end + +module SeqIterTest = MakeItererTest (SeqGen) + +module MakeFolderTest (M : sig + include GEN + + include + Traits.FOLDLEFT_SEQUENTIAL with type 'a elt := 'a and type 'a t := 'a t +end) = +struct + open M + open Testing.Folder + + (* test that all sequential operators fail-early *) + let test_fail_early _ _ = + (* error with error *) + eq (Error 3) @@ fold_left_e (e 3) (-10) (up 100) ; + (* lwt with exception *) + (eq_s_catch (Error 4) @@ fun () -> fold_left_es (exn_es 4) (-10) (up 100)) + >>= fun () -> + (* lwt with immediate exception *) + (eq_s_catch (Error 2048) @@ fun () -> fold_left_es exn_now (-10) (up 100)) + >>= fun () -> + (* error-lwt with exception *) + (eq_s_catch (Error 5) @@ fun () -> fold_left_es (exn_es 5) (-10) (up 100)) + >>= fun () -> + (* error-lwt with immediate exception *) + (eq_s_catch (Error 2048) @@ fun () -> fold_left_es exn_now (-10) (up 100)) + >>= fun () -> + (* error-lwt with error *) + eq_s (Error 6) @@ fold_left_es (es 6) (-10) (up 100) + >>= fun () -> Lwt.return_unit + + let tests = [Alcotest_lwt.test_case "fail-early" `Quick test_fail_early] +end + +module SeqFoldTest = MakeFolderTest (SeqGen) + +module MakeMapperTest (M : sig + include GEN + + include Traits.MAP_SEQUENTIAL with type 'a t := 'a t +end) = +struct + open M + + open Testing.Mapper (M) + + (* test that all sequential operators fail-early *) + let test_fail_early _ _ = + (* error with error *) + eq (Error 3) @@ map_e (e 3) (up 100) ; + (* lwt with exception *) + (eq_s_catch (Error 4) @@ fun () -> map_es (exn_es 4) (up 100)) + >>= fun () -> + (* lwt with immediate exception *) + (eq_s_catch (Error 2048) @@ fun () -> map_es exn_now (up 100)) + >>= fun () -> + (* error-lwt with exception *) + (eq_s_catch (Error 5) @@ fun () -> map_es (exn_es 5) (up 100)) + >>= fun () -> + (* error-lwt with immediate exception *) + (eq_s_catch (Error 2048) @@ fun () -> map_es exn_now (up 100)) + >>= fun () -> + (* error-lwt with error *) + eq_s (Error 6) @@ map_es (es 6) (up 100) >>= fun () -> Lwt.return_unit + + let tests = [Alcotest_lwt.test_case "fail-early" `Quick test_fail_early] +end + +module SeqMapTest = MakeMapperTest (SeqGen) + +let () = + Alcotest_lwt.run + "traversor-generic" + [ ("seq-iter", SeqIterTest.tests); + ("seq-fold", SeqFoldTest.tests); + ("seq-map", SeqMapTest.tests) ] + |> Lwt_main.run diff --git a/src/lib_lwt_result_stdlib/test/traits.ml b/src/lib_lwt_result_stdlib/test/traits.ml new file mode 100644 index 0000000000000000000000000000000000000000..09e3700f42470bd86468dde2fdbafa38260e7277 --- /dev/null +++ b/src/lib_lwt_result_stdlib/test/traits.ml @@ -0,0 +1,586 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Lwtreslib.Seq.Monad + +module type BASE = 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 +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 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_shell/p2p_reader.ml b/src/lib_shell/p2p_reader.ml index c429bf51c87ba2b499ea039d4769a162887bc900..5d6e852415364354f18365a60dd505d22cf8f5c6 100644 --- a/src/lib_shell/p2p_reader.ml +++ b/src/lib_shell/p2p_reader.ml @@ -85,19 +85,19 @@ 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_first (fun chain_db -> + |> Seq.find (fun chain_db -> Distributed_db_requester.Raw_operations.pending chain_db.operations_db (h, i)) let find_pending_operation {peer_active_chains; _} h = Chain_id.Table.to_seq_values peer_active_chains - |> Seq.find_first (fun chain_db -> + |> Seq.find (fun chain_db -> 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_first_map : ('a -> 'b option) -> 'a Seq.t -> 'b option] + 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 -> @@ -124,7 +124,7 @@ let read_block_header {disk; _} h = let find_pending_block_header {peer_active_chains; _} h = Chain_id.Table.to_seq_values peer_active_chains - |> Seq.find_first (fun chain_db -> + |> Seq.find (fun chain_db -> Distributed_db_requester.Raw_block_header.pending chain_db.block_header_db h)