Add subrepo utils

Author: mbarbin

src/central/subrepo.ml

@@ -39,3 +39,27 @@ let all ~repo_root =
     |> List.sort ~cmp:String.compare
     |> List.map ~f:v
 ;;
+
+let find_on_disk ~repo_root ~name =
+  List.find_opt (all ~repo_root) ~f:(fun t -> String.equal (to_string t) name)
+;;
+
+let central_path t ~subrepo_path =
+  Vcs.Path_in_repo.v
+    (Printf.sprintf
+       "%s/%s"
+       (Vcs.Path_in_repo.to_string (root t))
+       (Vcs.Path_in_repo.to_string subrepo_path))
+;;
+
+let subrepo_path t ~central_path =
+  let prefix = Vcs.Path_in_repo.to_string (root t) ^ "/" in
+  let central_path = Vcs.Path_in_repo.to_string central_path in
+  if
+    String.is_prefix central_path ~prefix
+    && String.length central_path > String.length prefix
+  then (
+    let len = String.length central_path - String.length prefix in
+    Some (Vcs.Path_in_repo.v (String.sub central_path ~pos:(String.length prefix) ~len)))
+  else None
+;;

src/central/subrepo.mli

@@ -31,3 +31,24 @@ val gitrepo_file_path : t -> Vcs.Path_in_repo.t
     its direct children and keeps the ones that contain a [.gitrepo] file.
     The result is sorted by name. *)
 val all : repo_root:Vcs.Repo_root.t -> t list
+
+(** Look [name] (a sub-repo name, e.g. what {!to_string} returns - not a
+    path) up against {!all}. Unlike {!of_string}, this validates that the
+    name actually names a vendored sub-repo (not merely that it has the
+    right shape). This reads the filesystem (via {!all}). *)
+val find_on_disk : repo_root:Vcs.Repo_root.t -> name:string -> t option
+
+(** {1 Manipulating paths}
+
+    Pure path manipulation: unlike {!find_on_disk}, neither of these reads
+    the filesystem, and neither confirms that the sub-repo or the path it is
+    given actually exist on disk. *)
+
+(** [central_path t ~subrepo_path] is [subrepo_path], expressed as a path in
+    the enclosing monorepo (i.e. prefixed with {!root}). *)
+val central_path : t -> subrepo_path:Vcs.Path_in_repo.t -> Vcs.Path_in_repo.t
+
+(** [subrepo_path t ~central_path] is [central_path], expressed relative to
+    [t]'s own root, if [central_path] is strictly under {!root} (not equal to
+    it - a path in the subrepo's own repo is never empty). *)
+val subrepo_path : t -> central_path:Vcs.Path_in_repo.t -> Vcs.Path_in_repo.t option

test/SUMMARY.md

@@ -10,4 +10,5 @@
 - [Advance Main, Advance Subrepo](expect/advance.md)
 - [Todo](expect/todo.md)
 - [Config](expect/config.md)
+- [Subrepo](expect/subrepo.md)
 - [Deterministic Revisions](expect/redact.md)

test/expect/dune

@@ -140,6 +140,21 @@
  (action
   (diff config.md config.md.gen)))
 
+(rule
+ (enabled_if %{bin-available:mdexp})
+ (target subrepo.md.gen)
+ (deps subrepo.ml)
+ (action
+  (with-stdout-to
+   %{target}
+   (run mdexp pp %{deps}))))
+
+(rule
+ (enabled_if %{bin-available:mdexp})
+ (alias runtest)
+ (action
+  (diff subrepo.md subrepo.md.gen)))
+
 (rule
  (enabled_if %{bin-available:mdexp})
  (target todo.md.gen)

test/expect/subrepo.md

@@ -0,0 +1,38 @@
+# Subrepo
+
+`Central.Subrepo.t` identifies one of the sub-repos vendored under `repo/`
+in the enclosing monorepo. It isn't a fixed, hand-maintained enum: it's just
+a validated string (the directory name under `repo/`), and the set of known
+sub-repos is discovered dynamically by walking the filesystem.
+
+## Discovery
+
+`all` walks `repo/`'s direct children and keeps the ones that contain a
+`.gitrepo` file, sorted by name:
+
+`find_on_disk` looks a sub-repo name up against `all` - unlike `of_string`,
+it validates that the name actually names a vendored sub-repo, not merely
+that it has the right shape:
+
+## Manipulating paths
+
+Unlike `all` and `find_on_disk` above, everything in this section is pure
+path manipulation: none of it reads the filesystem, or confirms that
+anything it is given actually exists on disk.
+
+`root` and `gitrepo_file_path` locate a sub-repo's own directory, and its
+`.gitrepo` file, as paths in the enclosing monorepo:
+
+`central_path` and `subrepo_path` convert a path back and forth between the
+two frames of reference a path can be expressed in: relative to the
+sub-repo's own root (what the sub-repo's standalone checkout sees), or
+relative to the enclosing monorepo (prefixed with `root`, what the monorepo
+checkout sees):
+
+```text
+repo/widget/src/dune
+```
+
+`subrepo_path` returns `None` for a path that doesn't belong to the
+sub-repo at all - and, since a path in the sub-repo's own repo is never
+empty, for the sub-repo's root itself:

test/expect/subrepo.ml

