diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 4cac27ff3eecaefc69c50493daa43a9b846e72ac..49e07dd8167a56eab59fb46fcad5074f63119e04 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## diff --git a/src/lib_base/p2p_peer.mli b/src/lib_base/p2p_peer.mli index 7810d9add6cb72985adeeeda4f2c1a5aada04651..90db74a55fbd2f1f7cdaa103c0f8a6e7f547b6b3 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 cc86fd7b814309f0cd704bfcf4be661764a986b2..793b9a17e800637a0b03ae402aad12531065669e 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 7e4212b8f5e0557a2a7cad9b2b9010c676210092..268b1ef6d45a0c7ea2895d412193af639a9d7845 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 f7d5359f70d48633173d5be14862ca5018eed190..2a43d4d74d1a12bea5b51fa23a908269dfc6fdb4 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 cb870b85a4a8992432ad6d579e14f721015b4c6c..f4792c54a41012191c7b836b7b604d1637d47dc1 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 6422e0fff378120a3c3e6268922889d51d64e18b..0000000000000000000000000000000000000000 --- 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 7594c352e52f901fadf59958ec7ff89290af1752..0000000000000000000000000000000000000000 --- 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/dune b/src/lib_error_monad/test/dune deleted file mode 100644 index 34250ff973a66d39b71fc96a958c472e4ac80080..0000000000000000000000000000000000000000 --- 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_error_monad/tezos-error-monad.opam b/src/lib_error_monad/tezos-error-monad.opam index c4dba5058c0852d73f323aadd1a02db16a945874..3df391ffb101ebde7c73410e9883f69a0aff9227 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_lwt_result_stdlib/functors/hashtbl.ml b/src/lib_lwt_result_stdlib/functors/hashtbl.ml new file mode 100644 index 0000000000000000000000000000000000000000..4b827e24bbf2b1f8e88825726d0ab2f843559df8 --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.ml @@ -0,0 +1,162 @@ +(*****************************************************************************) +(* *) +(* 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 + 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 + 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) ; + (* 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 + + 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_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_with_waiting_es f t init = + fold_left_es + (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) + + 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 0000000000000000000000000000000000000000..2e6642684d59fab641a8aca52a7fcb60a0c6849b --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.mli @@ -0,0 +1,37 @@ +(*****************************************************************************) +(* *) +(* 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 + (** [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 + + 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 0000000000000000000000000000000000000000..13033733a7702ccfece8ceb069ff2e437a92db45 --- /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 0000000000000000000000000000000000000000..42704721ab9d40ebb1b5540b44a2cd6300a548a9 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/hashtbl.mli @@ -0,0 +1,35 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +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 + +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 7d29527fa2278349239975c3dc8fee172d545ff8..a40eb489f321b197f2df4b162e9a0ee62c44b9f7 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 bc57a9b6e44b7031a8708393b57e953ac5df23c6..4f2865c1862c0f6b5bdf0f46b159051490fd96c1 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 0000000000000000000000000000000000000000..e5e725f92822fc655b7612dcb8f3afd397c27208 --- /dev/null +++ b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml @@ -0,0 +1,269 @@ +(*****************************************************************************) +(* *) +(* 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. + 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 + to the following behavior: + + [ + (* setup *) + let t = create 256 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 (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 (length t = 1) in + + (* when the original promise errors, the binding is removed *) + let () = Lwt.wakeup r (Error ..) in + let () = assert (length t = 0) in + + (* and both [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). + + 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. +*) +module type S_LWT = sig + type error + + type key + + type 'a t + + 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 + + val mem : 'a t -> key -> bool + + (** [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 + + (** [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 + + (** [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 -> + ('b, error) result Lwt.t + + 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 + + val stats : 'a t -> Stdlib.Hashtbl.statistics +end diff --git a/src/lib_error_monad/test/.ocamlformat b/src/lib_lwt_result_stdlib/test/.ocamlformat similarity index 100% rename from src/lib_error_monad/test/.ocamlformat rename to src/lib_lwt_result_stdlib/test/.ocamlformat 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 0000000000000000000000000000000000000000..2eaac865f2858267d80f73732ea31457b1d6006e --- /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 942999e18c3ca452cf650e89bcfbea0658902499..9808047f16005bd62a9728ddf4e3f05310b9e4db 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 2a428934eeb61f294039d814f1aa9a7d07d1ba87..6fb5f31fa4f55c8beb29b2a71e955e2c374164a7 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] diff --git a/src/lib_shell/chain_validator.ml b/src/lib_shell/chain_validator.ml index a940aeba1f579ab41af6c552fece1aa5c665cc86..0743d64fa7b2c6ea91ca64f0e992487d7cfc5214 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 ->