From 988edfe955986196596c97b5c2245db3e682f84e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 20 Nov 2020 10:15:53 +0100 Subject: [PATCH 1/5] Lib_base: be over-specific about List's provenance from Stdlib Specifically, mark `List` as `Stdlib.List`. This is to avoid upcoming shadowing from `Lwtreslib`. --- src/lib_base/tzPervasives.ml | 2 +- src/lib_base/tzPervasives.mli | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/lib_base/tzPervasives.ml b/src/lib_base/tzPervasives.ml index 55c2ba6a919f..321aa3d7091e 100644 --- a/src/lib_base/tzPervasives.ml +++ b/src/lib_base/tzPervasives.ml @@ -41,7 +41,7 @@ module Option = struct end module List = struct - include List + include Stdlib.List include Tezos_stdlib.TzList end diff --git a/src/lib_base/tzPervasives.mli b/src/lib_base/tzPervasives.mli index 76629784611a..cb08f6ce2048 100644 --- a/src/lib_base/tzPervasives.mli +++ b/src/lib_base/tzPervasives.mli @@ -50,7 +50,7 @@ module Option : sig end module List : sig - include module type of List + include module type of Stdlib.List include module type of Tezos_stdlib.TzList end -- GitLab From 305e8318bbeae31610d9673289d558bc910443c1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 17 Jun 2020 16:08:56 +0100 Subject: [PATCH 2/5] Lwtreslib: List --- src/lib_lwt_result_stdlib/functors/list.ml | 1176 +++++++++++++++++++ src/lib_lwt_result_stdlib/functors/list.mli | 27 + src/lib_lwt_result_stdlib/lib/list.ml | 26 + src/lib_lwt_result_stdlib/lib/list.mli | 26 + src/lib_lwt_result_stdlib/lwtreslib.ml | 1 + src/lib_lwt_result_stdlib/lwtreslib.mli | 2 + src/lib_lwt_result_stdlib/sigs/list.ml | 787 +++++++++++++ 7 files changed, 2045 insertions(+) create mode 100644 src/lib_lwt_result_stdlib/functors/list.ml create mode 100644 src/lib_lwt_result_stdlib/functors/list.mli create mode 100644 src/lib_lwt_result_stdlib/lib/list.ml create mode 100644 src/lib_lwt_result_stdlib/lib/list.mli create mode 100644 src/lib_lwt_result_stdlib/sigs/list.ml diff --git a/src/lib_lwt_result_stdlib/functors/list.ml b/src/lib_lwt_result_stdlib/functors/list.ml new file mode 100644 index 000000000000..d015e5a1e8ec --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/list.ml @@ -0,0 +1,1176 @@ +(*****************************************************************************) +(* *) +(* 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 : Sigs.Monad.S) : + Sigs.List.S with type 'error trace := 'error Monad.trace = struct + open Lwt.Infix + open Monad + module Legacy = Stdlib.List + include Legacy + + let nil = [] + + let nil_e = Ok [] + + let nil_s = Lwt.return_nil + + let nil_es = Lwt.return nil_e + + let hd = function x :: _ -> Some x | [] -> None + + let tl = function _ :: xs -> Some xs | [] -> None + + let nth xs n = + if n < 0 then None + else + let rec aux xs n = + match (xs, n) with + | ([], _) -> + None + | (x :: _, 0) -> + Some x + | (_ :: xs, n) -> + (aux [@ocaml.tailcall]) xs (n - 1) + in + aux xs n + + let rec last hd = function + | [] -> + hd + | [last] -> + last + | hd :: (_ :: _ as tl) -> + (last [@ocaml.tailcall]) hd tl + + let last_opt = function [] -> None | hd :: tl -> Some (last hd tl) + + let find = find_opt + + let rec iter2 ~when_different_lengths f xs ys = + (* NOTE: We could do the following but we would need to assume [f] does not + raise [Invalid_argument] + [try + Ok (iter2 f xs ys) + with Invalid_argument _ -> + Error when_different_lengths] + The same remark applies to the other 2-list iterators. + *) + match (xs, ys) with + | ([], []) -> + ok_unit + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | (x :: xs, y :: ys) -> + f x y ; + (iter2 [@ocaml.tailcall]) ~when_different_lengths f xs ys + + let rev_map2 ~when_different_lengths f xs ys = + let rec aux zs xs ys = + match (xs, ys) with + | ([], []) -> + Ok zs + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | (x :: xs, y :: ys) -> + let z = f x y in + (aux [@ocaml.tailcall]) (z :: zs) xs ys + in + aux [] xs ys + + let map2 ~when_different_lengths f xs ys = + rev_map2 ~when_different_lengths f xs ys >|? rev + + let fold_left2 ~when_different_lengths f a xs ys = + let rec aux acc xs ys = + match (xs, ys) with + | ([], []) -> + Ok acc + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | (x :: xs, y :: ys) -> + let acc = f acc x y in + (aux [@ocaml.tailcall]) acc xs ys + in + aux a xs ys + + let fold_right2 ~when_different_lengths f xs ys a = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Ok a + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | (x :: xs, y :: ys) -> + aux xs ys >|? fun acc -> f x y acc + in + aux xs ys + + let for_all2 ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Ok true + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | (x :: xs, y :: ys) -> ( + match f x y with + | true -> + (aux [@ocaml.tailcall]) xs ys + | false -> + Ok false ) + in + aux xs ys + + let exists2 ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Ok false + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | (x :: xs, y :: ys) -> ( + match f x y with + | true -> + Ok true + | false -> + (aux [@ocaml.tailcall]) xs ys ) + in + aux xs ys + + let assoc = assoc_opt + + let assq = assq_opt + + let init ~when_negative_length l f = + if l < 0 then Error when_negative_length + else if l = 0 then nil_e + else Ok (Legacy.init l f) + + let init_e ~when_negative_length l f = + let rec aux acc i = + if i >= l then Ok (rev acc) + else f i >>? fun v -> (aux [@ocaml.tailcall]) (v :: acc) (i + 1) + in + if l < 0 then Error when_negative_length + else if l = 0 then nil_e + else aux [] 0 + + let init_s ~when_negative_length l f = + let rec aux acc i = + if i >= l then Lwt.return (Ok (rev acc)) + else f i >>= fun v -> (aux [@ocaml.tailcall]) (v :: acc) (i + 1) + in + if l < 0 then Lwt.return (Error when_negative_length) + else if l = 0 then nil_es + else Lwt.apply f 0 >>= fun v -> aux [v] 1 + + let init_es ~when_negative_length l f = + let rec aux acc i = + if i >= l then Lwt.return (Ok (rev acc)) + else f i >>=? fun v -> (aux [@ocaml.tailcall]) (v :: acc) (i + 1) + in + if l < 0 then Lwt.return (Error when_negative_length) + else if l = 0 then nil_es + else Lwt.apply f 0 >>=? fun v -> aux [v] 1 + + let init_p ~when_negative_length l f = + let rec aux acc i = + if i >= l then all_p (rev acc) >>= fun xs -> Lwt.return (Ok xs) + else (aux [@ocaml.tailcall]) (Lwt.apply f i :: acc) (i + 1) + in + if l < 0 then Lwt.return (Error when_negative_length) + else if l = 0 then nil_es + else aux [] 0 + + let init_ep ~when_negative_length l f = + let rec aux acc i = + if i >= l then all_ep (rev acc) + else (aux [@ocaml.tailcall]) (Lwt.apply f i :: acc) (i + 1) + in + if l < 0 then Lwt.return (Error (Monad.make when_negative_length)) + else if l = 0 then nil_es + else aux [] 0 + + let rec find_e f = function + | [] -> + ok_none + | x :: xs -> ( + f x + >>? function + | true -> Ok (Some x) | false -> (find_e [@ocaml.tailcall]) f xs ) + + let rec find_s f = function + | [] -> + Lwt.return_none + | x :: xs -> ( + f x + >>= function + | true -> + Lwt.return (Some x) + | false -> + (find_s [@ocaml.tailcall]) f xs ) + + let find_s f = function + | [] -> + Lwt.return_none + | x :: xs -> ( + Lwt.apply f x + >>= function + | true -> + Lwt.return (Some x) + | false -> + (find_s [@ocaml.tailcall]) f xs ) + + let rec find_es f = function + | [] -> + return_none + | x :: xs -> ( + f x + >>=? function + | true -> + Lwt.return (Ok (Some x)) + | false -> + (find_es [@ocaml.tailcall]) f xs ) + + let find_es f = function + | [] -> + return_none + | x :: xs -> ( + Lwt.apply f x + >>=? function + | true -> + Lwt.return (Ok (Some x)) + | false -> + (find_es [@ocaml.tailcall]) f xs ) + + let rev_filter f xs = + fold_left (fun rev_xs x -> if f x then x :: rev_xs else rev_xs) [] xs + + let rev_filter_e f xs = + let rec aux acc = function + | [] -> + Ok acc + | x :: xs -> ( + f x + >>? function + | true -> + (aux [@ocaml.tailcall]) (x :: acc) xs + | false -> + (aux [@ocaml.tailcall]) acc xs ) + in + aux [] xs + + let rev_filter_some oxs = + let rec aux xs = function + | [] -> + xs + | Some x :: oxs -> + (aux [@ocaml.tailcall]) (x :: xs) oxs + | None :: oxs -> + (aux [@ocaml.tailcall]) xs oxs + in + aux [] oxs + + let filter_some oxs = rev_filter_some oxs |> rev + + let rev_filter_ok rxs = + let rec aux xs = function + | [] -> + xs + | Ok x :: rxs -> + (aux [@ocaml.tailcall]) (x :: xs) rxs + | Error _ :: rxs -> + (aux [@ocaml.tailcall]) xs rxs + in + aux [] rxs + + let filter_ok rxs = rev_filter_ok rxs |> rev + + let rev_filter_error rxs = + let rec aux xs = function + | [] -> + xs + | Error x :: rxs -> + (aux [@ocaml.tailcall]) (x :: xs) rxs + | Ok _ :: rxs -> + (aux [@ocaml.tailcall]) xs rxs + in + aux [] rxs + + let filter_error rxs = rev_filter_error rxs |> rev + + let filter_e f xs = rev_filter_e f xs >|? rev + + let rev_filter_s f xs = + let rec aux acc = function + | [] -> + Lwt.return acc + | x :: xs -> ( + f x + >>= function + | true -> + (aux [@ocaml.tailcall]) (x :: acc) xs + | false -> + (aux [@ocaml.tailcall]) acc xs ) + in + match xs with + | [] -> + Lwt.return [] + | x :: xs -> ( + Lwt.apply f x + >>= function + | true -> + (aux [@ocaml.tailcall]) [x] xs + | false -> + (aux [@ocaml.tailcall]) [] xs ) + + let filter_s f xs = rev_filter_s f xs >|= rev + + let rev_filter_es f xs = + let rec aux acc = function + | [] -> + Lwt.return (Ok acc) + | x :: xs -> ( + f x + >>=? function + | true -> + (aux [@ocaml.tailcall]) (x :: acc) xs + | false -> + (aux [@ocaml.tailcall]) acc xs ) + in + match xs with + | [] -> + Lwt.return (Ok []) + | x :: xs -> ( + Lwt.apply f x >>=? function true -> aux [x] xs | false -> aux [] xs ) + + let filter_es f xs = rev_filter_es f xs >|=? rev + + let rec iter_e f = function + | [] -> + ok_unit + | h :: t -> + f h >>? fun () -> (iter_e [@ocaml.tailcall]) f t + + let rec iter_s f = function + | [] -> + Lwt.return_unit + | h :: t -> + f h >>= fun () -> (iter_s [@ocaml.tailcall]) f t + + let iter_s f = function + | [] -> + Lwt.return_unit + | h :: t -> + Lwt.apply f h >>= fun () -> (iter_s [@ocaml.tailcall]) f t + + let rec iter_es f = function + | [] -> + return_unit + | h :: t -> + f h >>=? fun () -> (iter_es [@ocaml.tailcall]) f t + + let iter_es f = function + | [] -> + return_unit + | h :: t -> + Lwt.apply f h >>=? fun () -> (iter_es [@ocaml.tailcall]) f t + + let iter_p f l = join_p (rev_map (Lwt.apply f) l) + + let iter_ep f l = join_ep (rev_map (Lwt.apply f) l) + + let iteri_e f l = + let rec aux i = function + | [] -> + ok_unit + | x :: xs -> + f i x >>? fun () -> (aux [@ocaml.tailcall]) (i + 1) xs + 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 + | [] -> + Lwt.return_unit + | x :: xs -> + f i x >>= fun () -> (aux [@ocaml.tailcall]) (i + 1) xs + in + match l with + | [] -> + Lwt.return_unit + | x :: xs -> + lwt_apply2 f 0 x >>= fun () -> aux 1 xs + + let iteri_es f l = + let rec aux i = function + | [] -> + return_unit + | x :: xs -> + f i x >>=? fun () -> (aux [@ocaml.tailcall]) (i + 1) xs + in + match l with + | [] -> + return_unit + | x :: xs -> + lwt_apply2 f 0 x >>=? fun () -> aux 1 xs + + let iteri_p f l = join_p (mapi (lwt_apply2 f) l) + + let iteri_ep f l = join_ep (mapi (lwt_apply2 f) l) + + let rev_map_e f l = + let rec aux ys = function + | [] -> + Ok ys + | x :: xs -> + f x >>? fun y -> (aux [@ocaml.tailcall]) (y :: ys) xs + in + aux [] l + + let map_e f l = rev_map_e f l >|? rev + + let rev_map_s f l = + let rec aux ys = function + | [] -> + Lwt.return ys + | x :: xs -> + f x >>= fun y -> (aux [@ocaml.tailcall]) (y :: ys) xs + in + match l with + | [] -> + Lwt.return [] + | x :: xs -> + Lwt.apply f x >>= fun y -> aux [y] xs + + let map_s f l = rev_map_s f l >|= rev + + let rev_map_es f l = + let rec aux ys = function + | [] -> + return ys + | x :: xs -> + f x >>=? fun y -> (aux [@ocaml.tailcall]) (y :: ys) xs + in + match l with + | [] -> + return [] + | x :: xs -> + Lwt.apply f x >>=? fun y -> aux [y] xs + + let map_es f l = rev_map_es f l >|=? rev + + let rev_map_p f l = all_p @@ rev_map (Lwt.apply f) l + + let map_p f l = rev_map_p f l >|= rev + + let rev_map_ep f l = all_ep @@ rev_map (Lwt.apply f) l + + let map_ep f l = rev_map_ep f l >|=? rev + + let rev_mapi_e f l = + let rec aux i ys = function + | [] -> + Ok ys + | x :: xs -> + f i x >>? fun y -> (aux [@ocaml.tailcall]) (i + 1) (y :: ys) xs + in + aux 0 [] l + + let mapi_e f l = rev_mapi_e f l >|? rev + + let rev_mapi_s f l = + let rec aux i ys = function + | [] -> + Lwt.return ys + | x :: xs -> + f i x >>= fun y -> (aux [@ocaml.tailcall]) (i + 1) (y :: ys) xs + in + match l with + | [] -> + Lwt.return [] + | x :: xs -> + lwt_apply2 f 0 x >>= fun y -> aux 1 [y] xs + + let mapi_s f l = rev_mapi_s f l >|= rev + + let rev_mapi_es f l = + let rec aux i ys = function + | [] -> + return ys + | x :: xs -> + f i x >>=? fun y -> (aux [@ocaml.tailcall]) (i + 1) (y :: ys) xs + in + match l with + | [] -> + return [] + | x :: xs -> + lwt_apply2 f 0 x >>=? fun y -> aux 1 [y] xs + + let mapi_es f l = rev_mapi_es f l >|=? rev + + let rev_mapi f l = + let rec aux i ys = function + | [] -> + ys + | x :: xs -> + (aux [@ocaml.tailcall]) (i + 1) (f i x :: ys) xs + in + aux 0 [] l + + let rev_mapi_p f l = all_p @@ rev_mapi f l + + let mapi_p f l = rev_mapi_p f l >|= rev + + let rev_mapi_ep f l = all_ep @@ rev_mapi f l + + let mapi_ep f l = rev_mapi_ep f l >|=? rev + + let rec fold_left_e f acc = function + | [] -> + Ok acc + | x :: xs -> + f acc x >>? fun acc -> (fold_left_e [@ocaml.tailcall]) f acc xs + + let rec fold_left_s f acc = function + | [] -> + Lwt.return acc + | x :: xs -> + f acc x >>= fun acc -> (fold_left_s [@ocaml.tailcall]) f acc xs + + let fold_left_s f acc = function + | [] -> + Lwt.return acc + | x :: xs -> + lwt_apply2 f acc x >>= fun acc -> fold_left_s f acc xs + + let rec fold_left_es f acc = function + | [] -> + return acc + | x :: xs -> + f acc x >>=? fun acc -> (fold_left_es [@ocaml.tailcall]) f acc xs + + let fold_left_es f acc = function + | [] -> + return acc + | x :: xs -> + lwt_apply2 f acc x >>=? fun acc -> fold_left_es f acc xs + + let filter_p f l = + rev_map_p (fun x -> f x >|= fun b -> if b then Some x else None) l + >|= rev_filter_some + + let filter_ep f l = + rev_map_ep (fun x -> f x >|=? fun b -> if b then Some x else None) l + >|=? rev_filter_some + + let rev_filter_map f l = + fold_left + (fun acc x -> match f x with None -> acc | Some y -> y :: acc) + [] + l + + let filter_map f l = rev_filter_map f l |> rev + + let rev_filter_map_e f l = + fold_left_e + (fun acc x -> f x >|? function None -> acc | Some y -> y :: acc) + [] + l + + let filter_map_e f l = rev_filter_map_e f l >|? rev + + let rev_filter_map_s f l = + fold_left_s + (fun acc x -> f x >|= function None -> acc | Some y -> y :: acc) + [] + l + + let filter_map_s f l = rev_filter_map_s f l >|= rev + + let rev_filter_map_es f l = + fold_left_es + (fun acc x -> f x >|=? function None -> acc | Some y -> y :: acc) + [] + l + + let filter_map_es f l = rev_filter_map_es f l >|=? rev + + let filter_map_p f l = rev_map_p f l >|= rev_filter_some + + let filter_map_ep f l = rev_map_ep f l >|=? rev_filter_some + + let rec fold_right_e f l acc = + match l with + | [] -> + Ok acc + | x :: xs -> + fold_right_e f xs acc >>? fun acc -> f x acc + + let rec fold_right_s f l acc = + match l with + | [] -> + Lwt.return acc + | x :: xs -> + fold_right_s f xs acc >>= fun acc -> f x acc + + let rec fold_right_es f l acc = + match l with + | [] -> + return acc + | x :: xs -> + fold_right_es f xs acc >>=? fun acc -> f x acc + + let rev_map2_e ~when_different_lengths f xs ys = + let rec aux zs xs ys = + match (xs, ys) with + | ([], []) -> + Ok zs + | (x :: xs, y :: ys) -> + f x y >>? fun z -> (aux [@ocaml.tailcall]) (z :: zs) xs ys + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + in + aux [] xs ys + + let rev_map2_s ~when_different_lengths f xs ys = + let rec aux zs xs ys = + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok zs) + | (x :: xs, y :: ys) -> + f x y >>= fun z -> (aux [@ocaml.tailcall]) (z :: zs) xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + in + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok []) + | (x :: xs, y :: ys) -> + lwt_apply2 f x y >>= fun z -> aux [z] xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + + let rev_map2_es ~when_different_lengths f xs ys = + let rec aux zs xs ys = + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok zs) + | (x :: xs, y :: ys) -> + f x y >>=? fun z -> (aux [@ocaml.tailcall]) (z :: zs) xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + in + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok []) + | (x :: xs, y :: ys) -> + lwt_apply2 f x y >>=? fun z -> aux [z] xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + + let map2_e ~when_different_lengths f xs ys = + rev_map2_e ~when_different_lengths f xs ys >|? rev + + let map2_s ~when_different_lengths f xs ys = + rev_map2_s ~when_different_lengths f xs ys >|=? rev + + let map2_es ~when_different_lengths f xs ys = + rev_map2_es ~when_different_lengths f xs ys >|=? rev + + let iter2_e ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Monad.ok_unit + | (x :: xs, y :: ys) -> + f x y >>? fun () -> (aux [@ocaml.tailcall]) xs ys + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + in + aux xs ys + + let iter2_s ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok ()) + | (x :: xs, y :: ys) -> + f x y >>= fun () -> (aux [@ocaml.tailcall]) xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + in + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok ()) + | (x :: xs, y :: ys) -> + lwt_apply2 f x y >>= fun () -> aux xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + + let iter2_es ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Monad.return_unit + | (x :: xs, y :: ys) -> + f x y >>=? fun () -> (aux [@ocaml.tailcall]) xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + in + match (xs, ys) with + | ([], []) -> + Monad.return_unit + | (x :: xs, y :: ys) -> + lwt_apply2 f x y >>=? fun () -> aux xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + + let fold_left2_e ~when_different_lengths f init xs ys = + let rec aux acc xs ys = + match (xs, ys) with + | ([], []) -> + Ok acc + | (x :: xs, y :: ys) -> + f acc x y >>? fun acc -> (aux [@ocaml.tailcall]) acc xs ys + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + 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 + | ([], []) -> + Lwt.return (Ok acc) + | (x :: xs, y :: ys) -> + f acc x y >>= fun acc -> (aux [@ocaml.tailcall]) acc xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + in + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok init) + | (x :: xs, y :: ys) -> + lwt_apply3 f init x y >>= fun acc -> aux acc xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + + let fold_left2_es ~when_different_lengths f init xs ys = + let rec aux acc xs ys = + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok acc) + | (x :: xs, y :: ys) -> + f acc x y >>=? fun acc -> (aux [@ocaml.tailcall]) acc xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + in + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok init) + | (x :: xs, y :: ys) -> + lwt_apply3 f init x y >>=? fun acc -> (aux [@ocaml.tailcall]) acc xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + + let fold_right2_e ~when_different_lengths f xs ys init = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Ok init + | (x :: xs, y :: ys) -> + aux xs ys >>? fun acc -> f x y acc + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + in + aux xs ys + + let fold_right2_s ~when_different_lengths f xs ys init = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Lwt.return (Ok init) + | (x :: xs, y :: ys) -> + (* We could use a specific operator for that. It'd need the following type + ('a, 'err) result Lwt.t -> ('a -> 'b Lwt.t) -> ('b, 'err) result Lwt.t + *) + aux xs ys >>=? fun acc -> f x y acc >|= ok + in + aux xs ys + + let fold_right2_es ~when_different_lengths f xs ys init = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Lwt.return (Ok init) + | (x :: xs, y :: ys) -> + aux xs ys >>=? fun acc -> f x y acc + in + aux xs ys + + let rec for_all_e f = function + | [] -> + Monad.ok_true + | x :: xs -> ( + f x + >>? function + | true -> (for_all_e [@ocaml.tailcall]) f xs | false -> Monad.ok_false + ) + + let rec for_all_s f = function + | [] -> + Lwt.return_true + | x :: xs -> ( + f x + >>= function + | true -> + (for_all_s [@ocaml.tailcall]) f xs + | false -> + Lwt.return_false ) + + let for_all_s f = function + | [] -> + Lwt.return_true + | x :: xs -> ( + Lwt.apply f x + >>= function + | true -> + (for_all_s [@ocaml.tailcall]) f xs + | false -> + Lwt.return_false ) + + let rec for_all_es f = function + | [] -> + Monad.return_true + | x :: xs -> ( + f x + >>=? function + | true -> + (for_all_es [@ocaml.tailcall]) f xs + | false -> + Monad.return_false ) + + let for_all_es f = function + | [] -> + Monad.return_true + | x :: xs -> ( + Lwt.apply f x + >>=? function + | true -> + (for_all_es [@ocaml.tailcall]) f xs + | false -> + Monad.return_false ) + + let for_all_p f l = rev_map_p f l >|= for_all Fun.id + + let for_all_ep f l = rev_map_ep f l >|=? for_all Fun.id + + let rec exists_e f = function + | [] -> + Monad.ok_false + | x :: xs -> ( + f x + >>? function + | false -> (exists_e [@ocaml.tailcall]) f xs | true -> Monad.ok_true ) + + let rec exists_s f = function + | [] -> + Lwt.return_false + | x :: xs -> ( + f x + >>= function + | false -> (exists_s [@ocaml.tailcall]) f xs | true -> Lwt.return_true + ) + + let exists_s f = function + | [] -> + Lwt.return_false + | x :: xs -> ( + Lwt.apply f x + >>= function false -> exists_s f xs | true -> Lwt.return_true ) + + let rec exists_es f = function + | [] -> + Monad.return_false + | x :: xs -> ( + f x + >>=? function + | false -> + (exists_es [@ocaml.tailcall]) f xs + | true -> + Monad.return_true ) + + let exists_es f = function + | [] -> + Monad.return_false + | x :: xs -> ( + Lwt.apply f x + >>=? function false -> exists_es f xs | true -> Monad.return_true ) + + let exists_p f l = rev_map_p f l >|= exists Fun.id + + let exists_ep f l = rev_map_ep f l >|=? exists Fun.id + + let for_all2_e ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | ([], []) -> + Monad.ok_true + | (x :: xs, y :: ys) -> ( + f x y + >>? function + | true -> (aux [@ocaml.tailcall]) xs ys | false -> Monad.ok_false ) + in + aux xs ys + + let for_all2_s ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Monad.return_true + | (x :: xs, y :: ys) -> ( + f x y + >>= function + | true -> (aux [@ocaml.tailcall]) xs ys | false -> Monad.return_false + ) + in + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Monad.return_true + | (x :: xs, y :: ys) -> ( + lwt_apply2 f x y + >>= function true -> aux xs ys | false -> Monad.return_false ) + + let for_all2_es ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Monad.return_true + | (x :: xs, y :: ys) -> ( + f x y + >>=? function + | true -> (aux [@ocaml.tailcall]) xs ys | false -> Monad.return_false + ) + in + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Monad.return_true + | (x :: xs, y :: ys) -> ( + lwt_apply2 f x y + >>=? function true -> aux xs ys | false -> Monad.return_false ) + + let exists2_e ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | ([], []) -> + Monad.ok_false + | (x :: xs, y :: ys) -> ( + f x y + >>? function + | false -> (aux [@ocaml.tailcall]) xs ys | true -> Monad.ok_true ) + in + aux xs ys + + let exists2_s ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Monad.return_false + | (x :: xs, y :: ys) -> ( + f x y + >>= function + | false -> (aux [@ocaml.tailcall]) xs ys | true -> Monad.return_true + ) + in + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Monad.return_false + | (x :: xs, y :: ys) -> ( + lwt_apply2 f x y + >>= function false -> aux xs ys | true -> Monad.return_true ) + + let exists2_es ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Monad.return_false + | (x :: xs, y :: ys) -> ( + f x y + >>=? function + | false -> (aux [@ocaml.tailcall]) xs ys | true -> Monad.return_true + ) + in + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Monad.return_false + | (x :: xs, y :: ys) -> ( + lwt_apply2 f x y + >>=? function false -> aux xs ys | true -> Monad.return_true ) + + let rev_partition_result xs = + let rec aux oks errors = function + | [] -> + (oks, errors) + | Ok ok :: xs -> + (aux [@ocaml.tailcall]) (ok :: oks) errors xs + | Error error :: xs -> + (aux [@ocaml.tailcall]) oks (error :: errors) xs + in + aux [] [] xs + + let partition_result xs = + let (rev_oks, rev_errors) = rev_partition_result xs in + (rev rev_oks, rev rev_errors) + + let rev_partition_e f l = + let rec aux trues falses = function + | [] -> + Ok (trues, falses) + | x :: xs -> + f x + >>? fun b -> + if b then (aux [@ocaml.tailcall]) (x :: trues) falses xs + else (aux [@ocaml.tailcall]) trues (x :: falses) xs + in + aux [] [] l + + let partition_e f l = + rev_partition_e f l >|? fun (trues, falses) -> (rev trues, rev falses) + + let rev_partition_s f l = + let rec aux trues falses = function + | [] -> + Lwt.return (trues, falses) + | x :: xs -> + f x + >>= fun b -> + if b then (aux [@ocaml.tailcall]) (x :: trues) falses xs + else (aux [@ocaml.tailcall]) trues (x :: falses) xs + in + match l with + | [] -> + Lwt.return ([], []) + | x :: xs -> + Lwt.apply f x >>= fun b -> if b then aux [x] [] xs else aux [] [x] xs + + let partition_s f l = + rev_partition_s f l >|= fun (trues, falses) -> (rev trues, rev falses) + + let rev_partition_es f l = + let rec aux trues falses = function + | [] -> + Lwt.return_ok (trues, falses) + | x :: xs -> + f x + >>=? fun b -> + if b then (aux [@ocaml.tailcall]) (x :: trues) falses xs + else (aux [@ocaml.tailcall]) trues (x :: falses) xs + in + match l with + | [] -> + Lwt.return_ok ([], []) + | x :: xs -> + Lwt.apply f x >>=? fun b -> if b then aux [x] [] xs else aux [] [x] xs + + let partition_es f l = + rev_partition_es f l >|=? fun (trues, falses) -> (rev trues, rev falses) + + let partition_p f l = + rev_map_p (fun x -> f x >|= fun b -> (b, x)) l + >|= fun bxs -> + fold_left + (fun (trues, falses) (b, x) -> + if b then (x :: trues, falses) else (trues, x :: falses)) + ([], []) + bxs + + let partition_ep f l = + rev_map_ep (fun x -> f x >|=? fun b -> (b, x)) l + >|=? fun bxs -> + fold_left + (fun (trues, falses) (b, x) -> + if b then (x :: trues, falses) else (trues, x :: falses)) + ([], []) + bxs + + let combine ~when_different_lengths xs ys = + map2 ~when_different_lengths (fun x y -> (x, y)) xs ys + + let rev_combine ~when_different_lengths xs ys = + rev_map2 ~when_different_lengths (fun x y -> (x, y)) xs ys + + let combine_with_leftovers xs ys = + let rec aux rev_combined xs ys = + match (xs, ys) with + | ([], []) -> + (rev rev_combined, None) + | ((_ :: _ as left), []) -> + (rev rev_combined, Some (`Left left)) + | ([], (_ :: _ as right)) -> + (rev rev_combined, Some (`Right right)) + | (x :: xs, y :: ys) -> + (aux [@ocaml.tailcall]) ((x, y) :: rev_combined) xs ys + in + aux [] xs ys + + let combine_drop xs ys = + let rec aux rev_combined xs ys = + match (xs, ys) with + | (x :: xs, y :: ys) -> + (aux [@ocaml.tailcall]) ((x, y) :: rev_combined) xs ys + | ([], []) | (_ :: _, []) | ([], _ :: _) -> + rev rev_combined + in + aux [] xs ys +end diff --git a/src/lib_lwt_result_stdlib/functors/list.mli b/src/lib_lwt_result_stdlib/functors/list.mli new file mode 100644 index 000000000000..d1230ce4576c --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/list.mli @@ -0,0 +1,27 @@ +(*****************************************************************************) +(* *) +(* 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 : Sigs.Monad.S) : + Sigs.List.S with type 'error trace := 'error Monad.trace diff --git a/src/lib_lwt_result_stdlib/lib/list.ml b/src/lib_lwt_result_stdlib/lib/list.ml new file mode 100644 index 000000000000..a6dac7678449 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/list.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 Functors.List.Make (Seq.Monad) diff --git a/src/lib_lwt_result_stdlib/lib/list.mli b/src/lib_lwt_result_stdlib/lib/list.mli new file mode 100644 index 000000000000..e686712c35bd --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/list.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 Sigs.List.S with type 'error trace := 'error Error_monad.trace diff --git a/src/lib_lwt_result_stdlib/lwtreslib.ml b/src/lib_lwt_result_stdlib/lwtreslib.ml index a40eb489f321..3128b884eed2 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.ml +++ b/src/lib_lwt_result_stdlib/lwtreslib.ml @@ -27,3 +27,4 @@ module Seq = Lib.Seq module Set = Lib.Set module Map = Lib.Map module Hashtbl = Lib.Hashtbl +module List = Lib.List diff --git a/src/lib_lwt_result_stdlib/lwtreslib.mli b/src/lib_lwt_result_stdlib/lwtreslib.mli index 4f2865c1862c..155975a8c993 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.mli +++ b/src/lib_lwt_result_stdlib/lwtreslib.mli @@ -52,3 +52,5 @@ module Set : module type of Lib.Set module Map : module type of Lib.Map module Hashtbl : module type of Lib.Hashtbl + +module List : module type of Lib.List diff --git a/src/lib_lwt_result_stdlib/sigs/list.ml b/src/lib_lwt_result_stdlib/sigs/list.ml new file mode 100644 index 000000000000..11ba967312e5 --- /dev/null +++ b/src/lib_lwt_result_stdlib/sigs/list.ml @@ -0,0 +1,787 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** {1 List} + + A wrapper around {!Stdlib.List} that includes lwt-, error- and + lwt-error-aware traversal functions. + + Supersedes {!Stdlib.List} and {!Lwt_list} both. + +*) + +(** + {2 Basics} + + This follows the design principles and semantic described in {!Sigs.Seq}. In + a nutshell: + - Stdlib functions that raise exceptions are replaced by safe variants + (typically returning [option]). + - The [_e] suffix is for error-aware traversors, [_s] and [_p] are for + lwt-aware, and [_es] and [_ep] are for lwt-error-aware. + - [_e], [_s], and [_es] traversors are {i fail-early}: they stop traversal + as soon as a failure ([Error] or [Fail]) occurs; [_p] and [_ep] + traversors are {i best-effort}: they only resolve once all of the + intermediate promises have even if a failure occurs. + +*) + +(** + + {2 Double-traversal and combine} + + Note that double-list traversors ([iter2], [map2], etc., and also [combine]) + take an additional [when_different_lengths] parameter. This is to control + the error that is returned when the two lists passed as arguments have + different lengths. + + Note that, as per the fail-early behaviour mentioned above, [_e], [_s], and + [_es] traversors will have already processed the common-prefix before the + error is returned. + + Because the best-effort behaviour of [_p] and [_ep] is unsatisfying for this + failure case, double parallel traversors are omitted from this library. + (Specifically, it is not obvious whether nor how the + [when_different_lengths] error should be composed with the other errors, + what shape the trace should have.) + + To obtain a different behaviour for sequential traversors, or to process + two lists in parallel, you can use {!combine} or any of the alternative that + handles the error differently: {!combine_drop}, {!combine_with_leftovers}. + Finally, the {!rev_combine} is provided to allow to avoid + multiple-reversing. + + {3 Special considerations} + + Because they traverse the list from right-to-left, the {!fold_right2} + function and all its variants fail with [when_different_lengths] before any + of the processing starts. Whilst this is still within the fail-early + behaviour, it may be surprising enough that it requires mentioning here. + + Because they return early, {!for_all2} and {!exists2} and all their variants + may return [Ok _] even tough the arguments have different lengths. + + +*) + +(** {2 S} *) +module type S = sig + (** {3 Boilerplate} *) + + (** For substituting based on the {!Sigs.Trace} type. *) + type 'error trace + + (** Include the legacy list. Unsafe functions are shadowed below. *) + include + module type of Stdlib.List with type 'a t = 'a Stdlib.List.t + + (** {3 Trivial values} *) + + (** in-monad, preallocated nil *) + + (** [nil] is [[]] *) + val nil : 'a list + + (** [nil] is [Ok []] *) + val nil_e : ('a list, 'trace) result + + (** [nil] is [Lwt.return_nil] *) + val nil_s : 'a list Lwt.t + + (** [nil] is [Lwt.return (Ok [])] *) + val nil_es : ('a list, 'trace) result Lwt.t + + (** {3 Safe wrappers} + + Shadowing unsafe functions to avoid all exceptions. *) + + (** {4 Safe lookups, scans, retrievals} + + Return option rather than raise [Not_found] or [Invalid_argument _] *) + + (** [hd xs] is the head (first element) of the list or [None] if the list is + empty. *) + val hd : 'a list -> 'a option + + (** [tl xs] is the tail of the list (the whole list except the first element) + or [None] if the list is empty. *) + val tl : 'a list -> 'a list option + + (** [nth xs n] is the [n]th element of the list or [None] if the list has + fewer than [n] elements. + + [nth xs 0 = tl xs] *) + val nth : '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: + [match l with | None -> … | Some x :: xs -> last x xs] + but it can also be used for a default value: + [last default_value_if_empty xs]. *) + val last : 'a -> 'a list -> 'a + + (** [last_opt xs] is the last element of the list [xs] or [None] if the list + [xs] is empty. *) + val last_opt : 'a list -> 'a option + + (** [find predicate xs] is the first element [x] of the list [xs] such that + [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 + + (** [assq k kvs] is the same as [assoc k kvs] but it uses the physical + equality. *) + val assq : 'a -> ('a * 'b) list -> 'b option + + (** {4 Initialisation} *) + + (** [init ~when_negative_length n f] is [Error when_negative_length] if [n] is + strictly negative and + [Ok] {!Stdlib.List.init n f} otherwise. *) + val init : + when_negative_length:'trace -> + int -> + (int -> 'a) -> + ('a list, 'trace) result + + (** {4 Double-list traversals} + + These safe-wrappers take an explicit value to handle the case of lists of + unequal length. + *) + + (** [combine ~when_different_lengths l1 l2] is either + - [Error when_different_lengths] if [List.length l1 <> List.length l2] + - a list of pairs of elements from [l1] and [l2] + + E.g., [combine ~when_different_lengths [] [] = Ok []] + + E.g., [combine ~when_different_lengths [1; 2] ['a'; 'b'] = Ok [(1,'a'); (2, 'b')]] + + E.g., [combine ~when_different_lengths:() [1] [] = Error ()] + + Note: [combine ~when_different_lengths l1 l2] is equivalent to + [try Ok (Stdlib.List.combine l1 l2) + with Invalid_argument _ -> when_different_lengths] + + The same equivalence almost holds for the other double traversors below. + The notable difference is if the functions passed as argument to the + traversors raise the [Invalid_argument _] exception. *) + val combine : + when_different_lengths:'trace -> + 'a list -> + 'b list -> + (('a * 'b) list, 'trace) result + + (** [rev_combine ~when_different_lengths xs ys] is + [rev (combine ~when_different_lengths xs ys)] but more efficient. *) + val rev_combine : + when_different_lengths:'trace -> + 'a list -> + 'b list -> + (('a * 'b) list, 'trace) result + + val iter2 : + when_different_lengths:'trace -> + ('a -> 'b -> unit) -> + 'a list -> + 'b list -> + (unit, 'trace) result + + val map2 : + when_different_lengths:'trace -> + ('a -> 'b -> 'c) -> + 'a list -> + 'b list -> + ('c list, 'trace) result + + val rev_map2 : + when_different_lengths:'trace -> + ('a -> 'b -> 'c) -> + 'a list -> + 'b list -> + ('c list, 'trace) result + + val fold_left2 : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> 'a) -> + 'a -> + 'b list -> + 'c list -> + ('a, 'trace) result + + (** This function is not tail-recursive *) + val fold_right2 : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> 'c) -> + 'a list -> + 'b list -> + 'c -> + ('c, 'trace) result + + val for_all2 : + when_different_lengths:'trace -> + ('a -> 'b -> bool) -> + 'a list -> + 'b list -> + (bool, 'trace) result + + val exists2 : + when_different_lengths:'trace -> + ('a -> 'b -> bool) -> + 'a list -> + 'b list -> + (bool, 'trace) result + + (** {3 Monad-aware variants} + + The functions below are strict extensions of the standard {!Stdlib.List} + module. It is for error-, lwt- and lwt-error-aware variants. The meaning + of the suffix is as described above and in {!Sigs.Seq}. *) + + (** {4 Initialisation variants} + + Note that for asynchronous variants ([_s], [_es], [_p], and [_ep]), if the + length parameter is negative, then the promise is returned already + fulfilled with [Error when_different_lengths]. *) + + val init_e : + when_negative_length:'trace -> + int -> + (int -> ('a, 'trace) result) -> + ('a list, 'trace) result + + val init_s : + when_negative_length:'trace -> + int -> + (int -> 'a Lwt.t) -> + ('a list, 'trace) result Lwt.t + + val init_es : + when_negative_length:'trace -> + int -> + (int -> ('a, 'trace) result Lwt.t) -> + ('a list, 'trace) result Lwt.t + + val init_p : + when_negative_length:'trace -> + int -> + (int -> 'a Lwt.t) -> + ('a list, 'trace) result Lwt.t + + val init_ep : + when_negative_length:'error -> + int -> + (int -> ('a, 'error trace) result Lwt.t) -> + ('a list, 'error trace) result Lwt.t + + (** {4 Query variants} *) + + val find_e : + ('a -> (bool, 'trace) result) -> 'a list -> ('a option, 'trace) result + + val find_s : ('a -> bool Lwt.t) -> 'a list -> 'a option Lwt.t + + val find_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + ('a option, 'trace) result Lwt.t + + (** [rev_filter f l] is [rev (filter f l)] but more efficient. *) + val rev_filter : ('a -> bool) -> 'a list -> 'a list + + val rev_filter_some : 'a option list -> 'a list + + val filter_some : 'a option list -> 'a list + + val rev_filter_ok : ('a, 'b) result list -> 'a list + + val filter_ok : ('a, 'b) result list -> 'a list + + val rev_filter_error : ('a, 'b) result list -> 'b list + + val filter_error : ('a, 'b) result list -> 'b list + + val rev_filter_e : + ('a -> (bool, 'trace) result) -> 'a list -> ('a list, 'trace) result + + val filter_e : + ('a -> (bool, 'trace) result) -> 'a list -> ('a list, 'trace) result + + val rev_filter_s : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t + + val filter_s : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t + + val rev_filter_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + ('a list, 'trace) result Lwt.t + + val filter_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + ('a list, 'trace) result Lwt.t + + val filter_p : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t + + val filter_ep : + ('a -> (bool, 'error trace) result Lwt.t) -> + 'a list -> + ('a list, 'error trace) result Lwt.t + + val rev_partition_result : ('a, 'b) result list -> 'a list * 'b list + + val partition_result : ('a, 'b) result list -> 'a list * 'b list + + val rev_partition_e : + ('a -> (bool, 'trace) result) -> + 'a list -> + ('a list * 'a list, 'trace) result + + val partition_e : + ('a -> (bool, 'trace) result) -> + 'a list -> + ('a list * 'a list, 'trace) result + + val rev_partition_s : + ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t + + val partition_s : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t + + val rev_partition_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + ('a list * 'a list, 'trace) result Lwt.t + + val partition_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + ('a list * 'a list, 'trace) result Lwt.t + + val partition_p : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t + + val partition_ep : + ('a -> (bool, 'error trace) result Lwt.t) -> + 'a list -> + ('a list * 'a list, 'error trace) result Lwt.t + + (** {4 Traversal variants} *) + + val iter_e : + ('a -> (unit, 'trace) result) -> 'a list -> (unit, 'trace) result + + val iter_s : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t + + val iter_es : + ('a -> (unit, 'trace) result Lwt.t) -> + 'a list -> + (unit, 'trace) result Lwt.t + + val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t + + val iter_ep : + ('a -> (unit, 'error trace) result Lwt.t) -> + 'a list -> + (unit, 'error trace) result Lwt.t + + val iteri_e : + (int -> 'a -> (unit, 'trace) result) -> 'a list -> (unit, 'trace) result + + val iteri_s : (int -> 'a -> unit Lwt.t) -> 'a list -> unit Lwt.t + + val iteri_es : + (int -> 'a -> (unit, 'trace) result Lwt.t) -> + 'a list -> + (unit, 'trace) result Lwt.t + + val iteri_p : (int -> 'a -> unit Lwt.t) -> 'a list -> unit Lwt.t + + val iteri_ep : + (int -> 'a -> (unit, 'error trace) result Lwt.t) -> + 'a list -> + (unit, 'error trace) result Lwt.t + + val map_e : + ('a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result + + val map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + + val map_es : + ('a -> ('b, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t + + val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + + val map_ep : + ('a -> ('b, 'error trace) result Lwt.t) -> + 'a list -> + ('b list, 'error trace) result Lwt.t + + val mapi_e : + (int -> 'a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result + + val mapi_s : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + + val mapi_es : + (int -> 'a -> ('b, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t + + val mapi_p : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + + val mapi_ep : + (int -> 'a -> ('b, 'error trace) result Lwt.t) -> + 'a list -> + ('b list, 'error trace) result Lwt.t + + val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list + + val rev_map_e : + ('a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result + + val rev_map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + + val rev_map_es : + ('a -> ('b, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t + + val rev_map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + + val rev_map_ep : + ('a -> ('b, 'error trace) result Lwt.t) -> + 'a list -> + ('b list, 'error trace) result Lwt.t + + val rev_mapi_e : + (int -> 'a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result + + val rev_mapi_s : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + + val rev_mapi_es : + (int -> 'a -> ('b, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t + + val rev_mapi_p : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + + val rev_mapi_ep : + (int -> 'a -> ('b, 'error trace) result Lwt.t) -> + 'a list -> + ('b list, 'error trace) result Lwt.t + + val rev_filter_map : ('a -> 'b option) -> 'a list -> 'b list + + val rev_filter_map_e : + ('a -> ('b option, 'trace) result) -> 'a list -> ('b list, 'trace) result + + val filter_map_e : + ('a -> ('b option, 'trace) result) -> 'a list -> ('b list, 'trace) result + + val rev_filter_map_s : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t + + val filter_map_s : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t + + val rev_filter_map_es : + ('a -> ('b option, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t + + val filter_map_es : + ('a -> ('b option, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t + + val filter_map_p : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t + + val filter_map_ep : + ('a -> ('b option, 'error trace) result Lwt.t) -> + 'a list -> + ('b list, 'error trace) result Lwt.t + + val fold_left_e : + ('a -> 'b -> ('a, 'trace) result) -> 'a -> 'b list -> ('a, 'trace) result + + val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b list -> 'a Lwt.t + + val fold_left_es : + ('a -> 'b -> ('a, 'trace) result Lwt.t) -> + 'a -> + 'b list -> + ('a, 'trace) result Lwt.t + + (** This function is not tail-recursive *) + val fold_right_e : + ('a -> 'b -> ('b, 'trace) result) -> 'a list -> 'b -> ('b, 'trace) result + + (** This function is not tail-recursive *) + val fold_right_s : ('a -> 'b -> 'b Lwt.t) -> 'a list -> 'b -> 'b Lwt.t + + (** This function is not tail-recursive *) + val fold_right_es : + ('a -> 'b -> ('b, 'trace) result Lwt.t) -> + 'a list -> + 'b -> + ('b, 'trace) result Lwt.t + + (** {4 Double-traversal variants} + + As mentioned above, there are no [_p] and [_ep] double-traversors. Use + {!combine} (and variants) to circumvent this. *) + + val iter2_e : + when_different_lengths:'trace -> + ('a -> 'b -> (unit, 'trace) result) -> + 'a list -> + 'b list -> + (unit, 'trace) result + + val iter2_s : + when_different_lengths:'trace -> + ('a -> 'b -> unit Lwt.t) -> + 'a list -> + 'b list -> + (unit, 'trace) result Lwt.t + + val iter2_es : + when_different_lengths:'trace -> + ('a -> 'b -> (unit, 'trace) result Lwt.t) -> + 'a list -> + 'b list -> + (unit, 'trace) result Lwt.t + + val map2_e : + when_different_lengths:'trace -> + ('a -> 'b -> ('c, 'trace) result) -> + 'a list -> + 'b list -> + ('c list, 'trace) result + + val map2_s : + when_different_lengths:'trace -> + ('a -> 'b -> 'c Lwt.t) -> + 'a list -> + 'b list -> + ('c list, 'trace) result Lwt.t + + val map2_es : + when_different_lengths:'trace -> + ('a -> 'b -> ('c, 'trace) result Lwt.t) -> + 'a list -> + 'b list -> + ('c list, 'trace) result Lwt.t + + val rev_map2_e : + when_different_lengths:'trace -> + ('a -> 'b -> ('c, 'trace) result) -> + 'a list -> + 'b list -> + ('c list, 'trace) result + + val rev_map2_s : + when_different_lengths:'trace -> + ('a -> 'b -> 'c Lwt.t) -> + 'a list -> + 'b list -> + ('c list, 'trace) result Lwt.t + + val rev_map2_es : + when_different_lengths:'trace -> + ('a -> 'b -> ('c, 'trace) result Lwt.t) -> + 'a list -> + 'b list -> + ('c list, 'trace) result Lwt.t + + val fold_left2_e : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> ('a, 'trace) result) -> + 'a -> + 'b list -> + 'c list -> + ('a, 'trace) result + + val fold_left2_s : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> 'a Lwt.t) -> + 'a -> + 'b list -> + 'c list -> + ('a, 'trace) result Lwt.t + + val fold_left2_es : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> ('a, 'trace) result Lwt.t) -> + 'a -> + 'b list -> + 'c list -> + ('a, 'trace) result Lwt.t + + (** This function is not tail-recursive *) + val fold_right2_e : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> ('c, 'trace) result) -> + 'a list -> + 'b list -> + 'c -> + ('c, 'trace) result + + (** This function is not tail-recursive *) + val fold_right2_s : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> 'c Lwt.t) -> + 'a list -> + 'b list -> + 'c -> + ('c, 'trace) result Lwt.t + + (** This function is not tail-recursive *) + val fold_right2_es : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> ('c, 'trace) result Lwt.t) -> + 'a list -> + 'b list -> + 'c -> + ('c, 'trace) result Lwt.t + + (** {4 Scanning variants} *) + + val for_all_e : + ('a -> (bool, 'trace) result) -> 'a list -> (bool, 'trace) result + + val for_all_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t + + val for_all_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + (bool, 'trace) result Lwt.t + + val for_all_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t + + val for_all_ep : + ('a -> (bool, 'error trace) result Lwt.t) -> + 'a list -> + (bool, 'error trace) result Lwt.t + + val exists_e : + ('a -> (bool, 'trace) result) -> 'a list -> (bool, 'trace) result + + val exists_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t + + val exists_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + (bool, 'trace) result Lwt.t + + val exists_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t + + val exists_ep : + ('a -> (bool, 'error trace) result Lwt.t) -> + 'a list -> + (bool, 'error trace) result Lwt.t + + (** {4 Double-scanning variants} + + As mentioned above, there are no [_p] and [_ep] double-scanners. Use + {!combine} (and variants) to circumvent this. *) + + val for_all2_e : + when_different_lengths:'trace -> + ('a -> 'b -> (bool, 'trace) result) -> + 'a list -> + 'b list -> + (bool, 'trace) result + + val for_all2_s : + when_different_lengths:'trace -> + ('a -> 'b -> bool Lwt.t) -> + 'a list -> + 'b list -> + (bool, 'trace) result Lwt.t + + val for_all2_es : + when_different_lengths:'trace -> + ('a -> 'b -> (bool, 'trace) result Lwt.t) -> + 'a list -> + 'b list -> + (bool, 'trace) result Lwt.t + + val exists2_e : + when_different_lengths:'trace -> + ('a -> 'b -> (bool, 'trace) result) -> + 'a list -> + 'b list -> + (bool, 'trace) result + + val exists2_s : + when_different_lengths:'trace -> + ('a -> 'b -> bool Lwt.t) -> + 'a list -> + 'b list -> + (bool, 'trace) result Lwt.t + + val exists2_es : + when_different_lengths:'trace -> + ('a -> 'b -> (bool, 'trace) result Lwt.t) -> + 'a list -> + 'b list -> + (bool, 'trace) result Lwt.t + + (** {3 Combine variants} + + These are primarily intended to be used for preprocessing before applying + a traversor to the resulting list of pairs. They give alternatives to the + [when_different_lengths] mechanism of the immediate double-traversors + above. + + In case the semantic of, say, [map2_es] was unsatisfying, one can use + [map_es] on a [combine]-preprocessed pair of lists. The different variants + of [combine] give different approaches to different-length handling. *) + + (** [combine_drop ll lr] is a list [l] of pairs of elements taken from the + common-length prefix of [ll] and [lr]. The suffix of whichever list is + longer (if any) is dropped. + + More formally [nth l n] is: + - [None] if [n >= min (length ll) (length lr)] + - [Some (Option.get @@ nth ll n, Option.get @@ nth lr n)] otherwise + *) + val combine_drop : 'a list -> 'b list -> ('a * 'b) list + + (** [combine_with_leftovers ll lr] is a tuple [(combined, leftover)] + where [combined] is [combine_drop ll lr] + and [leftover] is either [`Left lsuffix] or [`Right rsuffix] depending on + which of [ll] or [lr] is longer. [leftover] is [None] if the two lists + have the same length. *) + val combine_with_leftovers : + 'a list -> + 'b list -> + ('a * 'b) list * [`Left of 'a list | `Right of 'b list] option +end -- GitLab From 59d71f6fdd69106b576a9394f27a9e6a07ef8055 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Thu, 12 Nov 2020 10:01:40 +0100 Subject: [PATCH 3/5] Lwtreslib: test List --- src/lib_lwt_result_stdlib/test/dune | 12 + .../test/test_fuzzing_helpers.ml | 40 +++ .../test/test_fuzzing_list.ml | 59 ++++ .../test/test_fuzzing_tests.ml | 55 ++++ .../test/test_generic.ml | 18 +- .../test/test_list_basic.ml | 300 ++++++++++++++++++ src/lib_lwt_result_stdlib/test/traits.ml | 22 ++ 7 files changed, 505 insertions(+), 1 deletion(-) create mode 100644 src/lib_lwt_result_stdlib/test/test_fuzzing_list.ml create mode 100644 src/lib_lwt_result_stdlib/test/test_list_basic.ml diff --git a/src/lib_lwt_result_stdlib/test/dune b/src/lib_lwt_result_stdlib/test/dune index bef7149d741c..4201e9045042 100644 --- a/src/lib_lwt_result_stdlib/test/dune +++ b/src/lib_lwt_result_stdlib/test/dune @@ -1,8 +1,10 @@ (executables (names test_hashtbl + test_list_basic test_generic test_fuzzing_seq + test_fuzzing_list test_fuzzing_set ) (libraries tezos-lwt-result-stdlib @@ -17,7 +19,9 @@ (deps test_hashtbl.exe test_generic.exe + test_list_basic.exe test_fuzzing_seq.exe + test_fuzzing_list.exe test_fuzzing_set.exe )) @@ -27,9 +31,15 @@ (rule (alias runtest_generic) (action (run %{exe:test_generic.exe}))) +(rule + (alias runtest_list_basic) + (action (run %{exe:test_list_basic.exe}))) (rule (alias runtest_fuzzing_seq) (action (run %{exe:test_fuzzing_seq.exe}))) +(rule + (alias runtest_fuzzing_list) + (action (run %{exe:test_fuzzing_list.exe}))) (rule (alias runtest_fuzzing_set) (action (run %{exe:test_fuzzing_set.exe}))) @@ -40,7 +50,9 @@ (deps (alias runtest_hashtbl) (alias runtest_generic) + (alias runtest_list_basic) (alias runtest_fuzzing_seq) + (alias runtest_fuzzing_list) (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 index bb8f9a90dae3..64decbaca7de 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml @@ -91,6 +91,10 @@ module IterOf = struct let fn r fn y = r := fn !r y end +module IteriOf = struct + let fn r fn i y = r := fn !r (fn i y) +end + module Iter2Of = struct let fn r fn x y = r := fn !r (fn x y) end @@ -121,6 +125,14 @@ module IterEOf = struct let fn_e r fn y = fn !r y >|? fun t -> r := t end +module IteriEOf = struct + let fn r fn i y = + r := fn !r (fn i y) ; + Ok () + + let fn_e r fn i y = fn i y >>? fun z -> fn !r z >|? fun t -> r := t +end + module Iter2EOf = struct let fn r fn x y = r := fn x y ; @@ -183,6 +195,14 @@ module IterSOf = struct let fn_s r fn y = fn !r y >|= fun t -> r := t end +module IteriSOf = struct + let fn r fn i y = + r := fn !r (fn i y) ; + Lwt.return_unit + + let fn_s r fn i y = fn i y >>= fun z -> fn !r z >|= fun t -> r := t +end + module Iter2SOf = struct let fn r fn x y = r := fn x y ; @@ -253,6 +273,26 @@ module IterESOf = struct let fn_es r fn y = fn !r y >|=? fun t -> r := t end +module IteriESOf = struct + let fn r fn i y = + r := fn !r (fn i y) ; + return_unit + + let fn_e r fn i y = + Lwt.return @@ fn i y + >>=? fun z -> Lwt.return @@ fn !r z >|=? fun t -> r := t + + let fn_s r fn i y = + fn i y + >>= fun z -> + fn !r z + >|= fun t -> + r := t ; + Ok () + + let fn_es r fn i y = fn i y >>=? fun z -> fn !r z >|=? fun t -> r := t +end + module Iter2ESOf = struct let fn r fn x y = r := fn x y ; diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_list.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_list.ml new file mode 100644 index 000000000000..46b6ed5f9f1f --- /dev/null +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_list.ml @@ -0,0 +1,59 @@ +(*****************************************************************************) +(* *) +(* 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 ListWithBase = struct + type 'a elt = 'a + + include Lwtreslib.List + + let of_list = Fun.id + + let to_list = Fun.id + + let name = "List" +end + +(* Internal consistency *) +module IterFold = TestIterFold (ListWithBase) +module RevMapRevMap = TestRevMapRevMap (ListWithBase) + +(* consistency w.r.t. Stdlib *) +module ExistForall = TestExistForallAgainstStdlibList (ListWithBase) +module Filter = TestFilterAgainstStdlibList (ListWithBase) +module Filterp = TestFilterpAgainstStdlibList (ListWithBase) +module Filtermap = TestFiltermapAgainstStdlibList (ListWithBase) +module Filtermapp = TestFiltermappAgainstStdlibList (ListWithBase) +module Fold = TestFoldAgainstStdlibList (ListWithBase) +module FoldRight = TestFoldRightAgainstStdlibList (ListWithBase) +module Iter = TestIterAgainstStdlibList (ListWithBase) +module Iteri = TestIteriAgainstStdlibList (ListWithBase) +module Iterp = TestIterMonotoneAgainstStdlibList (ListWithBase) +module Map = TestMapAgainstStdlibList (ListWithBase) +module Mapp = TestMappAgainstStdlibList (ListWithBase) +module Find = TestFindStdlibList (ListWithBase) +module Partition = TestPartitionStdlibList (ListWithBase) +module Double = TestDoubleTraversorsStdlibList (ListWithBase) diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml index a70023eb9270..f512c627e762 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml @@ -213,6 +213,61 @@ struct (Lwt.return_ok @@ with_stdlib_iter fn init input)) end +module TestIteriAgainstStdlibList (M : sig + include BASE with type 'a elt := int + + include + Traits.ITERI_SEQUENTIAL with type 'a elt := int and type 'a t := int t +end) = +struct + let with_stdlib_iteri fn init input = + let acc = ref init in + Stdlib.List.iteri (IteriOf.fn acc fn) input ; + !acc + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iteri, Stdlib.List.iteri" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq + (let acc = ref init in + M.iteri (IteriOf.fn acc fn) (M.of_list input) ; + !acc) + (with_stdlib_iteri fn init input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iteri_e, Stdlib.List.iteri" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq_e + (let acc = ref init in + M.iteri_e (IteriEOf.fn acc fn) (M.of_list input) >|? fun () -> !acc) + (Ok (with_stdlib_iteri fn init input))) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iteri_s, Stdlib.List.iteri" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq_s + (let acc = ref init in + M.iteri_s (IteriSOf.fn acc fn) (M.of_list input) >|= fun () -> !acc) + (Lwt.return @@ with_stdlib_iteri fn init input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iteri_es, Stdlib.List.iteri" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq_es + (let acc = ref init in + M.iteri_es (IteriESOf.fn acc fn) (M.of_list input) + >|=? fun () -> !acc) + (Lwt.return_ok @@ with_stdlib_iteri fn init input)) +end + module TestIterMonotoneAgainstStdlibList (M : sig include BASE with type 'a elt := int diff --git a/src/lib_lwt_result_stdlib/test/test_generic.ml b/src/lib_lwt_result_stdlib/test/test_generic.ml index 49fd33c579ea..87054a150879 100644 --- a/src/lib_lwt_result_stdlib/test/test_generic.ml +++ b/src/lib_lwt_result_stdlib/test/test_generic.ml @@ -45,6 +45,16 @@ module SeqGen = struct let up n = up n 0 end +module ListGen = struct + include Lwtreslib.List + + let rec down n : int t = if n < 0 then [] else n :: down (pred n) + + let rec up n i : int t = if i > n then [] else i :: up n (succ i) + + let up n = up n 0 +end + module Testing = struct exception Nope of int @@ -208,6 +218,7 @@ struct end module SeqIterTest = MakeItererTest (SeqGen) +module ListIterTest = MakeItererTest (ListGen) module MakeFolderTest (M : sig include GEN @@ -243,6 +254,7 @@ struct end module SeqFoldTest = MakeFolderTest (SeqGen) +module ListFoldTest = MakeFolderTest (ListGen) module MakeMapperTest (M : sig include GEN @@ -277,11 +289,15 @@ struct end module SeqMapTest = MakeMapperTest (SeqGen) +module ListMapTest = MakeMapperTest (ListGen) let () = Alcotest_lwt.run "traversor-generic" [ ("seq-iter", SeqIterTest.tests); ("seq-fold", SeqFoldTest.tests); - ("seq-map", SeqMapTest.tests) ] + ("seq-map", SeqMapTest.tests); + ("list-iter", ListIterTest.tests); + ("list-fold", ListFoldTest.tests); + ("list-map", ListMapTest.tests) ] |> Lwt_main.run diff --git a/src/lib_lwt_result_stdlib/test/test_list_basic.ml b/src/lib_lwt_result_stdlib/test/test_list_basic.ml new file mode 100644 index 000000000000..b9232d19624f --- /dev/null +++ b/src/lib_lwt_result_stdlib/test/test_list_basic.ml @@ -0,0 +1,300 @@ +(*****************************************************************************) +(* *) +(* 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 + +let assert_eq_s pa pb = + let open Lwt.Infix in + pa + >>= fun a -> + pb + >>= fun b -> + assert (a = b) ; + Lwt.return_unit + +let assert_err e = e = Error () + +let assert_err_s e = + let open Lwt.Infix in + e + >>= fun e -> + assert (e = Error ()) ; + Lwt.return_unit + +let assert_err_p e = + let open Lwt.Infix in + e + >>= fun e -> + assert (e = Error (make ())) ; + Lwt.return_unit + +let result_get = function Ok ok -> ok | Error _ -> assert false + +module ListGen = struct + include Lwtreslib.List + + let rec down n : int t = if n < 0 then [] else n :: down (pred n) + + let rec up n i : int t = if i > n then [] else i :: up n (succ i) + + let up n = up n 0 +end + +open ListGen + +module Nth = struct + let nth _ = + assert (nth (up 10) 0 = Some 0) ; + assert (nth (up 10) 1 = Some 1) ; + assert (nth (up 10) 7 = Some 7) ; + assert (nth (up 10) 10 = Some 10) ; + assert (nth (up 10) 11 = None) ; + assert (nth (up 10) 12 = None) ; + assert (nth [] 0 = None) ; + assert (nth [] 1 = None) ; + assert (nth (up 104) max_int = None) ; + assert (nth (up 104) (-1) = None) ; + assert (nth (up 1) (-100) = None) ; + assert (nth (up 0) (-100) = None) ; + () + + let tests = [Alcotest_lwt.test_case_sync "nth" `Quick nth] +end + +module Last = struct + let last _ = + assert (last (-1) [] = -1) ; + assert (last (-1) (up 0) = 0) ; + assert (last (-1) (up 10) = 10) ; + () + + let last_opt _ = + assert (last_opt [] = None) ; + assert (last_opt (up 0) = Some 0) ; + assert (last_opt (up 10) = Some 10) ; + () + + let tests = + [ Alcotest_lwt.test_case_sync "last" `Quick last; + Alcotest_lwt.test_case_sync "last_opt" `Quick last_opt ] +end + +module Init = struct + let init () = + assert (assert_err @@ init ~when_negative_length:() (-10) Fun.id) ; + assert (init ~when_negative_length:() 0 Fun.id = Ok []) ; + assert (init ~when_negative_length:() 11 Fun.id = Ok (up 10)) ; + () + + let init_e () = + assert (assert_err @@ init_e ~when_negative_length:() (-10) ok) ; + assert (init_e ~when_negative_length:() 0 ok = nil_e) ; + assert (init_e ~when_negative_length:() 11 ok = ok @@ up 10) ; + () + + let init_s _ () = + let open Lwt.Infix in + assert_err_s (init_s ~when_negative_length:() (-10) Lwt.return) + >>= fun () -> + assert_eq_s (init_s ~when_negative_length:() 0 Lwt.return) nil_es + >>= fun () -> + assert_eq_s + (init_s ~when_negative_length:() 11 Lwt.return) + (Lwt.return_ok @@ up 10) + >>= fun () -> Lwt.return_unit + + let init_es _ () = + let open Lwt.Infix in + assert_err_s (init_es ~when_negative_length:() (-10) Lwt.return_ok) + >>= fun () -> + assert_eq_s (init_es ~when_negative_length:() 0 Lwt.return_ok) nil_es + >>= fun () -> + assert_eq_s + (init_es ~when_negative_length:() 11 Lwt.return_ok) + (Lwt.return_ok @@ up 10) + >>= fun () -> Lwt.return_unit + + let init_p _ () = + let open Lwt.Infix in + assert_err_s (init_p ~when_negative_length:() (-10) Lwt.return) + >>= fun () -> + assert_eq_s (init_p ~when_negative_length:() 0 Lwt.return) nil_es + >>= fun () -> + assert_eq_s + (init_p ~when_negative_length:() 11 Lwt.return) + (Lwt.return_ok @@ up 10) + >>= fun () -> Lwt.return_unit + + let init_ep _ () = + let open Lwt.Infix in + assert_err_p (init_ep ~when_negative_length:() (-10) Lwt.return_ok) + >>= fun () -> + assert_eq_s (init_ep ~when_negative_length:() 0 Lwt.return_ok) nil_es + >>= fun () -> + assert_eq_s + (init_ep ~when_negative_length:() 11 Lwt.return_ok) + (Lwt.return_ok @@ up 10) + >>= fun () -> Lwt.return_unit + + let tests = + [ Alcotest_lwt.test_case_sync "init" `Quick init; + Alcotest_lwt.test_case_sync "init_e" `Quick init_e; + Alcotest_lwt.test_case "init_s" `Quick init_s; + Alcotest_lwt.test_case "init_es" `Quick init_es; + Alcotest_lwt.test_case "init_p" `Quick init_p; + Alcotest_lwt.test_case "init_ep" `Quick init_ep ] +end + +module FilterSmthg = struct + let cond x = x mod 2 = 0 + + let filter_some () = + assert (filter_some [] = []) ; + assert (filter_some [None] = []) ; + assert (filter_some [Some 0] = [0]) ; + assert ( + let base = up 17 in + let left = base |> filter cond in + let right = + base |> map (fun x -> if cond x then Some x else None) |> filter_some + in + left = right ) ; + () + + let filter_ok () = + assert (filter_ok [] = []) ; + assert (filter_ok [Error 10] = []) ; + assert (filter_ok [Ok 0] = [0]) ; + assert ( + let base = up 17 in + let left = base |> filter cond in + let right = + base + |> map (fun x -> if cond x then Ok x else Error (4 * x)) + |> filter_ok + in + left = right ) ; + () + + let filter_error () = + assert (filter_error [] = []) ; + assert (filter_error [Ok 10] = []) ; + assert (filter_error [Error 0] = [0]) ; + assert ( + let base = up 17 in + let left = base |> filter cond in + let right = + base + |> map (fun x -> if cond x then Error x else Ok (4 * x)) + |> filter_error + in + left = right ) ; + () + + let tests = + [ Alcotest_lwt.test_case_sync "filter_some" `Quick filter_some; + Alcotest_lwt.test_case_sync "filter_ok" `Quick filter_ok; + Alcotest_lwt.test_case_sync "filter_error" `Quick filter_error ] +end + +module Combine = struct + let combine_error () = + assert (combine ~when_different_lengths:() [] [0] = Error ()) ; + assert (combine ~when_different_lengths:() [0] [] = Error ()) ; + assert (combine ~when_different_lengths:() (up 100) (up 99) = Error ()) ; + () + + let combine_ok () = + assert (combine ~when_different_lengths:() [] [] = Ok []) ; + assert (combine ~when_different_lengths:() [0] [1] = Ok [(0, 1)]) ; + assert ( + combine ~when_different_lengths:() (up 100) (down 100) + = init ~when_negative_length:() 101 (fun i -> (i, 100 - i)) ) ; + () + + let combine_drop () = + assert (combine_drop [] [] = []) ; + assert ( + Ok (combine_drop (up 100) (down 100)) + = init ~when_negative_length:() 101 (fun i -> (i, 100 - i)) ) ; + assert (combine_drop [0] [1] = [(0, 1)]) ; + assert (combine_drop [] [0] = []) ; + assert (combine_drop [0] [] = []) ; + assert (combine_drop (up 100) (up 99) = map (fun i -> (i, i)) (up 99)) ; + () + + let combine_with_leftovers () = + assert (combine_with_leftovers [] [] = ([], None)) ; + assert ( + combine_with_leftovers (up 100) (down 100) + = ( result_get + @@ init ~when_negative_length:() 101 (fun i -> (i, 100 - i)), + None ) ) ; + assert (combine_with_leftovers [0] [1] = ([(0, 1)], None)) ; + assert (combine_with_leftovers [] [0] = ([], Some (`Right [0]))) ; + assert (combine_with_leftovers [0] [] = ([], Some (`Left [0]))) ; + assert ( + combine_with_leftovers (up 100) (up 99) + = (map (fun i -> (i, i)) (up 99), Some (`Left [100])) ) ; + () + + let tests = + [ Alcotest_lwt.test_case_sync "combine-error" `Quick combine_error; + Alcotest_lwt.test_case_sync "combine-ok" `Quick combine_ok; + Alcotest_lwt.test_case_sync "combine_drop" `Quick combine_drop; + Alcotest_lwt.test_case_sync + "combine_with_leftovers" + `Quick + combine_with_leftovers ] +end + +module Partition = struct + let cond x = x mod 2 = 0 + + let partition_result () = + assert (partition_result [] = ([], [])) ; + assert (partition_result [Ok 0] = ([0], [])) ; + assert (partition_result [Error 0] = ([], [0])) ; + assert (partition_result (map ok (up 11)) = (up 11, [])) ; + assert (partition_result (map (fun x -> Error x) (up 11)) = ([], up 11)) ; + assert ( + let input = map (fun x -> if cond x then Ok x else Error x) (up 101) in + partition_result input = (filter_ok input, filter_error input) ) ; + () + + let tests = + [Alcotest_lwt.test_case_sync "partition-result" `Quick partition_result] +end + +let () = + Alcotest_lwt.run + "list-basic" + [ ("nth", Nth.tests); + ("last", Last.tests); + ("init", Init.tests); + ("filter_*", FilterSmthg.tests); + ("combine_*", Combine.tests); + ("partition_*", Partition.tests) ] + |> Lwt_main.run diff --git a/src/lib_lwt_result_stdlib/test/traits.ml b/src/lib_lwt_result_stdlib/test/traits.ml index 09e3700f4247..93a1cc883523 100644 --- a/src/lib_lwt_result_stdlib/test/traits.ml +++ b/src/lib_lwt_result_stdlib/test/traits.ml @@ -70,6 +70,28 @@ module type ITER_PARALLEL = sig (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 -- GitLab From 10eb4714b0a9e227cc926df8f0708d82b12f63ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 29 Jun 2020 10:32:04 +0200 Subject: [PATCH 4/5] Crypto: unshadow Stdlib's List in PVSS --- src/lib_crypto/pvss.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/lib_crypto/pvss.ml b/src/lib_crypto/pvss.ml index ba01b111fb87..e9ba83a2a638 100644 --- a/src/lib_crypto/pvss.ml +++ b/src/lib_crypto/pvss.ml @@ -23,6 +23,9 @@ (* *) (*****************************************************************************) +(* We reshadow the List module with Stdlib's because there are many safe uses of + double-list traversors *) +module List = Stdlib.List module H = Blake2B (** Polynomial ring (ℤ/qℤ)[X] *) -- GitLab From 02628a6e9c86f4922d26260db52ac420f0652bb0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 14 Jul 2020 14:19:17 +0200 Subject: [PATCH 5/5] Crypto: adapt to new shadows --- src/lib_crypto/blake2B.ml | 8 ++++---- src/lib_crypto/test/dune | 1 + src/lib_crypto/test/test_hacl.ml | 9 ++++++++- src/lib_crypto/test/test_pvss.ml | 3 +++ 4 files changed, 16 insertions(+), 5 deletions(-) diff --git a/src/lib_crypto/blake2B.ml b/src/lib_crypto/blake2B.ml index 70cac2bd886a..4d4ac3faa85b 100644 --- a/src/lib_crypto/blake2B.ml +++ b/src/lib_crypto/blake2B.ml @@ -255,8 +255,8 @@ struct H.empty | [x] -> H.leaf x - | _ :: _ :: _ -> - let last = TzList.last_exn xs in + | _ :: one :: rest -> + let last = List.last one rest in let n = List.length xs in let a = Array.make (n + 1) (H.leaf last) in List.iteri (fun i x -> a.(i) <- H.leaf x) xs ; @@ -285,8 +285,8 @@ struct invalid_arg "compute_path" | [_] -> Op - | _ :: _ :: _ -> - let last = TzList.last_exn xs in + | _ :: one :: rest -> + let last = List.last one rest in let n = List.length xs in if i < 0 || n <= i then invalid_arg "compute_path" ; let a = Array.make (n + 1) (H.leaf last) in diff --git a/src/lib_crypto/test/dune b/src/lib_crypto/test/dune index b614a71f62b4..626aa8925676 100644 --- a/src/lib_crypto/test/dune +++ b/src/lib_crypto/test/dune @@ -16,6 +16,7 @@ alcotest-lwt) (flags (:standard -open Tezos_stdlib -open Tezos_crypto + -open Tezos_lwt_result_stdlib.Lwtreslib -open Data_encoding))) (rule diff --git a/src/lib_crypto/test/test_hacl.ml b/src/lib_crypto/test/test_hacl.ml index 2932fa18e963..22a1295a10c2 100644 --- a/src/lib_crypto/test/test_hacl.ml +++ b/src/lib_crypto/test/test_hacl.ml @@ -407,9 +407,11 @@ let test_vectors_p256 () = block) Vectors_p256.sigs in - List.iter2 + List.iter2_e + ~when_different_lengths:() (fun (sk, pk) sigs -> List.iter2 + ~when_different_lengths:() (fun msg s -> assert (verify ~pk ~msg ~signature:s) ; let signature = sign ~sk ~msg in @@ -418,6 +420,11 @@ let test_vectors_p256 () = sigs) keys expected_sigs + |> function + | Ok () -> + () + | Error () -> + failwith "unequal number of keys, messages, and signatures" let p256 = [ ("export", `Quick, test_export_p256); diff --git a/src/lib_crypto/test/test_pvss.ml b/src/lib_crypto/test/test_pvss.ml index 93d6916c24e1..5f35153896dd 100644 --- a/src/lib_crypto/test/test_pvss.ml +++ b/src/lib_crypto/test/test_pvss.ml @@ -30,6 +30,9 @@ Subject: On Publicly Verifiable Secret Sharing [Schoenmakers, 1999] *) +(* We reshadow the List module with Stdlib's because there are many safe uses of + double-list traversors *) +module List = Stdlib.List module Pvss = Pvss_secp256k1 module Sp = Secp256k1_group -- GitLab