Proto_env: remove Context.list

This was a reminder of old-time (before irmin-1.0). It is now replaced
with: `Context.{fold,keys}`.

src/environment/v1/context.mli

@@ -23,9 +23,17 @@ 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 del: t -> key -> t Lwt.t
-val list: t -> key list -> key list Lwt.t
 val remove_rec: t -> key -> t Lwt.t
 
+val fold:
+  t -> key -> init:'a ->
+  f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) ->
+  'a Lwt.t
+
+val keys: t -> key -> key list Lwt.t
+val fold_keys:
+  t -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
+
 val register_resolver:
   'a Base58.encoding -> (t -> string -> 'a list Lwt.t) -> unit
 

src/node/db/context.ml

@@ -170,19 +170,35 @@ let raw_del ctxt key =
   Lwt.return { ctxt with tree }
 let del t key = raw_del t (data_key key)
 
-let list_one ctxt key =
-  Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () ->
-  GitStore.Tree.list ctxt.tree (data_key key) >>= fun keys ->
-  Lwt.return (List.map (fun (k,_) -> key @ [k]) keys)
-
-let list ctxt keys =
-  Lwt_list.map_p (list_one ctxt) keys >|= List.flatten
-
 let remove_rec ctxt key =
   Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () ->
   GitStore.Tree.remove ctxt.tree (data_key key) >>= fun tree ->
   Lwt.return { ctxt with tree }
 
+let fold ctxt key ~init ~f =
+  Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () ->
+  GitStore.Tree.list ctxt.tree (data_key key) >>= fun keys ->
+  Lwt_list.fold_left_s
+    begin fun acc (name, kind) ->
+      let key =
+        match kind with
+        | `Contents -> `Key (key @ [name])
+        | `Node -> `Dir (key @ [name]) in
+      f key acc
+    end
+    init keys
+
+let fold_keys s k ~init ~f =
+  let rec loop k acc =
+    fold s k ~init:acc
+      ~f:(fun file acc ->
+          match file with
+          | `Key k -> f k acc
+          | `Dir k -> loop k acc) in
+  loop k init
+
+let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))
+
 (*-- Predefined Fields -------------------------------------------------------*)
 
 let get_protocol v =

src/node/db/context.mli

@@ -48,9 +48,17 @@ val dir_mem: context -> key -> bool Lwt.t
 val get: context -> key -> value option Lwt.t
 val set: context -> key -> value -> t Lwt.t
 val del: context -> key -> t Lwt.t
-val list: context -> key list -> key list Lwt.t
 val remove_rec: context -> key -> t Lwt.t
 
+val fold:
+  context -> key -> init:'a ->
+  f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) ->
+  'a Lwt.t
+
+val keys: context -> key -> key list Lwt.t
+val fold_keys:
+  context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
+
 (** {2 Accessing and Updating Versions} **************************************)
 
 val exists: index -> commit -> bool Lwt.t

src/proto/alpha/persist.ml

@@ -21,8 +21,14 @@ module type STORE = sig
   val get: t -> key -> value option Lwt.t
   val set: t -> key -> value -> t Lwt.t
   val del: t -> key -> t Lwt.t
-  val list: t -> key list -> key list Lwt.t
   val remove_rec: t -> key -> t Lwt.t
+  val fold:
+    t -> key -> init:'a ->
+    f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) ->
+    'a Lwt.t
+  val keys: t -> key -> key list Lwt.t
+  val fold_keys:
+    t -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
 end
 
 module type BYTES_STORE = sig
@@ -32,7 +38,6 @@ module type BYTES_STORE = sig
   val get: t -> key -> value option Lwt.t
   val set: t -> key -> value -> t Lwt.t
   val del: t -> key -> t Lwt.t
-  val list: t -> key list -> key list Lwt.t
   val remove_rec: t -> key -> t Lwt.t
 end
 
@@ -69,7 +74,7 @@ module type PERSISTENT_SET = sig
   val elements : t -> key list Lwt.t
   val clear : t -> t Lwt.t
   val iter : t -> f:(key -> unit Lwt.t) -> unit Lwt.t
-  val fold : t -> 'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
+  val fold : t -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
 end
 
 module type BUFFERED_PERSISTENT_SET = sig
@@ -88,7 +93,7 @@ module type PERSISTENT_MAP = sig
   val bindings : t -> (key * value) list Lwt.t
   val clear : t -> t Lwt.t
   val iter : t -> f:(key -> value -> unit Lwt.t) -> unit Lwt.t
