From 1268e8501f98413b4e326f9f73153120f42c3f35 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 22 May 2020 14:57:44 +0100 Subject: [PATCH 1/6] Lwtreslib: Hastbl --- src/lib_error_monad/test/dune | 19 -- src/lib_lwt_result_stdlib/functors/hashtbl.ml | 140 ++++++++++++ .../functors/hashtbl.mli | 34 +++ src/lib_lwt_result_stdlib/lib/hashtbl.ml | 26 +++ src/lib_lwt_result_stdlib/lib/hashtbl.mli | 33 +++ src/lib_lwt_result_stdlib/lwtreslib.ml | 1 + src/lib_lwt_result_stdlib/lwtreslib.mli | 2 + src/lib_lwt_result_stdlib/sigs/hashtbl.ml | 206 ++++++++++++++++++ src/lib_lwt_result_stdlib/test/.ocamlformat | 12 + .../test/assert.ml | 0 src/lib_lwt_result_stdlib/test/dune | 20 ++ .../test/test_hashtbl.ml} | 80 ++++--- .../tezos-lwt-result-stdlib.opam | 1 + 13 files changed, 514 insertions(+), 60 deletions(-) delete mode 100644 src/lib_error_monad/test/dune create mode 100644 src/lib_lwt_result_stdlib/functors/hashtbl.ml create mode 100644 src/lib_lwt_result_stdlib/functors/hashtbl.mli create mode 100644 src/lib_lwt_result_stdlib/lib/hashtbl.ml create mode 100644 src/lib_lwt_result_stdlib/lib/hashtbl.mli create mode 100644 src/lib_lwt_result_stdlib/sigs/hashtbl.ml create mode 100644 src/lib_lwt_result_stdlib/test/.ocamlformat rename src/{lib_error_monad => lib_lwt_result_stdlib}/test/assert.ml (100%) create mode 100644 src/lib_lwt_result_stdlib/test/dune rename src/{lib_error_monad/test/test_error_tables.ml => lib_lwt_result_stdlib/test/test_hashtbl.ml} (72%) diff --git a/src/lib_error_monad/test/dune b/src/lib_error_monad/test/dune deleted file mode 100644 index 34250ff973a6..000000000000 --- a/src/lib_error_monad/test/dune +++ /dev/null @@ -1,19 +0,0 @@ -(executables - (names test_error_tables) - (libraries tezos-error-monad - lwt.unix - alcotest-lwt) - (flags (:standard -open Tezos_error_monad))) - -(alias - (name buildtest) - (deps test_error_tables.exe)) - -(alias - (name runtest_error_tables) - (action (run %{exe:test_error_tables.exe}))) - -(alias - (name runtest) - (package tezos-error-monad) - (deps (alias runtest_error_tables))) diff --git a/src/lib_lwt_result_stdlib/functors/hashtbl.ml b/src/lib_lwt_result_stdlib/functors/hashtbl.ml new file mode 100644 index 000000000000..5674bddbf4fa --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.ml @@ -0,0 +1,140 @@ +(*****************************************************************************) +(* *) +(* 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 (Seq : Sigs.Seq.S) = struct + module type S = Sigs.Hashtbl.S with type error := Seq.Monad.out_error + + module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t = struct + open Seq + include Stdlib.Hashtbl.Make (H) + + let iter_e f t = iter_e (fun (k, v) -> f k v) (to_seq t) + + let iter_s f t = iter_s (fun (k, v) -> f k v) (to_seq t) + + let iter_es f t = iter_es (fun (k, v) -> f k v) (to_seq t) + + let iter_p f t = iter_p (fun (k, v) -> f k v) (to_seq t) + + let iter_ep f t = iter_ep (fun (k, v) -> f k v) (to_seq t) + + let fold_e f t init = + fold_left_e (fun acc (k, v) -> f k v acc) init (to_seq t) + + let fold_s f t init = + fold_left_s (fun acc (k, v) -> f k v acc) init (to_seq t) + + let fold_es f t init = + fold_left_es (fun acc (k, v) -> f k v acc) init (to_seq t) + + let find = find_opt + + let try_map_inplace f t = + filter_map_inplace + (fun k v -> match f k v with Error _ -> None | Ok r -> Some r) + t + end + + module type S_LWT = Sigs.Hashtbl.S_LWT with type error := Seq.Monad.out_error + + module Make_Lwt (H : Stdlib.Hashtbl.HashedType) : S_LWT with type key = H.t = + struct + open Seq + open Seq.Monad + module T = Stdlib.Hashtbl.Make (H) + + type key = H.t + + type 'a t = ('a, Seq.Monad.out_error) result Lwt.t T.t + + let create n = T.create n + + let clear t = + T.iter (fun _ a -> Lwt.cancel a) t ; + T.clear t + + let reset t = + T.iter (fun _ a -> Lwt.cancel a) t ; + T.reset t + + let find_or_make t k make = + match T.find_opt t k with + | Some a -> + a + | None -> + let p = Lwt.apply make () in + ( match Lwt.state p with + | Return (Ok _) -> + T.add t k p + | Return (Error _) -> + () + | Fail _ -> + () + | Sleep -> + T.add t k p ; + Lwt.on_any + p + (function Ok _ -> () | Error _ -> T.remove t k) + (fun _ -> T.remove t k) ) ; + p + + let find t k = T.find_opt t k + + let remove t k = + (match T.find_opt t k with None -> () | Some a -> Lwt.cancel a) ; + T.remove t k + + let mem t k = T.mem t k + + let iter_es f t = iter_es (fun (k, v) -> v >>=? f k) (T.to_seq t) + + let iter_ep f t = iter_ep (fun (k, v) -> v >>=? f k) (T.to_seq t) + + let fold_es f t init = + fold_left_es + (fun acc (k, v) -> v >>=? fun vv -> f k vv acc) + init + (T.to_seq t) + + let fold_keys f t init = T.fold (fun k _ acc -> f k acc) t init + + let fold_promises f t init = T.fold f t init + + let fold_resolved f t init = + T.fold + (fun k p acc -> + match Lwt.state p with + | Lwt.Return (Ok v) -> + f k v acc + | Lwt.Return (Error _) | Lwt.Fail _ | Lwt.Sleep -> + acc) + t + init + + let length t = T.length t + + let stats t = T.stats t + end +end diff --git a/src/lib_lwt_result_stdlib/functors/hashtbl.mli b/src/lib_lwt_result_stdlib/functors/hashtbl.mli new file mode 100644 index 000000000000..39c5b7db0591 --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.mli @@ -0,0 +1,34 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module Make (Seq : Sigs.Seq.S) : sig + module type S = Sigs.Hashtbl.S with type error := Seq.Monad.out_error + + module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t + + module type S_LWT = Sigs.Hashtbl.S_LWT with type error := Seq.Monad.out_error + + module Make_Lwt (H : Stdlib.Hashtbl.HashedType) : S_LWT with type key = H.t +end diff --git a/src/lib_lwt_result_stdlib/lib/hashtbl.ml b/src/lib_lwt_result_stdlib/lib/hashtbl.ml new file mode 100644 index 000000000000..13033733a770 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/hashtbl.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.Hashtbl.Make (Seq) diff --git a/src/lib_lwt_result_stdlib/lib/hashtbl.mli b/src/lib_lwt_result_stdlib/lib/hashtbl.mli new file mode 100644 index 000000000000..e814f6a146c5 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/hashtbl.mli @@ -0,0 +1,33 @@ +(*****************************************************************************) +(* *) +(* 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 type S = Sigs.Hashtbl.S with type error := Error_monad.error list + +module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t + +module type S_LWT = + Sigs.Hashtbl.S_LWT with type error := Error_monad.error list + +module Make_Lwt (H : Stdlib.Hashtbl.HashedType) : S_LWT with type key = H.t diff --git a/src/lib_lwt_result_stdlib/lwtreslib.ml b/src/lib_lwt_result_stdlib/lwtreslib.ml index 7d29527fa227..a40eb489f321 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.ml +++ b/src/lib_lwt_result_stdlib/lwtreslib.ml @@ -26,3 +26,4 @@ module Seq = Lib.Seq module Set = Lib.Set module Map = Lib.Map +module Hashtbl = Lib.Hashtbl diff --git a/src/lib_lwt_result_stdlib/lwtreslib.mli b/src/lib_lwt_result_stdlib/lwtreslib.mli index bc57a9b6e44b..4f2865c1862c 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.mli +++ b/src/lib_lwt_result_stdlib/lwtreslib.mli @@ -50,3 +50,5 @@ module Seq : module type of Lib.Seq module Set : module type of Lib.Set module Map : module type of Lib.Map + +module Hashtbl : module type of Lib.Hashtbl diff --git a/src/lib_lwt_result_stdlib/sigs/hashtbl.ml b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml new file mode 100644 index 000000000000..846fc42e1092 --- /dev/null +++ b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml @@ -0,0 +1,206 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** Modules with the signature [S] are safe (e.g., [find] uses [option] rather + than raising [Not_found]) extensions of [Hashtbl.S] with some Lwt- and + Error-aware traversal functions. *) +module type S = sig + type error + + type key + + type 'a t + + val create : int -> 'a t + + val clear : 'a t -> unit + + val reset : 'a t -> unit + + val add : 'a t -> key -> 'a -> unit + + val remove : 'a t -> key -> unit + + val find : 'a t -> key -> 'a option + + val find_all : 'a t -> key -> 'a list + + val replace : 'a t -> key -> 'a -> unit + + val mem : 'a t -> key -> bool + + val iter : (key -> 'a -> unit) -> 'a t -> unit + + val iter_s : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t + + val iter_p : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t + + val iter_e : + (key -> 'a -> (unit, error) result) -> 'a t -> (unit, error) result + + val iter_es : + (key -> 'a -> (unit, error) result Lwt.t) -> + 'a t -> + (unit, error) result Lwt.t + + val iter_ep : + (key -> 'a -> (unit, error) result Lwt.t) -> + 'a t -> + (unit, error) result Lwt.t + + val filter_map_inplace : (key -> 'a -> 'a option) -> 'a t -> unit + + val try_map_inplace : (key -> 'a -> ('a, error) result) -> 'a t -> unit + + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + + val fold_s : (key -> 'a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t + + val fold_e : + (key -> 'a -> 'b -> ('b, error) result) -> 'a t -> 'b -> ('b, error) result + + val fold_es : + (key -> 'a -> 'b -> ('b, error) result Lwt.t) -> + 'a t -> + 'b -> + ('b, error) result Lwt.t + + val length : 'a t -> int + + val stats : 'a t -> Stdlib.Hashtbl.statistics + + val to_seq : 'a t -> (key * 'a) Stdlib.Seq.t + + val to_seq_keys : _ t -> key Stdlib.Seq.t + + val to_seq_values : 'a t -> 'a Stdlib.Seq.t + + val add_seq : 'a t -> (key * 'a) Stdlib.Seq.t -> unit + + val replace_seq : 'a t -> (key * 'a) Stdlib.Seq.t -> unit + + val of_seq : (key * 'a) Stdlib.Seq.t -> 'a t +end + +(** Modules with the signature [S_LWT] are Hashtbl-like with the following + differences: + + First, the module exports only a few functions in an attempt to limit the + likelihood of race-conditions. Of particular interest is the following: in + order to insert a value, one has to use `find_or_make` which either returns + an existing promise for a value bound to the given key, or makes such a + promise. It is not possible to insert another value for an existing key. + + Second, the table is automatically cleaned. Specifically, when a promise for + a value is fulfilled with an [Error _], the binding is removed. This leads + to the following behavior: + + [ + (* setup *) + let t = create 256 in + let () = assert (fold_keys (fun _ acc -> succ acc) t 0 = 0) in + + (* insert a first promise for a value *) + let p, r = Lwt.task () in + let i1 = find_or_make t 1 (fun () -> p) in + let () = assert (fold_keys (fun _ acc -> succ acc) t 0 = 1) in + + (* because the same key is used, the promise is not inserted. *) + let i2 = find_or_make t 1 (fun () -> assert false) in + let () = assert (fold_keys (fun _ acc -> succ acc) t 0 = 1) in + + (* when the original promise errors, the binding is removed *) + let () = Lwt.wakeup r (Error ..) in + let () = assert (fold_keys (fun _ acc -> succ acc) t 0 = 0) in + + (* and both the [find_or_make] promises have the error *) + let () = match Lwt.state i1 with + | Return (Error ..) -> () + | _ -> assert false + in + let () = match Lwt.state i2 with + | Return (Error ..) -> () + | _ -> assert false + in + ] + + This automatic cleaning relieves the user from the responsibility of + cleaning the table (which is another possible source of race condition). + + Third, every time a promise is removed from the table (be it by [clean], + [reset], or just [remove]), the promise is canceled. +*) +module type S_LWT = sig + type error + + type key + + type 'a t + + val create : int -> 'a t + + val clear : 'a t -> unit + + val reset : 'a t -> unit + + val find_or_make : + 'a t -> + key -> + (unit -> ('a, error) result Lwt.t) -> + ('a, error) result Lwt.t + + val remove : 'a t -> key -> unit + + val find : 'a t -> key -> ('a, error) result Lwt.t option + + val mem : 'a t -> key -> bool + + val iter_es : + (key -> 'a -> (unit, error) result Lwt.t) -> + 'a t -> + (unit, error) result Lwt.t + + val iter_ep : + (key -> 'a -> (unit, error) result Lwt.t) -> + 'a t -> + (unit, error) result Lwt.t + + val fold_es : + (key -> 'a -> 'b -> ('b, error) result Lwt.t) -> + 'a t -> + 'b -> + ('b, error) result Lwt.t + + val fold_keys : (key -> 'b -> 'b) -> 'a t -> 'b -> 'b + + val fold_promises : + (key -> ('a, error) result Lwt.t -> 'b -> 'b) -> 'a t -> 'b -> 'b + + val fold_resolved : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + + val length : 'a t -> int + + val stats : 'a t -> Stdlib.Hashtbl.statistics +end diff --git a/src/lib_lwt_result_stdlib/test/.ocamlformat b/src/lib_lwt_result_stdlib/test/.ocamlformat new file mode 100644 index 000000000000..8278a132e3d6 --- /dev/null +++ b/src/lib_lwt_result_stdlib/test/.ocamlformat @@ -0,0 +1,12 @@ +version=0.10 +wrap-fun-args=false +let-binding-spacing=compact +field-space=loose +break-separators=after-and-docked +sequence-style=separator +doc-comments=before +margin=80 +module-item-spacing=sparse +parens-tuple=always +parens-tuple-patterns=always +break-string-literals=newlines-and-wrap diff --git a/src/lib_error_monad/test/assert.ml b/src/lib_lwt_result_stdlib/test/assert.ml similarity index 100% rename from src/lib_error_monad/test/assert.ml rename to src/lib_lwt_result_stdlib/test/assert.ml diff --git a/src/lib_lwt_result_stdlib/test/dune b/src/lib_lwt_result_stdlib/test/dune new file mode 100644 index 000000000000..2eaac865f285 --- /dev/null +++ b/src/lib_lwt_result_stdlib/test/dune @@ -0,0 +1,20 @@ +(executables + (names test_hashtbl) + (libraries tezos-lwt-result-stdlib + tezos-error-monad + lwt.unix + alcotest-lwt) + (flags (:standard -open Tezos_lwt_result_stdlib))) + +(alias + (name buildtest) + (deps test_hashtbl.exe)) + +(alias + (name runtest_hashtbl) + (action (run %{exe:test_hashtbl.exe}))) + +(alias + (name runtest) + (package tezos-lwt-result-stdlib) + (deps (alias runtest_hashtbl))) diff --git a/src/lib_error_monad/test/test_error_tables.ml b/src/lib_lwt_result_stdlib/test/test_hashtbl.ml similarity index 72% rename from src/lib_error_monad/test/test_error_tables.ml rename to src/lib_lwt_result_stdlib/test/test_hashtbl.ml index 942999e18c3c..9808047f1600 100644 --- a/src/lib_error_monad/test/test_error_tables.ml +++ b/src/lib_lwt_result_stdlib/test/test_hashtbl.ml @@ -23,19 +23,19 @@ (* *) (*****************************************************************************) -open Lwt.Infix +open Tezos_error_monad.Error_monad -module IntErrorTable = Error_table.Make (Hashtbl.Make (struct +module IntLwtHashtbl = Lwtreslib.Hashtbl.Make_Lwt (struct type t = int let equal x y = x = y let hash x = x -end)) +end) let test_add_remove _ _ = - let t = IntErrorTable.create 2 in - IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 0) + let t = IntLwtHashtbl.create 2 in + IntLwtHashtbl.find_or_make t 0 (fun () -> return 0) >>= function | Error _ -> Assert.fail "Ok 0" "Error _" "find_or_make" @@ -43,89 +43,88 @@ let test_add_remove _ _ = if not (n = 0) then Assert.fail "Ok 0" (Format.asprintf "Ok %d" n) "find_or_make" else - match IntErrorTable.find_opt t 0 with + match IntLwtHashtbl.find t 0 with | None -> - Assert.fail "Some (Ok 0)" "None" "find_opt" + Assert.fail "Some (Ok 0)" "None" "find" | Some p -> ( p >>= function | Error _ -> - Assert.fail "Some (Ok 0)" "Some (Error _)" "find_opt" + Assert.fail "Some (Ok 0)" "Some (Error _)" "find" | Ok n -> if not (n = 0) then Assert.fail "Some (Ok 0)" (Format.asprintf "Some (Ok %d)" n) - "find_opt" + "find" else ( - IntErrorTable.remove t 0 ; - match IntErrorTable.find_opt t 0 with + IntLwtHashtbl.remove t 0 ; + match IntLwtHashtbl.find t 0 with | Some _ -> - Assert.fail "None" "Some _" "remove;find_opt" + Assert.fail "None" "Some _" "remove;find" | None -> Lwt.return_unit ) ) ) let test_add_add _ _ = - let t = IntErrorTable.create 2 in - IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 0) + let t = IntLwtHashtbl.create 2 in + IntLwtHashtbl.find_or_make t 0 (fun () -> return 0) >>= fun _ -> - IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 1) + IntLwtHashtbl.find_or_make t 0 (fun () -> return 1) >>= fun _ -> - match IntErrorTable.find_opt t 0 with + match IntLwtHashtbl.find t 0 with | None -> - Assert.fail "Some (Ok 0)" "None" "find_opt" + Assert.fail "Some (Ok 0)" "None" "find" | Some p -> ( p >>= function | Error _ -> - Assert.fail "Some (Ok 0)" "Some (Error _)" "find_opt" + Assert.fail "Some (Ok 0)" "Some (Error _)" "find" | Ok n -> if not (n = 0) then - Assert.fail - "Some (Ok 0)" - (Format.asprintf "Some (Ok %d)" n) - "find_opt" + Assert.fail "Some (Ok 0)" (Format.asprintf "Some (Ok %d)" n) "find" else Lwt.return_unit ) let test_length _ _ = - let t = IntErrorTable.create 2 in - IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 0) + let t = IntLwtHashtbl.create 2 in + IntLwtHashtbl.find_or_make t 0 (fun () -> return 0) >>= fun _ -> - IntErrorTable.find_or_make t 1 (fun () -> Error_monad.return 1) + IntLwtHashtbl.find_or_make t 1 (fun () -> return 1) >>= fun _ -> - IntErrorTable.find_or_make t 2 (fun () -> Error_monad.return 2) + IntLwtHashtbl.find_or_make t 2 (fun () -> return 2) >>= fun _ -> - IntErrorTable.find_or_make t 3 (fun () -> Error_monad.return 3) + IntLwtHashtbl.find_or_make t 3 (fun () -> return 3) >>= fun _ -> - let l = IntErrorTable.length t in + let l = IntLwtHashtbl.length t in if not (l = 4) then Assert.fail "4" (Format.asprintf "%d" l) "length" else Lwt.return_unit let test_self_clean _ _ = - let t = IntErrorTable.create 2 in - IntErrorTable.find_or_make t 0 (fun () -> Lwt.return (Ok 0)) + let t = IntLwtHashtbl.create 2 in + IntLwtHashtbl.find_or_make t 0 (fun () -> Lwt.return (Ok 0)) >>= fun _ -> - IntErrorTable.find_or_make t 1 (fun () -> Lwt.return (Error [])) + IntLwtHashtbl.find_or_make t 1 (fun () -> Lwt.return (Error [])) >>= fun _ -> - IntErrorTable.find_or_make t 2 (fun () -> Lwt.return (Error [])) + IntLwtHashtbl.find_or_make t 2 (fun () -> Lwt.return (Error [])) >>= fun _ -> - IntErrorTable.find_or_make t 3 (fun () -> Lwt.return (Ok 3)) + IntLwtHashtbl.find_or_make t 3 (fun () -> Lwt.return (Ok 3)) >>= fun _ -> - IntErrorTable.find_or_make t 4 (fun () -> Lwt.return (Ok 4)) + IntLwtHashtbl.find_or_make t 4 (fun () -> Lwt.return (Ok 4)) >>= fun _ -> - IntErrorTable.find_or_make t 5 (fun () -> Lwt.return (Error [])) + IntLwtHashtbl.find_or_make t 5 (fun () -> Lwt.return (Error [])) >>= fun _ -> - let l = IntErrorTable.length t in + IntLwtHashtbl.find_or_make t 6 (fun () -> Lwt.fail Not_found) + >>= fun _ -> + let l = IntLwtHashtbl.length t in if not (l = 3) then Assert.fail "3" (Format.asprintf "%d" l) "length" else Lwt.return_unit let test_order _ _ = - let t = IntErrorTable.create 2 in + let t = IntLwtHashtbl.create 2 in let (wter, wker) = Lwt.task () in let world = ref [] in (* PROMISE A *) let p_a = - IntErrorTable.find_or_make t 0 (fun () -> + IntLwtHashtbl.find_or_make t 0 (fun () -> wter >>= fun r -> world := "a_inner" :: !world ; @@ -138,7 +137,7 @@ let test_order _ _ = >>= fun () -> (* PROMISE B *) let p_b = - IntErrorTable.find_or_make t 0 (fun () -> + IntLwtHashtbl.find_or_make t 0 (fun () -> world := "b_inner" :: !world ; Lwt.return (Ok 1024)) >>= fun r_b -> @@ -185,5 +184,4 @@ let tests = Alcotest_lwt.test_case "self_clean" `Quick test_length; Alcotest_lwt.test_case "order" `Quick test_order ] -let () = - Alcotest_lwt.run "error_tables" [("error_tables", tests)] |> Lwt_main.run +let () = Alcotest_lwt.run "hashtbl" [("hashtbl-lwt", tests)] |> Lwt_main.run diff --git a/src/lib_lwt_result_stdlib/tezos-lwt-result-stdlib.opam b/src/lib_lwt_result_stdlib/tezos-lwt-result-stdlib.opam index 2a428934eeb6..6fb5f31fa4f5 100644 --- a/src/lib_lwt_result_stdlib/tezos-lwt-result-stdlib.opam +++ b/src/lib_lwt_result_stdlib/tezos-lwt-result-stdlib.opam @@ -11,6 +11,7 @@ depends: [ "ocaml" { >= "4.07" } "tezos-error-monad" "lwt" + "alcotest-lwt" { with-test & >= "1.1.0" } ] build: [ ["dune" "build" "-p" name "-j" jobs] -- GitLab From f48af45fb0e72ec5cdae9114888a5466a80ebf88 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 22 May 2020 15:32:51 +0100 Subject: [PATCH 2/6] Error_monad: remove Error_table, use Lwtreslib.Hashtbl.S_LWT instead --- src/lib_base/p2p_peer.mli | 3 +- src/lib_crypto/dune | 1 + src/lib_crypto/helpers.ml | 2 +- src/lib_crypto/s.ml | 2 +- src/lib_crypto/tezos-crypto.opam | 1 + src/lib_error_monad/error_table.ml | 144 --------------------- src/lib_error_monad/error_table.mli | 104 --------------- src/lib_error_monad/test/.ocamlformat | 12 -- src/lib_error_monad/tezos-error-monad.opam | 1 - src/lib_shell/chain_validator.ml | 2 +- 10 files changed, 7 insertions(+), 265 deletions(-) delete mode 100644 src/lib_error_monad/error_table.ml delete mode 100644 src/lib_error_monad/error_table.mli delete mode 100644 src/lib_error_monad/test/.ocamlformat diff --git a/src/lib_base/p2p_peer.mli b/src/lib_base/p2p_peer.mli index 7810d9add6cb..90db74a55fbd 100644 --- a/src/lib_base/p2p_peer.mli +++ b/src/lib_base/p2p_peer.mli @@ -28,7 +28,8 @@ module Map = Id.Map module Set = Id.Set module Table = Id.Table -module Error_table : Error_table.S with type key = Table.key +module Error_table : + Tezos_lwt_result_stdlib.Lwtreslib.Hashtbl.S_LWT with type key = Table.key module Filter : sig type t = Accepted | Running | Disconnected diff --git a/src/lib_crypto/dune b/src/lib_crypto/dune index cc86fd7b8143..793b9a17e800 100644 --- a/src/lib_crypto/dune +++ b/src/lib_crypto/dune @@ -8,6 +8,7 @@ (libraries tezos-stdlib data-encoding tezos-error-monad + tezos-lwt-result-stdlib tezos-rpc lwt hacl-star diff --git a/src/lib_crypto/helpers.ml b/src/lib_crypto/helpers.ml index 7e4212b8f5e0..268b1ef6d45a 100644 --- a/src/lib_crypto/helpers.ml +++ b/src/lib_crypto/helpers.ml @@ -257,7 +257,7 @@ struct end module Error_table = struct - include Error_table.Make (Table) + include Tezos_lwt_result_stdlib.Lwtreslib.Hashtbl.Make_Lwt (H) end module WeakRingTable = struct diff --git a/src/lib_crypto/s.ml b/src/lib_crypto/s.ml index f7d5359f70d4..2a43d4d74d1a 100644 --- a/src/lib_crypto/s.ml +++ b/src/lib_crypto/s.ml @@ -169,7 +169,7 @@ module type INDEXES = sig end module Error_table : sig - include Error_table.S with type key = t + include Tezos_lwt_result_stdlib.Lwtreslib.Hashtbl.S_LWT with type key = t end module WeakRingTable : sig diff --git a/src/lib_crypto/tezos-crypto.opam b/src/lib_crypto/tezos-crypto.opam index cb870b85a4a8..f4792c54a410 100644 --- a/src/lib_crypto/tezos-crypto.opam +++ b/src/lib_crypto/tezos-crypto.opam @@ -11,6 +11,7 @@ depends: [ "tezos-stdlib" "data-encoding" { = "0.2" } "tezos-error-monad" + "tezos-lwt-result-stdlib" "tezos-rpc" "tezos-clic" "lwt" diff --git a/src/lib_error_monad/error_table.ml b/src/lib_error_monad/error_table.ml deleted file mode 100644 index 6422e0fff378..000000000000 --- a/src/lib_error_monad/error_table.ml +++ /dev/null @@ -1,144 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 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 Error_monad - -module type S = sig - type key - - type 'a t - - val create : int -> 'a t - - val clear : 'a t -> unit - - val reset : 'a t -> unit - - val find_or_make : - 'a t -> key -> (unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t - - val remove : 'a t -> key -> unit - - val find_opt : 'a t -> key -> 'a tzresult Lwt.t option - - val mem : 'a t -> key -> bool - - val iter_s : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t - - val iter_p : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t - - val fold : (key -> 'a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t - - val fold_promises : - (key -> 'a tzresult Lwt.t -> 'b -> 'b) -> 'a t -> 'b -> 'b - - val fold_resolved : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - - val fold_keys : (key -> 'b -> 'b) -> 'a t -> 'b -> 'b - - val length : 'a t -> int -end - -module Make (T : Hashtbl.S) : S with type key = T.key = struct - type key = T.key - - type 'a t = {table : 'a tzresult Lwt.t T.t; cleaners : unit Lwt.t T.t} - - let create n = {table = T.create n; cleaners = T.create n} - - let clear t = - T.iter (fun _ cleaner -> Lwt.cancel cleaner) t.cleaners ; - T.iter (fun _ a -> Lwt.cancel a) t.table ; - T.clear t.cleaners ; - T.clear t.table - - let reset t = - T.iter (fun _ cleaner -> Lwt.cancel cleaner) t.cleaners ; - T.iter (fun _ a -> Lwt.cancel a) t.table ; - T.reset t.cleaners ; - T.reset t.table - - let find_or_make t k i = - match T.find_opt t.table k with - | Some a -> - a - | None -> - let p = i () in - T.add t.table k p ; - T.add - t.cleaners - k - ( p - >>= function - | Ok _ -> - T.remove t.cleaners k ; Lwt.return_unit - | Error _ -> - T.remove t.table k ; T.remove t.cleaners k ; Lwt.return_unit ) ; - p - - let remove t k = - (match T.find_opt t.cleaners k with None -> () | Some a -> Lwt.cancel a) ; - T.remove t.cleaners k ; - (match T.find_opt t.table k with None -> () | Some a -> Lwt.cancel a) ; - T.remove t.table k - - let find_opt t k = T.find_opt t.table k - - let mem t k = T.mem t.table k - - let iter_s f t = - T.fold (fun k a acc -> (k, a) :: acc) t.table [] - |> Lwt_list.iter_s (fun (k, a) -> - a >>= function Error _ -> Lwt.return_unit | Ok a -> f k a) - - let iter_p f t = - T.fold (fun k a acc -> (k, a) :: acc) t.table [] - |> Lwt_list.iter_p (fun (k, a) -> - a >>= function Error _ -> Lwt.return_unit | Ok a -> f k a) - - let fold f t acc = - T.fold (fun k a acc -> (k, a) :: acc) t.table [] - |> Lwt_list.fold_left_s - (fun acc (k, a) -> - a >>= function Error _ -> Lwt.return acc | Ok a -> f k a acc) - acc - - let fold_promises f t acc = T.fold f t.table acc - - let fold_resolved f t acc = - T.fold - (fun k a acc -> - match Lwt.state a with - | Lwt.Sleep | Lwt.Fail _ | Lwt.Return (Error _) -> - acc - | Lwt.Return (Ok a) -> - f k a acc) - t.table - acc - - let fold_keys f t acc = T.fold (fun k _ acc -> f k acc) t.table acc - - let length t = T.length t.table -end diff --git a/src/lib_error_monad/error_table.mli b/src/lib_error_monad/error_table.mli deleted file mode 100644 index 7594c352e52f..000000000000 --- a/src/lib_error_monad/error_table.mli +++ /dev/null @@ -1,104 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 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 Error_monad - -module type S = sig - (** This is mostly [Hashtbl.S] with the following differences: - - Looking up an element and creating an element to insert in the table are - the same operations. In other words: - - The function [find_or_make t k gen] behaves in two separate ways - depending if an element is already bound to key [k] in table [t]. - - If an element is bound, then it is returned. - - Otherwise, an element is generated using the [gen] function and recorded - in the table. - - The table does not record elements per se. Instead it records promises of - results of elements. This means that [find_or_make t k gen] is a value - within the lwt-error monad. - - The table automatically cleans itself of errors. Specifically, when one of - the promises resolves as an error, all the caller of [find_or_make] for - the matching key are woken up with [Error] and the value is removed from - the table. The next call to [find_or_make] with the same key causes the - provided [gen] function to be called. *) - - type key - - type 'a t - - val create : int -> 'a t - - val clear : 'a t -> unit - - val reset : 'a t -> unit - - (** [find_or_make t k gen] is [p] if [k] is already bound to [k] in [t]. In - this case, no side-effect is performed. - - [find_or_make t k gen] is [r] if [k] is not bound in [t] where [r] is [gen - ()]. In this case, [r] becomes bound to [k] in [t]. In addition, a - listener is added to [r] so that if [r] resolves to [Error _], the binding - is removed. *) - val find_or_make : - 'a t -> key -> (unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t - - val remove : 'a t -> key -> unit - - (** [find_opt t k] is [None] if there are no bindings for [k] in [t], and - [Some p] if [p] is bound to [k] in [t]. *) - val find_opt : 'a t -> key -> 'a tzresult Lwt.t option - - val mem : 'a t -> key -> bool - - val iter_s : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t - - (** [iter_{s,p} f t] iterates [f] over the promises of [t]. It blocks on - unresolved promises and only applies the function on the ones that resolve - successfully. *) - val iter_p : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t - - (** [fold f t init] folds [f] over the successfully resolving promises - of [t]. I.e., it goes through the promises in the table and waits for each - of the promise to resolve in order to fold over it. *) - val fold : (key -> 'a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t - - (** [fold_promises f t init] folds [f] over the promises of [t]. *) - val fold_promises : - (key -> 'a tzresult Lwt.t -> 'b -> 'b) -> 'a t -> 'b -> 'b - - (** [fold_resolved f t init] folds [f] over the successfully resolved promises - of [t]. *) - val fold_resolved : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - - (** [fold_keys f t init] folds [f] over the keys bound in [t]. *) - val fold_keys : (key -> 'b -> 'b) -> 'a t -> 'b -> 'b - - val length : 'a t -> int -end - -(** Intended use: [Make(Hashtbl.Make(M))]. *) -module Make (T : Hashtbl.S) : S with type key = T.key diff --git a/src/lib_error_monad/test/.ocamlformat b/src/lib_error_monad/test/.ocamlformat deleted file mode 100644 index 8278a132e3d6..000000000000 --- a/src/lib_error_monad/test/.ocamlformat +++ /dev/null @@ -1,12 +0,0 @@ -version=0.10 -wrap-fun-args=false -let-binding-spacing=compact -field-space=loose -break-separators=after-and-docked -sequence-style=separator -doc-comments=before -margin=80 -module-item-spacing=sparse -parens-tuple=always -parens-tuple-patterns=always -break-string-literals=newlines-and-wrap diff --git a/src/lib_error_monad/tezos-error-monad.opam b/src/lib_error_monad/tezos-error-monad.opam index c4dba5058c08..3df391ffb101 100644 --- a/src/lib_error_monad/tezos-error-monad.opam +++ b/src/lib_error_monad/tezos-error-monad.opam @@ -13,7 +13,6 @@ depends: [ "data-encoding" { = "0.2" } "lwt" "lwt-canceler" { = "0.2" } - "alcotest-lwt" { with-test & >= "1.1.0" } ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/src/lib_shell/chain_validator.ml b/src/lib_shell/chain_validator.ml index a940aeba1f57..0743d64fa7b2 100644 --- a/src/lib_shell/chain_validator.ml +++ b/src/lib_shell/chain_validator.ml @@ -653,7 +653,7 @@ let on_launch start_prevalidator w _ parameters = trace) (fun () -> let nv = Worker.state w in - match P2p_peer.Error_table.find_opt nv.active_peers peer_id with + match P2p_peer.Error_table.find nv.active_peers peer_id with | None -> return_unit | Some pv -> -- GitLab From bef16a1bb4f7efa3cb8d8283105832270dfa96a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 25 May 2020 09:49:02 +0100 Subject: [PATCH 3/6] CI: update_unit_test, update_opam_test --- .gitlab-ci.yml | 81 +++++++++++++++++++++++++++----------------------- 1 file changed, 43 insertions(+), 38 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 4cac27ff3eec..49e07dd8167a 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -103,105 +103,110 @@ build: # this section is updated using the script scripts/update_unit_test.sh ##BEGIN_UNITEST## -unit:shell: +unit:signer_backends/unix: <<: *test_definition script: - - dune build @src/lib_shell/runtest + - dune build @src/lib_signer_backends/unix/runtest -unit:client_base: +unit:signer_backends: <<: *test_definition script: - - dune build @src/lib_client_base/runtest + - dune build @src/lib_signer_backends/runtest -unit:requester: +unit:crypto: <<: *test_definition script: - - dune build @src/lib_requester/runtest + - dune build @src/lib_crypto/runtest -unit:error_monad: +unit:protocol_environment: <<: *test_definition script: - - dune build @src/lib_error_monad/runtest + - dune build @src/lib_protocol_environment/runtest -unit:src/proto_006_PsCARTHA/lib_client: +unit:stdlib: <<: *test_definition script: - - dune build @src/proto_006_PsCARTHA/lib_client/runtest + - dune build @src/lib_stdlib/runtest -unit:src/proto_006_PsCARTHA/lib_protocol: +unit:shell: <<: *test_definition script: - - dune build @src/proto_006_PsCARTHA/lib_protocol/runtest + - dune build @src/lib_shell/runtest -unit:src/proto_alpha/lib_client: +unit:src/bin_client: <<: *test_definition script: - - dune build @src/proto_alpha/lib_client/runtest + - dune build @src/bin_client/runtest -unit:src/proto_alpha/lib_protocol: +unit:error_monad: <<: *test_definition script: - - dune build @src/proto_alpha/lib_protocol/runtest + - dune build @src/lib_error_monad/runtest -unit:crypto: +unit:micheline: <<: *test_definition script: - - dune build @src/lib_crypto/runtest + - dune build @src/lib_micheline/runtest -unit:stdlib: +unit:storage: <<: *test_definition script: - - dune build @src/lib_stdlib/runtest + - dune build @src/lib_storage/runtest -unit:storage: +unit:src/proto_006_PsCARTHA/lib_client: <<: *test_definition script: - - dune build @src/lib_storage/runtest + - dune build @src/proto_006_PsCARTHA/lib_client/runtest -unit:p2p: +unit:src/proto_006_PsCARTHA/lib_protocol: <<: *test_definition script: - - dune build @src/lib_p2p/runtest + - dune build @src/proto_006_PsCARTHA/lib_protocol/runtest -unit:micheline: +unit:src/proto_alpha/lib_client: <<: *test_definition script: - - dune build @src/lib_micheline/runtest + - dune build @src/proto_alpha/lib_client/runtest -unit:protocol_environment: +unit:src/proto_alpha/lib_protocol: <<: *test_definition script: - - dune build @src/lib_protocol_environment/runtest + - dune build @src/proto_alpha/lib_protocol/runtest -unit:signer_backends/unix: +unit:lwt_result_stdlib: <<: *test_definition script: - - dune build @src/lib_signer_backends/unix/runtest + - dune build @src/lib_lwt_result_stdlib/runtest -unit:signer_backends: +unit:client_base: <<: *test_definition script: - - dune build @src/lib_signer_backends/runtest + - dune build @src/lib_client_base/runtest -unit:src/bin_client: +unit:requester: <<: *test_definition script: - - dune build @src/bin_client/runtest + - dune build @src/lib_requester/runtest -unit:ocaml-uecc: +unit:p2p: <<: *test_definition script: - - dune build @vendors/ocaml-uecc/runtest + - dune build @src/lib_p2p/runtest + +unit:ocaml-lmdb: + <<: *test_definition + script: + - dune build @vendors/ocaml-lmdb/runtest unit:ocaml-ledger-wallet: <<: *test_definition script: - dune build @vendors/ocaml-ledger-wallet/runtest -unit:ocaml-lmdb: +unit:ocaml-uecc: <<: *test_definition script: - - dune build @vendors/ocaml-lmdb/runtest + - dune build @vendors/ocaml-uecc/runtest ##END_UNITEST## -- GitLab From 70db94e75fb8eb5333437aab3a23ec1866b47d6c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 10 Jun 2020 10:48:29 +0100 Subject: [PATCH 4/6] Lwtreslib: export Hastbl.hash for easy shadowing --- src/lib_lwt_result_stdlib/functors/hashtbl.ml | 2 ++ src/lib_lwt_result_stdlib/functors/hashtbl.mli | 3 +++ src/lib_lwt_result_stdlib/lib/hashtbl.mli | 2 ++ 3 files changed, 7 insertions(+) diff --git a/src/lib_lwt_result_stdlib/functors/hashtbl.ml b/src/lib_lwt_result_stdlib/functors/hashtbl.ml index 5674bddbf4fa..03dc7c4bd349 100644 --- a/src/lib_lwt_result_stdlib/functors/hashtbl.ml +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.ml @@ -24,6 +24,8 @@ (*****************************************************************************) module Make (Seq : Sigs.Seq.S) = struct + let hash = Stdlib.Hashtbl.hash + module type S = Sigs.Hashtbl.S with type error := Seq.Monad.out_error module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t = struct diff --git a/src/lib_lwt_result_stdlib/functors/hashtbl.mli b/src/lib_lwt_result_stdlib/functors/hashtbl.mli index 39c5b7db0591..2e6642684d59 100644 --- a/src/lib_lwt_result_stdlib/functors/hashtbl.mli +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.mli @@ -24,6 +24,9 @@ (*****************************************************************************) module Make (Seq : Sigs.Seq.S) : sig + (** [Stdlib.Hashtbl.hash] reexported to allow shadowing *) + val hash : 'a -> int + module type S = Sigs.Hashtbl.S with type error := Seq.Monad.out_error module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t diff --git a/src/lib_lwt_result_stdlib/lib/hashtbl.mli b/src/lib_lwt_result_stdlib/lib/hashtbl.mli index e814f6a146c5..42704721ab9d 100644 --- a/src/lib_lwt_result_stdlib/lib/hashtbl.mli +++ b/src/lib_lwt_result_stdlib/lib/hashtbl.mli @@ -23,6 +23,8 @@ (* *) (*****************************************************************************) +val hash : 'a -> int + module type S = Sigs.Hashtbl.S with type error := Error_monad.error list module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t -- GitLab From b77ab9d61281e219e581c5f22e198f9dca5c9d3d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Thu, 25 Jun 2020 08:39:46 +0200 Subject: [PATCH 5/6] Lwtreslib: improve documentation of Lwt-Hastbl --- src/lib_lwt_result_stdlib/functors/hashtbl.ml | 2 ++ src/lib_lwt_result_stdlib/sigs/hashtbl.ml | 31 ++++++++++++++++--- 2 files changed, 28 insertions(+), 5 deletions(-) diff --git a/src/lib_lwt_result_stdlib/functors/hashtbl.ml b/src/lib_lwt_result_stdlib/functors/hashtbl.ml index 03dc7c4bd349..1225d9ffeac7 100644 --- a/src/lib_lwt_result_stdlib/functors/hashtbl.ml +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.ml @@ -106,6 +106,8 @@ module Make (Seq : Sigs.Seq.S) = struct let remove t k = (match T.find_opt t k with None -> () | Some a -> Lwt.cancel a) ; + (* NOTE: we still need to call [T.remove] in case the promise is not + cancelable (in which case it is not rejected and thus not removed) *) T.remove t k let mem t k = T.mem t k diff --git a/src/lib_lwt_result_stdlib/sigs/hashtbl.ml b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml index 846fc42e1092..d45d3c2ac516 100644 --- a/src/lib_lwt_result_stdlib/sigs/hashtbl.ml +++ b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml @@ -112,6 +112,9 @@ end order to insert a value, one has to use `find_or_make` which either returns an existing promise for a value bound to the given key, or makes such a promise. It is not possible to insert another value for an existing key. + This limits the table (e.g., it can only hold one value for any given key), + but it forces the user to *atomically* test membership and insert an + element. Second, the table is automatically cleaned. Specifically, when a promise for a value is fulfilled with an [Error _], the binding is removed. This leads @@ -120,22 +123,22 @@ end [ (* setup *) let t = create 256 in - let () = assert (fold_keys (fun _ acc -> succ acc) t 0 = 0) in + let () = assert (length t = 0) in (* insert a first promise for a value *) let p, r = Lwt.task () in let i1 = find_or_make t 1 (fun () -> p) in - let () = assert (fold_keys (fun _ acc -> succ acc) t 0 = 1) in + let () = assert (length t = 1) in (* because the same key is used, the promise is not inserted. *) let i2 = find_or_make t 1 (fun () -> assert false) in - let () = assert (fold_keys (fun _ acc -> succ acc) t 0 = 1) in + let () = assert (length t = 1) in (* when the original promise errors, the binding is removed *) let () = Lwt.wakeup r (Error ..) in - let () = assert (fold_keys (fun _ acc -> succ acc) t 0 = 0) in + let () = assert (length t = 0) in - (* and both the [find_or_make] promises have the error *) + (* and both [find_or_make] promises have the error *) let () = match Lwt.state i1 with | Return (Error ..) -> () | _ -> assert false @@ -161,16 +164,34 @@ module type S_LWT = sig val create : int -> 'a t + (** [clear tbl] cancels and removes all the promises in [tbl]. *) val clear : 'a t -> unit + (** [reset tbl] cancels and removes all the promises in [tbl], and resizes + [tbl] to its initial size. *) val reset : 'a t -> unit + (** [find_or_make tbl k make] behaves differently depending on [k] being bound + in [tbl]: + - if [k] is bound in [tbl] then [find_or_make tbl k make] returns the + promise [p] that [k] is bound to. This [p] might be already fulfilled + with [Ok _] or it might be pending. This [p] cannot be already fulfilled + with [Error _] or already rejected. This is because [Error]/rejected + promises are removed from the table automatically. Note however that if + this [p] is pending, [p] might become fulfilled with [Error _] or become + rejected. + - if [k] is not bound in [tbl] then [make ()] is called and the returned + promise [p] is bound to [k] in [tbl]. Then [p] is returned. When [p] is + resolved, it may be removed automatically from [tbl] as described above. + *) val find_or_make : 'a t -> key -> (unit -> ('a, error) result Lwt.t) -> ('a, error) result Lwt.t + (** [remove tbl k] cancels the promise bound to [k] in [tbl] and removes it. + If [k] is not bound in [tbl] it does nothing. *) val remove : 'a t -> key -> unit val find : 'a t -> key -> ('a, error) result Lwt.t option -- GitLab From e7266ad0ad41093d6db5251666d377414c6f78f4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Thu, 25 Jun 2020 09:01:43 +0200 Subject: [PATCH 6/6] Lwtreslib: Better semantic, names, and doc for Lwt-Hashtbl traversors --- src/lib_lwt_result_stdlib/functors/hashtbl.ml | 26 ++++++++-- src/lib_lwt_result_stdlib/sigs/hashtbl.ml | 48 +++++++++++++++++-- 2 files changed, 67 insertions(+), 7 deletions(-) diff --git a/src/lib_lwt_result_stdlib/functors/hashtbl.ml b/src/lib_lwt_result_stdlib/functors/hashtbl.ml index 1225d9ffeac7..4b827e24bbf2 100644 --- a/src/lib_lwt_result_stdlib/functors/hashtbl.ml +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.ml @@ -112,13 +112,31 @@ module Make (Seq : Sigs.Seq.S) = struct let mem t k = T.mem t k - let iter_es f t = iter_es (fun (k, v) -> v >>=? f k) (T.to_seq t) + let iter_with_waiting_es f t = + iter_es + (fun (k, p) -> + Lwt.try_bind + (fun () -> p) + (function Error _ -> Monad.return_unit | Ok v -> f k v) + (fun _ -> Monad.return_unit)) + (T.to_seq t) - let iter_ep f t = iter_ep (fun (k, v) -> v >>=? f k) (T.to_seq t) + let iter_with_waiting_ep f t = + iter_ep + (fun (k, p) -> + Lwt.try_bind + (fun () -> p) + (function Error _ -> Monad.return_unit | Ok v -> f k v) + (fun _ -> Monad.return_unit)) + (T.to_seq t) - let fold_es f t init = + let fold_with_waiting_es f t init = fold_left_es - (fun acc (k, v) -> v >>=? fun vv -> f k vv acc) + (fun acc (k, p) -> + Lwt.try_bind + (fun () -> p) + (function Error _ -> return acc | Ok v -> f k v acc) + (fun _ -> return acc)) init (T.to_seq t) diff --git a/src/lib_lwt_result_stdlib/sigs/hashtbl.ml b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml index d45d3c2ac516..e5e725f92822 100644 --- a/src/lib_lwt_result_stdlib/sigs/hashtbl.ml +++ b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml @@ -152,6 +152,8 @@ end This automatic cleaning relieves the user from the responsibility of cleaning the table (which is another possible source of race condition). + For consistency, traversal functions ignore [Error _] and rejections. + Third, every time a promise is removed from the table (be it by [clean], [reset], or just [remove]), the promise is canceled. *) @@ -198,17 +200,49 @@ module type S_LWT = sig val mem : 'a t -> key -> bool - val iter_es : + (** [iter_with_waiting_es f tbl] iterates [f] over the bindings in [tbl]. + + Specifically, for each binding [(k, p)] it waits for [p] to be fulfilled + with [Ok v] and calls [f k v]. If [p] fulfills with [Error _] or is + rejected, then no call is made for this binding. Note however that an + [Error]/rejection in one promise returned by [f] interrupts the + iteration. + + It processes bindings one after the other: it waits for both the bound + promise to resolve and then the call promise to resolve before continuing + to the next binding. *) + val iter_with_waiting_es : (key -> 'a -> (unit, error) result Lwt.t) -> 'a t -> (unit, error) result Lwt.t - val iter_ep : + (** [iter_with_waiting_ep f tbl] iterates [f] over the bindings in [tbl]. + + Specifically, for each binding [(k, p)] it waits for [p] to be fulfilled + with [Ok v] and calls [f k v]. If [p] fulfills with [Error _] or is + rejected, then no call is made for this binding. + + Note however that if one (or more) of the promises returned by [f] ends in + [Error]/rejection, the final result of this promise is an + [Error]/rejection. Even so, it only resolves once all the promises have. + + It processes all bindings concurrently: it concurrently waits for all the + bound promises to resolve and calls [f] as they resolve. *) + val iter_with_waiting_ep : (key -> 'a -> (unit, error) result Lwt.t) -> 'a t -> (unit, error) result Lwt.t - val fold_es : + (** [fold_with_waiting_es f tbl init] folds [init] with [f] over the bindings + in [tbl]. + + Specifically, for each binding [(k, p)] it waits for [p] to be fulfilled + with [Ok v] and determines the next accumulator by calling [f k v acc]. If + [p] fulfills with [Error _] or is rejected, then no call is made for this + binding. + + It processes bindings one after the other. *) + val fold_with_waiting_es : (key -> 'a -> 'b -> ('b, error) result Lwt.t) -> 'a t -> 'b -> @@ -216,9 +250,17 @@ module type S_LWT = sig val fold_keys : (key -> 'b -> 'b) -> 'a t -> 'b -> 'b + (** [fold_promises f tbl init] folds over the table, passing the raw promises + to [f]. This means that [f] can observe [Error]/rejections. + + This can be used to, e.g., count the number of resolved/unresolved + promises. *) val fold_promises : (key -> ('a, error) result Lwt.t -> 'b -> 'b) -> 'a t -> 'b -> 'b + (** [fold_resolved f tbl init] folds over the already resolved promises of + [tbl]. More specifically, it folds over the [v] for all the promises + fulfilled with [Ok v] that are bound in [tbl]. *) val fold_resolved : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val length : 'a t -> int -- GitLab