diff --git a/src/lib_protocol_environment/sigs/v1/context.mli b/src/lib_protocol_environment/sigs/v1/context.mli index 78322931d..b06089f73 100644 --- a/src/lib_protocol_environment/sigs/v1/context.mli +++ b/src/lib_protocol_environment/sigs/v1/context.mli @@ -25,6 +25,9 @@ val get: t -> key -> value option Lwt.t val set: t -> key -> value -> t Lwt.t +(** [copy] returns None if the [from] key is not bound *) +val copy: t -> from:key -> to_:key -> t option Lwt.t + val del: t -> key -> t Lwt.t val remove_rec: t -> key -> t Lwt.t diff --git a/src/lib_protocol_environment/tezos_protocol_environment.ml b/src/lib_protocol_environment/tezos_protocol_environment.ml index 0c3c63e79..837f1b20f 100644 --- a/src/lib_protocol_environment/tezos_protocol_environment.ml +++ b/src/lib_protocol_environment/tezos_protocol_environment.ml @@ -17,6 +17,7 @@ module type CONTEXT = sig val dir_mem: t -> key -> bool Lwt.t val get: t -> key -> value option Lwt.t val set: t -> key -> value -> t Lwt.t + val copy: t -> from:key -> to_:key -> t option Lwt.t val del: t -> key -> t Lwt.t val remove_rec: t -> key -> t Lwt.t val fold: diff --git a/src/lib_protocol_environment/tezos_protocol_environment.mli b/src/lib_protocol_environment/tezos_protocol_environment.mli index 39a7e5ef4..3289fbdac 100644 --- a/src/lib_protocol_environment/tezos_protocol_environment.mli +++ b/src/lib_protocol_environment/tezos_protocol_environment.mli @@ -10,6 +10,7 @@ module type CONTEXT = sig val dir_mem: t -> key -> bool Lwt.t val get: t -> key -> value option Lwt.t val set: t -> key -> value -> t Lwt.t + val copy: t -> from:key -> to_:key -> t option Lwt.t val del: t -> key -> t Lwt.t val remove_rec: t -> key -> t Lwt.t val fold: diff --git a/src/lib_protocol_environment/tezos_protocol_environment_faked.ml b/src/lib_protocol_environment/tezos_protocol_environment_faked.ml index 18ed49f63..ce5997d7c 100644 --- a/src/lib_protocol_environment/tezos_protocol_environment_faked.ml +++ b/src/lib_protocol_environment/tezos_protocol_environment_faked.ml @@ -16,6 +16,7 @@ module Context = struct let dir_mem _ _ = assert false let get _ _ = assert false let set _ _ _ = assert false + let copy _ ~from:_ ~to_:_ = assert false let del _ _ = assert false let remove_rec _ _ = assert false let fold _ _ ~init:_ ~f:_ = assert false diff --git a/src/lib_protocol_environment/tezos_protocol_environment_memory.ml b/src/lib_protocol_environment/tezos_protocol_environment_memory.ml index e5672a3a1..57c74b46b 100644 --- a/src/lib_protocol_environment/tezos_protocol_environment_memory.ml +++ b/src/lib_protocol_environment/tezos_protocol_environment_memory.ml @@ -86,6 +86,10 @@ module Context = struct match raw_set m k None with | None -> Lwt.return m | Some m -> Lwt.return m + let copy m ~from ~to_ = + match raw_get m from with + | None -> Lwt.return_none + | Some v -> Lwt.return (raw_set m to_ (Some v)) let fold m k ~init ~f = match raw_get m k with diff --git a/src/lib_storage/context.ml b/src/lib_storage/context.ml index 820ccc1a9..1155ce7ff 100644 --- a/src/lib_storage/context.ml +++ b/src/lib_storage/context.ml @@ -157,6 +157,13 @@ let remove_rec ctxt key = GitStore.Tree.remove ctxt.tree (data_key key) >>= fun tree -> Lwt.return { ctxt with tree } +let copy ctxt ~from ~to_ = + GitStore.Tree.find_tree ctxt.tree (data_key from) >>= function + | None -> Lwt.return_none + | Some sub_tree -> + GitStore.Tree.add_tree ctxt.tree (data_key to_) sub_tree >>= fun tree -> + Lwt.return_some { ctxt with tree } + let fold ctxt key ~init ~f = GitStore.Tree.list ctxt.tree (data_key key) >>= fun keys -> Lwt_list.fold_left_s diff --git a/src/lib_storage/context.mli b/src/lib_storage/context.mli index 9a24996bb..2cad47acb 100644 --- a/src/lib_storage/context.mli +++ b/src/lib_storage/context.mli @@ -45,6 +45,9 @@ val set: context -> key -> value -> t Lwt.t val del: context -> key -> t Lwt.t val remove_rec: context -> key -> t Lwt.t +(** [copy] returns None if the [from] key is not bound *) +val copy: context -> from:key -> to_:key -> context option Lwt.t + val fold: context -> key -> init:'a -> f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) ->