-  val fold : t -> 'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t
+  val fold : t -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t
 end
 
 module type BUFFERED_PERSISTENT_MAP = sig
@@ -123,7 +128,6 @@ module MakeBytesStore
   let to_path k =
     let suffix = K.to_path k in
     prefix K.prefix suffix
-  let of_path k = K.of_path (unprefix K.prefix k)
 
   let mem s k =
     S.mem s (to_path k)
@@ -137,10 +141,6 @@ module MakeBytesStore
   let del s k =
     S.del s (to_path k)
 
-  let list s l =
-    S.list s (List.map to_path l) >>= fun res ->
-    Lwt.return (List.map of_path res)
-
   let remove_rec s k =
     S.remove_rec s (to_path k)
 
@@ -212,21 +212,26 @@ module MakePersistentSet
   let clear c =
     S.remove_rec c K.prefix
 
-  let fold c x ~f =
-    let rec dig i root acc =
-      if CompareStringList.(root = inited_key) then
-        Lwt.return acc
-      else if Compare.Int.(i <= 0) then
-        f (of_path root) acc
+  let fold s ~init ~f =
+    let rec dig i path acc =
+      if Compare.Int.(i <= 1) then
+        S.fold s path ~init:acc ~f:begin fun k acc ->
+          match k with
+          | `Dir _ -> Lwt.return acc
+          | `Key file -> f (of_path file) acc
+        end
       else
-        S.list c [root] >>= fun roots ->
-        Lwt_list.fold_right_s (dig (i - 1)) roots acc in
-    S.mem c inited_key >>= function
-    | true -> dig K.length K.prefix x
-    | false -> Lwt.return x
+        S.fold s path ~init:acc ~f:begin fun k acc ->
+          match k with
+          | `Dir k ->
+              dig (i-1) k acc
+          | `Key _ ->
+              Lwt.return acc
+        end in
+    dig K.length K.prefix init
 
-  let iter c ~f = fold c () ~f:(fun x () -> f x)
-  let elements c = fold c [] ~f:(fun p xs -> Lwt.return (p :: xs))
+  let iter c ~f = fold c ~init:() ~f:(fun x () -> f x)
+  let elements c = fold c ~init:[] ~f:(fun p xs -> Lwt.return (p :: xs))
 
 end
 
@@ -236,7 +241,7 @@ module MakeBufferedPersistentSet
   include MakePersistentSet(S)(K)
 
   let read c =
-    fold c Set.empty ~f:(fun p set -> Lwt.return (Set.add p set))
+    fold c ~init:Set.empty ~f:(fun p set -> Lwt.return (Set.add p set))
 
   let write c set =
     S.set c inited_key empty >>= fun c ->
@@ -286,26 +291,32 @@ module MakePersistentMap
   let clear c =
     S.remove_rec c K.prefix
 
-  let fold c x ~f =
-    let rec dig i root acc =
-      if CompareStringList.(root = inited_key) then
-        Lwt.return acc
-      else if Compare.Int.(i <= 0) then
-        S.get c root >>= function
-        | None -> Lwt.return acc
-        | Some b ->
-            match C.of_bytes b with
-            | None -> Lwt.return acc
-            | Some v -> f (of_path root) v acc
+  let fold s ~init ~f =
+    let rec dig i path acc =
+      if Compare.Int.(i <= 1) then
+        S.fold s path ~init:acc ~f:begin fun k acc ->
+          match k with
+          | `Dir _ -> Lwt.return acc
+          | `Key file ->
+              S.get s file >>= function
+              | None -> Lwt.return acc
+              | Some b ->
+                  match C.of_bytes b with
+                  | None ->
+                      (* Silently ignore unparsable data *)
+                      Lwt.return acc
+                  | Some v -> f (of_path file) v acc
+        end
       else
-        S.list c [root] >>= fun roots ->
-        Lwt_list.fold_right_s (dig (i - 1)) roots acc in
-    S.mem c inited_key >>= function
-    | true -> dig K.length K.prefix x
-    | false -> Lwt.return x
+        S.fold s path ~init:acc ~f:begin fun k acc ->
+          match k with
+          | `Dir k -> dig (i-1) k acc
+          | `Key _ -> Lwt.return acc
+        end in
+    dig K.length K.prefix init
 
-  let iter c ~f = fold c () ~f:(fun k v () -> f k v)
-  let bindings c = fold c [] ~f:(fun k v acc -> Lwt.return ((k, v) :: acc))
+  let iter c ~f = fold c ~init:() ~f:(fun k v () -> f k v)
+  let bindings c = fold c ~init:[] ~f:(fun k v acc -> Lwt.return ((k, v) :: acc))
 
 end
 
