diff --git a/src/lib_protocol_environment/dummy_context.ml b/src/lib_protocol_environment/dummy_context.ml index 57148b40d96b1cc04eaeb58c5dc490b41aba08ae..a305aa50d9c14ad33e7532dfca952914088db135 100644 --- a/src/lib_protocol_environment/dummy_context.ml +++ b/src/lib_protocol_environment/dummy_context.ml @@ -45,6 +45,10 @@ module M = struct let kind _ = assert false + let to_value _ = assert false + + let of_value _ _ = assert false + let find _ _ = assert false let add _ _ _ = assert false diff --git a/src/lib_protocol_environment/environment_V0.ml b/src/lib_protocol_environment/environment_V0.ml index 7e0e0314682363b43a21dcee4b52cab640e10194..56c3e2be7abf1360e502bc143b4b98eb660f4f4a 100644 --- a/src/lib_protocol_environment/environment_V0.ml +++ b/src/lib_protocol_environment/environment_V0.ml @@ -885,17 +885,13 @@ struct let fold_keys s root ~init ~f = Context.fold s root ~init ~f:(fun k v acc -> let k = root @ k in - match Tree.kind v with - | `Value _ -> - f k acc - | `Tree -> - Lwt.return acc) + match Tree.kind v with `Value -> f k acc | `Tree -> Lwt.return acc) let fold t root ~init ~f = Context.fold ~depth:(`Eq 1) t root ~init ~f:(fun k v acc -> let k = root @ k in match Tree.kind v with - | `Value _ -> + | `Value -> f (`Key k) acc | `Tree -> f (`Dir k) acc) diff --git a/src/lib_protocol_environment/environment_V1.ml b/src/lib_protocol_environment/environment_V1.ml index 10eada363cd7f29317b7be95ab20188f5643bf76..89f52d085fdd348d54c632d54707a60683783483 100644 --- a/src/lib_protocol_environment/environment_V1.ml +++ b/src/lib_protocol_environment/environment_V1.ml @@ -1072,11 +1072,7 @@ struct let fold_keys s root ~init ~f = Context.fold s root ~init ~f:(fun k v acc -> let k = root @ k in - match Tree.kind v with - | `Value _ -> - f k acc - | `Tree -> - Lwt.return acc) + match Tree.kind v with `Value -> f k acc | `Tree -> Lwt.return acc) type key_or_dir = [`Key of string list | `Dir of string list] @@ -1084,7 +1080,7 @@ struct fold ~depth:(`Eq 1) t root ~init ~f:(fun k v acc -> let k = root @ k in match Tree.kind v with - | `Value _ -> + | `Value -> f (`Key k) acc | `Tree -> f (`Dir k) acc) diff --git a/src/lib_protocol_environment/environment_context.ml b/src/lib_protocol_environment/environment_context.ml index 21323951a5673d74faa9a02a654b73818e551e7d..8ce71afbc99986e8728a7d75372a9ca392600ed7 100644 --- a/src/lib_protocol_environment/environment_context.ml +++ b/src/lib_protocol_environment/environment_context.ml @@ -162,6 +162,15 @@ module Context = struct let kind (Tree {ops = (module Ops); tree; _}) = Ops.Tree.kind tree + let to_value (Tree {ops = (module Ops); tree; _}) = Ops.Tree.to_value tree + + let of_value + (Context + {ops = (module Ops) as ops; ctxt; equality_witness; impl_name; _}) v + = + Ops.Tree.of_value ctxt v + >|= fun tree -> Tree {ops; tree; equality_witness; impl_name} + let equal (Tree {ops = (module Ops); tree; equality_witness; _}) (Tree t) = match equiv equality_witness t.equality_witness with | (Some Refl, Some Refl) -> diff --git a/src/lib_protocol_environment/proxy_context.ml b/src/lib_protocol_environment/proxy_context.ml index b0c509514c93c835ed8a21c11c04a6b0769eeba9..9980b3c7697a8eedbff81325b2d3882c417415e2 100644 --- a/src/lib_protocol_environment/proxy_context.ml +++ b/src/lib_protocol_environment/proxy_context.ml @@ -101,7 +101,8 @@ module C = struct type elt = Key of value | Dir of Local.tree - let elt t = match Local.Tree.kind t with `Value v -> Key v | `Tree -> Dir t + let elt t = + Local.Tree.to_value t >|= function Some v -> Key v | None -> Dir t let raw_find (t : tree) k = Local.Tree.find_tree t.tree k @@ -127,7 +128,7 @@ module C = struct Local.Tree.find_tree t.tree k >|= Option.map Local.Tree.kind >>= function - | Some (`Value _) -> + | Some `Value -> Lwt.return (kind = `Value) | Some `Tree -> Lwt.return (kind = `Tree) @@ -174,8 +175,12 @@ module C = struct let find t k = data_tree t >>= fun tree -> - raw_find tree k >|= Option.map elt - >|= function Some (Key v) -> Some v | _ -> None + raw_find tree k + >>= function + | None -> + Lwt.return_none + | Some v -> ( + elt v >|= function Key v -> Some v | _ -> None ) let find_tree t k = data_tree t @@ -249,11 +254,8 @@ module C = struct let find t k = raw_find t k - >|= function - | None -> - None - | Some tree -> ( - match Local.Tree.kind tree with `Value v -> Some v | `Tree -> None ) + >>= function + | None -> Lwt.return_none | Some tree -> Local.Tree.to_value tree let find_tree t k = raw_find t k @@ -275,6 +277,12 @@ module C = struct let kind t = Local.Tree.kind t.tree + let to_value t = Local.Tree.to_value t.tree + + let of_value t v = + Local.Tree.of_value t.M.local v + >|= fun tree -> {proxy = t.proxy; path = []; tree} + let list = raw_list let clear ?depth t = Local.Tree.clear ?depth t.tree diff --git a/src/lib_protocol_environment/sigs/v2/context.mli b/src/lib_protocol_environment/sigs/v2/context.mli index 7e521fdef38cf50dc8b5ffd3a1d9fa80a0d9f49d..31c82a24a1b158b0379e262ad2046226fc26bd6a 100644 --- a/src/lib_protocol_environment/sigs/v2/context.mli +++ b/src/lib_protocol_environment/sigs/v2/context.mli @@ -127,6 +127,8 @@ module type TREE = sig (** The type for context trees. *) type tree + include VIEW with type t := tree and type tree := tree + (** [empty _] is the empty tree. *) val empty : t -> tree @@ -135,7 +137,16 @@ module type TREE = sig (** [kind t] is [t]'s kind. It's either a tree node or a leaf value. *) - val kind : tree -> [`Value of bytes | `Tree] + val kind : tree -> [`Value | `Tree] + + (** [to_value t] is an Lwt promise that resolves to [Some v] if [t] + is a leaf tree and [None] otherwise. It is equivalent to [find t + []]. *) + val to_value : tree -> value option Lwt.t + + (** [of_value _ v] is an Lwt promise that resolves to the leaf tree + [v]. Is is equivalent to [add (empty _) [] v]. *) + val of_value : t -> value -> tree Lwt.t (** [hash t] is [t]'s Merkle hash. *) val hash : tree -> Context_hash.t @@ -143,8 +154,6 @@ module type TREE = sig (** [equal x y] is true iff [x] and [y] have the same Merkle hash. *) val equal : tree -> tree -> bool - include VIEW with type t := tree and type tree := tree - (** {2 Caches} *) (** [clear ?depth t] clears all caches in the tree [t] for subtrees with a diff --git a/src/lib_protocol_environment/test/test_mem_context.ml b/src/lib_protocol_environment/test/test_mem_context.ml index eb6064d333000853b537b57451a8c54b5e7a4d28..b75455a101a01de6f31f2fdaa80c16e5441072f5 100644 --- a/src/lib_protocol_environment/test/test_mem_context.ml +++ b/src/lib_protocol_environment/test/test_mem_context.ml @@ -180,7 +180,7 @@ let test_replay {genesis = ctxt0; _} = let fold_keys s root ~init ~f = Context.fold s root ~init ~f:(fun k v acc -> match Context.Tree.kind v with - | `Value _ -> + | `Value -> f (root @ k) acc | `Tree -> Lwt.return acc) @@ -238,7 +238,7 @@ let test_fold {genesis = ctxt; _} = [] ~f:(fun path tree (cs, ns) -> match Context.Tree.kind tree with - | `Value _ -> + | `Value -> Lwt.return (path :: cs, ns) | `Tree -> Lwt.return (cs, path :: ns)) @@ -328,7 +328,7 @@ let test_trees {genesis = ctxt; _} = [] ~f:(fun path tree (cs, ns) -> match Context.Tree.kind tree with - | `Value _ -> + | `Value -> Lwt.return (path :: cs, ns) | `Tree -> Lwt.return (cs, path :: ns)) diff --git a/src/lib_shell_benchmarks/io_stats.ml b/src/lib_shell_benchmarks/io_stats.ml index 27f53e80a86e95e34da3673cff2ebba814aee1c3..073b4606bc6e3396b5c8952a793765c3e34f783d 100644 --- a/src/lib_shell_benchmarks/io_stats.ml +++ b/src/lib_shell_benchmarks/io_stats.ml @@ -92,12 +92,13 @@ let load_tree context key = key ~init:Io_helpers.Key_map.empty ~f:(fun path t tree -> - match Context.Tree.kind t with - | `Value bytes -> + Context.Tree.to_value t + >|= function + | Some bytes -> let len = Bytes.length bytes in - Lwt.return (Io_helpers.Key_map.insert path len tree) - | `Tree -> - Lwt.return tree) + Io_helpers.Key_map.insert path len tree + | None -> + tree) let context_statistics base_dir context_hash = let (context, index) = diff --git a/src/lib_storage/context.ml b/src/lib_storage/context.ml index 6d1fd6ec1d8260a8ce1de481c9ddda772e35c95b..1954e17a6cc48ba179e0d82aa2a0dbcdbd218b85 100644 --- a/src/lib_storage/context.ml +++ b/src/lib_storage/context.ml @@ -668,12 +668,12 @@ module Dumpable_context = struct let context_tree ctxt = ctxt.tree let tree_hash tree = - tree |> Store.Tree.destruct - |> function + let hash = Store.Tree.hash tree in + match Store.Tree.destruct tree with | `Node _ -> - `Node (Store.Tree.hash tree) - | `Contents (b, _) -> - `Blob (Store.Contents.hash b) + `Node hash + | `Contents _ -> + `Blob hash type binding = { key : string; diff --git a/src/lib_storage/helpers/context.ml b/src/lib_storage/helpers/context.ml index c0fea728b768354ed41143f3326f9db0b312c530..3ac53a58458385f2323b3d7bac89c46c79f4c1e3 100644 --- a/src/lib_storage/helpers/context.ml +++ b/src/lib_storage/helpers/context.ml @@ -49,11 +49,16 @@ module Make_tree (Store : DB) = struct let add t k v = Store.Tree.add t k v let kind t = + match Store.Tree.destruct t with `Contents _ -> `Value | `Node _ -> `Tree + + let to_value t = match Store.Tree.destruct t with | `Contents (c, _) -> - `Value c + Lwt.return (Some c) | `Node _ -> - `Tree + Lwt.return_none + + let of_value _ v = Store.Tree.add Store.Tree.empty [] v let fold ?depth t k ~init ~f = find_tree t k diff --git a/src/lib_storage/helpers/context.mli b/src/lib_storage/helpers/context.mli index 095cb4153e35ac38b0afd3abc8ea8df76d4a3300..a1fab3c68fdf1438517b0ad70a4bd4652bdb08b6 100644 --- a/src/lib_storage/helpers/context.mli +++ b/src/lib_storage/helpers/context.mli @@ -39,13 +39,15 @@ module Make_tree (DB : DB) : sig include Tezos_storage_sigs.Context.TREE with type t := DB.t - and type key := string list - and type value := bytes + and type key := DB.key + and type value := DB.contents and type tree := DB.tree val empty : _ -> DB.tree - type raw = [`Value of bytes | `Tree of raw TzString.Map.t] + val of_value : _ -> DB.contents -> DB.tree Lwt.t + + type raw = [`Value of DB.contents | `Tree of raw TzString.Map.t] val raw_encoding : raw Data_encoding.t diff --git a/src/lib_storage/sigs/context.ml b/src/lib_storage/sigs/context.ml index 192e345457d148b727fe9184fae4c8b78ef6cbaf..b554ea3b9297f3a2598d7d7f89e4f33868968a72 100644 --- a/src/lib_storage/sigs/context.ml +++ b/src/lib_storage/sigs/context.ml @@ -124,6 +124,8 @@ module type TREE = sig (** The type for context trees. *) type tree + include VIEW with type t := tree and type tree := tree + (** [empty _] is the empty tree. *) val empty : t -> tree @@ -132,7 +134,16 @@ module type TREE = sig (** [kind t] is [t]'s kind. It's either a tree node or a leaf value. *) - val kind : tree -> [`Value of bytes | `Tree] + val kind : tree -> [`Value | `Tree] + + (** [to_value t] is an Lwt promise that resolves to [Some v] if [t] + is a leaf tree and [None] otherwise. It is equivalent to [find t + []]. *) + val to_value : tree -> value option Lwt.t + + (** [of_value _ v] is an Lwt promise that resolves to the leaf tree + [v]. Is is equivalent to [add (empty _) [] v]. *) + val of_value : t -> value -> tree Lwt.t (** [hash t] is [t]'s Merkle hash. *) val hash : tree -> Context_hash.t @@ -140,8 +151,6 @@ module type TREE = sig (** [equal x y] is true iff [x] and [y] have the same Merkle hash. *) val equal : tree -> tree -> bool - include VIEW with type t := tree and type tree := tree - (** {2 Caches} *) (** [clear ?depth t] clears all caches in the tree [t] for subtrees with a diff --git a/src/lib_storage/test/test_context.ml b/src/lib_storage/test/test_context.ml index 36a4a5b65e7b9ec556ebe3b7ed1591d54e2cbd46..6e56b4fe7b0e2cd21a366f0eaa1fef030fad38c9 100644 --- a/src/lib_storage/test/test_context.ml +++ b/src/lib_storage/test/test_context.ml @@ -256,7 +256,7 @@ let test_replay {idx; genesis; _} = let fold_keys s root ~init ~f = fold s root ~init ~f:(fun k v acc -> match Tree.kind v with - | `Value _ -> + | `Value -> f (root @ k) acc | `Tree -> Lwt.return acc) @@ -356,7 +356,7 @@ let test_fold {idx; genesis; _} = match Tree.kind t with | `Tree -> Lwt.return (cs, path :: ns) - | `Value _ -> + | `Value -> Lwt.return (path :: cs, ns)) >>= fun (cs, ns) -> Assert.equal_string_list_list ~msg:__LOC__ ecs cs ; @@ -407,7 +407,7 @@ let test_trees {idx; genesis; _} = match Tree.kind t with | `Tree -> Lwt.return (cs, path :: ns) - | `Value _ -> + | `Value -> Lwt.return (path :: cs, ns)) >>= fun (cs, ns) -> Assert.equal_string_list_list ~msg:__LOC__ ecs cs ; diff --git a/src/proto_alpha/lib_protocol/raw_context_intf.ml b/src/proto_alpha/lib_protocol/raw_context_intf.ml index b82f376e9b55fd88bc83f2fa675a282a726ecdc5..c2e095ec9ea623cd894b537b39eb85f91fdc8a33 100644 --- a/src/proto_alpha/lib_protocol/raw_context_intf.ml +++ b/src/proto_alpha/lib_protocol/raw_context_intf.ml @@ -190,6 +190,8 @@ module type TREE = sig (** The type for context trees. *) type tree + include VIEW with type t := tree and type tree := tree + (** [empty _] is the empty tree. *) val empty : t -> tree @@ -198,7 +200,10 @@ module type TREE = sig (** [kind t] is [t]'s kind. It's either a tree node or a leaf value. *) - val kind : tree -> [`Value of bytes | `Tree] + val kind : tree -> [`Value | `Tree] + + (** [to_value t] is [Some v] is [t] is a leaf tree and [None] otherwise. *) + val to_value : tree -> value option Lwt.t (** [hash t] is [t]'s Merkle hash. *) val hash : tree -> Context_hash.t @@ -206,8 +211,6 @@ module type TREE = sig (** [equal x y] is true iff [x] and [y] have the same Merkle hash. *) val equal : tree -> tree -> bool - include VIEW with type t := tree and type tree := tree - (** {2 Caches} *) (** [clear ?depth t] clears all caches in the tree [t] for subtrees with a diff --git a/src/proto_alpha/lib_protocol/storage_functors.ml b/src/proto_alpha/lib_protocol/storage_functors.ml index 2971e5ea2200ed1c8a5a0c70da0c056ef4e9be53..7a6af8c1504ec4db4eff18b36a6bbb9947356f38 100644 --- a/src/proto_alpha/lib_protocol/storage_functors.ml +++ b/src/proto_alpha/lib_protocol/storage_functors.ml @@ -244,7 +244,7 @@ module Make_data_set_storage (C : Raw_context.T) (I : INDEX) : let fold s ~init ~f = C.fold ~depth:(`Eq I.path_length) s [] ~init ~f:(fun file tree acc -> match C.Tree.kind tree with - | `Value _ -> ( + | `Value -> ( match I.of_path file with None -> assert false | Some p -> f p acc ) | `Tree -> Lwt.return acc) @@ -319,8 +319,9 @@ module Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) : let fold s ~init ~f = C.fold ~depth:(`Eq I.path_length) s [] ~init ~f:(fun file tree acc -> - match C.Tree.kind tree with - | `Value v -> ( + C.Tree.to_value tree + >>= function + | Some v -> ( match I.of_path file with | None -> assert false @@ -331,7 +332,7 @@ module Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) : f path v acc | Error _ -> Lwt.return acc ) ) - | `Tree -> + | None -> Lwt.return acc) let fold_keys s ~init ~f = fold s ~init ~f:(fun k _ acc -> f k acc) @@ -492,7 +493,7 @@ struct let fold_keys_unaccounted s ~init ~f = C.fold ~depth:(`Eq I.path_length) s [] ~init ~f:(fun file tree acc -> match C.Tree.kind tree with - | `Value _ -> ( + | `Value -> ( match List.rev file with | last :: _ when Compare.String.(last = len_name) -> Lwt.return acc @@ -635,7 +636,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : assert false | Some path -> f path acc ) - | `Value _ -> + | `Value -> Lwt.return acc) let keys t = fold_keys t ~init:[] ~f:(fun i acc -> Lwt.return (i :: acc)) @@ -655,7 +656,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : let list t k = C.fold ~depth:(`Eq 1) t k ~init:[] ~f:(fun k t acc -> match C.Tree.kind t with - | `Value _ -> + | `Value -> Lwt.return (`Key k :: acc) | `Tree -> Lwt.return (`Dir k :: acc))