From 523bcd43ac89754aaf96a50eada32d9f5e086f9d Mon Sep 17 00:00:00 2001 From: Zolisa Bleki Date: Thu, 4 Jul 2024 01:49:27 +0200 Subject: [PATCH] Split `Node.t` into `ArrayNode.t` and `GroupNode.t`. This reduces the number of runtime checks to determine the kind of node when calling storage functions. --- lib/node.ml | 242 ++++++++++++++++++++++++------------ lib/node.mli | 145 ++++++++++++++------- lib/storage/storage.ml | 141 ++++++++++----------- lib/storage/storage_intf.ml | 135 +++++++++----------- test/test_node.ml | 177 ++++++++++++++++++-------- test/test_storage.ml | 43 +++---- 6 files changed, 530 insertions(+), 353 deletions(-) diff --git a/lib/node.ml b/lib/node.ml index fa6c176..e7a1ada 100644 --- a/lib/node.ml +++ b/lib/node.ml @@ -1,8 +1,3 @@ -type t = - | Root - | Cons of t * string - [@@deriving show] - type error = [ `Node_invariant of string ] @@ -13,77 +8,170 @@ let rep_ok name = not (String.for_all (Char.equal '.') name) && not (String.starts_with ~prefix:"__" name) -let root = Root - -let create parent name = - if rep_ok name then - Result.ok @@ Cons (parent, name) - else - Error (`Node_invariant name) - -let ( / ) = create - -let of_path = function - | "/" -> Ok Root - | str -> - if not String.(starts_with ~prefix:"/" str) then - Result.error @@ - `Node_invariant "path should start with a /" - else if String.ends_with ~suffix:"/" str then - Result.error @@ - `Node_invariant "path should not end with a /" - else - let open Util.Result_syntax in - List.fold_left - (fun acc n -> acc >>= fun p -> create p n) - (Ok Root) (List.tl @@ String.split_on_char '/' str) - -let name = function - | Root -> "" - | Cons (_, n) -> n - -let parent = function - | Root -> None - | Cons (parent, _) -> Some parent - -let rec fold f acc = function - | Root -> f acc Root - | Cons (parent, _) as p -> - fold f (f acc p) parent - -let rec ( = ) x y = - match x, y with - | Root, Root -> true - | Root, Cons _ | Cons _, Root -> false - | Cons (p, n), Cons (q, m) -> ( = ) p q && String.equal n m - -let to_path = function - | Root -> "/" - | p -> +module rec GroupNode : sig + type t + val root : t + val create : t -> string -> (t, [> error]) result + val ( / ) : t -> string -> (t, [> error]) result + val of_path : string -> (t, [> error]) result + val to_path : t -> string + val name : t -> string + val parent : t -> t option + val ( = ) : t -> t -> bool + val ancestors : t -> t list + val to_key : t -> string + val to_prefix : t -> string + val to_metakey : t -> string + val is_child_group : t -> t -> bool + val show : t -> string + val pp : Format.formatter -> t -> unit +end = struct + type t = + | Root + | Cons of t * string + [@@deriving show] + + let create parent name = + if rep_ok name then + Result.ok @@ Cons (parent, name) + else + Error (`Node_invariant name) + + let ( / ) = create + + let root = Root + + let of_path = function + | "/" -> Ok Root + | str -> + if not String.(starts_with ~prefix:"/" str) then + Result.error @@ + `Node_invariant "path should start with a /" + else if String.ends_with ~suffix:"/" str then + Result.error @@ + `Node_invariant "path should not end with a /" + else + let open Util.Result_syntax in + List.fold_left + (fun acc n -> acc >>= fun p -> create p n) + (Ok Root) (List.tl @@ String.split_on_char '/' str) + + let name = function + | Root -> "" + | Cons (_, n) -> n + + let parent = function + | Root -> None + | Cons (parent, _) -> Some parent + + let rec ( = ) x y = + match x, y with + | Root, Root -> true + | Root, Cons _ | Cons _, Root -> false + | Cons (p, n), Cons (q, m) -> ( = ) p q && String.equal n m + + let rec fold f acc = function + | Root -> f acc Root + | Cons (parent, _) as p -> + fold f (f acc p) parent + + let to_path = function + | Root -> "/" + | p -> + fold (fun acc -> function + | Root -> acc + | Cons (_, n) -> "/" :: n :: acc) [] p + |> String.concat "" + + let ancestors p = fold (fun acc -> function | Root -> acc - | Cons (_, n) -> "/" :: n :: acc) [] p - |> String.concat "" - -let ancestors p = - fold (fun acc -> function - | Root -> acc - | Cons (parent, _) -> parent :: acc) [] p - -let to_key p = - let str = to_path p in - String.(length str - 1 |> sub str 1) - -let to_prefix = function - | Root -> "" - | p -> to_key p ^ "/" - -let to_metakey p = - to_prefix p ^ "zarr.json" - -let is_parent x y = - match x, y with - | Root, _ -> false - | Cons (parent, _), v -> parent = v - -let show n = to_path n + | Cons (parent, _) -> parent :: acc) [] p + + let to_key p = + let str = to_path p in + String.(length str - 1 |> sub str 1) + + let to_prefix = function + | Root -> "" + | p -> to_key p ^ "/" + + let to_metakey p = + to_prefix p ^ "zarr.json" + + let is_child_group x y = + match x, y with + | _, Root -> false + | v, Cons (parent, _) -> parent = v + + let show n = to_path n +end + +and ArrayNode : sig + type t + val create : GroupNode.t -> string -> (t, [> error]) result + val ( / ) : GroupNode.t -> string -> (t, [> error]) result + val of_path : string -> (t, [> error]) result + val to_path : t -> string + val name : t -> string + val parent : t -> GroupNode.t + val ( = ) : t -> t -> bool + val ancestors : t -> GroupNode.t list + val is_parent : t -> GroupNode.t -> bool + val to_key : t -> string + val to_metakey : t -> string + val show : t -> string + val pp : Format.formatter -> t -> unit +end = struct + type t = {parent : GroupNode.t; name : string} [@@deriving show] + + let create parent name = + if rep_ok name then + Result.ok @@ {parent; name} + else + Error (`Node_invariant name) + + let ( / ) = create + + let of_path p = + match GroupNode.of_path p with + | Error e -> Error e + | Ok g -> + match GroupNode.parent g with + | Some parent -> + Ok {parent; name = GroupNode.name g} + | None -> + Result.error @@ + `Node_invariant "Cannot create an array node from a root path" + + let ( = ) + {parent = p; name = n} + {parent = q; name = m} = p = q && n = m + + let name = function + | {parent = _; name} -> name + + let parent = function + | {parent; _} -> parent + + let to_path = function + | {parent = p; name} -> + if GroupNode.(p = root) then + "/" ^ name + else + GroupNode.to_path p ^ "/" ^ name + + let ancestors = function + | {parent; _} -> parent :: GroupNode.ancestors parent + + let is_parent x y = + match x with + | {parent = p; _} -> GroupNode.(p = y) + + let to_key = function + | {parent; name} -> GroupNode.to_prefix parent ^ name + + let to_metakey p = to_key p ^ "/zarr.json" + + let show = to_path +end diff --git a/lib/node.mli b/lib/node.mli index 5a1759b..b5b89b4 100644 --- a/lib/node.mli +++ b/lib/node.mli @@ -10,67 +10,118 @@ - must not be a string composed only of period characters, e.g. "." or "..". - must not start with the reserved prefix "__".*) -type t -(** The type of a node. *) - type error = [ `Node_invariant of string ] -(** The error type for operations on the {!Node.t} type. It is returned by - functions that create a {!Node.t} type when one or more of a Node's - invariants are not satisfied as defined in the Zarr V3 specification.*) +(** The error type for operations on node types. It is returned by + functions that create an array or group node type when one or more of a + node's invariants are not satisfied as defined in the Zarr V3 specification.*) + +module GroupNode : sig + type t + (** The type of a Group node. *) + + val root : t + (** creates the root node *) + + val create : t -> string -> (t, [> error]) result + (** [create p n] returns a group node with parent [p] and name [n] + or an error if this operation fails. *) + + val ( / ) : t -> string -> (t, [> error]) result + (** The infix operator alias of {!create} *) + + val of_path : string -> (t, [> error]) result + (** [of_path s] returns a node from string [s] or an error upon failure. *) + + val to_path : t -> string + (** [to_path n] returns node [n] as a string path. *) + + val name : t -> string + (** [name n] returns the name of node [n]. The root node does not have a + name and thus the empty string [""] is returned if [n] is a root node. *) + + val parent : t -> t option + (** [parent n] returns [Some p] where [p] is the parent node of [n] + of [None] if node [n] is the root node. *) + + val ( = ) : t -> t -> bool + (** [x = y] returns [true] if nodes [x] and [y] are equal, + and [false] otherwise. *) + + val ancestors : t -> t list + (** [ancestors n] returns ancestor nodes of [n] including the root node. + The root node has no ancestors, thus this returns the empty list + is called on a root node. *) + + val to_key : t -> string + (** [to_key n] converts a node's path to a key, as defined in the Zarr V3 + specification. *) + + val to_prefix : t -> string + (** [to_prefix n] converts a node's path to a prefix key, as defined + in the Zarr V3 specification. *) + + val to_metakey : t -> string + (** [to_prefix n] returns the metadata key associated with node [n], + as defined in the Zarr V3 specification. *) + + val is_child_group : t -> t -> bool + (** [is_child_group m n] Tests if group node [m] is a the immediate parent of + group node [n]. Returns [true] when the test passes and [false] otherwise. *) + + val show : t -> string + (** [show n] returns a string representation of a node type. *) -val root : t -(** Returns the root node *) + val pp : Format.formatter -> t -> unit + (** [pp fmt t] pretty prints a node type value. *) +end -val create : t -> string -> (t, [> error]) result -(** [create p n] returns a node with parent [p] and name [n] - or an error of type {!error} if this operation fails. *) +module ArrayNode : sig + type t + (** The type of an array node. *) -val ( / ) : t -> string -> (t, [> error]) result -(** The infix operator alias of {!Node.create} *) + val create : GroupNode.t -> string -> (t, [> error]) result + (** [create p n] returns an array node with parent [p] and name [n] + or an error if this operation fails. *) -val of_path : string -> (t, [> error]) result -(** [of_path s] returns a node from string [s] or an error of - type {!error} upon failure. *) + val ( / ) : GroupNode.t -> string -> (t, [> error]) result + (** The infix operator alias of {!ArrayNode.create} *) -val to_path : t -> string -(** [to_path n] returns node [n] as a string path. *) + val of_path : string -> (t, [> error]) result + (** [of_path s] returns an array node from string [s] or an error + upon failure. *) -val name : t -> string -(** [name n] returns the name of node [n]. The root node does not have a - name and thus the empty string [""] is returned if [n] is a root node. *) + val to_path : t -> string + (** [to_path n] returns array node [n] as a string path. *) -val parent : t -> t option -(** [parent n] returns [Some p] where [p] is the parent node of [n] - of [None] if node [n] is the root node. *) + val name : t -> string + (** [name n] returns the name of array node [n]. *) -val ( = ) : t -> t -> bool -(** [x = y] returns [true] if nodes [x] and [y] are equal, - and [false] otherwise. *) + val parent : t -> GroupNode.t + (** [parent n] returns parent group node of [n].*) -val ancestors : t -> t list -(** [ancestors n] returns ancestor nodes of [n] including the root node. - The root node has no ancestors, thus this returns the empty list - is called on a root node. *) + val ( = ) : t -> t -> bool + (** [x = y] returns [true] if nodes [x] and [y] are equal, + and [false] otherwise. *) -val to_key : t -> string -(** [to_key n] converts a node's path to a key, as defined in the Zarr V3 - specification. *) + val ancestors : t -> GroupNode.t list + (** [ancestors n] returns ancestor group nodes of [n]. *) -val to_prefix : t -> string -(** [to_prefix n] converts a node's path to a prefix key, as defined - in the Zarr V3 specification. *) + val is_parent : t -> GroupNode.t -> bool + (** [is_parent n g] returns [true] if group node [g] is the immediate + parent of array node [n] and [false] otherwise. *) -val to_metakey : t -> string -(** [to_prefix n] returns the metadata key associated with node [n], - as defined in the Zarr V3 specification. *) + val to_key : t -> string + (** [to_key n] converts a node's path to a key, as defined in the Zarr V3 + specification. *) -val is_parent : t -> t -> bool -(** [is_parent m n] Tests if node [n] is a the immediate parent of - node [m]. Returns [true] when the test passes and [false] otherwise. *) + val to_metakey : t -> string + (** [to_prefix n] returns the metadata key associated with node [n], + as defined in the Zarr V3 specification. *) -val show : t -> string -(** [show n] returns a string representation of a node type. *) + val show : t -> string + (** [show n] returns a string representation of a node type. *) -val pp : Format.formatter -> t -> unit -(** [pp fmt t] pretty prints a node type value. *) + val pp : Format.formatter -> t -> unit + (** [pp fmt t] pretty prints a node type value. *) +end diff --git a/lib/storage/storage.ml b/lib/storage/storage.ml index 8c29860..2edcfb0 100644 --- a/lib/storage/storage.ml +++ b/lib/storage/storage.ml @@ -1,26 +1,31 @@ include Storage_intf open Util.Result_syntax +open Node + +module Ndarray = Owl.Dense.Ndarray.Generic +module ArraySet = Util.ArraySet +module Arraytbl = Util.Arraytbl +module AM = Metadata.ArrayMetadata +module GM = Metadata.GroupMetadata module Make (M : STORE) : S with type t = M.t = struct - module Ndarray = Owl.Dense.Ndarray.Generic - module ArraySet = Util.ArraySet - module Arraytbl = Util.Arraytbl - module AM = Metadata.ArrayMetadata - module GM = Metadata.GroupMetadata include M (* All nodes are explicit upon creation so just check the node's metadata key.*) - let is_member t node = - M.is_member t @@ Node.to_metakey node + let group_exists t node = + M.is_member t @@ GroupNode.to_metakey node + + let array_exists t node = + M.is_member t @@ ArrayNode.to_metakey node let rec create_group ?metadata t node = - if is_member t node then () + if group_exists t node then () else - (match metadata, Node.to_metakey node with + (match metadata, GroupNode.to_metakey node with | Some m, k -> set t k @@ GM.encode m; | None, k -> set t k @@ GM.(default |> encode)); - make_implicit_groups_explicit t @@ Node.parent node + make_implicit_groups_explicit t @@ GroupNode.parent node and make_implicit_groups_explicit t = function | None -> () @@ -55,84 +60,85 @@ module Make (M : STORE) : S with type t = M.t = struct fill_value chunks in - set t (Node.to_metakey node) (AM.encode meta); - Ok (make_implicit_groups_explicit t @@ Node.parent node) - - (* Assumes without checking that [metakey] is a valid node metadata key.*) - let unsafe_node_type t metakey = - let open Yojson.Safe in - get t metakey |> Result.get_ok |> from_string - |> Util.member "node_type" |> Util.to_string + set t (ArrayNode.to_metakey node) (AM.encode meta); + Result.ok @@ + make_implicit_groups_explicit t @@ + Some (ArrayNode.parent node) let group_metadata node t = - if not @@ is_member t node then + if not @@ group_exists t node then Result.error @@ - `Store_read (Node.show node ^ " is not a member of this store.") + `Store_read (GroupNode.show node ^ " is not a member of this store.") else - get t @@ Node.to_metakey node >>= fun bytes -> - match GM.decode bytes with - | Ok meta -> Ok meta - | Error _ -> - Result.error @@ - `Store_read (Node.show node ^ " is not an array node.") + get t @@ GroupNode.to_metakey node >>= fun bytes -> + GM.decode bytes let array_metadata node t = - if not @@ is_member t node then + if not @@ array_exists t node then Result.error @@ - `Store_read (Node.show node ^ " is not a member of this store.") + `Store_read (ArrayNode.show node ^ " is not a member of this store.") else - get t @@ Node.to_metakey node >>= fun bytes -> - match AM.decode bytes with - | Ok meta -> Ok meta - | Error _ -> - Result.error @@ - `Store_read (Node.show node ^ " is not an array node.") + get t @@ ArrayNode.to_metakey node >>= fun bytes -> + AM.decode bytes + + (* Assumes without checking that [metakey] is a valid node metadata key.*) + let unsafe_node_type t metakey = + let open Yojson.Safe in + get t metakey |> Result.get_ok |> from_string + |> Util.member "node_type" |> Util.to_string let find_child_nodes t node = - match is_member t node, Node.to_metakey node with - | true, k when unsafe_node_type t k = "group" -> + if group_exists t node then Result.ok @@ List.fold_left (fun (lacc, racc) pre -> - let x = - Result.get_ok @@ (* this operation should not fail *) - Node.of_path @@ - "/" ^ String.(length pre - 1 |> sub pre 0) - in if unsafe_node_type t (pre ^ "zarr.json") = "array" then - x :: lacc, racc + let x = + Result.get_ok @@ + ArrayNode.of_path @@ + "/" ^ String.(length pre - 1 |> sub pre 0) + in + x :: lacc, racc else - lacc, x :: racc) - ([], []) (snd @@ list_dir t @@ Node.to_prefix node) - | true, _ -> - Result.error @@ - `Store_read (Node.show node ^ " is not a group node.") - | false, _ -> - Result.error @@ - `Store_read (Node.show node ^ " is not a node in this heirarchy.") + let x = + Result.get_ok @@ + GroupNode.of_path @@ + "/" ^ String.(length pre - 1 |> sub pre 0) + in + lacc, x :: racc) + ([], []) (snd @@ list_dir t @@ GroupNode.to_prefix node) + else + let msg = + GroupNode.show node ^ " is not a node in this heirarchy." in + Result.error @@ `Store_read msg let find_all_nodes t = - let rec aux acc p = + let rec aux ((l, r) as acc) p = match find_child_nodes t p with | Error _ -> acc - | Ok ([], []) -> p :: acc + | Ok ([], []) -> (l, p :: r) | Ok (arrays, groups) -> - arrays @ p :: List.concat_map (aux acc) groups - in aux [] Node.root + let (l', r') = + List.map (aux acc) groups |> List.split in + arrays @ List.concat l', p :: List.concat r' + in aux ([], []) GroupNode.root + + let erase_group_node t node = + erase_prefix t @@ GroupNode.to_prefix node - let erase_node t node = - erase_prefix t @@ Node.to_prefix node + let erase_array_node t node = + erase t @@ ArrayNode.to_metakey node let set_array : type a b. - Node.t -> + ArrayNode.t -> Owl_types.index array -> (a, b) Ndarray.t -> t -> (unit, [> error]) result = fun node slice x t -> let open Util in - get t @@ Node.to_metakey node >>= fun bytes -> + get t @@ ArrayNode.to_metakey node >>= fun bytes -> AM.decode bytes >>= fun meta -> (if Ndarray.shape x = Indexing.slice_shape slice @@ AM.shape meta then Ok () @@ -158,7 +164,7 @@ module Make (M : STORE) : S with type t = M.t = struct ;fill_value = AM.fillvalue_of_kind meta @@ Ndarray.kind x} in let codecs = AM.codecs meta in - let prefix = Node.to_prefix node in + let prefix = ArrayNode.to_key node ^ "/" in let cindices = ArraySet.of_seq @@ Arraytbl.to_seq_keys tbl in ArraySet.fold (fun idx acc -> acc >>= fun () -> @@ -187,14 +193,14 @@ module Make (M : STORE) : S with type t = M.t = struct let get_array : type a b. - Node.t -> + ArrayNode.t -> Owl_types.index array -> (a, b) Bigarray.kind -> t -> ((a, b) Ndarray.t, [> error]) result = fun node slice kind t -> let open Util in - get t @@ Node.to_metakey node >>= fun bytes -> + get t @@ ArrayNode.to_metakey node >>= fun bytes -> AM.decode bytes >>= fun meta -> (if AM.is_valid_kind meta kind then Ok () @@ -214,7 +220,7 @@ module Make (M : STORE) : S with type t = M.t = struct (AM.index_coord_pair meta) (Indexing.coords_of_slice slice @@ AM.shape meta) in let tbl = Arraytbl.create @@ Array.length pair in - let prefix = Node.to_prefix node in + let prefix = ArrayNode.to_key node ^ "/" in let chain = AM.codecs meta in let repr = {kind @@ -239,20 +245,15 @@ module Make (M : STORE) : S with type t = M.t = struct Ndarray.of_array kind (Array.of_list res) sshape let reshape t node shape = - let mkey = Node.to_metakey node in - (if "array" = unsafe_node_type t mkey then - Ok () - else - Error (`Store_write (Node.show node ^ " is not an array node."))) - >>= fun () -> - get t mkey >>= fun bytes -> + let mkey = ArrayNode.to_metakey node in + get t mkey >>= fun bytes -> AM.decode bytes >>= fun meta -> (if Array.length shape = Array.length @@ AM.shape meta then Ok () else Error (`Store_write "new shape must have same number of dimensions.")) >>= fun () -> - let pre = Node.to_prefix node in + let pre = ArrayNode.to_key node ^ "/" in let s = ArraySet.of_list @@ AM.chunk_indices meta @@ AM.shape meta in let s' = diff --git a/lib/storage/storage_intf.ml b/lib/storage/storage_intf.ml index 546965b..59c2e09 100644 --- a/lib/storage/storage_intf.ml +++ b/lib/storage/storage_intf.ml @@ -1,4 +1,5 @@ open Metadata +open Node type key = string @@ -7,6 +8,7 @@ type range = ByteRange of int * int option type error = [ `Store_read of string | `Store_write of string + | Node.error | Metadata.error | Codecs.error ] @@ -48,9 +50,9 @@ module type S = sig (** The storage type. *) val create_group - : ?metadata:GroupMetadata.t -> t -> Node.t -> unit + : ?metadata:GroupMetadata.t -> t -> GroupNode.t -> unit (** [create_group ~meta t node] creates a group node in store [t] - containing metadata [meta]. This is a no-op if a node [node] + containing metadata [meta]. This is a no-op if [node] is already a member of this store. *) val create_array @@ -62,7 +64,7 @@ module type S = sig chunks:int array -> ('a, 'b) Bigarray.kind -> 'a -> - Node.t -> + ArrayNode.t -> t -> (unit, [> Codecs.error]) result (** [create_array ~sep ~dimension_names ~attributes ~codecs ~shape ~chunks kind fill node t] @@ -77,43 +79,46 @@ module type S = sig This operation can fail if the codec chain is not well defined. *) val array_metadata - : Node.t -> t -> (ArrayMetadata.t, [> error]) result + : ArrayNode.t -> t -> (ArrayMetadata.t, [> error]) result (** [array_metadata node t] returns the metadata of array node [node]. - This operation returns an error if: - - The node is not a member of store [t]. - - if node [node] is a group node. *) + This operation returns an error if node is not a member of store [t]. *) val group_metadata - : Node.t -> t -> (GroupMetadata.t, [> error]) result + : GroupNode.t -> t -> (GroupMetadata.t, [> error]) result (** [group_metadata node t] returns the metadata of group node [node]. - This operation returns an error if: - - The node is not a member of store [t]. - - if node [node] is an array node. *) + This operation returns an error if node is not a member of store [t].*) val find_child_nodes - : t -> Node.t -> (Node.t list * Node.t list, [> error]) result + : t -> GroupNode.t -> (ArrayNode.t list * GroupNode.t list, [> error]) result (** [find_child_nodes t n] returns a tuple of child nodes of group node [n]. - The first element of the tuple is a list of array child nodes, and the - second element a list of child group nodes. - This operation can fail if: - - Node [n] is not a member of store [t]. - - Node [n] is an array node of store [t]. *) - - val find_all_nodes : t -> Node.t list - (** [find_all_nodes t] returns a list of all nodes in store [t]. If the - store has no nodes, an empty list is returned. *) - - val erase_node : t -> Node.t -> unit - (** [erase_node t n] erases node [n] from store [t]. This function erases - all child nodes if [n] is a group node. If node [n] is not a member + This operation can fail if [n] is not a member of store [t]. *) + + val find_all_nodes : t -> ArrayNode.t list * GroupNode.t list + (** [find_all_nodes t] returns [Some p] where [p] is a pair of lists + representing all nodes in store [t]. The first element of the pair + is a list of all array nodes, and the second element is a list of + all group nodes. If the store has no nodes, [None] is returned. *) + + val erase_group_node : t -> GroupNode.t -> unit + (** [erase_group_node t n] erases group node [n] from store [t]. This also + erases all child nodes of [n]. If node [n] is not a member of store [t] then this is a no-op. *) - val is_member : t -> Node.t -> bool - (** [is_member t n] returns [true] if node [n] is a member of store [t] - and [false] otherwise. *) + val erase_array_node : t -> ArrayNode.t -> unit + (** [erase_array_node t n] erases group node [n] from store [t]. This also + erases all child nodes of [n]. If node [n] is not a member + of store [t] then this is a no-op. *) + + val group_exists : t -> GroupNode.t -> bool + (** [group_exists t n] returns [true] if group node [n] is a member + of store [t] and [false] otherwise. *) + val array_exists : t -> ArrayNode.t -> bool + (** [array_exists t n] returns [true] if array node [n] is a member + of store [t] and [false] otherwise. *) + val set_array - : Node.t -> + : ArrayNode.t -> Owl_types.index array -> ('a, 'b) Ndarray.t -> t -> @@ -126,7 +131,7 @@ module type S = sig - If there is a problem decoding/encoding node [n] chunks.*) val get_array - : Node.t -> + : ArrayNode.t -> Owl_types.index array -> ('a, 'b) Bigarray.kind -> t -> @@ -138,12 +143,11 @@ module type S = sig in its metadata document. - The slice [s] is not a valid slice of array node [n].*) - val reshape : t -> Node.t -> int array -> (unit, [> error]) result + val reshape : t -> ArrayNode.t -> int array -> (unit, [> error]) result (** [reshape t n shape] resizes array node [n] of store [t] into new - size [shape]. If this operation fails, an error is returned. It - can fail if: - - Node [n] is not a valid array node. - - If [shape] does not have the same dimensions as node [n]'s shape. *) + size [shape]. If this operation fails, an error is returned. + It can fail if [shape] does not have the same dimensions as [n]'s shape. + If node [n] is not a member of store [t] then this is a no-op. *) end module type MAKER = functor (M : STORE) -> S with type t = M.t @@ -178,57 +182,36 @@ module Base = struct module StrSet = Set.Make (String) - let erase_values ~erase_fn t keys = - StrSet.iter (erase_fn t) @@ StrSet.of_list keys - - let erase_prefix ~list_fn ~erase_fn t pre = - List.iter (fun k -> - if String.starts_with ~prefix:pre k - then begin - erase_fn t k - end) @@ list_fn t - let list_prefix ~list_fn t pre = List.filter (String.starts_with ~prefix:pre) (list_fn t) + let erase_values ~erase_fn t keys = + StrSet.iter (erase_fn t) @@ StrSet.of_list keys + + let erase_prefix ~list_fn ~erase_fn t pre = + erase_values ~erase_fn t @@ list_prefix ~list_fn t pre + let list_dir ~list_fn t pre = - let paths = - List.map - (fun k -> - Result.get_ok @@ - Node.of_path @@ - String.cat "/" k) - (list_prefix ~list_fn t pre) - in - let is_prefix_child k = - match Node.parent k with - | Some par -> - String.equal pre @@ Node.to_prefix par - | None -> false in + let n = String.length pre in let keys, rest = - List.partition_map (fun k -> - match is_prefix_child k with - | true -> Either.left @@ Node.to_key k - | false -> Either.right k) - paths + StrSet.fold + (fun k (l, r) -> + if not @@ String.contains_from k n '/' then + StrSet.add k l, r + else + l, StrSet.add k r) + (StrSet.of_list @@ list_prefix ~list_fn t pre) + (StrSet.empty, StrSet.empty) in let prefixes = - List.fold_left (fun acc k -> - match - List.find_opt - is_prefix_child - (Node.ancestors k) - with - | None -> acc - | Some v -> - let w = Node.to_prefix v in - if List.mem w acc then acc - else w :: acc) - [] rest + StrSet.map + (fun k -> + String.sub k 0 @@ + 1 + String.index_from k n '/') rest in - keys, prefixes + StrSet.(elements keys, elements prefixes) let rec get_partial_values ~get_fn t kr_pairs = match kr_pairs with diff --git a/test/test_node.ml b/test/test_node.ml index 8f65bce..c39d38f 100644 --- a/test/test_node.ml +++ b/test/test_node.ml @@ -1,103 +1,170 @@ open OUnit2 -open Zarr +open Zarr.Node -let creation_failure = "Creation of node should not fail." -let tests = [ +let group_node = [ +"group node tests" >:: (fun _ -> + let creation_failure = "Creation of group node should not fail." in + let r = GroupNode.(root / "somename") in + assert_bool creation_failure @@ Result.is_ok r; -"creation" >:: (fun _ -> - let n = Node.(root / "somename") in - assert_bool creation_failure @@ Result.is_ok n; - let p = Result.get_ok n in - let msg = "Creation of node should not succeed." in + (* test node invariants *) + let n = Result.get_ok r in + let msg = "Creation of group node should not succeed." in List.iter (fun x -> assert_bool msg @@ Result.is_error x) @@ - List.map (Node.create p) [""; "na/me"; "...."; "__name"]) -; -"creation from path string" >:: (fun _ -> - let n = Node.of_path "/" in - assert_bool creation_failure @@ Result.is_ok n; - assert_equal - ~printer:Node.show Node.root @@ Result.get_ok n; - let msg = "Creation of node should not succeed" in + List.map (GroupNode.create n) [""; "na/me"; "...."; "__name"]; + + (* creation from string path *) + let r = GroupNode.of_path "/" in + assert_bool creation_failure @@ Result.is_ok r; + assert_equal + ~printer:GroupNode.show GroupNode.root @@ Result.get_ok r; List.iter (fun x -> assert_bool msg @@ Result.is_error x) @@ List.map - Node.of_path @@ - [""; "na/meas"; "/some/..."; "/root/__name"; "/sd/"]) -; -"exploratory functions" >:: (fun _ -> + GroupNode.of_path @@ + [""; "na/meas"; "/some/..."; "/root/__name"; "/sd/"]; + + (* node name tests *) let s = "/some/dir/moredirs/path/pname" in - let n = Node.of_path s |> Result.get_ok in - assert_equal "pname" @@ Node.name n; - assert_equal "" @@ Node.name Node.root; + let n = GroupNode.of_path s |> Result.get_ok in + assert_equal "pname" @@ GroupNode.name n; + assert_equal "" @@ GroupNode.name GroupNode.root; - assert_equal None @@ Node.parent Node.root; - match Node.parent n with + (* parent tests *) + assert_equal None @@ GroupNode.parent GroupNode.root; + match GroupNode.parent n with | None -> - assert_failure - "A non-root node must have a parent."; + assert_failure "A non-root node must have a parent."; | Some p -> - assert_equal - "/some/dir/moredirs/path" @@ Node.show p; + assert_equal "/some/dir/moredirs/path" @@ GroupNode.show p; - assert_equal ~printer:Node.show Node.root Node.root; + (* equality tests *) + assert_equal ~printer:GroupNode.show GroupNode.root GroupNode.root; assert_bool "root node cannot be equal to its child" @@ - not Node.(root = n); + not GroupNode.(root = n); assert_bool "non-root node cannot have root as child" @@ - not Node.(n = root); + not GroupNode.(n = root); - assert_equal [] @@ Node.ancestors Node.root; + (* ancestory tests *) + assert_equal [] @@ GroupNode.ancestors GroupNode.root; assert_equal ~printer:[%show: string list] ["/"; "/some"; "/some/dir"; "/some/dir/moredirs" ;"/some/dir/moredirs/path"] - (Node.ancestors n |> List.map Node.show); + (GroupNode.ancestors n |> List.map GroupNode.show); + let exp_parents = GroupNode.ancestors n in + let r, l = List.fold_left_map + (fun acc _ -> + match GroupNode.parent acc with + | Some acc' -> acc', acc' + | None -> acc, acc) n exp_parents + in + assert_equal + ~printer:[%show: GroupNode.t list] + exp_parents @@ + List.rev l; + assert_equal ~printer:GroupNode.show r GroupNode.root; - let p = Node.parent n |> Option.get in + (* child node tests *) + let p = GroupNode.parent n |> Option.get in assert_equal ~printer:string_of_bool true @@ - Node.is_parent n p; + GroupNode.is_child_group p n; assert_equal ~printer:string_of_bool false @@ - Node.is_parent Node.root n; + GroupNode.is_child_group n GroupNode.root; assert_equal ~printer:string_of_bool false @@ - Node.is_parent Node.root Node.root; - - let exp_parents = Node.ancestors n in - let r, l = List.fold_left_map - (fun acc _ -> - match Node.parent acc with - | Some acc' -> acc', acc' - | None -> acc, acc) n exp_parents - in - assert_equal - ~printer:[%show: Node.t list] - exp_parents @@ - List.rev l; - assert_equal ~printer:Node.show r Node.root; + GroupNode.is_child_group GroupNode.root GroupNode.root; + (* stringify tests *) assert_equal - ~printer:Fun.id "" @@ Node.to_key Node.root; + ~printer:Fun.id "" @@ GroupNode.to_key GroupNode.root; assert_equal ~printer:Fun.id "some/dir/moredirs/path/pname" @@ - Node.to_key n; + GroupNode.to_key n; assert_equal ~printer:Fun.id "zarr.json" @@ - Node.to_metakey Node.root; + GroupNode.to_metakey GroupNode.root; + + assert_equal + ~printer:Fun.id + ("some/dir/moredirs/path/pname/zarr.json") @@ + GroupNode.to_metakey n) +] + +let array_node = [ +"array node tests" >:: (fun _ -> + let r = ArrayNode.(GroupNode.root / "somename") in + assert_bool "" @@ Result.is_ok r; + + (* test node invariants *) + let msg = "Creation of group node should not succeed." in + List.iter + (fun x -> assert_bool msg @@ Result.is_error x) @@ + List.map + (ArrayNode.create GroupNode.root) + [""; "na/me"; "...."; "__name"]; + + (* creation from string path *) + let msg = "creating an array node from an illformed path is impossible" in + List.iter + (fun x -> assert_bool msg @@ Result.is_error x) @@ + List.map + ArrayNode.of_path @@ + ["/"; ""; "na/meas"; "/some/..."; "/root/__name"; "/sd/"]; + + (* node name tests *) + let s = "/some/dir/moredirs/path/pname" in + let n = ArrayNode.of_path s |> Result.get_ok in + assert_equal "pname" @@ ArrayNode.name n; + assert_equal ~printer:Fun.id s @@ ArrayNode.to_path n; + + (* parent tests *) + assert_equal + ~printer:GroupNode.show + GroupNode.root @@ + ArrayNode.parent (ArrayNode.of_path "/nodename" |> Result.get_ok); + + (* equality tests *) + assert_equal + true @@ ArrayNode.(n = (ArrayNode.of_path s |> Result.get_ok)); + assert_equal + false @@ + ArrayNode.(n = Result.get_ok @@ ArrayNode.of_path (s ^ "/more")); + + (* ancestory tests *) + assert_equal + ~printer:[%show: string list] + ["/"; "/some"; "/some/dir"; "/some/dir/moredirs" + ;"/some/dir/moredirs/path"] + (ArrayNode.ancestors n + |> List.map GroupNode.show + |> List.fast_sort String.compare); + let m = ArrayNode.of_path "/some" |> Result.get_ok in + assert_equal true @@ ArrayNode.is_parent m GroupNode.root; + + (* stringify tests *) + assert_equal + ~printer:Fun.id + "some/dir/moredirs/path/pname" @@ + ArrayNode.to_key n; assert_equal ~printer:Fun.id ("some/dir/moredirs/path/pname/zarr.json") @@ - Node.to_metakey n) + ArrayNode.to_metakey n) ] + +let tests = group_node @ array_node diff --git a/test/test_storage.ml b/test/test_storage.ml index 732f312..9193e3d 100644 --- a/test/test_storage.ml +++ b/test/test_storage.ml @@ -1,5 +1,6 @@ open OUnit2 open Zarr +open Zarr.Node open Zarr.Storage module Ndarray = Owl.Dense.Ndarray.Generic @@ -8,13 +9,13 @@ let string_of_list = [%show: string list] let test_store (type a) (module M : Zarr.Storage.S with type t = a) (store : a) = - let gnode = Node.root in + let gnode = GroupNode.root in M.create_group store gnode; assert_equal ~printer:string_of_bool true @@ - M.is_member store gnode; + M.group_exists store gnode; (match M.group_metadata gnode store with | Ok meta -> @@ -25,13 +26,13 @@ let test_store "group node created with default values should have metadata with default values."); - M.erase_node store gnode; + M.erase_group_node store gnode; assert_bool "Cannot retrive metadata of a node not in the store." @@ Result.is_error @@ M.group_metadata gnode store; assert_equal - ~printer:[%show: Node.t list] - [] @@ + ~printer:[%show: ArrayNode.t list * GroupNode.t list] + ([], []) @@ M.find_all_nodes store; let attrs = `Assoc [("questions", `String "answer")] in @@ -50,13 +51,13 @@ let test_store "group node created with specified values should have metadata with said values."); - let fake = Node.(gnode / "non-member") |> Result.get_ok in + let fake = ArrayNode.(gnode / "non-member") |> Result.get_ok in assert_equal ~printer:string_of_bool false @@ - M.is_member store fake; + M.array_exists store fake; - let anode = Node.(gnode / "arrnode") |> Result.get_ok in + let anode = ArrayNode.(gnode / "arrnode") |> Result.get_ok in let r = M.create_array ~shape:[|100; 100; 50|] @@ -68,10 +69,6 @@ let test_store in assert_equal (Ok ()) r; - assert_bool - "Cannot get group metadata from an array node" @@ - Result.is_error @@ M.group_metadata anode store; - let slice = Owl_types.[|R [0; 20]; I 10; R []|] in let expected = Ndarray.create Bigarray.Complex64 [|21; 1; 50|] Complex.zero in @@ -117,30 +114,26 @@ let test_store Result.is_error @@ M.set_array anode slice bad_arr store; - let child = Node.of_path "/some/child" |> Result.get_ok in + let child = GroupNode.of_path "/some/child" |> Result.get_ok in M.create_group store child; (match M.find_child_nodes store gnode with | Ok (arrays, groups) -> assert_equal ~printer:string_of_list ["/arrnode"] @@ - List.map Node.to_path arrays; + List.map ArrayNode.to_path arrays; assert_equal ~printer:string_of_list ["/some"] @@ - List.map Node.to_path groups + List.map GroupNode.to_path groups | Error _ -> assert_failure "a store with more than one node should return children for a root node."); - assert_bool - "Array nodes cannot have children" - (Result.is_error @@ M.find_child_nodes store anode); - + let ac, gc = M.find_all_nodes store in let got = - M.find_all_nodes store - |> List.map Node.show + List.map ArrayNode.show ac @ List.map GroupNode.show gc |> List.fast_sort String.compare in assert_equal ~printer:string_of_list @@ -157,21 +150,15 @@ let test_store ~printer:[%show: int array] new_shape @@ ArrayMetadata.shape meta; - assert_bool - "Group nodes cannot be reshaped" @@ - Result.is_error @@ M.reshape store gnode new_shape; assert_bool "New shape must have the number of dims as the node." @@ Result.is_error @@ M.reshape store anode [|25; 10|]; - assert_bool - "Cannot get array metadata from a group node" @@ - Result.is_error @@ M.array_metadata gnode store; assert_bool "Cannot get array metadata from a node not a member of store" @@ Result.is_error @@ M.array_metadata fake store; - M.erase_node store anode + M.erase_array_node store anode let tests = [