@@ -314,7 +325,7 @@ module MakeBufferedPersistentMap
 
   include MakePersistentMap(S)(K)(C)
 
-  let read c = fold c Map.empty ~f:(fun k v m -> Lwt.return (Map.add k v m))
+  let read c = fold c ~init:Map.empty ~f:(fun k v m -> Lwt.return (Map.add k v m))
 
   let write c m =
     clear c >>= fun c ->
@@ -369,7 +380,10 @@ module MakeHashResolver
     (Store : sig
        type t
        val dir_mem: t -> string list -> bool Lwt.t
-       val list: t -> string list list -> string list list Lwt.t
+       val fold:
+         t -> key -> init:'a ->
+         f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) ->
+         'a Lwt.t
        val prefix: string list
      end)
     (H: HASH) = struct
@@ -377,20 +391,28 @@ module MakeHashResolver
   let build path =
     H.of_path_exn @@
     Misc.remove_elem_from_list plen path
+  let list t k =
+    Store.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))
   let resolve t p =
     let rec loop prefix = function
       | [] ->
-          Lwt.return [build prefix]
+          list t prefix >>= fun prefixes ->
+          Lwt_list.map_p (function
+              | `Key prefix | `Dir prefix -> loop prefix []) prefixes
+          >|= List.flatten
       | "" :: ds ->
-          Store.list t [prefix] >>= fun prefixes ->
-          Lwt_list.map_p (fun prefix -> loop prefix ds) prefixes
+          list t prefix >>= fun prefixes ->
+          Lwt_list.map_p (function
+              | `Key prefix | `Dir prefix -> loop prefix ds) prefixes
           >|= List.flatten
       | [d] ->
-          Store.list t [prefix] >>= fun prefixes ->
-          Lwt_list.filter_map_p (fun prefix ->
-              match Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix)) with
-              | None -> Lwt.return_none
-              | Some _ -> Lwt.return (Some (build prefix))
+          list t prefix >>= fun prefixes ->
+          Lwt_list.filter_map_p (function
+              | `Dir _ -> Lwt.return_none
+              | `Key prefix ->
+                  match Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix)) with
+                  | None -> Lwt.return_none
+                  | Some _ -> Lwt.return (Some (build prefix))
             ) prefixes
       | d :: ds ->
           Store.dir_mem t (prefix @ [d]) >>= function

src/proto/alpha/persist.mli

@@ -23,8 +23,14 @@ module type STORE = sig
   val get: t -> key -> value option Lwt.t
   val set: t -> key -> value -> t Lwt.t
   val del: t -> key -> t Lwt.t
-  val list: t -> key list -> key list Lwt.t
   val remove_rec: t -> key -> t Lwt.t
+  val fold:
+    t -> key -> init:'a ->
+    f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) ->
+    'a Lwt.t
+  val keys: t -> key -> key list Lwt.t
+  val fold_keys:
+    t -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
 end
 
 (** Projection of OCaml keys of some abstract type to concrete storage
@@ -62,7 +68,6 @@ module type BYTES_STORE = sig
   val get: t -> key -> value option Lwt.t
   val set: t -> key -> value -> t Lwt.t
   val del: t -> key -> t Lwt.t
-  val list: t -> key list -> key list Lwt.t
   val remove_rec: t -> key -> t Lwt.t
 end
 
@@ -100,7 +105,7 @@ module type PERSISTENT_SET = sig
   val elements : t -> key list Lwt.t
   val clear : t -> t Lwt.t
   val iter : t -> f:(key -> unit Lwt.t) -> unit Lwt.t
-  val fold : t -> 'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
+  val fold : t -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
 end
 
 (** Signature of a buffered set as returned by {!MakeBufferedPersistentSet} *)
@@ -139,7 +144,7 @@ module type PERSISTENT_MAP = sig
   val bindings : t -> (key * value) list Lwt.t
   val clear : t -> t Lwt.t
   val iter : t -> f:(key -> value -> unit Lwt.t) -> unit Lwt.t
-  val fold : t -> 'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t
+  val fold : t -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t
 end
 
 (** Signature of a buffered map as returned by {!MakeBufferedPersistentMap} *)
@@ -202,7 +207,10 @@ module MakeHashResolver
     (Store : sig
        type t
        val dir_mem: t -> key -> bool Lwt.t
-       val list: t -> key list -> key list Lwt.t
+       val fold:
+         t -> key -> init:'a ->
+         f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) ->
+         'a Lwt.t
        val prefix: string list
      end)
     (H: Hash.HASH) : sig

