Add Tree.is_val and Tree.Contents.is_val functions

src/irmin-test/store.ml

@@ -1417,6 +1417,37 @@ module Make (S : Generic_key) = struct
     in
     run x test
 
+  let test_lazy_tree x () =
+    let is_val_aux v t k =
+      let str = Fmt.str "empty is_val %a" Irmin.Type.(pp S.path_t) k in
+      let b = S.Tree.is_val t k in
+      Alcotest.(check bool) str v b
+    in
+    let is_val = is_val_aux true in
+    let is_not_val = is_val_aux false in
+    let test repo =
+      let v0 = S.Tree.empty () in
+      is_val v0 [];
+      is_val v0 [ "foo" ];
+      is_val v0 [ "foo"; "bar" ];
+
+      let* r1 = r1 ~repo in
+      let v1 = S.Commit.tree r1 in
+      is_not_val v1 [];
+      is_not_val v1 [ "a" ];
+
+      let* _ = S.Tree.find_tree v1 [ "a" ] in
+      is_val v1 [];
+      is_val v1 [ "a" ];
+
+      S.Tree.clear v1;
+      is_not_val v1 [];
+      is_not_val v1 [ "a" ];
+
+      Lwt.return ()
+    in
+    run x test
+
   let pp_proof = Irmin.Type.pp (S.Tree.Proof.t S.Tree.Proof.tree_t)
   let pp_stream = Irmin.Type.pp (S.Tree.Proof.t S.Tree.Proof.stream_t)
 
@@ -2441,6 +2472,7 @@ let suite (speed, x) =
   suite'
     ([
        ("High-level operations on trees", speed, T.test_trees x);
+       ("Test lazy trees", speed, T.test_lazy_tree x);
        ("Basic operations on contents", speed, T.test_contents x);
        ("Basic operations on nodes", speed, T.test_nodes x);
        ("Basic operations on commits", speed, T.test_commits x);

src/irmin/tree.ml

@@ -320,6 +320,8 @@ module Make (P : Backend.S) = struct
               if cache then c.info.ptr <- Hash h;
               h)
 
+    let is_val t = match cached_value t with None -> false | Some _ -> true
+
     let key t =
       match t.v with Key (_, k) -> Some k | Value _ | Pruned _ -> None
 
@@ -1227,6 +1229,20 @@ module Make (P : Backend.S) = struct
 
     let findv = findv_aux ~value_of_key ~return:Lwt.return ~bind:Lwt.bind
 
+    exception Lazy
+
+    let findv' ctx t k =
+      findv_aux ~cache:false
+        ~value_of_key:(fun ~cache:_ _ _ _ -> raise Lazy)
+        ~return:Fun.id
+        ~bind:(fun x f -> f x)
+        ctx t k
+
+    let is_val t =
+      match (cached_map t, cached_value t) with
+      | None, None -> false
+      | _ -> true
+
     let seq_of_map ?(offset = 0) ?length m : (step * elt) Seq.t =
       let take seq =
         match length with None -> seq | Some n -> Seq.take n seq
@@ -1691,6 +1707,19 @@ module Make (P : Backend.S) = struct
     | `Node n -> (aux [@tailcall]) n path
     | `Contents _ -> Lwt.return_none
 
+  let is_val t path =
+    let rec aux node path =
+      match Path.decons path with
+      | None -> Node.is_val node
+      | Some (h, p) -> (
+          match Node.findv' "is_val" node h with
+          | None -> true
+          | exception Node.Lazy -> false
+          | Some (`Contents (c, _)) -> Contents.is_val c
+          | Some (`Node n) -> aux n p)
+    in
+    match t with `Node n -> aux n path | `Contents (c, _) -> Contents.is_val c
+
   let find_tree (t : t) path =
     let cache = true in
     [%log.debug "Tree.find_tree %a" pp_path path];

src/irmin/tree_intf.ml

@@ -82,6 +82,12 @@ module type S = sig
   (** [is_empty t] is true iff [t] is {!empty} (i.e. a tree node with no
       children). Trees with {!kind} = [`Contents] are never considered empty. *)
 
+  val is_val : t -> path -> bool
+  (** [is_val t k] is [true] iff the path [k] has already been forced in [t]. In
+      that case, that means that all the nodes traversed by [k] are loaded in
+      memory. If the leaf node is a contents [c], then [Contents.is_val c]
+      should also be [true]. *)
+
   (** {1 Diffs} *)
 
   val diff : t -> t -> (path * (contents * metadata) Diff.t) list Lwt.t
@@ -128,6 +134,10 @@ module type S = sig
     (** Equivalent to {!val-force}, but raises an exception if the lazy content
         value is not present in the underlying repository. *)
 
+    val is_val : t -> bool
+    (** [is_val x] is [true] iff [x] has already been forced (and so is loaded
+        in memory). *)
+
     val clear : t -> unit
     (** [clear t] clears [t]'s cache. *)