From 995358e461b5c8a8756d46507657d9dde9333ca3 Mon Sep 17 00:00:00 2001 From: Mathieu Barbin Date: Mon, 24 Aug 2026 14:12:58 +0200 Subject: [PATCH] Add subrepo utils --- src/central/subrepo.ml | 24 +++++++++ src/central/subrepo.mli | 21 ++++++++ test/SUMMARY.md | 1 + test/expect/dune | 15 ++++++ test/expect/subrepo.md | 38 ++++++++++++++ test/expect/subrepo.ml | 113 ++++++++++++++++++++++++++++++++++++++++ test/expect/subrepo.mli | 5 ++ 7 files changed, 217 insertions(+) create mode 100644 test/expect/subrepo.md create mode 100644 test/expect/subrepo.ml create mode 100644 test/expect/subrepo.mli diff --git a/src/central/subrepo.ml b/src/central/subrepo.ml index cd9e2ba..3708ae7 100644 --- a/src/central/subrepo.ml +++ b/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 +;; diff --git a/src/central/subrepo.mli b/src/central/subrepo.mli index d3f7cc2..e2a0f91 100644 --- a/src/central/subrepo.mli +++ b/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 diff --git a/test/SUMMARY.md b/test/SUMMARY.md index dd22f41..588ce7f 100644 --- a/test/SUMMARY.md +++ b/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) diff --git a/test/expect/dune b/test/expect/dune index 80b97f5..838e534 100644 --- a/test/expect/dune +++ b/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) diff --git a/test/expect/subrepo.md b/test/expect/subrepo.md new file mode 100644 index 0000000..18c3647 --- /dev/null +++ b/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: diff --git a/test/expect/subrepo.ml b/test/expect/subrepo.ml new file mode 100644 index 0000000..5b7f726 --- /dev/null +++ b/test/expect/subrepo.ml @@ -0,0 +1,113 @@ +(*********************************************************************************) +(* central - Manage history between sub-repos and their monorepo *) +(* SPDX-FileCopyrightText: 2024-2026 Mathieu Barbin *) +(* 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 |}] +;; diff --git a/test/expect/subrepo.mli b/test/expect/subrepo.mli new file mode 100644 index 0000000..bdaa586 --- /dev/null +++ b/test/expect/subrepo.mli @@ -0,0 +1,5 @@ +(*_********************************************************************************) +(*_ central - Manage history between sub-repos and their monorepo *) +(*_ SPDX-FileCopyrightText: 2024-2026 Mathieu Barbin *) +(*_ SPDX-License-Identifier: MIT *) +(*_********************************************************************************)