src/proto/alpha/storage_functors.ml

@@ -266,7 +266,7 @@ module Make_data_set_storage (P : Single_data_description) = struct
     map_s (fun (_, data) -> Lwt.return (unserial data)) elts
 
   let fold { context = c } init ~f =
-    HashTbl.fold c (ok init)
+    HashTbl.fold c ~init:(ok init)
       ~f:(fun _ data acc ->
           match acc with
           | Error _ -> Lwt.return acc
@@ -278,7 +278,7 @@ module Make_data_set_storage (P : Single_data_description) = struct
                   return acc)
 
   let clear ({ context = c } as s) =
-    HashTbl.fold c c ~f:(fun hash _ c -> HashTbl.del c hash) >>= fun c ->
+    HashTbl.fold c ~init:c ~f:(fun hash _ c -> HashTbl.del c hash) >>= fun c ->
     return { s with context = c }
 
 end
@@ -363,8 +363,8 @@ module Raw_make_iterable_data_storage
     HashTbl.clear c >>= fun c ->
     Lwt.return { s with context = c }
 
-  let fold { context = c } x ~f = HashTbl.fold c x ~f:(fun k v acc -> f k v acc)
-  let iter { context = c } ~f = HashTbl.fold c () ~f:(fun k v () -> f k v)
+  let fold { context = c } x ~f = HashTbl.fold c ~init:x ~f:(fun k v acc -> f k v acc)
+  let iter { context = c } ~f = HashTbl.fold c ~init:() ~f:(fun k v () -> f k v)
 
 end
 

test/shell/test_context.ml

@@ -176,7 +176,7 @@ let test_replay { idx ; genesis }  =
       Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ;
       Lwt.return ()
 
-let test_list { idx ; genesis } =
+let test_keys { idx ; genesis } =
   checkout idx genesis >>= function
   | None ->
       Assert.fail_msg "checkout genesis_block"
@@ -186,20 +186,23 @@ let test_list { idx ; genesis } =
       set ctxt ["a"; "d"; "e"] (MBytes.of_string "Septembre") >>= fun ctxt ->
       set ctxt ["f";] (MBytes.of_string "Avril") >>= fun ctxt ->
       set ctxt ["g"; "h"] (MBytes.of_string "Avril") >>= fun ctxt ->
-      list ctxt [[]] >>= fun l ->
-      Assert.equal_string_list_list ~msg:__LOC__ [["a"];["f"];["g"]] l ;
-      list ctxt [["a"]] >>= fun l ->
-      Assert.equal_string_list_list
-        ~msg:__LOC__ [["a";"b"]; ["a";"c"]; ["a";"d"]] l ;
-      list ctxt [["f"]] >>= fun l ->
-      Assert.equal_string_list_list ~msg:__LOC__ [] l ;
-      list ctxt [["g"]] >>= fun l ->
-      Assert.equal_string_list_list ~msg:__LOC__ [["g";"h"]] l ;
-      list ctxt [["i"]] >>= fun l ->
-      Assert.equal_string_list_list ~msg:__LOC__ [] l ;
-      list ctxt [["a"];["g"]] >>= fun l ->
+      keys ctxt [] >>= fun l ->
       Assert.equal_string_list_list ~msg:__LOC__
-        [["a"; "b"]; ["a"; "c"]; ["a"; "d"]; ["g"; "h"]] l ;
+        [["a";"b"];
+         ["a";"c"];
+         ["a";"d";"e"];
+         ["f"];
+         ["g";"h"]] (List.sort compare l) ;
+      keys ctxt ["a"] >>= fun l ->
+      Assert.equal_string_list_list
+        ~msg:__LOC__ [["a";"b"]; ["a";"c"]; ["a";"d";"e"]]
+        (List.sort compare l) ;
+      keys ctxt ["f"] >>= fun l ->
+      Assert.equal_string_list_list ~msg:__LOC__ [] l ;
+      keys ctxt ["g"] >>= fun l ->
+      Assert.equal_string_list_list ~msg:__LOC__ [["g";"h"]] l ;
+      keys ctxt ["i"] >>= fun l ->
+      Assert.equal_string_list_list ~msg:__LOC__ [] l ;
       Lwt.return ()
 
 
@@ -210,7 +213,7 @@ let tests : (string * (t -> unit Lwt.t)) list = [
   "continuation", test_continuation ;
   "fork", test_fork ;
   "replay", test_replay ;
-  "list", test_list ;
+  "keys", test_keys ;
 ]
 
 let () =