@@ -0,0 +1,113 @@
+(*********************************************************************************)
+(*  central - Manage history between sub-repos and their monorepo                *)
+(*  SPDX-FileCopyrightText: 2024-2026 Mathieu Barbin <mathieu.barbin@gmail.com>  *)
+(*  SPDX-License-Identifier: MIT                                                 *)
+(*********************************************************************************)
+
+open! Central
+
+(* @mdexp
+
+# Subrepo
+
+`Central.Subrepo.t` identifies one of the sub-repos vendored under `repo/`
+in the enclosing monorepo. It isn't a fixed, hand-maintained enum: it's just
+a validated string (the directory name under `repo/`), and the set of known
+sub-repos is discovered dynamically by walking the filesystem.
+
+## Discovery
+
+`all` walks `repo/`'s direct children and keeps the ones that contain a
+`.gitrepo` file, sorted by name: *)
+
+let%expect_test "Subrepo.all" =
+  let vcs = Volgo_git_unix.create () in
+  let widget = Subrepo.v "widget" in
+  let gadget = Subrepo.v "gadget" in
+  let fake_central = Central_test_helpers.create ~vcs ~subrepos:[ widget; gadget ] in
+  let { Central_test_helpers.Fake_central.central_root; _ } = fake_central in
+  List.iter (Subrepo.all ~repo_root:central_root) ~f:(fun t ->
+    print_endline (Subrepo.to_string t));
+  [%expect
+    {|
+    gadget
+    widget
+    |}]
+;;
+
+(* @mdexp
+
+`find_on_disk` looks a sub-repo name up against `all` - unlike `of_string`,
+it validates that the name actually names a vendored sub-repo, not merely
+that it has the right shape: *)
+
+let%expect_test "Subrepo.find_on_disk" =
+  let vcs = Volgo_git_unix.create () in
+  let widget = Subrepo.v "widget" in
+  let fake_central = Central_test_helpers.create ~vcs ~subrepos:[ widget ] in
+  let { Central_test_helpers.Fake_central.central_root; _ } = fake_central in
+  let print_find name =
+    print_dyn
+      (Subrepo.find_on_disk ~repo_root:central_root ~name |> Dyn.option Subrepo.to_dyn)
+  in
+  print_find "widget";
+  [%expect {| Some "widget" |}];
+  print_find "does-not-exist";
+  [%expect {| None |}]
+;;
+
+(* @mdexp
+
+## Manipulating paths
+
+Unlike `all` and `find_on_disk` above, everything in this section is pure
+path manipulation: none of it reads the filesystem, or confirms that
+anything it is given actually exists on disk.
+
+`root` and `gitrepo_file_path` locate a sub-repo's own directory, and its
+`.gitrepo` file, as paths in the enclosing monorepo: *)
+
+let%expect_test "Subrepo.root, Subrepo.gitrepo_file_path" =
+  let widget = Subrepo.v "widget" in
+  print_endline (Vcs.Path_in_repo.to_string (Subrepo.root widget));
+  [%expect {| repo/widget |}];
+  print_endline (Vcs.Path_in_repo.to_string (Subrepo.gitrepo_file_path widget));
+  [%expect {| repo/widget/.gitrepo |}]
+;;
+
+(* @mdexp
+
+`central_path` and `subrepo_path` convert a path back and forth between the
+two frames of reference a path can be expressed in: relative to the
+sub-repo's own root (what the sub-repo's standalone checkout sees), or
+relative to the enclosing monorepo (prefixed with `root`, what the monorepo
+checkout sees): *)
+
+let print_subrepo_path t ~central_path =
+  print_dyn (Subrepo.subrepo_path t ~central_path |> Dyn.option Vcs.Path_in_repo.to_dyn)
+;;
+
+let%expect_test "Subrepo.central_path, Subrepo.subrepo_path" =
+  let widget = Subrepo.v "widget" in
+  let subrepo_path = Vcs.Path_in_repo.v "src/dune" in
+  let central_path = Subrepo.central_path widget ~subrepo_path in
+  print_endline (Vcs.Path_in_repo.to_string central_path);
+  (* @mdexp.snapshot { lang: "text" } *)
+  [%expect {| repo/widget/src/dune |}];
+  print_subrepo_path widget ~central_path;
+  [%expect {| Some "src/dune" |}]
+;;
+
+(* @mdexp
+
+`subrepo_path` returns `None` for a path that doesn't belong to the
+sub-repo at all - and, since a path in the sub-repo's own repo is never
+empty, for the sub-repo's root itself: *)
+
+let%expect_test "Subrepo.subrepo_path, not under root" =
+  let widget = Subrepo.v "widget" in
+  print_subrepo_path widget ~central_path:(Vcs.Path_in_repo.v "README.md");
+  [%expect {| None |}];
+  print_subrepo_path widget ~central_path:(Vcs.Path_in_repo.v "repo/widget");
+  [%expect {| None |}]
+;;

test/expect/subrepo.mli

@@ -0,0 +1,5 @@
+(*_********************************************************************************)
+(*_  central - Manage history between sub-repos and their monorepo                *)
+(*_  SPDX-FileCopyrightText: 2024-2026 Mathieu Barbin <mathieu.barbin@gmail.com>  *)
+(*_  SPDX-License-Identifier: MIT                                                 *)
+(*_********************************************************************************)