diff --git a/manifest/main.ml b/manifest/main.ml index 46570e866478fa199badd7f66e201ffdbf4389a3..7810f850d26350cec1d60f65ab7a4f5d32d4d730 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -356,7 +356,7 @@ let tezos_stdlib = "tezos-stdlib" ~path:"src/lib_stdlib" ~synopsis:"Tezos: yet-another local-extension of the OCaml standard library" - ~deps:[hex; zarith; zarith_stubs_js; lwt] + ~deps:[hex; zarith; zarith_stubs_js; lwt; ringo] ~ocaml:V.(at_least "4.08") ~js_compatible:true ~inline_tests:ppx_inline_test @@ -370,6 +370,7 @@ let _tezos_stdlib_tests = "test_tzString"; "test_fallbackArray"; "test_functionalArray"; + "test_hash_queue"; ] ~path:"src/lib_stdlib/test" ~opam:"src/lib_stdlib/tezos-stdlib" @@ -386,7 +387,12 @@ let _tezos_stdlib_tests = let _tezos_stdlib_unix_tests = tests - ["test_lwt_pipe"; "test_circular_buffer"; "test_circular_buffer_fuzzy"] + [ + "test_lwt_pipe"; + "test_circular_buffer"; + "test_circular_buffer_fuzzy"; + "test_hash_queue_lwt"; + ] ~path:"src/lib_stdlib/test-unix" ~opam:"src/lib_stdlib/tezos-stdlib" ~deps: diff --git a/src/lib_stdlib/dune b/src/lib_stdlib/dune index ca78f04bbf26e321115d4737740eee78c6f44593..f342b23d41bb81751a0522fc7d458e6dd6691eea 100644 --- a/src/lib_stdlib/dune +++ b/src/lib_stdlib/dune @@ -9,7 +9,8 @@ hex zarith zarith_stubs_js - lwt) + lwt + ringo) (inline_tests (flags -verbose) (modes native)) (preprocess (pps ppx_inline_test)) (js_of_ocaml)) diff --git a/src/proto_alpha/bin_tx_rollup_node/hash_queue.ml b/src/lib_stdlib/hash_queue.ml similarity index 83% rename from src/proto_alpha/bin_tx_rollup_node/hash_queue.ml rename to src/lib_stdlib/hash_queue.ml index c2978719d8bbbb7b97f4f1bcd383abd059c644a7..040e8887ed731675fa999cfc7cfec2ca56580516 100644 --- a/src/proto_alpha/bin_tx_rollup_node/hash_queue.ml +++ b/src/lib_stdlib/hash_queue.ml @@ -27,7 +27,7 @@ module RingoMaker : Ringo.MAP_MAKER = (val Ringo.(map_maker ~replacement:FIFO ~overflow:Strong ~accounting:Precise)) module Make - (K : Stdlib.Hashtbl.HashedType) (V : sig + (K : Hashtbl.HashedType) (V : sig type t end) = struct @@ -62,28 +62,29 @@ struct let fold f q acc = Ring.fold_oldest_first f q acc let fold_s f q acc = - let open Lwt_syntax in + let open Lwt.Syntax in fold (fun k v acc -> let* acc = acc in f k v acc) q - (return acc) + (Lwt.return acc) let fold_es (type error) f q acc : (_, error) result Lwt.t = - let open Lwt_syntax in + let open Lwt.Syntax in let exception Error of error in - try - let+ res = + Lwt.try_bind + (fun () -> fold_s (fun k v acc -> - let+ res = f k v acc in - match res with Ok acc -> acc | Error e -> raise (Error e)) + let* res = f k v acc in + match res with + | Ok acc -> Lwt.return acc + | Error e -> Lwt.fail (Error e)) q - acc - in - Ok res - with Error e -> return_error e + acc) + Lwt.return_ok + (function Error e -> Lwt.return_error e | e -> Lwt.fail e) let peek q = match oldest_elements q 1 (fun _ _ _ -> ()) with @@ -99,5 +100,11 @@ struct let peek_at_most q n = oldest_elements q n (fun _ _ _ -> ()) - let take_at_most q n = oldest_elements q n (fun k _ q -> remove q k) + let take_at_most q n = + (* Removing the keys during the fold does not work, accumulating the keys + then removing them does the trick. *) + let keys = ref [] in + let values = oldest_elements q n (fun k _ _ -> keys := k :: !keys) in + List.iter (remove q) !keys ; + values end diff --git a/src/proto_alpha/bin_tx_rollup_node/hash_queue.mli b/src/lib_stdlib/hash_queue.mli similarity index 81% rename from src/proto_alpha/bin_tx_rollup_node/hash_queue.mli rename to src/lib_stdlib/hash_queue.mli index e47c955a71a142dafe0e5ffac00af75363bd5391..172a0f1f5f10d6d71aa03e888551d925bb3d9ad2 100644 --- a/src/proto_alpha/bin_tx_rollup_node/hash_queue.mli +++ b/src/lib_stdlib/hash_queue.mli @@ -23,8 +23,16 @@ (* *) (*****************************************************************************) +(** Bounded queues combined with hash-tables, based on {!Ringo}. + + A {e hash queue} is a structure where one can add elements to the back of + the queue, while associating them to keys. This allows for efficiently + retrieving elements based on the key and for removing elements anywhere in + the queue. +*) + module Make - (K : Stdlib.Hashtbl.HashedType) (V : sig + (K : Hashtbl.HashedType) (V : sig type t end) : sig (** The type of hash queues holding bindings from [K.t] to [V.t] *) @@ -47,7 +55,7 @@ module Make otherwise. *) val find_opt : t -> K.t -> V.t option - (** [filter q f] retain only the bindings [(k, v)] such that [f k v = true]. *) + (** [filter q f] retains only the bindings [(k, v)] such that [f k v = true]. *) val filter : t -> (K.t -> V.t -> bool) -> unit (** [length q] is the number of bindings held by [q]. *) @@ -60,33 +68,33 @@ module Make (** [clear q] removes all bindings from [q]. *) val clear : t -> unit - (** [fold f q init] folds the function [f] and V.t [init] over the bindings + (** [fold f q init] folds the function [f] over the bindings of [q]. The elements are iterated from oldest to newest. *) val fold : (K.t -> V.t -> 'a -> 'a) -> t -> 'a -> 'a (** Folding in the Lwt monad, from oldest to newest. *) val fold_s : (K.t -> V.t -> 'a -> 'a Lwt.t) -> t -> 'a -> 'a Lwt.t - (** Folding in the Lwt monad, from oldest to newest. *) + (** Folding in the error monad, from oldest to newest. *) val fold_es : (K.t -> V.t -> 'a -> ('a, 'error) result Lwt.t) -> t -> 'a -> ('a, 'error) result Lwt.t - (** Returns the first element of the queue when not empty. Returns [None] when - empty. *) + (** Returns the oldest element of the queue when not empty. Returns [None] + when empty. *) val peek : t -> V.t option - (** [take q] removes and returns the first element in queue [q], or returns + (** [take q] removes and returns the oldest element in queue [q], or returns [None] if the queue is empty. *) val take : t -> V.t option - (** [peek_at_most q n] returns the first n elements of the queue [q]. If the + (** [peek_at_most q n] returns the oldest n elements of the queue [q]. If the queue has less than [n] elements, returns all elements of the queue. *) val peek_at_most : t -> int -> V.t list - (** [take_at_most q n] removes and returns the first n elements of the queue + (** [take_at_most q n] removes and returns the oldest n elements of the queue [q]. If the queue has less than [n] elements, removes and returns all elements of the queue. *) val take_at_most : t -> int -> V.t list diff --git a/src/lib_stdlib/test-unix/dune b/src/lib_stdlib/test-unix/dune index ab5688c60bf781a2635eec70500df3a57e87d552..3c25b7ff18aa1bd936ad4cb40a535ddccf38a8ea 100644 --- a/src/lib_stdlib/test-unix/dune +++ b/src/lib_stdlib/test-unix/dune @@ -2,7 +2,11 @@ ; Edit file manifest/main.ml instead. (executables - (names test_lwt_pipe test_circular_buffer test_circular_buffer_fuzzy) + (names + test_lwt_pipe + test_circular_buffer + test_circular_buffer_fuzzy + test_hash_queue_lwt) (libraries tezos-stdlib alcotest @@ -28,3 +32,8 @@ (alias runtest) (package tezos-stdlib) (action (run %{dep:./test_circular_buffer_fuzzy.exe}))) + +(rule + (alias runtest) + (package tezos-stdlib) + (action (run %{dep:./test_hash_queue_lwt.exe}))) diff --git a/src/lib_stdlib/test-unix/test_hash_queue_lwt.ml b/src/lib_stdlib/test-unix/test_hash_queue_lwt.ml new file mode 100644 index 0000000000000000000000000000000000000000..cbdbb51eb2f9303b3c17813ee3c804a2c51d0d0e --- /dev/null +++ b/src/lib_stdlib/test-unix/test_hash_queue_lwt.ml @@ -0,0 +1,117 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 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 String = struct + include String + + let hash = Hashtbl.hash +end + +module Queue = Hash_queue.Make (String) (Int) + +let mock_key n = Printf.sprintf "val<%d>" n + +let gen_values n = + let rec gen n acc = + if n < 0 then acc else gen (n - 1) ((mock_key n, n) :: acc) + in + gen (n - 1) [] + +let add_multiple_values q vs = List.iter (fun (k, v) -> Queue.replace q k v) vs + +(* Invariants: + - (key, value) are ("val", i) for i in [0, n-1] + - keys are added in increasing order, hence ("val<0>", 0) is always the oldest + value if `capacity` >= `n`. + - there is no capacity check. If n > capacity, the oldest values are replaced + *) +let init_queue capacity n = + let q = Queue.create capacity in + let vs = gen_values n in + add_multiple_values q vs ; + q + +let assert_eq_s eq pa pb = + let open Lwt.Syntax in + let* a = pa and* b = pb in + assert (eq a b) ; + Lwt.return_unit + +let test_fold_s () = + let q = init_queue 10 10 in + let vs = Lwt.return @@ List.rev @@ gen_values 10 in + let vs_from_fold = + (* The resulting list is newest to oldest *) + Queue.fold_s (fun k v acc -> Lwt.return ((k, v) :: acc)) q [] + in + assert_eq_s + (List.equal (fun (k1, v1) (k2, v2) -> String.equal k1 k2 && Int.equal v1 v2)) + vs + vs_from_fold + +let test_fold_es () = + let q = init_queue 10 10 in + let vs = Lwt.return_ok @@ List.rev @@ gen_values 10 in + let vs_from_fold = + (* The resulting list is newest to oldest *) + Queue.fold_es (fun k v acc -> Lwt.return_ok ((k, v) :: acc)) q [] + in + assert_eq_s + (Result.equal + ~ok: + (List.equal (fun (k1, v1) (k2, v2) -> + String.equal k1 k2 && Int.equal v1 v2)) + ~error:(fun () () -> true)) + vs + vs_from_fold + +let test_fold_es_error () = + let q = init_queue 10 10 in + let vs = Lwt.return_error () in + let vs_from_fold = + (* The resulting list is newest to oldest *) + Queue.fold_es (fun _k _v _acc -> Lwt.return_error ()) q [] + in + assert_eq_s + (Result.equal + ~ok: + (List.equal (fun (k1, v1) (k2, v2) -> + String.equal k1 k2 && Int.equal v1 v2)) + ~error:(fun () () -> true)) + vs + vs_from_fold + +let () = + Alcotest_lwt.run + "stdlib" + [ + ( "hash_queue", + [ + ("fold_s", `Quick, test_fold_s); + ("fold_es", `Quick, test_fold_es); + ("fold_es_error", `Quick, test_fold_es_error); + ] ); + ] + |> Lwt_main.run diff --git a/src/lib_stdlib/test/dune b/src/lib_stdlib/test/dune index e039b158c98513fb8ca0a6f7891e02ba89f023bb..bf0dd4e49003da98ddca341b370a421eb8414320 100644 --- a/src/lib_stdlib/test/dune +++ b/src/lib_stdlib/test/dune @@ -8,7 +8,8 @@ test_bounded_heap test_tzString test_fallbackArray - test_functionalArray) + test_functionalArray + test_hash_queue) (modes native js) (libraries tezos-stdlib @@ -49,6 +50,11 @@ (package tezos-stdlib) (action (run %{dep:./test_functionalArray.exe}))) +(rule + (alias runtest) + (package tezos-stdlib) + (action (run %{dep:./test_hash_queue.exe}))) + (rule (alias runtest_js) (package tezos-stdlib) @@ -78,3 +84,8 @@ (alias runtest_js) (package tezos-stdlib) (action (run node %{dep:./test_functionalArray.bc.js}))) + +(rule + (alias runtest_js) + (package tezos-stdlib) + (action (run node %{dep:./test_hash_queue.bc.js}))) diff --git a/src/lib_stdlib/test/test_hash_queue.ml b/src/lib_stdlib/test/test_hash_queue.ml new file mode 100644 index 0000000000000000000000000000000000000000..1549d65e6f459b2ad1b6de0b317afc23ceb5a424 --- /dev/null +++ b/src/lib_stdlib/test/test_hash_queue.ml @@ -0,0 +1,254 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 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. *) +(* *) +(*****************************************************************************) + +(** Testing + _______ + + Invocation: dune build @src/lib_stdlib/test/runtest + *) + +module Assert = Lib_test.Assert + +module String = struct + include String + + let hash = Hashtbl.hash +end + +module Queue = Hash_queue.Make (String) (Int) + +let mock_key n = Printf.sprintf "val<%d>" n + +let gen_values n = + let rec gen n acc = + if n < 0 then acc else gen (n - 1) ((mock_key n, n) :: acc) + in + gen (n - 1) [] + +let add_multiple_values q vs = List.iter (fun (k, v) -> Queue.replace q k v) vs + +(* Invariants: + - (key, value) are ("val", i) for i in [0, n-1] + - keys are added in increasing order, hence ("val<0>", 0) is always the oldest + value if `capacity` >= `n`. + - there is no capacity check. If n > capacity, the oldest values are replaced + *) +let init_queue capacity n = + let q = Queue.create capacity in + let vs = gen_values n in + add_multiple_values q vs ; + q + +let string_of_opt_int = function None -> "None" | Some i -> string_of_int i + +let string_of_int_list l = + Printf.sprintf "[%s]" @@ (List.map string_of_int l |> String.concat ";") + +let test_create () = + let q = Queue.create 10 in + Assert.equal ~prn:string_of_int ~msg:__LOC__ 10 (Queue.capacity q) + +let test_replace () = + let q = Queue.create 10 in + Queue.replace q "v" 3 ; + let v = Queue.find_opt q "v" in + Assert.equal ~msg:__LOC__ (Some 3) v + +let test_replace_existing () = + let q = Queue.create 10 in + Queue.replace q "v" 3 ; + Queue.replace q "v" 12 ; + let v = Queue.find_opt q "v" in + Assert.equal ~prn:string_of_opt_int ~msg:__LOC__ (Some 12) v + +let test_replace_incr_length () = + let q = init_queue 10 5 in + Queue.replace q "v" 12 ; + Assert.equal ~prn:string_of_int ~msg:__LOC__ 6 (Queue.length q) + +let test_peek () = + let q = init_queue 10 10 in + Assert.equal ~prn:string_of_opt_int ~msg:__LOC__ (Some 0) (Queue.peek q) + +let test_peek_empty () = + let q = Queue.create 10 in + Assert.equal ~prn:string_of_opt_int ~msg:__LOC__ None (Queue.peek q) + +let test_peek_at_most () = + let q = init_queue 10 10 in + Assert.equal + ~prn:string_of_int_list + ~msg:__LOC__ + [0; 1; 2] + (Queue.peek_at_most q 3) + +let test_peek_at_most_above_length () = + let q = init_queue 3 2 in + Assert.equal + ~prn:string_of_int_list + ~msg:__LOC__ + [0; 1] + (Queue.peek_at_most q 3) + +let test_peek_at_most_above_capacity () = + let q = init_queue 3 3 in + Assert.equal + ~prn:string_of_int_list + ~msg:__LOC__ + [0; 1; 2] + (Queue.peek_at_most q 4) + +let test_take () = + let q = init_queue 10 10 in + Assert.equal ~prn:string_of_opt_int ~msg:__LOC__ (Some 0) (Queue.take q) ; + Assert.equal ~prn:string_of_opt_int ~msg:__LOC__ (Some 1) (Queue.peek q) ; + Assert.equal ~prn:string_of_int ~msg:__LOC__ 9 (Queue.length q) + +let test_take_empty () = + let q = Queue.create 10 in + Assert.equal ~msg:__LOC__ None (Queue.take q) + +let test_take_at_most () = + let q = init_queue 10 10 in + Assert.equal + ~prn:string_of_int_list + ~msg:__LOC__ + [0; 1; 2] + (Queue.take_at_most q 3) ; + Assert.equal ~prn:string_of_opt_int ~msg:__LOC__ (Some 3) (Queue.peek q) ; + Assert.equal ~prn:string_of_int ~msg:__LOC__ 7 (Queue.length q) + +let test_take_at_most_above_length () = + let q = init_queue 10 2 in + Assert.equal + ~prn:string_of_int_list + ~msg:__LOC__ + (Queue.take_at_most q 3) + [0; 1] ; + Assert.equal ~prn:string_of_opt_int ~msg:__LOC__ None (Queue.peek q) ; + Assert.equal ~prn:string_of_int ~msg:__LOC__ 0 (Queue.length q) + +let test_take_at_most_above_capacity () = + let q = init_queue 3 3 in + Assert.equal + ~prn:string_of_int_list + ~msg:__LOC__ + (Queue.take_at_most q 4) + [0; 1; 2] ; + Assert.equal ~prn:string_of_opt_int ~msg:__LOC__ None (Queue.peek q) ; + Assert.equal ~prn:string_of_int ~msg:__LOC__ 0 (Queue.length q) + +let test_replace_above_capacity () = + let q = init_queue 10 10 in + let length_before = Queue.length q in + Queue.replace q "new_key" 10 ; + Assert.equal ~prn:string_of_int ~msg:__LOC__ length_before (Queue.length q) ; + Assert.equal ~prn:string_of_opt_int ~msg:__LOC__ (Some 1) (Queue.peek q) ; + Assert.equal + ~prn:string_of_opt_int + ~msg:__LOC__ + (Queue.find_opt q (mock_key 0)) + None + +let test_filter () = + let q = init_queue 10 10 in + Queue.filter q (fun _ v -> v < 5) ; + Assert.equal ~prn:string_of_int ~msg:__LOC__ 5 (Queue.length q) + +let test_filter_none () = + let q = init_queue 10 10 in + Queue.filter q (fun _ v -> v < 15) ; + Assert.equal ~prn:string_of_int ~msg:__LOC__ 10 (Queue.length q) + +let test_clear () = + let q = init_queue 10 10 in + Queue.clear q ; + Assert.equal ~prn:string_of_int ~msg:__LOC__ 0 (Queue.length q) + +let test_fold () = + let q = init_queue 10 10 in + let vs = gen_values 10 in + let vs_from_fold = + (* The resulting list is newest to oldest *) + Queue.fold (fun k v acc -> (k, v) :: acc) q [] + in + Assert.make_equal_list + ~msg:__LOC__ + (fun (k1, v1) (k2, v2) -> String.equal k1 k2 && Int.equal v1 v2) + (fun (k, v) -> Printf.sprintf "(%s, %d)" k v) + vs + (vs_from_fold |> List.rev) + +let test_elements () = + let q = init_queue 10 10 in + let (_, vs) = gen_values 10 |> List.split in + let elts = Queue.elements q in + Assert.make_equal_list ~msg:__LOC__ Int.equal string_of_int vs elts + +let test_take_replace_keep_order () = + let q = init_queue 10 5 in + let _ = Queue.take_at_most q 3 in + (* Queue should be [3; 4] *) + Queue.replace q "val<25>" 25 ; + (* Queue is now be [3; 4; 25] *) + Assert.make_equal_list + ~msg:__LOC__ + Int.equal + string_of_int + [3; 4; 25] + (Queue.elements q) + +let () = + Alcotest.run + "stdlib" + [ + ( "hash_queue", + [ + ("capacity (create n) = n", `Quick, test_create); + ("replace", `Quick, test_replace); + ("replace_existing", `Quick, test_replace_existing); + ("peek", `Quick, test_peek); + ("peek_empty", `Quick, test_peek_empty); + ("peek_at_most", `Quick, test_peek_at_most); + ("peek_at_most_above_length", `Quick, test_peek_at_most_above_length); + ( "peek_at_most_above_capacity", + `Quick, + test_peek_at_most_above_capacity ); + ("take", `Quick, test_take); + ("take_empty", `Quick, test_take_empty); + ("take_at_most", `Quick, test_take_at_most); + ("take_at_most_above_length", `Quick, test_take_at_most_above_length); + ( "take_at_most_above_capacity", + `Quick, + test_take_at_most_above_capacity ); + ("replace_above_capacity", `Quick, test_replace_above_capacity); + ("filter", `Quick, test_filter); + ("filter_none", `Quick, test_filter_none); + ("clear", `Quick, test_clear); + ("fold", `Quick, test_fold); + ("elements", `Quick, test_elements); + ("take_replace_keep_order", `Quick, test_take_replace_keep_order); + ] ); + ] diff --git a/src/lib_stdlib/tezos-stdlib.opam b/src/lib_stdlib/tezos-stdlib.opam index 80b129a82d49f8fbdb2bd8fb4eb3a08421ccb6fe..65ee05613cd42c4074ba8e7cd91e68574bc3c0d4 100644 --- a/src/lib_stdlib/tezos-stdlib.opam +++ b/src/lib_stdlib/tezos-stdlib.opam @@ -15,6 +15,7 @@ depends: [ "zarith" { >= "1.12" & < "1.13" } "zarith_stubs_js" "lwt" { >= "5.4.0" } + "ringo" { = "0.8" } "alcotest" { with-test & >= "1.5.0" } "bigstring" {with-test} "tezos-test-helpers" {with-test} diff --git a/src/lib_stdlib/tezos_stdlib.ml b/src/lib_stdlib/tezos_stdlib.ml index 4483328d3d6aa75fb89ebe14adb77855c7b1497d..d3ac07595d3ca4d663b148c1db0f1c6aacabc087 100644 --- a/src/lib_stdlib/tezos_stdlib.ml +++ b/src/lib_stdlib/tezos_stdlib.ml @@ -21,6 +21,7 @@ module Circular_buffer = Circular_buffer module Compare = Compare module FallbackArray = FallbackArray module FunctionalArray = FunctionalArray +module Hash_queue = Hash_queue module Hex = TzHex module Lwt_dropbox = Lwt_dropbox module Lwt_idle_waiter = Lwt_idle_waiter diff --git a/src/proto_013_PtJakart/bin_tx_rollup_node/hash_queue.ml b/src/proto_013_PtJakart/bin_tx_rollup_node/hash_queue.ml deleted file mode 100644 index 8ba1b3d924dea73ffa1d43489338a7af9bb8b337..0000000000000000000000000000000000000000 --- a/src/proto_013_PtJakart/bin_tx_rollup_node/hash_queue.ml +++ /dev/null @@ -1,84 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 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 RingoMaker : Ringo.MAP_MAKER = -(val Ringo.(map_maker ~replacement:FIFO ~overflow:Strong ~accounting:Precise)) - -module Make - (K : Stdlib.Hashtbl.HashedType) (V : sig - type t - end) = -struct - module Ring = RingoMaker (K) - include Ring - - type nonrec t = V.t t - - let elements q = Ring.fold (fun _ x acc -> x :: acc) q [] - - (** [oldest_elements q n f] returns the (at most) [n] oldest elements of the - queue and calls [f] on the bindings for these elements. The elements are - returned from oldest to newest. *) - let oldest_elements q n action = - (* FIXME: https://gitlab.com/nomadic-labs/ringo/-/issues/5 *) - (* Ring.fold is from newest to oldest elements. So we iterate on the - elements until we reach the [n] ones at the end, i.e. the elements we - want to "take". *) - let first_index = Ring.length q - n in - Ring.fold - (fun k v (count, acc) -> - let acc = - if count >= first_index then ( - action k v q ; - v :: acc) - else acc - in - (count + 1, acc)) - q - (0, []) - |> snd - - (* Redefining fold to have elements treated in order of oldest to newest *) - (* FIXME: https://gitlab.com/nomadic-labs/ringo/-/issues/5 *) - let fold f q acc = - let bindings = fold (fun k v acc -> (k, v) :: acc) q [] in - List.fold_left (fun acc (k, v) -> f k v acc) acc bindings - - let peek q = - match oldest_elements q 1 (fun _ _ _ -> ()) with - | [] -> None - | [x] -> Some x - | _ -> assert false - - let take q = - match oldest_elements q 1 (fun k _ q -> remove q k) with - | [] -> None - | [x] -> Some x - | _ -> assert false - - let peek_at_most q n = oldest_elements q n (fun _ _ _ -> ()) - - let take_at_most q n = oldest_elements q n (fun k _ q -> remove q k) -end diff --git a/src/proto_013_PtJakart/bin_tx_rollup_node/hash_queue.mli b/src/proto_013_PtJakart/bin_tx_rollup_node/hash_queue.mli deleted file mode 100644 index 7f06df7fd8180a547f841aa8fff99f3773344e89..0000000000000000000000000000000000000000 --- a/src/proto_013_PtJakart/bin_tx_rollup_node/hash_queue.mli +++ /dev/null @@ -1,86 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 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 - (K : Stdlib.Hashtbl.HashedType) (V : sig - type t - end) : sig - (** The type of hash queues holding bindings from [K.t] to [V.t] *) - type t - - (** [create n] creates an empty hash queue of capacity [n]. New - elements added to a full hash queue push the oldest ones out. *) - val create : int -> t - - (** [remove q k] removes the binding from [k] in [q]. If [k] is not bound in - [c], it does nothing. *) - val remove : t -> K.t -> unit - - (** [replace q k v] binds the key [k] to the value [v] in the queue [q]. This - may or may not cause another binding to be removed, depending on the number - of bindings already present in [q]. *) - val replace : t -> K.t -> V.t -> unit - - (** [find_opt q k] is [Some v] if [k] is bound to [v] in [q]. It is [None] - otherwise. *) - val find_opt : t -> K.t -> V.t option - - (** [filter q f] retain only the bindings [(k, v)] such that [f k v = true]. *) - val filter : t -> (K.t -> V.t -> bool) -> unit - - (** [length q] is the number of bindings held by [q]. *) - val length : t -> int - - (** [capacity q] is the number of bindings [q] can hold: - [capacity (create n) = n] *) - val capacity : t -> int - - (** [clear q] removes all bindings from [q]. *) - val clear : t -> unit - - (** [fold f q init] folds the function [f] and V.t [init] over the bindings - of [q]. The elements are iterated from oldest to newest. *) - val fold : (K.t -> V.t -> 'a -> 'a) -> t -> 'a -> 'a - - (** Returns the first element of the queue when not empty. Returns [None] when - empty. *) - val peek : t -> V.t option - - (** [take q] removes and returns the first element in queue [q], or returns - [None] if the queue is empty. *) - val take : t -> V.t option - - (** [peek_at_most q n] returns the first n elements of the queue [q]. If the - queue has less than [n] elements, returns all elements of the queue. *) - val peek_at_most : t -> int -> V.t list - - (** [take_at_most q n] removes and returns the first n elements of the queue - [q]. If the queue has less than [n] elements, removes and returns all - elements of the queue. *) - val take_at_most : t -> int -> V.t list - - (** Returns the elements from oldest to newest. *) - val elements : t -> V.t list -end