From 1569950627562f3714983ca402e0e36acfc94423 Mon Sep 17 00:00:00 2001 From: Mathieu Barbin Date: Thu, 3 Oct 2024 16:02:11 +0200 Subject: [PATCH 01/14] Add Vcs.read_dir --- CHANGES.md | 14 +++++ lib/vcs/src/non_raising.ml | 2 + lib/vcs/src/trait_file_system.mli | 11 ++++ lib/vcs/src/vcs.mli | 6 +++ lib/vcs/src/vcs0.ml | 6 +++ lib/vcs/src/vcs_interface.mli | 2 + lib/vcs_git_blocking/src/runtime.ml | 7 +++ lib/vcs_git_blocking/test/dune | 3 +- .../test/test__file_system.ml | 52 ++++++++++++++++++ .../test/test__file_system.mli | 0 .../test/test__hello_commit.ml | 32 +++++++++++ lib/vcs_git_eio/src/runtime.ml | 5 ++ lib/vcs_git_eio/test/test__file_system.ml | 54 +++++++++++++++++++ lib/vcs_git_eio/test/test__file_system.mli | 0 14 files changed, 193 insertions(+), 1 deletion(-) create mode 100644 lib/vcs_git_blocking/test/test__file_system.ml create mode 100644 lib/vcs_git_blocking/test/test__file_system.mli create mode 100644 lib/vcs_git_eio/test/test__file_system.ml create mode 100644 lib/vcs_git_eio/test/test__file_system.mli diff --git a/CHANGES.md b/CHANGES.md index 9361520..c8f005f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,17 @@ +## 0.0.9 (unreleased) + +### Added + +- Add `Vcs.read_dir` helper (#PR, @mbarbin). + +### Changed + +### Deprecated + +### Fixed + +### Removed + ## 0.0.8 (2024-09-30) ### Changed diff --git a/lib/vcs/src/non_raising.ml b/lib/vcs/src/non_raising.ml index 3fb2442..5028e51 100644 --- a/lib/vcs/src/non_raising.ml +++ b/lib/vcs/src/non_raising.ml @@ -51,6 +51,8 @@ module Make (M : M) : try_with (fun () -> Vcs0.save_file ?perms vcs ~path ~file_contents) ;; + let read_dir vcs ~dir = try_with (fun () -> Vcs0.read_dir vcs ~dir) + let rename_current_branch vcs ~repo_root ~to_ = try_with (fun () -> Vcs0.rename_current_branch vcs ~repo_root ~to_) ;; diff --git a/lib/vcs/src/trait_file_system.mli b/lib/vcs/src/trait_file_system.mli index f019d3c..a6e38ae 100644 --- a/lib/vcs/src/trait_file_system.mli +++ b/lib/vcs/src/trait_file_system.mli @@ -29,12 +29,23 @@ module type S = sig type t + (** Returns the contents of the file at the given path or an error if the file + does not exist or is not readable. *) val load_file : t -> path:Absolute_path.t -> File_contents.t Or_error.t + (** [save_file] is expected to truncate the file if it already exists. Errors + are reserved for other cases, such as trying to write to an non existing + directory, not having write permissions, etc. *) val save_file : ?perms:int (** defaults to [0o666]. *) -> t -> path:Absolute_path.t -> file_contents:File_contents.t -> unit Or_error.t + + (** Returns the entries contained in the given directory, ordered increasingly + according to [String.compare]. This must error out if [dir] is not a + directory, or if we don't have access to it. The unix entries "." and + ".." shall not be included in the result. *) + val read_dir : t -> dir:Absolute_path.t -> Fpart.t list Or_error.t end diff --git a/lib/vcs/src/vcs.mli b/lib/vcs/src/vcs.mli index 363e8bf..de969fd 100644 --- a/lib/vcs/src/vcs.mli +++ b/lib/vcs/src/vcs.mli @@ -134,6 +134,7 @@ val show_file_at_rev val load_file : [> Trait.file_system ] t -> path:Absolute_path.t -> File_contents.t +(** Create a new file, or truncate an existing one. *) val save_file : ?perms:int (** defaults to [0o666]. *) -> [> Trait.file_system ] t @@ -141,6 +142,11 @@ val save_file -> file_contents:File_contents.t -> unit +(** Returns the entries of the supplied directory, ordered increasingly + according to [String.compare]. The result does not include the unix entries + ".", "..". *) +val read_dir : [> Trait.file_system ] t -> dir:Absolute_path.t -> Fpart.t list + (** {1 Branches & Tags} *) module Branch_name = Branch_name diff --git a/lib/vcs/src/vcs0.ml b/lib/vcs/src/vcs0.ml index 2438660..36e6483 100644 --- a/lib/vcs/src/vcs0.ml +++ b/lib/vcs/src/vcs0.ml @@ -42,6 +42,12 @@ let save_file ?perms (Provider.T { t; handler }) ~path ~file_contents = (lazy [%sexp "Vcs.save_file", { perms : int option; path : Absolute_path.t }]) ;; +let read_dir (Provider.T { t; handler }) ~dir = + let module M = (val Provider.Handler.lookup handler ~trait:Trait.File_system) in + M.read_dir t ~dir + |> of_result ~step:(lazy [%sexp "Vcs.read_dir", { dir : Absolute_path.t }]) +;; + let add (Provider.T { t; handler }) ~repo_root ~path = let module M = (val Provider.Handler.lookup handler ~trait:Trait.Add) in M.add t ~repo_root ~path diff --git a/lib/vcs/src/vcs_interface.mli b/lib/vcs/src/vcs_interface.mli index 45203d2..14e6ab5 100644 --- a/lib/vcs/src/vcs_interface.mli +++ b/lib/vcs/src/vcs_interface.mli @@ -100,6 +100,8 @@ module type S = sig -> file_contents:File_contents.t -> unit result + val read_dir : [> Trait.file_system ] t -> dir:Absolute_path.t -> Fpart.t list result + val rename_current_branch : [> Trait.branch ] t -> repo_root:Repo_root.t diff --git a/lib/vcs_git_blocking/src/runtime.ml b/lib/vcs_git_blocking/src/runtime.ml index 1273fc6..1d9db1f 100644 --- a/lib/vcs_git_blocking/src/runtime.ml +++ b/lib/vcs_git_blocking/src/runtime.ml @@ -44,6 +44,13 @@ let save_file ?(perms = 0o666) () ~path ~(file_contents : Vcs.File_contents.t) = (fun () -> Stdlib.Out_channel.output_string oc (file_contents :> string))) ;; +let read_dir () ~dir = + Or_error.try_with (fun () -> + let entries = Stdlib.Sys.readdir (Absolute_path.to_string dir) in + Array.sort entries ~compare:String.compare; + entries |> Array.map ~f:Fpart.v |> Array.to_list) +;; + let with_cwd ~cwd ~f = let old_cwd = Unix.getcwd () in Stdlib.Fun.protect diff --git a/lib/vcs_git_blocking/test/dune b/lib/vcs_git_blocking/test/dune index 3a22b64..d43f6f6 100644 --- a/lib/vcs_git_blocking/test/dune +++ b/lib/vcs_git_blocking/test/dune @@ -20,7 +20,8 @@ fpath fpath-sexp0 vcs - vcs_git_blocking) + vcs_git_blocking + vcs_test_helpers) (instrumentation (backend bisect_ppx)) (lint diff --git a/lib/vcs_git_blocking/test/test__file_system.ml b/lib/vcs_git_blocking/test/test__file_system.ml new file mode 100644 index 0000000..4c25a9f --- /dev/null +++ b/lib/vcs_git_blocking/test/test__file_system.ml @@ -0,0 +1,52 @@ +let%expect_test "read_dir" = + let vcs = Vcs_git_blocking.create () in + let read_dir dir = print_s [%sexp (Vcs.read_dir vcs ~dir : Fpart.t list)] in + let cwd = Unix.getcwd () in + let dir = Stdlib.Filename.temp_dir ~temp_dir:cwd "vcs_test" "" |> Absolute_path.v in + let save_file file file_contents = + Vcs.save_file + vcs + ~path:(Absolute_path.extend dir (Fpart.v file)) + ~file_contents:(Vcs.File_contents.create file_contents) + in + read_dir dir; + [%expect {| () |}]; + save_file "hello.txt" "Hello World!\n"; + [%expect {||}]; + read_dir dir; + [%expect {| (hello.txt) |}]; + save_file "foo" "Hello Foo!\n"; + [%expect {||}]; + read_dir dir; + [%expect {| (foo hello.txt) |}]; + (* Below we redact the actual temporary directory because they make the tests + non stable. We redact the error when it contains a non-stable path. *) + let () = + (* [Vcs.read_dir] errors out on non-existing directories. *) + match Vcs.read_dir vcs ~dir:(Absolute_path.v "/non-existing") with + | (_ : Fpart.t list) -> assert false + | exception Vcs.E err -> + print_s (Vcs_test_helpers.redact_sexp (Vcs.Err.sexp_of_t err) ~fields:[ "dir" ]) + in + [%expect + {| + ((steps ((Vcs.read_dir ((dir ))))) + (error (Sys_error "/non-existing: No such file or directory"))) + |}]; + let () = + (* [Vcs.read_dir] errors out when called on an existing file rather than a + directory. *) + let path = Absolute_path.extend dir (Fpart.v "foo") in + let file_exists = Stdlib.Sys.file_exists (Absolute_path.to_string path) in + assert file_exists; + print_s [%sexp { file_exists : bool }]; + [%expect {| ((file_exists true)) |}]; + match Vcs.read_dir vcs ~dir:path with + | (_ : Fpart.t list) -> assert false + | exception Vcs.E err -> + print_s + (Vcs_test_helpers.redact_sexp (Vcs.Err.sexp_of_t err) ~fields:[ "dir"; "error" ]) + in + [%expect {| ((steps ((Vcs.read_dir ((dir ))))) (error )) |}]; + () +;; diff --git a/lib/vcs_git_blocking/test/test__file_system.mli b/lib/vcs_git_blocking/test/test__file_system.mli new file mode 100644 index 0000000..e69de29 diff --git a/lib/vcs_git_blocking/test/test__hello_commit.ml b/lib/vcs_git_blocking/test/test__hello_commit.ml index 90942da..70c81c7 100644 --- a/lib/vcs_git_blocking/test/test__hello_commit.ml +++ b/lib/vcs_git_blocking/test/test__hello_commit.ml @@ -60,3 +60,35 @@ let%expect_test "hello commit" = [%expect {| (Ok (Present "Hello World!\n")) |}]; () ;; + +let%expect_test "read_dir" = + let vcs = Vcs_git_blocking.create () in + let read_dir dir = print_s [%sexp (Vcs.read_dir vcs ~dir : Fpart.t list)] in + let cwd = Unix.getcwd () in + let dir = Stdlib.Filename.temp_dir ~temp_dir:cwd "vcs_test" "" |> Absolute_path.v in + let save_file file file_contents = + Vcs.save_file + vcs + ~path:(Absolute_path.extend dir (Fpart.v file)) + ~file_contents:(Vcs.File_contents.create file_contents) + in + read_dir dir; + [%expect {| () |}]; + save_file "hello.txt" "Hello World!\n"; + [%expect {||}]; + read_dir dir; + [%expect {| (hello.txt) |}]; + save_file "foo" "Hello Foo!\n"; + [%expect {||}]; + read_dir dir; + [%expect {| (foo hello.txt) |}]; + require_does_raise [%here] (fun () -> + Vcs.read_dir vcs ~dir:(Absolute_path.v "/invalid")); + [%expect + {| + (repo/vcs/lib/vcs/src/exn0.ml.E ( + (steps ((Vcs.read_dir ((dir /invalid))))) + (error (Sys_error "/invalid: No such file or directory")))) + |}]; + () +;; diff --git a/lib/vcs_git_eio/src/runtime.ml b/lib/vcs_git_eio/src/runtime.ml index 4d0e59e..ba737ce 100644 --- a/lib/vcs_git_eio/src/runtime.ml +++ b/lib/vcs_git_eio/src/runtime.ml @@ -42,6 +42,11 @@ let save_file ?(perms = 0o666) t ~path ~(file_contents : Vcs.File_contents.t) = Eio.Path.save ~create:(`Or_truncate perms) path (file_contents :> string)) ;; +let read_dir t ~dir = + let dir = Eio.Path.(t.fs / Absolute_path.to_string dir) in + Or_error.try_with (fun () -> Eio.Path.read_dir dir |> List.map ~f:Fpart.v) +;; + (* The modules [Exit_status], [Lines] and the function [git] below are derived from the [Eio_process] project version [0.0.4] which is released under MIT and may be found at [https://github.com/mbarbin/eio-process]. diff --git a/lib/vcs_git_eio/test/test__file_system.ml b/lib/vcs_git_eio/test/test__file_system.ml new file mode 100644 index 0000000..db6be62 --- /dev/null +++ b/lib/vcs_git_eio/test/test__file_system.ml @@ -0,0 +1,54 @@ +let%expect_test "read_dir" = + Eio_main.run + @@ fun env -> + Eio.Switch.run + @@ fun sw -> + let vcs = Vcs_git_eio.create ~env in + let repo_root = Vcs_test_helpers.init_temp_repo ~env ~sw ~vcs in + let dir = Vcs.Repo_root.to_absolute_path repo_root in + let read_dir dir = print_s [%sexp (Vcs.read_dir vcs ~dir : Fpart.t list)] in + let save_file file file_contents = + Vcs.save_file + vcs + ~path:(Absolute_path.extend dir (Fpart.v file)) + ~file_contents:(Vcs.File_contents.create file_contents) + in + read_dir dir; + [%expect {| (.git) |}]; + save_file "hello.txt" "Hello World!\n"; + [%expect {||}]; + read_dir dir; + [%expect {| (.git hello.txt) |}]; + save_file "foo" "Hello Foo!\n"; + [%expect {||}]; + read_dir dir; + [%expect {| (.git foo hello.txt) |}]; + (* Below we redact the actual temporary directory because they make the tests + non stable. We redact the error because it either contains the path too, or + shows very specific Eio messages which may make the test brittle. *) + let () = + (* [Vcs.read_dir] errors out on non-existing directories. *) + match Vcs.read_dir vcs ~dir:(Absolute_path.v "/non-existing") with + | (_ : Fpart.t list) -> assert false + | exception Vcs.E err -> + print_s + (Vcs_test_helpers.redact_sexp (Vcs.Err.sexp_of_t err) ~fields:[ "dir"; "error" ]) + in + [%expect {| ((steps ((Vcs.read_dir ((dir ))))) (error )) |}]; + let () = + (* [Vcs.read_dir] errors out when called on an existing file rather than a + directory. *) + let path = Absolute_path.extend dir (Fpart.v "foo") in + let file_exists = Stdlib.Sys.file_exists (Absolute_path.to_string path) in + assert file_exists; + print_s [%sexp { file_exists : bool }]; + [%expect {| ((file_exists true)) |}]; + match Vcs.read_dir vcs ~dir:path with + | (_ : Fpart.t list) -> assert false + | exception Vcs.E err -> + print_s + (Vcs_test_helpers.redact_sexp (Vcs.Err.sexp_of_t err) ~fields:[ "dir"; "error" ]) + in + [%expect {| ((steps ((Vcs.read_dir ((dir ))))) (error )) |}]; + () +;; diff --git a/lib/vcs_git_eio/test/test__file_system.mli b/lib/vcs_git_eio/test/test__file_system.mli new file mode 100644 index 0000000..e69de29 From bb1eeeae6aa334dd0502c137e30a2ba52139ea0d Mon Sep 17 00:00:00 2001 From: Mathieu Barbin Date: Thu, 3 Oct 2024 16:14:16 +0200 Subject: [PATCH 02/14] Add ocaml-vcs tests --- CHANGES.md | 2 + doc/docs/explanation/exploratory_tests.md | 15 +++-- lib/vcs_command/src/vcs_command.ml | 30 +++++++--- test/cram/run.t | 72 +++++++++++++++++++---- 4 files changed, 92 insertions(+), 27 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index c8f005f..c47bf4a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -6,6 +6,8 @@ ### Changed +- Moved `ocaml-vcs more-tests` commands at top-level (#PR, @mbarbin). + ### Deprecated ### Fixed diff --git a/doc/docs/explanation/exploratory_tests.md b/doc/docs/explanation/exploratory_tests.md index 68da92d..8971943 100644 --- a/doc/docs/explanation/exploratory_tests.md +++ b/doc/docs/explanation/exploratory_tests.md @@ -24,8 +24,7 @@ SYNOPSIS We expect a 1:1 mapping between the function exposed in the [Vcs.S] - and the sub commands exposed here, plus additional functionality in - [more-tests]. + and the sub commands exposed here, plus additional ones. @@ -33,6 +32,9 @@ COMMANDS add [OPTION]… file add a file to the index + branch-revision [OPTION]… [branch] + revision of a branch + commit [--message=MSG] [--quiet] [OPTION]… commit a file @@ -42,6 +44,9 @@ COMMANDS current-revision [OPTION]… revision of HEAD + gca [OPTION]… [rev]… + print greatest common ancestors of revisions + git [OPTION]… [ARG]… run the git cli @@ -60,15 +65,15 @@ COMMANDS ls-files [--below=PATH] [OPTION]… list file - more-tests COMMAND … - more tests combining vcs functions - name-status [OPTION]… rev rev show a summary of the diff between 2 revs num-status [OPTION]… rev rev show a summary of the number of lines of diff between 2 revs + read-dir [OPTION]… file + print the list of files in a directory + refs [OPTION]… show the refs of current repo diff --git a/lib/vcs_command/src/vcs_command.ml b/lib/vcs_command/src/vcs_command.ml index 3d6bb83..f58123c 100644 --- a/lib/vcs_command/src/vcs_command.ml +++ b/lib/vcs_command/src/vcs_command.ml @@ -201,6 +201,22 @@ let num_status_cmd = ()) ;; +let read_dir_cmd = + Command.make + ~summary:"print the list of files in a directory" + (let%map_open.Command config = Vcs_arg.Config.arg + and dir = Vcs_arg.pos_path ~pos:0 ~doc:"dir to read" in + Eio_main.run + @@ fun env -> + let { Vcs_arg.Initialized.vcs; repo_root = _; context } = + Vcs_arg.initialize ~env ~config + in + let dir = Vcs_arg.resolve dir ~context in + let entries = Vcs.read_dir vcs ~dir in + print_sexp [%sexp (entries : Fpart.t list)]; + ()) +;; + let rename_current_branch_cmd = Command.make ~summary:"move/rename a branch to a new name" @@ -363,12 +379,6 @@ let greatest_common_ancestors_cmd = ()) ;; -let more_tests_cmd = - Command.group - ~summary:"more tests combining vcs functions" - [ "branch-revision", branch_revision_cmd; "gca", greatest_common_ancestors_cmd ] -;; - let main = Command.group ~summary:"call a command from the vcs interface" @@ -377,25 +387,27 @@ let main = This is an executable to test the Version Control System (vcs) library. We expect a 1:1 mapping between the function exposed in the [Vcs.S] and the -sub commands exposed here, plus additional functionality in [more-tests]. +sub commands exposed here, plus additional ones. |}) [ "add", add_cmd + ; "branch-revision", branch_revision_cmd ; "commit", commit_cmd ; "current-branch", current_branch_cmd ; "current-revision", current_revision_cmd + ; "gca", greatest_common_ancestors_cmd ; "git", git_cmd + ; "graph", graph_cmd ; "init", init_cmd ; "load-file", load_file_cmd ; "log", log_cmd ; "ls-files", ls_files_cmd ; "name-status", name_status_cmd ; "num-status", num_status_cmd + ; "read-dir", read_dir_cmd ; "refs", refs_cmd ; "rename-current-branch", rename_current_branch_cmd ; "save-file", save_file_cmd ; "set-user-config", set_user_config_cmd ; "show-file-at-rev", show_file_at_rev_cmd - ; "graph", graph_cmd - ; "more-tests", more_tests_cmd ] ;; diff --git a/test/cram/run.t b/test/cram/run.t index 9c5f52e..4622573 100644 --- a/test/cram/run.t +++ b/test/cram/run.t @@ -29,13 +29,13 @@ Rev-parse. $ ocaml-vcs current-branch main - $ ocaml-vcs more-tests branch-revision | sed -e "s/$rev0/rev0/g" + $ ocaml-vcs branch-revision | sed -e "s/$rev0/rev0/g" rev0 - $ ocaml-vcs more-tests branch-revision main | sed -e "s/$rev0/rev0/g" + $ ocaml-vcs branch-revision main | sed -e "s/$rev0/rev0/g" rev0 - $ ocaml-vcs more-tests branch-revision unknown-branch + $ ocaml-vcs branch-revision unknown-branch Error: Branch not found (branch_name unknown-branch) [123] @@ -53,14 +53,55 @@ Invalid path-in-repo. Error: Path is not in repo (path /hello) [123] -Save / Load files. +File system operations. + + $ ocaml-vcs read-dir untracked + Error: + ((steps + ((Vcs.read_dir + ((dir + $TESTCASE_ROOT/untracked))))) + (error + ( "Eio.Io Fs Not_found Unix_error (No such file or directory, \"openat2\", \"\"),\ + \n reading directory "))) + [123] $ mkdir -p untracked + + $ ocaml-vcs read-dir untracked + () + $ echo "New untracked file" | ocaml-vcs save-file untracked/hello + $ ocaml-vcs read-dir untracked + (hello) + + $ ocaml-vcs read-dir untracked/hello + Error: + ((steps + ((Vcs.read_dir + ((dir + $TESTCASE_ROOT/untracked/hello))))) + (error + ( "Eio.Io Unix_error (Not a directory, \"openat2\", \"\"),\ + \n reading directory "))) + [123] + $ ocaml-vcs load-file untracked/hello New untracked file + $ chmod -r untracked + $ ocaml-vcs read-dir untracked + Error: + ((steps + ((Vcs.read_dir + ((dir + $TESTCASE_ROOT/untracked))))) + (error + ( "Eio.Io Fs Permission_denied Unix_error (Permission denied, \"openat2\", \"\"),\ + \n reading directory "))) + [123] + $ rm untracked/hello $ rmdir untracked @@ -135,16 +176,16 @@ Graph. Greatest common ancestors. - $ ocaml-vcs more-tests gca + $ ocaml-vcs gca () - $ ocaml-vcs more-tests gca $rev1 | stabilize_output + $ ocaml-vcs gca $rev1 | stabilize_output ($REV1) - $ ocaml-vcs more-tests gca $rev1 $rev2 | stabilize_output + $ ocaml-vcs gca $rev1 $rev2 | stabilize_output ($REV1) - $ ocaml-vcs more-tests gca $rev1 2e9ab12edfe8e3a01cf2fa2b46210c042e9ab12e + $ ocaml-vcs gca $rev1 2e9ab12edfe8e3a01cf2fa2b46210c042e9ab12e Error: Rev not found (rev 2e9ab12edfe8e3a01cf2fa2b46210c042e9ab12e) [123] @@ -190,8 +231,7 @@ Vcs's help for review. We expect a 1:1 mapping between the function exposed in the [Vcs.S] - and the sub commands exposed here, plus additional functionality in - [more-tests]. + and the sub commands exposed here, plus additional ones. @@ -199,6 +239,9 @@ Vcs's help for review. add [OPTION]… file add a file to the index + branch-revision [OPTION]… [branch] + revision of a branch + commit [--message=MSG] [--quiet] [OPTION]… commit a file @@ -208,6 +251,9 @@ Vcs's help for review. current-revision [OPTION]… revision of HEAD + gca [OPTION]… [rev]… + print greatest common ancestors of revisions + git [OPTION]… [ARG]… run the git cli @@ -226,15 +272,15 @@ Vcs's help for review. ls-files [--below=PATH] [OPTION]… list file - more-tests COMMAND … - more tests combining vcs functions - name-status [OPTION]… rev rev show a summary of the diff between 2 revs num-status [OPTION]… rev rev show a summary of the number of lines of diff between 2 revs + read-dir [OPTION]… file + print the list of files in a directory + refs [OPTION]… show the refs of current repo From 32fe2d3823682923251c58d418f5edf558540288 Mon Sep 17 00:00:00 2001 From: Mathieu Barbin Date: Fri, 4 Oct 2024 11:22:50 +0200 Subject: [PATCH 03/14] Add function to find enclosing repo root --- lib/vcs/src/non_raising.ml | 5 +++++ lib/vcs/src/vcs.mli | 26 ++++++++++++++++++++++++-- lib/vcs/src/vcs0.ml | 20 ++++++++++++++++++++ lib/vcs/src/vcs_interface.mli | 6 ++++++ 4 files changed, 55 insertions(+), 2 deletions(-) diff --git a/lib/vcs/src/non_raising.ml b/lib/vcs/src/non_raising.ml index 5028e51..2b1f0b5 100644 --- a/lib/vcs/src/non_raising.ml +++ b/lib/vcs/src/non_raising.ml @@ -31,6 +31,11 @@ module Make (M : M) : ;; let init vcs ~path = try_with (fun () -> Vcs0.init vcs ~path) + + let find_enclosing_repo_root ?stop_if_present vcs ~from = + try_with (fun () -> Vcs0.find_enclosing_repo_root ?stop_if_present vcs ~from) + ;; + let add vcs ~repo_root ~path = try_with (fun () -> Vcs0.add vcs ~repo_root ~path) let commit vcs ~repo_root ~commit_message = diff --git a/lib/vcs/src/vcs.mli b/lib/vcs/src/vcs.mli index de969fd..07562f9 100644 --- a/lib/vcs/src/vcs.mli +++ b/lib/vcs/src/vcs.mli @@ -84,10 +84,32 @@ module Repo_name = Repo_name module Repo_root = Repo_root module Url = Url -(** Initialize a git repository at the given path. This errors out if a +(** Initialize a Git repository at the given path. This errors out if a repository is already initialized there. *) val init : [> Trait.init ] t -> path:Absolute_path.t -> Repo_root.t +(** [find_enclosing_repo_root ?stop_if_present vcs ~from:dir] walks up the path from + the given directory [dir] and stops when at the root of a repository. If no + repo root has been found when reaching the root path ["/"], the function + returns [None]. + + The way we determine whether we are at the root of a repo is by looking for + the presence of a [".git"] entry in the directory. + + When present, we do not check that the path [".git"] is itself a directory, + so that this function is able to correctly infer and return the root of Git + repos where [".git"] is not a directory (e.g. Git worktrees). + + You may also make the recursive search stop if specific entries are present. + For example, if you pass [~stop_if_present:[".hg"]] and call it from within + a Mercurial repo, the function will find its root and return it, along with + the [`Other ".hg"] tag. *) +val find_enclosing_repo_root + : ?stop_if_present:Fpart.t list + -> [> Trait.file_system ] t + -> from:Absolute_path.t + -> ([ `Git | `Other of Fpart.t ] * Repo_root.t) option + (** {1 Revisions} *) module Rev = Rev @@ -206,7 +228,7 @@ module User_name = User_name (** During tests in the GitHub environment we end up having issues if we do not set the user name and email. Also, we rather not do it globally. If this - is never called, the current user config is used as usual by git processes + is never called, the current user config is used as usual by Git processes invocations. *) val set_user_name diff --git a/lib/vcs/src/vcs0.ml b/lib/vcs/src/vcs0.ml index 36e6483..f3d40d4 100644 --- a/lib/vcs/src/vcs0.ml +++ b/lib/vcs/src/vcs0.ml @@ -60,6 +60,26 @@ let init (Provider.T { t; handler }) ~path = M.init t ~path |> of_result ~step:(lazy [%sexp "Vcs.init", { path : Absolute_path.t }]) ;; +let find_enclosing_repo_root ?(stop_if_present = []) t ~from = + let git_store = Fpart.v ".git" in + let stop_if_present = git_store :: stop_if_present in + let rec visit dir = + let entries = read_dir t ~dir in + match + List.find entries ~f:(fun entry -> + List.mem stop_if_present entry ~equal:Fpart.equal) + with + | Some entry -> + let tag = if Fpart.equal entry git_store then `Git else `Other entry in + Some (tag, Repo_root.of_absolute_path dir) + | None -> + (match Absolute_path.parent dir with + | None -> None + | Some parent_dir -> visit parent_dir) + in + visit from +;; + let current_branch (Provider.T { t; handler }) ~repo_root = let module M = (val Provider.Handler.lookup handler ~trait:Trait.Rev_parse) in M.current_branch t ~repo_root diff --git a/lib/vcs/src/vcs_interface.mli b/lib/vcs/src/vcs_interface.mli index 14e6ab5..21adc1b 100644 --- a/lib/vcs/src/vcs_interface.mli +++ b/lib/vcs/src/vcs_interface.mli @@ -56,6 +56,12 @@ module type S = sig val init : [> Trait.init ] t -> path:Absolute_path.t -> Repo_root.t result + val find_enclosing_repo_root + : ?stop_if_present:Fpart.t list + -> [> Trait.file_system ] t + -> from:Absolute_path.t + -> ([ `Git | `Other of Fpart.t ] * Repo_root.t) option result + val add : [> Trait.add ] t -> repo_root:Repo_root.t From 3c415ee8316b59ce6ee9c1df3c074e1e7d71cf36 Mon Sep 17 00:00:00 2001 From: Mathieu Barbin Date: Fri, 4 Oct 2024 12:46:41 +0200 Subject: [PATCH 04/14] Inline vcs_arg in vcs_command --- doc/docs/explanation/exploratory_tests.md | 18 +- lib/vcs_command/src/dune | 2 +- lib/vcs_command/src/vcs_command.ml | 300 ++++++++++++++-------- test/cram/run.t | 18 +- 4 files changed, 211 insertions(+), 127 deletions(-) diff --git a/doc/docs/explanation/exploratory_tests.md b/doc/docs/explanation/exploratory_tests.md index 8971943..2c15eb0 100644 --- a/doc/docs/explanation/exploratory_tests.md +++ b/doc/docs/explanation/exploratory_tests.md @@ -32,7 +32,7 @@ COMMANDS add [OPTION]… file add a file to the index - branch-revision [OPTION]… [branch] + branch-revision [OPTION]… [BRANCH] revision of a branch commit [--message=MSG] [--quiet] [OPTION]… @@ -44,7 +44,7 @@ COMMANDS current-revision [OPTION]… revision of HEAD - gca [OPTION]… [rev]… + gca [OPTION]… [REV]… print greatest common ancestors of revisions git [OPTION]… [ARG]… @@ -53,10 +53,10 @@ COMMANDS graph [OPTION]… compute graph of current repo - init [--quiet] [OPTION]… file + init [--quiet] [OPTION]… path/to/root initialize a new repository - load-file [OPTION]… file + load-file [OPTION]… path/to/file print a file from the filesystem (aka cat) log [OPTION]… @@ -65,13 +65,13 @@ COMMANDS ls-files [--below=PATH] [OPTION]… list file - name-status [OPTION]… rev rev + name-status [OPTION]… BASE TIP show a summary of the diff between 2 revs - num-status [OPTION]… rev rev + num-status [OPTION]… BASE TIP show a summary of the number of lines of diff between 2 revs - read-dir [OPTION]… file + read-dir [OPTION]… path/to/dir print the list of files in a directory refs [OPTION]… @@ -80,13 +80,13 @@ COMMANDS rename-current-branch [OPTION]… branch move/rename a branch to a new name - save-file [OPTION]… file + save-file [OPTION]… FILE save stdin to a file from the filesystem (aka tee) set-user-config [--user.email=EMAIL] [--user.name=USER] [OPTION]… set the user config - show-file-at-rev [--rev=REV] [OPTION]… file + show-file-at-rev [--rev=REV] [OPTION]… FILE show the contents of file at a given revision COMMON OPTIONS diff --git a/lib/vcs_command/src/dune b/lib/vcs_command/src/dune index 8119836..9d50f21 100644 --- a/lib/vcs_command/src/dune +++ b/lib/vcs_command/src/dune @@ -13,7 +13,7 @@ Fpath_sexp0 -open Cmdlang) - (libraries base cmdlang eio eio_main fpath-sexp0 vcs vcs-arg vcs-git-eio) + (libraries base cmdlang eio eio_main fpath-sexp0 vcs vcs-git-eio) (instrumentation (backend bisect_ppx)) (lint diff --git a/lib/vcs_command/src/vcs_command.ml b/lib/vcs_command/src/vcs_command.ml index f58123c..e8fb3bf 100644 --- a/lib/vcs_command/src/vcs_command.ml +++ b/lib/vcs_command/src/vcs_command.ml @@ -25,17 +25,53 @@ let print_sexp sexp = Stdlib.print_endline (Sexp.to_string_hum sexp) +module Initialized = struct + type t = + { vcs : Vcs_git_eio.t' + ; repo_root : Vcs.Repo_root.t + ; cwd : Absolute_path.t + } +end + +let find_enclosing_repo_root vcs ~from = + match Vcs.find_enclosing_repo_root vcs ~from with + | Some (`Git, repo_root) -> repo_root + | Some (`Other _, _) | None -> + Vcs.raise_s + "Failed to locate enclosing repo root from directory" + [%sexp { from : Absolute_path.t }] +;; + +let initialize ~env = + let vcs = Vcs_git_eio.create ~env in + let cwd = Unix.getcwd () |> Absolute_path.v in + let repo_root = find_enclosing_repo_root vcs ~from:cwd in + { Initialized.vcs; repo_root; cwd } +;; + +let relativize ~repo_root ~cwd ~path = + let path = Absolute_path.relativize ~root:cwd path in + match + Absolute_path.chop_prefix path ~prefix:(repo_root |> Vcs.Repo_root.to_absolute_path) + with + | Some relative_path -> Vcs.Path_in_repo.of_relative_path relative_path + | None -> Vcs.raise_s "Path is not in repo" [%sexp { path : Absolute_path.t }] +;; + let add_cmd = Command.make ~summary:"add a file to the index" - (let%map_open.Command config = Vcs_arg.Config.arg - and path = Vcs_arg.pos_path_in_repo ~pos:0 ~doc:"file to add" in + (let%map_open.Command path = + Arg.pos + ~pos:0 + (Param.validated_string (module Fpath)) + ~docv:"file" + ~doc:"file to add" + in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root; context } = - Vcs_arg.initialize ~env ~config - in - let path = Vcs_arg.resolve ~context path in + let { Initialized.vcs; repo_root; cwd } = initialize ~env in + let path = relativize ~repo_root ~cwd ~path in Vcs.add vcs ~repo_root ~path; ()) ;; @@ -43,14 +79,16 @@ let add_cmd = let commit_cmd = Command.make ~summary:"commit a file" - (let%map_open.Command config = Vcs_arg.Config.arg - and commit_message = Vcs_arg.commit_message - and quiet = Vcs_arg.quiet in + (let%map_open.Command commit_message = + Arg.named + [ "message"; "m" ] + (Param.validated_string (module Vcs.Commit_message)) + ~docv:"MSG" + ~doc:"commit message" + and quiet = Arg.flag [ "quiet"; "q" ] ~doc:"suppress output on success" in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root; context = _ } = - Vcs_arg.initialize ~env ~config - in + let { Initialized.vcs; repo_root; cwd = _ } = initialize ~env in let rev = Vcs.commit vcs ~repo_root ~commit_message in if not quiet then print_sexp [%sexp (rev : Vcs.Rev.t)]; ()) @@ -59,12 +97,10 @@ let commit_cmd = let current_branch_cmd = Command.make ~summary:"current branch" - (let%map_open.Command config = Vcs_arg.Config.arg in + (let%map_open.Command () = Arg.return () in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root; context = _ } = - Vcs_arg.initialize ~env ~config - in + let { Initialized.vcs; repo_root; cwd = _ } = initialize ~env in let branch = Vcs.current_branch vcs ~repo_root in print_sexp [%sexp (branch : Vcs.Branch_name.t)]; ()) @@ -73,12 +109,10 @@ let current_branch_cmd = let current_revision_cmd = Command.make ~summary:"revision of HEAD" - (let%map_open.Command config = Vcs_arg.Config.arg in + (let%map_open.Command () = Arg.return () in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root; context = _ } = - Vcs_arg.initialize ~env ~config - in + let { Initialized.vcs; repo_root; cwd = _ } = initialize ~env in let rev = Vcs.current_revision vcs ~repo_root in print_sexp [%sexp (rev : Vcs.Rev.t)]; ()) @@ -87,15 +121,12 @@ let current_revision_cmd = let git_cmd = Command.make ~summary:"run the git cli" - (let%map_open.Command config = Vcs_arg.Config.arg - and args = + (let%map_open.Command args = Arg.pos_all Param.string ~docv:"ARG" ~doc:"pass the remaining args to git" in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root; context = _ } = - Vcs_arg.initialize ~env ~config - in + let { Initialized.vcs; repo_root; cwd = _ } = initialize ~env in let { Vcs.Git.Output.exit_code; stdout; stderr } = Vcs.git vcs ~repo_root ~args ~f:Fn.id in @@ -107,15 +138,19 @@ let git_cmd = let init_cmd = Command.make ~summary:"initialize a new repository" - (let%map_open.Command config = Vcs_arg.Config.arg - and path = Vcs_arg.pos_path ~pos:0 ~doc:"where to initialize the repository" - and quiet = Vcs_arg.quiet in + (let%map_open.Command path = + Arg.pos + ~pos:0 + (Param.validated_string (module Fpath)) + ~docv:"path/to/root" + ~doc:"where to initialize the repository" + and quiet = + Arg.flag [ "quiet"; "q" ] ~doc:"do not print the initialized repo root" + in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root = _; context } = - Vcs_arg.initialize ~env ~config - in - let path = Vcs_arg.resolve path ~context in + let { Initialized.vcs; repo_root = _; cwd } = initialize ~env in + let path = Absolute_path.relativize ~root:cwd path in let repo_root = Vcs.init vcs ~path in if not quiet then print_sexp [%sexp (repo_root : Vcs.Repo_root.t)] [@coverage off]; ()) @@ -124,14 +159,17 @@ let init_cmd = let load_file_cmd = Command.make ~summary:"print a file from the filesystem (aka cat)" - (let%map_open.Command config = Vcs_arg.Config.arg - and path = Vcs_arg.pos_path ~pos:0 ~doc:"file to load" in + (let%map_open.Command path = + Arg.pos + ~pos:0 + (Param.validated_string (module Fpath)) + ~docv:"path/to/file" + ~doc:"file to load" + in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root = _; context } = - Vcs_arg.initialize ~env ~config - in - let path = Vcs_arg.resolve path ~context in + let { Initialized.vcs; repo_root = _; cwd } = initialize ~env in + let path = Absolute_path.relativize ~root:cwd path in let contents = Vcs.load_file vcs ~path in Stdlib.print_string (contents :> string); ()) @@ -140,15 +178,21 @@ let load_file_cmd = let ls_files_cmd = Command.make ~summary:"list file" - (let%map_open.Command config = Vcs_arg.Config.arg - and below = Vcs_arg.below_path_in_repo in + (let%map_open.Command below = + Arg.named_opt + [ "below" ] + (Param.validated_string (module Fpath)) + ~docv:"PATH" + ~doc:"restrict the selection to path/to/subdir" + in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root; context } = - Vcs_arg.initialize ~env ~config + let { Initialized.vcs; repo_root; cwd } = initialize ~env in + let below = + match below with + | None -> Vcs.Path_in_repo.root + | Some path -> relativize ~repo_root ~cwd ~path in - let below = Vcs_arg.resolve below ~context in - let below = Option.value below ~default:Vcs.Path_in_repo.root in let files = Vcs.ls_files vcs ~repo_root ~below in List.iter files ~f:(fun file -> Stdlib.print_endline (Vcs.Path_in_repo.to_string file)); @@ -158,12 +202,10 @@ let ls_files_cmd = let log_cmd = Command.make ~summary:"show the log of current repo" - (let%map_open.Command config = Vcs_arg.Config.arg in + (let%map_open.Command () = Arg.return () in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root; context = _ } = - Vcs_arg.initialize ~env ~config - in + let { Initialized.vcs; repo_root; cwd = _ } = initialize ~env in let log = Vcs.log vcs ~repo_root in print_sexp [%sexp (log : Vcs.Log.t)]; ()) @@ -172,14 +214,22 @@ let log_cmd = let name_status_cmd = Command.make ~summary:"show a summary of the diff between 2 revs" - (let%map_open.Command config = Vcs_arg.Config.arg - and src = Vcs_arg.pos_rev ~pos:0 ~doc:"base revision" - and dst = Vcs_arg.pos_rev ~pos:1 ~doc:"tip revision" in + (let%map_open.Command src = + Arg.pos + ~pos:0 + (Param.validated_string (module Vcs.Rev)) + ~docv:"BASE" + ~doc:"base revision" + and dst = + Arg.pos + ~pos:1 + (Param.validated_string (module Vcs.Rev)) + ~docv:"TIP" + ~doc:"tip revision" + in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root; context = _ } = - Vcs_arg.initialize ~env ~config - in + let { Initialized.vcs; repo_root; cwd = _ } = initialize ~env in let name_status = Vcs.name_status vcs ~repo_root ~changed:(Between { src; dst }) in print_sexp [%sexp (name_status : Vcs.Name_status.t)]; ()) @@ -188,14 +238,22 @@ let name_status_cmd = let num_status_cmd = Command.make ~summary:"show a summary of the number of lines of diff between 2 revs" - (let%map_open.Command config = Vcs_arg.Config.arg - and src = Vcs_arg.pos_rev ~pos:0 ~doc:"base revision" - and dst = Vcs_arg.pos_rev ~pos:1 ~doc:"tip revision" in + (let%map_open.Command src = + Arg.pos + ~pos:0 + (Param.validated_string (module Vcs.Rev)) + ~docv:"BASE" + ~doc:"base revision" + and dst = + Arg.pos + ~pos:1 + (Param.validated_string (module Vcs.Rev)) + ~docv:"TIP" + ~doc:"tip revision" + in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root; context = _ } = - Vcs_arg.initialize ~env ~config - in + let { Initialized.vcs; repo_root; cwd = _ } = initialize ~env in let num_status = Vcs.num_status vcs ~repo_root ~changed:(Between { src; dst }) in print_sexp [%sexp (num_status : Vcs.Num_status.t)]; ()) @@ -204,14 +262,17 @@ let num_status_cmd = let read_dir_cmd = Command.make ~summary:"print the list of files in a directory" - (let%map_open.Command config = Vcs_arg.Config.arg - and dir = Vcs_arg.pos_path ~pos:0 ~doc:"dir to read" in + (let%map_open.Command dir = + Arg.pos + ~pos:0 + (Param.validated_string (module Fpath)) + ~docv:"path/to/dir" + ~doc:"dir to read" + in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root = _; context } = - Vcs_arg.initialize ~env ~config - in - let dir = Vcs_arg.resolve dir ~context in + let { Initialized.vcs; repo_root = _; cwd } = initialize ~env in + let dir = Absolute_path.relativize ~root:cwd dir in let entries = Vcs.read_dir vcs ~dir in print_sexp [%sexp (entries : Fpart.t list)]; ()) @@ -220,13 +281,16 @@ let read_dir_cmd = let rename_current_branch_cmd = Command.make ~summary:"move/rename a branch to a new name" - (let%map_open.Command config = Vcs_arg.Config.arg - and branch_name = Vcs_arg.pos_branch_name ~pos:0 ~doc:"new name to rename to" in + (let%map_open.Command branch_name = + Arg.pos + ~pos:0 + (Param.validated_string (module Vcs.Branch_name)) + ~docv:"branch" + ~doc:"new name to rename to" + in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root; context = _ } = - Vcs_arg.initialize ~env ~config - in + let { Initialized.vcs; repo_root; cwd = _ } = initialize ~env in Vcs.rename_current_branch vcs ~repo_root ~to_:branch_name; ()) ;; @@ -234,12 +298,10 @@ let rename_current_branch_cmd = let refs_cmd = Command.make ~summary:"show the refs of current repo" - (let%map_open.Command config = Vcs_arg.Config.arg in + (let%map_open.Command () = Arg.return () in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root; context = _ } = - Vcs_arg.initialize ~env ~config - in + let { Initialized.vcs; repo_root; cwd = _ } = initialize ~env in let refs = Vcs.refs vcs ~repo_root in print_sexp [%sexp (refs : Vcs.Refs.t)]; ()) @@ -248,14 +310,17 @@ let refs_cmd = let save_file_cmd = Command.make ~summary:"save stdin to a file from the filesystem (aka tee)" - (let%map_open.Command config = Vcs_arg.Config.arg - and path = Vcs_arg.pos_path ~pos:0 ~doc:"file to save the contents to" in + (let%map_open.Command path = + Arg.pos + ~pos:0 + (Param.validated_string (module Fpath)) + ~docv:"FILE" + ~doc:"path to file where to save the contents to" + in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root = _; context } = - Vcs_arg.initialize ~env ~config - in - let path = Vcs_arg.resolve path ~context in + let { Initialized.vcs; repo_root = _; cwd } = initialize ~env in + let path = Absolute_path.relativize ~root:cwd path in let file_contents = Eio.Buf_read.parse_exn Eio.Buf_read.take_all @@ -270,14 +335,22 @@ let save_file_cmd = let set_user_config_cmd = Command.make ~summary:"set the user config" - (let%map_open.Command config = Vcs_arg.Config.arg - and user_name = Vcs_arg.user_name - and user_email = Vcs_arg.user_email in + (let%map_open.Command user_name = + Arg.named + [ "user.name" ] + (Param.validated_string (module Vcs.User_name)) + ~docv:"USER" + ~doc:"user name" + and user_email = + Arg.named + [ "user.email" ] + (Param.validated_string (module Vcs.User_email)) + ~docv:"EMAIL" + ~doc:"user email" + in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root; context = _ } = - Vcs_arg.initialize ~env ~config - in + let { Initialized.vcs; repo_root; cwd = _ } = initialize ~env in Vcs.set_user_name vcs ~repo_root ~user_name; Vcs.set_user_email vcs ~repo_root ~user_email; ()) @@ -286,15 +359,23 @@ let set_user_config_cmd = let show_file_at_rev_cmd = Command.make ~summary:"show the contents of file at a given revision" - (let%map_open.Command config = Vcs_arg.Config.arg - and rev = Vcs_arg.rev ~doc:"revision to show" - and path = Vcs_arg.pos_path_in_repo ~pos:0 ~doc:"path to file" in + (let%map_open.Command rev = + Arg.named + [ "rev"; "r" ] + (Param.validated_string (module Vcs.Rev)) + ~docv:"REV" + ~doc:"revision to show" + and path = + Arg.pos + ~pos:0 + (Param.validated_string (module Fpath)) + ~docv:"FILE" + ~doc:"path to file" + in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root; context } = - Vcs_arg.initialize ~env ~config - in - let path = Vcs_arg.resolve path ~context in + let { Initialized.vcs; repo_root; cwd } = initialize ~env in + let path = relativize ~repo_root ~cwd ~path in let result = Vcs.show_file_at_rev vcs ~repo_root ~rev ~path in (match result with | `Present contents -> Stdlib.print_string (contents :> string) @@ -309,12 +390,10 @@ let show_file_at_rev_cmd = let graph_cmd = Command.make ~summary:"compute graph of current repo" - (let%map_open.Command config = Vcs_arg.Config.arg in + (let%map_open.Command () = Arg.return () in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root; context = _ } = - Vcs_arg.initialize ~env ~config - in + let { Initialized.vcs; repo_root; cwd = _ } = initialize ~env in let graph = Vcs.graph vcs ~repo_root in print_sexp [%sexp (Vcs.Graph.summary graph : Vcs.Graph.Summary.t)]; ()) @@ -325,13 +404,16 @@ let graph_cmd = let branch_revision_cmd = Command.make ~summary:"revision of a branch" - (let%map_open.Command config = Vcs_arg.Config.arg - and branch_name = Vcs_arg.pos_branch_name_opt ~pos:0 ~doc:"which branch" in + (let%map_open.Command branch_name = + Arg.pos_opt + ~pos:0 + (Param.validated_string (module Vcs.Branch_name)) + ~docv:"BRANCH" + ~doc:"which branch" + in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root; context = _ } = - Vcs_arg.initialize ~env ~config - in + let { Initialized.vcs; repo_root; cwd = _ } = initialize ~env in let branch_name = match branch_name with | Some branch_name -> branch_name @@ -357,13 +439,15 @@ let branch_revision_cmd = let greatest_common_ancestors_cmd = Command.make ~summary:"print greatest common ancestors of revisions" - (let%map_open.Command config = Vcs_arg.Config.arg - and revs = Vcs_arg.pos_revs ~doc:"all revisions that must descend from the gcas" in + (let%map_open.Command revs = + Arg.pos_all + (Param.validated_string (module Vcs.Rev)) + ~docv:"REV" + ~doc:"all revisions that must descend from the gcas" + in Eio_main.run @@ fun env -> - let { Vcs_arg.Initialized.vcs; repo_root; context = _ } = - Vcs_arg.initialize ~env ~config - in + let { Initialized.vcs; repo_root; cwd = _ } = initialize ~env in let graph = Vcs.graph vcs ~repo_root in let nodes = List.map revs ~f:(fun rev -> diff --git a/test/cram/run.t b/test/cram/run.t index 4622573..5931a9c 100644 --- a/test/cram/run.t +++ b/test/cram/run.t @@ -239,7 +239,7 @@ Vcs's help for review. add [OPTION]… file add a file to the index - branch-revision [OPTION]… [branch] + branch-revision [OPTION]… [BRANCH] revision of a branch commit [--message=MSG] [--quiet] [OPTION]… @@ -251,7 +251,7 @@ Vcs's help for review. current-revision [OPTION]… revision of HEAD - gca [OPTION]… [rev]… + gca [OPTION]… [REV]… print greatest common ancestors of revisions git [OPTION]… [ARG]… @@ -260,10 +260,10 @@ Vcs's help for review. graph [OPTION]… compute graph of current repo - init [--quiet] [OPTION]… file + init [--quiet] [OPTION]… path/to/root initialize a new repository - load-file [OPTION]… file + load-file [OPTION]… path/to/file print a file from the filesystem (aka cat) log [OPTION]… @@ -272,13 +272,13 @@ Vcs's help for review. ls-files [--below=PATH] [OPTION]… list file - name-status [OPTION]… rev rev + name-status [OPTION]… BASE TIP show a summary of the diff between 2 revs - num-status [OPTION]… rev rev + num-status [OPTION]… BASE TIP show a summary of the number of lines of diff between 2 revs - read-dir [OPTION]… file + read-dir [OPTION]… path/to/dir print the list of files in a directory refs [OPTION]… @@ -287,13 +287,13 @@ Vcs's help for review. rename-current-branch [OPTION]… branch move/rename a branch to a new name - save-file [OPTION]… file + save-file [OPTION]… FILE save stdin to a file from the filesystem (aka tee) set-user-config [--user.email=EMAIL] [--user.name=USER] [OPTION]… set the user config - show-file-at-rev [--rev=REV] [OPTION]… file + show-file-at-rev [--rev=REV] [OPTION]… FILE show the contents of file at a given revision COMMON OPTIONS From dd8842376cb11eeb812b8cdd4eefabc4fe643fea Mon Sep 17 00:00:00 2001 From: Mathieu Barbin Date: Fri, 4 Oct 2024 12:48:31 +0200 Subject: [PATCH 05/14] Delete vcs-arg --- dune-project | 57 ------- headache.sh | 2 - lib/vcs_arg/src/dune | 30 ---- lib/vcs_arg/src/vcs_arg.ml | 254 ----------------------------- lib/vcs_arg/src/vcs_arg.mli | 108 ------------ lib/vcs_arg/test/dune | 39 ----- lib/vcs_arg/test/test__vcs_arg.ml | 35 ---- lib/vcs_arg/test/test__vcs_arg.mli | 22 --- vcs-arg.opam | 44 ----- vcs-command.opam | 1 - vcs-tests.opam | 1 - 11 files changed, 593 deletions(-) delete mode 100644 lib/vcs_arg/src/dune delete mode 100644 lib/vcs_arg/src/vcs_arg.ml delete mode 100644 lib/vcs_arg/src/vcs_arg.mli delete mode 100644 lib/vcs_arg/test/dune delete mode 100644 lib/vcs_arg/test/test__vcs_arg.ml delete mode 100644 lib/vcs_arg/test/test__vcs_arg.mli delete mode 100644 vcs-arg.opam diff --git a/dune-project b/dune-project index 08dec7d..dbee43d 100644 --- a/dune-project +++ b/dune-project @@ -64,59 +64,6 @@ (provider (>= 0.0.8)))) -(package - (name vcs-arg) - (synopsis "[Command.Arg] helpers for the Vcs library") - (depends - (ocaml - (>= 5.2)) - (base - (and - (>= v0.17) - (< v0.18))) - (cmdlang - (>= 0.0.5)) - (eio - (>= 1.0)) - (fpath - (>= 0.7.3)) - (fpath-sexp0 - (>= 0.2.0)) - (ppx_compare - (and - (>= v0.17) - (< v0.18))) - (ppx_enumerate - (and - (>= v0.17) - (< v0.18))) - (ppx_hash - (and - (>= v0.17) - (< v0.18))) - (ppx_here - (and - (>= v0.17) - (< v0.18))) - (ppx_let - (and - (>= v0.17) - (< v0.18))) - (ppx_sexp_conv - (and - (>= v0.17) - (< v0.18))) - (ppx_sexp_value - (and - (>= v0.17) - (< v0.18))) - (ppxlib - (>= 0.33)) - (vcs - (= :version)) - (vcs-git-eio - (= :version)))) - (package (name vcs-command) (synopsis "A command line tool for the Vcs library") @@ -175,8 +122,6 @@ (>= 0.33)) (vcs (= :version)) - (vcs-arg - (= :version)) (vcs-git-eio (= :version)))) @@ -444,8 +389,6 @@ (< v0.18))) (vcs (= :version)) - (vcs-arg - (= :version)) (vcs-command (= :version)) (vcs-git-blocking diff --git a/headache.sh b/headache.sh index 4294d2c..fa144ae 100755 --- a/headache.sh +++ b/headache.sh @@ -5,8 +5,6 @@ dirs=( "example" "lib/vcs/src" "lib/vcs/test" - "lib/vcs_arg/src" - "lib/vcs_arg/test" "lib/vcs_command/src" "lib/vcs_command/test" "lib/vcs_git_blocking/src" diff --git a/lib/vcs_arg/src/dune b/lib/vcs_arg/src/dune deleted file mode 100644 index aa34b75..0000000 --- a/lib/vcs_arg/src/dune +++ /dev/null @@ -1,30 +0,0 @@ -(library - (name vcs_arg) - (public_name vcs-arg) - (flags - :standard - -w - +a-4-40-41-42-44-45-48-66 - -warn-error - +a - -open - Base - -open - Fpath_sexp0 - -open - Cmdlang) - (libraries base cmdlang eio fpath fpath-sexp0 unix vcs vcs-git-eio) - (instrumentation - (backend bisect_ppx)) - (lint - (pps ppx_js_style -check-doc-comments)) - (preprocess - (pps - -unused-code-warnings=force - ppx_compare - ppx_enumerate - ppx_hash - ppx_here - ppx_let - ppx_sexp_conv - ppx_sexp_value))) diff --git a/lib/vcs_arg/src/vcs_arg.ml b/lib/vcs_arg/src/vcs_arg.ml deleted file mode 100644 index 75df3ac..0000000 --- a/lib/vcs_arg/src/vcs_arg.ml +++ /dev/null @@ -1,254 +0,0 @@ -(*******************************************************************************) -(* Vcs - a Versatile OCaml Library for Git Operations *) -(* Copyright (C) 2024 Mathieu Barbin *) -(* *) -(* This file is part of Vcs. *) -(* *) -(* Vcs is free software; you can redistribute it and/or modify it under *) -(* the terms of the GNU Lesser General Public License as published by the *) -(* Free Software Foundation either version 3 of the License, or any later *) -(* version, with the LGPL-3.0 Linking Exception. *) -(* *) -(* Vcs is distributed in the hope that it will be useful, but WITHOUT ANY *) -(* WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS *) -(* FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License and *) -(* the file `NOTICE.md` at the root of this repository for more details. *) -(* *) -(* You should have received a copy of the GNU Lesser General Public License *) -(* and the LGPL-3.0 Linking Exception along with this library. If not, see *) -(* and , respectively. *) -(*******************************************************************************) - -module Config = struct - (* This is boilerplate code to be used when we'll have things to select, such - as several backends, or backend modifiers. *) - type t = { unit : unit } - - let silence_w69_unused_field t = - ignore (t.unit : unit); - () - ;; - - let default = { unit = () } - - let arg = - let%map_open.Command () = Arg.return () in - let t = { unit = () } in - silence_w69_unused_field t; - t - ;; -end - -module Create_vcs_backend = struct - let repo_root (dir : _ Eio.Path.t) = - dir |> snd |> Absolute_path.v |> Vcs.Repo_root.of_absolute_path - ;; - - let from_cwd ~env ~cwd ~config:_ = - let fs = Eio.Stdenv.fs env in - match - With_return.with_return_option (fun { return } -> - let rec visit dir = - List.iter (Eio.Path.read_dir dir) ~f:(fun entry -> - match entry with - | ".git" -> - (* We don't check whether [".git"] is a directory, because this - breaks for git worktrees. Indeed, the file [".git"] at the root - of a repository created with [git worktree add] is a regular - file. *) - return (`Git, dir) - | _ -> ()); - match Eio.Path.split dir with - | None -> () - | Some (parent_dir, _) -> visit parent_dir - in - visit Eio.Path.(fs / (cwd |> Absolute_path.to_string))) - with - | None -> None - | Some ((`Git as vcs), dir) -> - let vcs = - match vcs with - | `Git -> Vcs_git_eio.create ~env - in - let repo_root = repo_root dir in - Some (vcs, repo_root) - ;; -end - -module Context = struct - type t = - { config : Config.t - ; fs : Eio.Fs.dir_ty Eio.Path.t - ; cwd : Absolute_path.t - ; vcs : Vcs_git_eio.t' - ; repo_root : Vcs.Repo_root.t - } - - let silence_w69_unused_field t = - ignore (t.config : Config.t); - ignore (t.fs : Eio.Fs.dir_ty Eio.Path.t); - () - ;; - - let create ?cwd ~env ~config () = - let cwd = - match cwd with - | Some cwd -> cwd - | None -> Unix.getcwd () |> Absolute_path.v - in - let vcs, repo_root = - match Create_vcs_backend.from_cwd ~env ~cwd ~config with - | Some x -> x - | None -> - raise - (Vcs.E - (Vcs.Err.create_s - [%sexp - "Not in a supported version control repo", { cwd : Absolute_path.t }])) - in - let t = - { config - ; fs = (Eio.Stdenv.fs env :> Eio.Fs.dir_ty Eio.Path.t) - ; cwd - ; vcs - ; repo_root - } - in - silence_w69_unused_field t; - t - ;; -end - -module Initialized = struct - type t = - { vcs : Vcs_git_eio.t' - ; repo_root : Vcs.Repo_root.t - ; context : Context.t - } -end - -let initialize ~env ~config = - let c = Context.create ~env ~config () in - { Initialized.vcs = c.vcs; repo_root = c.repo_root; context = c } -;; - -type 'a t = Context.t -> 'a - -let resolve t ~context = t context - -let pos_branch_name ~pos ~doc = - let%map_open.Command branch_name = - Arg.pos ~pos (Param.validated_string (module Vcs.Branch_name)) ~docv:"branch" ~doc - in - branch_name -;; - -let pos_branch_name_opt ~pos ~doc = - let%map_open.Command branch_name = - Arg.pos_opt ~pos (Param.validated_string (module Vcs.Branch_name)) ~docv:"branch" ~doc - in - branch_name -;; - -let pos_path ~pos ~doc = - let%map_open.Command path = - Arg.pos ~pos (Param.validated_string (module Fpath)) ~docv:"file" ~doc - in - fun (c : Context.t) -> Absolute_path.relativize ~root:c.cwd path -;; - -let pos_path_in_repo ~pos ~doc = - let%map_open.Command path = - Arg.pos ~pos (Param.validated_string (module Fpath)) ~docv:"file" ~doc - in - fun (c : Context.t) -> - let repo_root = Vcs.Repo_root.to_absolute_path c.repo_root in - let path = Absolute_path.relativize ~root:c.cwd path in - match Absolute_path.chop_prefix path ~prefix:repo_root with - | Some relative_path -> Vcs.Path_in_repo.of_relative_path relative_path - | None -> - raise - (Vcs.E - (Vcs.Err.create_s [%sexp "Path is not in repo", { path : Absolute_path.t }])) -;; - -let pos_rev ~pos ~doc = - let%map_open.Command rev = - Arg.pos ~pos (Param.validated_string (module Vcs.Rev)) ~docv:"rev" ~doc - in - rev -;; - -let pos_revs ~doc = - let%map_open.Command revs = - Arg.pos_all (Param.validated_string (module Vcs.Rev)) ~docv:"rev" ~doc - in - revs -;; - -let below_path_in_repo = - let%map_open.Command path = - Arg.named_opt - [ "below" ] - (Param.validated_string (module Fpath)) - ~docv:"PATH" - ~doc:"only below path" - in - fun (c : Context.t) -> - let repo_root = Vcs.Repo_root.to_absolute_path c.repo_root in - Option.map path ~f:(fun path -> - let path = Absolute_path.relativize ~root:c.cwd path in - match Absolute_path.chop_prefix path ~prefix:repo_root with - | Some relative_path -> Vcs.Path_in_repo.of_relative_path relative_path - | None -> - raise - (Vcs.E - (Vcs.Err.create_s [%sexp "Path is not in repo", { path : Absolute_path.t }]))) -;; - -let commit_message = - let%map_open.Command commit_message = - Arg.named - [ "message"; "m" ] - (Param.validated_string (module Vcs.Commit_message)) - ~docv:"MSG" - ~doc:"commit message" - in - commit_message -;; - -let quiet = - let%map_open.Command quiet = - Arg.flag [ "quiet"; "q" ] ~doc:"suppress output on success" - in - quiet -;; - -let rev ~doc = - let%map_open.Command rev = - Arg.named [ "rev"; "r" ] (Param.validated_string (module Vcs.Rev)) ~docv:"REV" ~doc - in - rev -;; - -let user_name = - let%map_open.Command user_name = - Arg.named - [ "user.name" ] - (Param.validated_string (module Vcs.User_name)) - ~docv:"USER" - ~doc:"user name" - in - user_name -;; - -let user_email = - let%map_open.Command user_email = - Arg.named - [ "user.email" ] - (Param.validated_string (module Vcs.User_email)) - ~docv:"EMAIL" - ~doc:"user email" - in - user_email -;; diff --git a/lib/vcs_arg/src/vcs_arg.mli b/lib/vcs_arg/src/vcs_arg.mli deleted file mode 100644 index 80f9518..0000000 --- a/lib/vcs_arg/src/vcs_arg.mli +++ /dev/null @@ -1,108 +0,0 @@ -(*_******************************************************************************) -(*_ Vcs - a Versatile OCaml Library for Git Operations *) -(*_ Copyright (C) 2024 Mathieu Barbin *) -(*_ *) -(*_ This file is part of Vcs. *) -(*_ *) -(*_ Vcs is free software; you can redistribute it and/or modify it under *) -(*_ the terms of the GNU Lesser General Public License as published by the *) -(*_ Free Software Foundation either version 3 of the License, or any later *) -(*_ version, with the LGPL-3.0 Linking Exception. *) -(*_ *) -(*_ Vcs is distributed in the hope that it will be useful, but WITHOUT ANY *) -(*_ WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS *) -(*_ FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License and *) -(*_ the file `NOTICE.md` at the root of this repository for more details. *) -(*_ *) -(*_ You should have received a copy of the GNU Lesser General Public License *) -(*_ and the LGPL-3.0 Linking Exception along with this library. If not, see *) -(*_ and , respectively. *) -(*_******************************************************************************) - -(** Common command line arguments in use in vcs. *) - -(** {1 Initialization} *) - -module Config : sig - type t - - val default : t - val arg : t Command.Arg.t -end - -module Context : sig - type t - - val create - : ?cwd:Absolute_path.t - -> env:< fs : _ Eio.Path.t ; process_mgr : _ Eio.Process.mgr ; .. > - -> config:Config.t - -> unit - -> t -end - -module Initialized : sig - type t = - { vcs : Vcs_git_eio.t' - ; repo_root : Vcs.Repo_root.t - ; context : Context.t - } -end - -(** The initialization should be created very early in the commands body. The - [cwd] shall not be changed subsequently. *) -val initialize - : env:< fs : _ Eio.Path.t ; process_mgr : _ Eio.Process.mgr ; .. > - -> config:Config.t - -> Initialized.t - -(** {1 Args} - - Some command line arguments may only be created under a certain context, in - that case they're exposed wrapped under a resolvable type. Otherwise they - can be exposed as command arguments directly. - - If not otherwise specified, the arguments are resolved under the current - context, and are required. Optional arguments ends with ["_opt"]. *) - -(** A ['a t] is a command line argument parser that produces a value of type - ['a] under the initialized context. *) -type 'a t - -(** To be called in the body of the command, after initialization. *) -val resolve : 'a t -> context:Context.t -> 'a - -(** A required pos [BRANCH]. *) -val pos_branch_name : pos:int -> doc:string -> Vcs.Branch_name.t Command.Arg.t - -(** An optional pos [BRANCH]. *) -val pos_branch_name_opt : pos:int -> doc:string -> Vcs.Branch_name.t option Command.Arg.t - -(** An positional argument for a path. It can be given either as an absolute - path or relative path in the command line, but will always be resolved to an - absolute path. *) -val pos_path : pos:int -> doc:string -> Absolute_path.t t Command.Arg.t - -(** An positional parameter for a path in repo. *) -val pos_path_in_repo : pos:int -> doc:string -> Vcs.Path_in_repo.t t Command.Arg.t - -(** A required pos [REV]. *) -val pos_rev : pos:int -> doc:string -> Vcs.Rev.t Command.Arg.t - -(** A required list of pos [REVs]. *) -val pos_revs : doc:string -> Vcs.Rev.t list Command.Arg.t - -(** A flag to restrict the repo to a subdirectory below a certain path. *) -val below_path_in_repo : Vcs.Path_in_repo.t option t Command.Arg.t - -(** A required [-m _] nonempty commit message. *) -val commit_message : Vcs.Commit_message.t Command.Arg.t - -(** Perform the side effect if any, but suppress the output in case of success. *) -val quiet : bool Command.Arg.t - -(** A required [--rev _] that produces a revision. *) -val rev : doc:string -> Vcs.Rev.t Command.Arg.t - -val user_email : Vcs.User_email.t Command.Arg.t -val user_name : Vcs.User_name.t Command.Arg.t diff --git a/lib/vcs_arg/test/dune b/lib/vcs_arg/test/dune deleted file mode 100644 index 7f64be4..0000000 --- a/lib/vcs_arg/test/dune +++ /dev/null @@ -1,39 +0,0 @@ -(library - (name vcs_arg_test) - (public_name vcs-tests.vcs_arg_test) - (inline_tests) - (flags - :standard - -w - +a-4-40-41-42-44-45-48-66 - -warn-error - +a - -open - Base - -open - Fpath_sexp0 - -open - Expect_test_helpers_base) - (libraries - base - eio - eio_main - expect_test_helpers_core.expect_test_helpers_base - fpath - fpath-sexp0 - vcs_arg) - (instrumentation - (backend bisect_ppx)) - (lint - (pps ppx_js_style -check-doc-comments)) - (preprocess - (pps - -unused-code-warnings=force - ppx_compare - ppx_enumerate - ppx_expect - ppx_hash - ppx_here - ppx_let - ppx_sexp_conv - ppx_sexp_value))) diff --git a/lib/vcs_arg/test/test__vcs_arg.ml b/lib/vcs_arg/test/test__vcs_arg.ml deleted file mode 100644 index a45d34a..0000000 --- a/lib/vcs_arg/test/test__vcs_arg.ml +++ /dev/null @@ -1,35 +0,0 @@ -(*******************************************************************************) -(* Vcs - a Versatile OCaml Library for Git Operations *) -(* Copyright (C) 2024 Mathieu Barbin *) -(* *) -(* This file is part of Vcs. *) -(* *) -(* Vcs is free software; you can redistribute it and/or modify it under *) -(* the terms of the GNU Lesser General Public License as published by the *) -(* Free Software Foundation either version 3 of the License, or any later *) -(* version, with the LGPL-3.0 Linking Exception. *) -(* *) -(* Vcs is distributed in the hope that it will be useful, but WITHOUT ANY *) -(* WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS *) -(* FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License and *) -(* the file `NOTICE.md` at the root of this repository for more details. *) -(* *) -(* You should have received a copy of the GNU Lesser General Public License *) -(* and the LGPL-3.0 Linking Exception along with this library. If not, see *) -(* and , respectively. *) -(*******************************************************************************) - -(* Most of [Vcs_arg] is tested via the vcs cram tests. This file contains - additional tests that help covering corner cases. *) - -let%expect_test "not-in-repo" = - Eio_main.run - @@ fun env -> - (match - Vcs_arg.Context.create ~cwd:Absolute_path.root ~env ~config:Vcs_arg.Config.default () - with - | _ -> assert false - | exception Vcs.E err -> print_s [%sexp (err : Vcs.Err.t)]); - [%expect {| ("Not in a supported version control repo" ((cwd /))) |}]; - () -;; diff --git a/lib/vcs_arg/test/test__vcs_arg.mli b/lib/vcs_arg/test/test__vcs_arg.mli deleted file mode 100644 index 951d437..0000000 --- a/lib/vcs_arg/test/test__vcs_arg.mli +++ /dev/null @@ -1,22 +0,0 @@ -(*_******************************************************************************) -(*_ Vcs - a Versatile OCaml Library for Git Operations *) -(*_ Copyright (C) 2024 Mathieu Barbin *) -(*_ *) -(*_ This file is part of Vcs. *) -(*_ *) -(*_ Vcs is free software; you can redistribute it and/or modify it under *) -(*_ the terms of the GNU Lesser General Public License as published by the *) -(*_ Free Software Foundation either version 3 of the License, or any later *) -(*_ version, with the LGPL-3.0 Linking Exception. *) -(*_ *) -(*_ Vcs is distributed in the hope that it will be useful, but WITHOUT ANY *) -(*_ WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS *) -(*_ FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License and *) -(*_ the file `NOTICE.md` at the root of this repository for more details. *) -(*_ *) -(*_ You should have received a copy of the GNU Lesser General Public License *) -(*_ and the LGPL-3.0 Linking Exception along with this library. If not, see *) -(*_ and , respectively. *) -(*_******************************************************************************) - -(*_ This signature is deliberately empty. *) diff --git a/vcs-arg.opam b/vcs-arg.opam deleted file mode 100644 index f5a2a08..0000000 --- a/vcs-arg.opam +++ /dev/null @@ -1,44 +0,0 @@ -# This file is generated by dune, edit dune-project instead -opam-version: "2.0" -synopsis: "[Command.Arg] helpers for the Vcs library" -maintainer: ["Mathieu Barbin "] -authors: ["Mathieu Barbin"] -license: "LGPL-3.0-or-later WITH LGPL-3.0-linking-exception" -homepage: "https://github.com/mbarbin/vcs" -doc: "https://mbarbin.github.io/vcs/" -bug-reports: "https://github.com/mbarbin/vcs/issues" -depends: [ - "dune" {>= "3.16"} - "ocaml" {>= "5.2"} - "base" {>= "v0.17" & < "v0.18"} - "cmdlang" {>= "0.0.5"} - "eio" {>= "1.0"} - "fpath" {>= "0.7.3"} - "fpath-sexp0" {>= "0.2.0"} - "ppx_compare" {>= "v0.17" & < "v0.18"} - "ppx_enumerate" {>= "v0.17" & < "v0.18"} - "ppx_hash" {>= "v0.17" & < "v0.18"} - "ppx_here" {>= "v0.17" & < "v0.18"} - "ppx_let" {>= "v0.17" & < "v0.18"} - "ppx_sexp_conv" {>= "v0.17" & < "v0.18"} - "ppx_sexp_value" {>= "v0.17" & < "v0.18"} - "ppxlib" {>= "0.33"} - "vcs" {= version} - "vcs-git-eio" {= version} - "odoc" {with-doc} -] -build: [ - ["dune" "subst"] {dev} - [ - "dune" - "build" - "-p" - name - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] -] -dev-repo: "git+https://github.com/mbarbin/vcs.git" diff --git a/vcs-command.opam b/vcs-command.opam index 587cf4a..e3efb96 100644 --- a/vcs-command.opam +++ b/vcs-command.opam @@ -28,7 +28,6 @@ depends: [ "ppx_sexp_value" {>= "v0.17" & < "v0.18"} "ppxlib" {>= "0.33"} "vcs" {= version} - "vcs-arg" {= version} "vcs-git-eio" {= version} "odoc" {with-doc} ] diff --git a/vcs-tests.opam b/vcs-tests.opam index 3a25b75..f064f3d 100644 --- a/vcs-tests.opam +++ b/vcs-tests.opam @@ -43,7 +43,6 @@ depends: [ "sexp_pretty" {>= "v0.17" & < "v0.18"} "stdio" {>= "v0.17" & < "v0.18"} "vcs" {= version} - "vcs-arg" {= version} "vcs-command" {= version} "vcs-git-blocking" {= version} "vcs-git-eio" {= version} From 280d284d28933cb5e7005d49abca2ce1c2e78f2c Mon Sep 17 00:00:00 2001 From: Mathieu Barbin Date: Fri, 4 Oct 2024 15:02:20 +0200 Subject: [PATCH 06/14] Change interface to find enclosing repo root --- doc/docs/explanation/exploratory_tests.md | 4 ++ lib/vcs/src/non_raising.ml | 8 ++- lib/vcs/src/vcs.mli | 36 +++++++---- lib/vcs/src/vcs0.ml | 23 ++++--- lib/vcs/src/vcs_interface.mli | 11 +++- lib/vcs_command/src/vcs_command.ml | 40 +++++++++++- test/cram/run.t | 24 +++++++ test/expect/raising_unit_tests.ml | 79 ++++++++++++++++++++++- 8 files changed, 195 insertions(+), 30 deletions(-) diff --git a/doc/docs/explanation/exploratory_tests.md b/doc/docs/explanation/exploratory_tests.md index 2c15eb0..caa6293 100644 --- a/doc/docs/explanation/exploratory_tests.md +++ b/doc/docs/explanation/exploratory_tests.md @@ -44,6 +44,10 @@ COMMANDS current-revision [OPTION]… revision of HEAD + find-enclosing-repo-root [--from=path/to/dir] [--store=VAL] + [OPTION]… + find enclosing repo root + gca [OPTION]… [REV]… print greatest common ancestors of revisions diff --git a/lib/vcs/src/non_raising.ml b/lib/vcs/src/non_raising.ml index 2b1f0b5..1718e7b 100644 --- a/lib/vcs/src/non_raising.ml +++ b/lib/vcs/src/non_raising.ml @@ -32,8 +32,12 @@ module Make (M : M) : let init vcs ~path = try_with (fun () -> Vcs0.init vcs ~path) - let find_enclosing_repo_root ?stop_if_present vcs ~from = - try_with (fun () -> Vcs0.find_enclosing_repo_root ?stop_if_present vcs ~from) + let find_enclosing_repo_root vcs ~from ~store = + try_with (fun () -> Vcs0.find_enclosing_repo_root vcs ~from ~store) + ;; + + let find_enclosing_git_repo_root vcs ~from = + try_with (fun () -> Vcs0.find_enclosing_git_repo_root vcs ~from) ;; let add vcs ~repo_root ~path = try_with (fun () -> Vcs0.add vcs ~repo_root ~path) diff --git a/lib/vcs/src/vcs.mli b/lib/vcs/src/vcs.mli index 07562f9..4ad25c6 100644 --- a/lib/vcs/src/vcs.mli +++ b/lib/vcs/src/vcs.mli @@ -88,27 +88,39 @@ module Url = Url repository is already initialized there. *) val init : [> Trait.init ] t -> path:Absolute_path.t -> Repo_root.t -(** [find_enclosing_repo_root ?stop_if_present vcs ~from:dir] walks up the path from +(** [find_enclosing_repo_root vcs ~from:dir ~store] walks up the path from the given directory [dir] and stops when at the root of a repository. If no repo root has been found when reaching the root path ["/"], the function returns [None]. The way we determine whether we are at the root of a repo is by looking for - the presence of a [".git"] entry in the directory. + the presence of one of the store entries in the directory (e.g. [".git"]). - When present, we do not check that the path [".git"] is itself a directory, - so that this function is able to correctly infer and return the root of Git - repos where [".git"] is not a directory (e.g. Git worktrees). + When present, we do not check that the store is itself a directory, so that + this function is able to correctly infer and return the root of Git repos + where [".git"] is not a directory (e.g. Git worktrees). - You may also make the recursive search stop if specific entries are present. - For example, if you pass [~stop_if_present:[".hg"]] and call it from within - a Mercurial repo, the function will find its root and return it, along with - the [`Other ".hg"] tag. *) + You may supply several stores if you want to stop at the first store that is + encountered, if you do not know in what kind of repo you are. For example, + [[".git"; ".hg"]]. The store that was matched is returned as part of the + result. + + If you know you are in a Git repository you may want to use the wrapper + {!val:find_enclosing_git_repo_root} instead. *) val find_enclosing_repo_root - : ?stop_if_present:Fpart.t list - -> [> Trait.file_system ] t + : [> Trait.file_system ] t + -> from:Absolute_path.t + -> store:Fpart.t list + -> ([ `Store of Fpart.t ] * Repo_root.t) option + +(** [find_enclosing_git_repo_root vcs ~from:dir] is a convenient wrapper around + {!val:find_enclosing_repo_root} for Git repositories. This is looking for + the right most directory containing a [".git"] entry, starting from [dir] + and walking up. *) +val find_enclosing_git_repo_root + : [> Trait.file_system ] t -> from:Absolute_path.t - -> ([ `Git | `Other of Fpart.t ] * Repo_root.t) option + -> Repo_root.t option (** {1 Revisions} *) diff --git a/lib/vcs/src/vcs0.ml b/lib/vcs/src/vcs0.ml index f3d40d4..bcead1d 100644 --- a/lib/vcs/src/vcs0.ml +++ b/lib/vcs/src/vcs0.ml @@ -60,18 +60,17 @@ let init (Provider.T { t; handler }) ~path = M.init t ~path |> of_result ~step:(lazy [%sexp "Vcs.init", { path : Absolute_path.t }]) ;; -let find_enclosing_repo_root ?(stop_if_present = []) t ~from = - let git_store = Fpart.v ".git" in - let stop_if_present = git_store :: stop_if_present in +let find_enclosing_repo_root t ~from ~store = let rec visit dir = let entries = read_dir t ~dir in - match - List.find entries ~f:(fun entry -> - List.mem stop_if_present entry ~equal:Fpart.equal) - with + match List.find entries ~f:(fun entry -> List.mem store entry ~equal:Fpart.equal) with | Some entry -> - let tag = if Fpart.equal entry git_store then `Git else `Other entry in - Some (tag, Repo_root.of_absolute_path dir) + let dir = + Fpath.rem_empty_seg (dir :> Fpath.t) + |> Absolute_path.of_fpath + |> Option.value ~default:dir + in + Some (`Store entry, Repo_root.of_absolute_path dir) | None -> (match Absolute_path.parent dir with | None -> None @@ -80,6 +79,12 @@ let find_enclosing_repo_root ?(stop_if_present = []) t ~from = visit from ;; +let find_enclosing_git_repo_root t ~from = + match find_enclosing_repo_root t ~from ~store:[ Fpart.dot_git ] with + | None -> None + | Some (_, repo_root) -> Some repo_root +;; + let current_branch (Provider.T { t; handler }) ~repo_root = let module M = (val Provider.Handler.lookup handler ~trait:Trait.Rev_parse) in M.current_branch t ~repo_root diff --git a/lib/vcs/src/vcs_interface.mli b/lib/vcs/src/vcs_interface.mli index 21adc1b..c55778f 100644 --- a/lib/vcs/src/vcs_interface.mli +++ b/lib/vcs/src/vcs_interface.mli @@ -56,11 +56,16 @@ module type S = sig val init : [> Trait.init ] t -> path:Absolute_path.t -> Repo_root.t result + val find_enclosing_git_repo_root + : [> Trait.file_system ] t + -> from:Absolute_path.t + -> Repo_root.t option result + val find_enclosing_repo_root - : ?stop_if_present:Fpart.t list - -> [> Trait.file_system ] t + : [> Trait.file_system ] t -> from:Absolute_path.t - -> ([ `Git | `Other of Fpart.t ] * Repo_root.t) option result + -> store:Fpart.t list + -> ([ `Store of Fpart.t ] * Repo_root.t) option result val add : [> Trait.add ] t diff --git a/lib/vcs_command/src/vcs_command.ml b/lib/vcs_command/src/vcs_command.ml index e8fb3bf..1549026 100644 --- a/lib/vcs_command/src/vcs_command.ml +++ b/lib/vcs_command/src/vcs_command.ml @@ -34,9 +34,9 @@ module Initialized = struct end let find_enclosing_repo_root vcs ~from = - match Vcs.find_enclosing_repo_root vcs ~from with - | Some (`Git, repo_root) -> repo_root - | Some (`Other _, _) | None -> + match Vcs.find_enclosing_repo_root vcs ~from ~store:[ Fpart.dot_git ] with + | Some (`Store _, repo_root) -> repo_root + | None -> Vcs.raise_s "Failed to locate enclosing repo root from directory" [%sexp { from : Absolute_path.t }] @@ -118,6 +118,39 @@ let current_revision_cmd = ()) ;; +let find_enclosing_repo_root_cmd = + Command.make + ~summary:"find enclosing repo root" + (let%map_open.Command from = + Arg.named_opt + [ "from" ] + (Param.validated_string (module Fpath)) + ~docv:"path/to/dir" + ~doc:"walk up from the supplied directory (default is cwd)" + and store = + Arg.named_opt + [ "store" ] + (Param.comma_separated (Param.validated_string (module Fpart))) + ~doc:"stop the search if one of these entries is found (e.g. '.hg')" + >>| Option.value ~default:[ Fpart.dot_git ] + in + Eio_main.run + @@ fun env -> + let { Initialized.vcs; repo_root = _; cwd } = initialize ~env in + let from = + match from with + | None -> cwd + | Some from -> Absolute_path.relativize ~root:cwd from + in + match Vcs.find_enclosing_repo_root vcs ~from ~store with + | None -> () + | Some (`Store store, repo_root) -> + Stdlib.Printf.printf + "%s: %s\n" + (Fpart.to_string store) + (Vcs.Repo_root.to_string repo_root)) +;; + let git_cmd = Command.make ~summary:"run the git cli" @@ -478,6 +511,7 @@ sub commands exposed here, plus additional ones. ; "commit", commit_cmd ; "current-branch", current_branch_cmd ; "current-revision", current_revision_cmd + ; "find-enclosing-repo-root", find_enclosing_repo_root_cmd ; "gca", greatest_common_ancestors_cmd ; "git", git_cmd ; "graph", graph_cmd diff --git a/test/cram/run.t b/test/cram/run.t index 5931a9c..8368bb6 100644 --- a/test/cram/run.t +++ b/test/cram/run.t @@ -105,6 +105,26 @@ File system operations. $ rm untracked/hello $ rmdir untracked +Find enclosing repo root. + + $ ocaml-vcs find-enclosing-repo-root + .git: $TESTCASE_ROOT + + $ mkdir subdir + $ ocaml-vcs find-enclosing-repo-root --from subdir + .git: $TESTCASE_ROOT + + $ ocaml-vcs find-enclosing-repo-root --from "/" + + $ mkdir -p subdir/hg/otherdir + $ touch subdir/hg/.hg + + $ ocaml-vcs find-enclosing-repo-root --from subdir/hg/otherdir + .git: $TESTCASE_ROOT + + $ ocaml-vcs find-enclosing-repo-root --from subdir/hg/otherdir --store .hg + .hg: $TESTCASE_ROOT/subdir/hg + Adding a new file under a directory. $ mkdir dir @@ -251,6 +271,10 @@ Vcs's help for review. current-revision [OPTION]… revision of HEAD + find-enclosing-repo-root [--from=path/to/dir] [--store=VAL] + [OPTION]… + find enclosing repo root + gca [OPTION]… [REV]… print greatest common ancestors of revisions diff --git a/test/expect/raising_unit_tests.ml b/test/expect/raising_unit_tests.ml index ced2571..7a06de4 100644 --- a/test/expect/raising_unit_tests.ml +++ b/test/expect/raising_unit_tests.ml @@ -19,4 +19,81 @@ (* and , respectively. *) (*******************************************************************************) -(* Cover once each function using the raising interface. *) +(* Test Vcs using the raising interface. *) + +let%expect_test "find_enclosing_repo_root" = + Eio_main.run + @@ fun env -> + Eio.Switch.run + @@ fun sw -> + let vcs = Vcs_git_eio.create ~env in + let repo_root = Vcs_test_helpers.init_temp_repo ~env ~sw ~vcs in + (* Find the root from the root itself. *) + let () = + match + Vcs.find_enclosing_git_repo_root + vcs + ~from:(repo_root |> Vcs.Repo_root.to_absolute_path) + with + | None -> assert false + | Some repo_root2 -> + require_equal [%here] (module Vcs.Repo_root) repo_root repo_root2; + [%expect {||}] + in + (* Find the root from a subdirectory. *) + let () = + let subdir = Vcs.Repo_root.append repo_root (Vcs.Path_in_repo.v "path/in/repo") in + Eio.Path.mkdirs + ~exists_ok:true + ~perm:0o777 + Eio.Path.(Eio.Stdenv.fs env / Absolute_path.to_string subdir); + match Vcs.find_enclosing_git_repo_root vcs ~from:subdir with + | None -> assert false + | Some repo_root2 -> + require_equal [%here] (module Vcs.Repo_root) repo_root repo_root2; + [%expect {||}] + in + (* Stop before root (e.g. in a Mercurial repo). *) + let () = + let stop_at = Vcs.Repo_root.append repo_root (Vcs.Path_in_repo.v "path") in + let subdir = Absolute_path.append stop_at (Relative_path.v "other/dir") in + Eio.Path.mkdirs + ~exists_ok:true + ~perm:0o777 + Eio.Path.(Eio.Stdenv.fs env / Absolute_path.to_string subdir); + (match + Vcs.find_enclosing_repo_root + vcs + ~from:subdir + ~store:[ Fpart.dot_git; Fpart.dot_hg ] + with + | None -> assert false + | Some (`Store store, repo_root2) -> + require_equal [%here] (module Fpart) store Fpart.dot_git; + require_equal [%here] (module Vcs.Repo_root) repo_root repo_root2; + [%expect {||}]); + Eio.Path.save + ~create:(`Or_truncate 0o666) + Eio.Path.(Eio.Stdenv.fs env / Absolute_path.to_string stop_at / ".hg") + ""; + match Vcs.find_enclosing_repo_root vcs ~from:subdir ~store:[ Fpart.dot_hg ] with + | None -> assert false + | Some (`Store store, repo_root2) -> + require_equal [%here] (module Fpart) store Fpart.dot_hg; + require_equal + [%here] + (module Vcs.Repo_root) + (Vcs.Repo_root.of_absolute_path stop_at) + repo_root2; + [%expect {||}] + in + (* Not found. This one is a bit more tricky to test because when running in + the dune environment, we are inside a Git repo. *) + let () = + (match Vcs.find_enclosing_git_repo_root vcs ~from:Absolute_path.root with + | Some _ -> assert false + | None -> ()); + [%expect {||}] + in + () +;; From 1c7f01a4cf01b48ec26b122931514c9e452cbdbe Mon Sep 17 00:00:00 2001 From: Mathieu Barbin Date: Fri, 4 Oct 2024 15:54:25 +0200 Subject: [PATCH 07/14] Changelog --- CHANGES.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index c47bf4a..1a85fc9 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,7 @@ ### Added +- Add `Vcs.find_enclosing_repo_root` helper (#PR, @mbarbin). - Add `Vcs.read_dir` helper (#PR, @mbarbin). ### Changed @@ -14,6 +15,8 @@ ### Removed +- Removed package `vcs-arg` and inline what's needed directly in `vcs-command` (#PR, @mbarbin). + ## 0.0.8 (2024-09-30) ### Changed From 8fb26197d131dd6ff04315aeaef441ac9a2e653a Mon Sep 17 00:00:00 2001 From: Mathieu Barbin Date: Fri, 4 Oct 2024 16:20:41 +0200 Subject: [PATCH 08/14] Fix brittle test --- lib/vcs_git_blocking/test/test__hello_commit.ml | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/lib/vcs_git_blocking/test/test__hello_commit.ml b/lib/vcs_git_blocking/test/test__hello_commit.ml index 70c81c7..71c2f52 100644 --- a/lib/vcs_git_blocking/test/test__hello_commit.ml +++ b/lib/vcs_git_blocking/test/test__hello_commit.ml @@ -82,13 +82,15 @@ let%expect_test "read_dir" = [%expect {||}]; read_dir dir; [%expect {| (foo hello.txt) |}]; - require_does_raise [%here] (fun () -> - Vcs.read_dir vcs ~dir:(Absolute_path.v "/invalid")); + let () = + match Vcs.read_dir vcs ~dir:(Absolute_path.v "/invalid") with + | (_ : Fpart.t list) -> assert false + | exception Vcs.E err -> print_s [%sexp (err : Vcs.Err.t)] + in [%expect {| - (repo/vcs/lib/vcs/src/exn0.ml.E ( - (steps ((Vcs.read_dir ((dir /invalid))))) - (error (Sys_error "/invalid: No such file or directory")))) + ((steps ((Vcs.read_dir ((dir /invalid))))) + (error (Sys_error "/invalid: No such file or directory"))) |}]; () ;; From 76a7a8d7d2ab94fdc0d2904f4fe576ca26cb0e31 Mon Sep 17 00:00:00 2001 From: Mathieu Barbin Date: Fri, 4 Oct 2024 16:23:57 +0200 Subject: [PATCH 09/14] Add test --- test/cram/run.t | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/test/cram/run.t b/test/cram/run.t index 8368bb6..0c920c9 100644 --- a/test/cram/run.t +++ b/test/cram/run.t @@ -107,6 +107,10 @@ File system operations. Find enclosing repo root. + $ (cd "/" && ocaml-vcs current-revision) + Error: Failed to locate enclosing repo root from directory (from /) + [123] + $ ocaml-vcs find-enclosing-repo-root .git: $TESTCASE_ROOT From c49be690484e5886228b8954042afb117065ee58 Mon Sep 17 00:00:00 2001 From: Mathieu Barbin Date: Fri, 4 Oct 2024 18:17:32 +0200 Subject: [PATCH 10/14] Refactor test filenames --- .../{raising_unit_tests.ml => find_enclosing_repo_root.ml} | 2 -- ...nonraising_unit_tests.mli => find_enclosing_repo_root.mli} | 0 test/expect/{nonraising_unit_tests.ml => small_graph.ml} | 4 +--- test/expect/{raising_unit_tests.mli => small_graph.mli} | 0 4 files changed, 1 insertion(+), 5 deletions(-) rename test/expect/{raising_unit_tests.ml => find_enclosing_repo_root.ml} (98%) rename test/expect/{nonraising_unit_tests.mli => find_enclosing_repo_root.mli} (100%) rename test/expect/{nonraising_unit_tests.ml => small_graph.ml} (98%) rename test/expect/{raising_unit_tests.mli => small_graph.mli} (100%) diff --git a/test/expect/raising_unit_tests.ml b/test/expect/find_enclosing_repo_root.ml similarity index 98% rename from test/expect/raising_unit_tests.ml rename to test/expect/find_enclosing_repo_root.ml index 7a06de4..5651820 100644 --- a/test/expect/raising_unit_tests.ml +++ b/test/expect/find_enclosing_repo_root.ml @@ -19,8 +19,6 @@ (* and , respectively. *) (*******************************************************************************) -(* Test Vcs using the raising interface. *) - let%expect_test "find_enclosing_repo_root" = Eio_main.run @@ fun env -> diff --git a/test/expect/nonraising_unit_tests.mli b/test/expect/find_enclosing_repo_root.mli similarity index 100% rename from test/expect/nonraising_unit_tests.mli rename to test/expect/find_enclosing_repo_root.mli diff --git a/test/expect/nonraising_unit_tests.ml b/test/expect/small_graph.ml similarity index 98% rename from test/expect/nonraising_unit_tests.ml rename to test/expect/small_graph.ml index 8b96562..34c058e 100644 --- a/test/expect/nonraising_unit_tests.ml +++ b/test/expect/small_graph.ml @@ -19,8 +19,6 @@ (* and , respectively. *) (*******************************************************************************) -(* Cover once each function using the non-raising interface. *) - (* A utility to map the revisions to short and stable keys ("rev0", "rev1", etc). *) let map_sexp = let next = ref (-1) in @@ -48,7 +46,7 @@ let map_sexp = aux ;; -let%expect_test "num stat without lines" = +let%expect_test "small graph" = Eio_main.run @@ fun env -> Eio.Switch.run diff --git a/test/expect/raising_unit_tests.mli b/test/expect/small_graph.mli similarity index 100% rename from test/expect/raising_unit_tests.mli rename to test/expect/small_graph.mli From 4dcd133db3fabac0f07e3b9edf28c8d69f90f0ed Mon Sep 17 00:00:00 2001 From: Mathieu Barbin Date: Fri, 4 Oct 2024 18:17:40 +0200 Subject: [PATCH 11/14] Edit spell config --- .vscode/settings.json | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/.vscode/settings.json b/.vscode/settings.json index dd64297..644b57e 100644 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -1,8 +1,15 @@ { "cSpell.words": [ + "chdir", + "ENOENT", "janestreet", + "mkdirs", "odoc", "opam", + "pathspec", + "rmtree", + "Stdenv", + "subdir", "worktree", "worktrees" ] From 068e329570f835c11c4f2340249115c4d1e930a7 Mon Sep 17 00:00:00 2001 From: Mathieu Barbin Date: Fri, 4 Oct 2024 18:34:56 +0200 Subject: [PATCH 12/14] Increase coverage --- test/expect/find_enclosing_repo_root.ml | 35 +++++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/test/expect/find_enclosing_repo_root.ml b/test/expect/find_enclosing_repo_root.ml index 5651820..818b93e 100644 --- a/test/expect/find_enclosing_repo_root.ml +++ b/test/expect/find_enclosing_repo_root.ml @@ -26,6 +26,16 @@ let%expect_test "find_enclosing_repo_root" = @@ fun sw -> let vcs = Vcs_git_eio.create ~env in let repo_root = Vcs_test_helpers.init_temp_repo ~env ~sw ~vcs in + (* read_dir *) + let () = + let entries = Vcs.read_dir vcs ~dir:(Vcs.Repo_root.to_absolute_path repo_root) in + print_s [%sexp (entries : Fpart.t list)]; + [%expect {| (.git) |}]; + (match Vcs.Result.read_dir vcs ~dir:(Vcs.Repo_root.to_absolute_path repo_root) with + | Error _ -> assert false + | Ok entries -> print_s [%sexp (entries : Fpart.t list)]); + [%expect {| (.git) |}] + in (* Find the root from the root itself. *) let () = match @@ -59,6 +69,7 @@ let%expect_test "find_enclosing_repo_root" = ~exists_ok:true ~perm:0o777 Eio.Path.(Eio.Stdenv.fs env / Absolute_path.to_string subdir); + (* 1. Raising [find_enclosing_repo_root]. *) (match Vcs.find_enclosing_repo_root vcs @@ -70,6 +81,30 @@ let%expect_test "find_enclosing_repo_root" = require_equal [%here] (module Fpart) store Fpart.dot_git; require_equal [%here] (module Vcs.Repo_root) repo_root repo_root2; [%expect {||}]); + (* 2. Non-raising [find_enclosing_repo_root]. *) + (match + Vcs.Result.find_enclosing_repo_root + vcs + ~from:subdir + ~store:[ Fpart.dot_git; Fpart.dot_hg ] + with + | Error _ | Ok None -> assert false + | Ok (Some (`Store store, repo_root2)) -> + require_equal [%here] (module Fpart) store Fpart.dot_git; + require_equal [%here] (module Vcs.Repo_root) repo_root repo_root2; + [%expect {||}]); + (* 3. Raising [find_enclosing_git_repo_root]. *) + (match Vcs.find_enclosing_git_repo_root vcs ~from:subdir with + | None -> assert false + | Some repo_root2 -> + require_equal [%here] (module Vcs.Repo_root) repo_root repo_root2; + [%expect {||}]); + (* 4. Non-raising [find_enclosing_git_repo_root]. *) + (match Vcs.Result.find_enclosing_git_repo_root vcs ~from:subdir with + | Error _ | Ok None -> assert false + | Ok (Some repo_root2) -> + require_equal [%here] (module Vcs.Repo_root) repo_root repo_root2; + [%expect {||}]); Eio.Path.save ~create:(`Or_truncate 0o666) Eio.Path.(Eio.Stdenv.fs env / Absolute_path.to_string stop_at / ".hg") From ef0ffec0fcf3a1b3ee0dabf54313758e34592963 Mon Sep 17 00:00:00 2001 From: Mathieu Barbin Date: Fri, 4 Oct 2024 18:41:35 +0200 Subject: [PATCH 13/14] Update PR number --- CHANGES.md | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 1a85fc9..14687b4 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,12 +2,12 @@ ### Added -- Add `Vcs.find_enclosing_repo_root` helper (#PR, @mbarbin). -- Add `Vcs.read_dir` helper (#PR, @mbarbin). +- Add `Vcs.find_enclosing_repo_root` helper (#28, @mbarbin). +- Add `Vcs.read_dir` helper (#28, @mbarbin). ### Changed -- Moved `ocaml-vcs more-tests` commands at top-level (#PR, @mbarbin). +- Moved `ocaml-vcs more-tests` commands at top-level (#28, @mbarbin). ### Deprecated @@ -15,7 +15,7 @@ ### Removed -- Removed package `vcs-arg` and inline what's needed directly in `vcs-command` (#PR, @mbarbin). +- Removed package `vcs-arg` and inline what's needed directly in `vcs-command` (#28, @mbarbin). ## 0.0.8 (2024-09-30) From 46c091e715147d5f492c1bc3d7070562a49666d0 Mon Sep 17 00:00:00 2001 From: Mathieu Barbin Date: Fri, 4 Oct 2024 18:46:40 +0200 Subject: [PATCH 14/14] Add LICENSE headers --- .../test/test__file_system.ml | 21 +++++++++++++++++++ .../test/test__file_system.mli | 20 ++++++++++++++++++ lib/vcs_git_eio/test/test__file_system.ml | 21 +++++++++++++++++++ lib/vcs_git_eio/test/test__file_system.mli | 20 ++++++++++++++++++ 4 files changed, 82 insertions(+) diff --git a/lib/vcs_git_blocking/test/test__file_system.ml b/lib/vcs_git_blocking/test/test__file_system.ml index 4c25a9f..6f46fd8 100644 --- a/lib/vcs_git_blocking/test/test__file_system.ml +++ b/lib/vcs_git_blocking/test/test__file_system.ml @@ -1,3 +1,24 @@ +(*******************************************************************************) +(* Vcs - a Versatile OCaml Library for Git Operations *) +(* Copyright (C) 2024 Mathieu Barbin *) +(* *) +(* This file is part of Vcs. *) +(* *) +(* Vcs is free software; you can redistribute it and/or modify it under *) +(* the terms of the GNU Lesser General Public License as published by the *) +(* Free Software Foundation either version 3 of the License, or any later *) +(* version, with the LGPL-3.0 Linking Exception. *) +(* *) +(* Vcs is distributed in the hope that it will be useful, but WITHOUT ANY *) +(* WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS *) +(* FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License and *) +(* the file `NOTICE.md` at the root of this repository for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* and the LGPL-3.0 Linking Exception along with this library. If not, see *) +(* and , respectively. *) +(*******************************************************************************) + let%expect_test "read_dir" = let vcs = Vcs_git_blocking.create () in let read_dir dir = print_s [%sexp (Vcs.read_dir vcs ~dir : Fpart.t list)] in diff --git a/lib/vcs_git_blocking/test/test__file_system.mli b/lib/vcs_git_blocking/test/test__file_system.mli index e69de29..45af050 100644 --- a/lib/vcs_git_blocking/test/test__file_system.mli +++ b/lib/vcs_git_blocking/test/test__file_system.mli @@ -0,0 +1,20 @@ +(*_******************************************************************************) +(*_ Vcs - a Versatile OCaml Library for Git Operations *) +(*_ Copyright (C) 2024 Mathieu Barbin *) +(*_ *) +(*_ This file is part of Vcs. *) +(*_ *) +(*_ Vcs is free software; you can redistribute it and/or modify it under *) +(*_ the terms of the GNU Lesser General Public License as published by the *) +(*_ Free Software Foundation either version 3 of the License, or any later *) +(*_ version, with the LGPL-3.0 Linking Exception. *) +(*_ *) +(*_ Vcs is distributed in the hope that it will be useful, but WITHOUT ANY *) +(*_ WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS *) +(*_ FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License and *) +(*_ the file `NOTICE.md` at the root of this repository for more details. *) +(*_ *) +(*_ You should have received a copy of the GNU Lesser General Public License *) +(*_ and the LGPL-3.0 Linking Exception along with this library. If not, see *) +(*_ and , respectively. *) +(*_******************************************************************************) diff --git a/lib/vcs_git_eio/test/test__file_system.ml b/lib/vcs_git_eio/test/test__file_system.ml index db6be62..8299c6f 100644 --- a/lib/vcs_git_eio/test/test__file_system.ml +++ b/lib/vcs_git_eio/test/test__file_system.ml @@ -1,3 +1,24 @@ +(*******************************************************************************) +(* Vcs - a Versatile OCaml Library for Git Operations *) +(* Copyright (C) 2024 Mathieu Barbin *) +(* *) +(* This file is part of Vcs. *) +(* *) +(* Vcs is free software; you can redistribute it and/or modify it under *) +(* the terms of the GNU Lesser General Public License as published by the *) +(* Free Software Foundation either version 3 of the License, or any later *) +(* version, with the LGPL-3.0 Linking Exception. *) +(* *) +(* Vcs is distributed in the hope that it will be useful, but WITHOUT ANY *) +(* WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS *) +(* FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License and *) +(* the file `NOTICE.md` at the root of this repository for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* and the LGPL-3.0 Linking Exception along with this library. If not, see *) +(* and , respectively. *) +(*******************************************************************************) + let%expect_test "read_dir" = Eio_main.run @@ fun env -> diff --git a/lib/vcs_git_eio/test/test__file_system.mli b/lib/vcs_git_eio/test/test__file_system.mli index e69de29..45af050 100644 --- a/lib/vcs_git_eio/test/test__file_system.mli +++ b/lib/vcs_git_eio/test/test__file_system.mli @@ -0,0 +1,20 @@ +(*_******************************************************************************) +(*_ Vcs - a Versatile OCaml Library for Git Operations *) +(*_ Copyright (C) 2024 Mathieu Barbin *) +(*_ *) +(*_ This file is part of Vcs. *) +(*_ *) +(*_ Vcs is free software; you can redistribute it and/or modify it under *) +(*_ the terms of the GNU Lesser General Public License as published by the *) +(*_ Free Software Foundation either version 3 of the License, or any later *) +(*_ version, with the LGPL-3.0 Linking Exception. *) +(*_ *) +(*_ Vcs is distributed in the hope that it will be useful, but WITHOUT ANY *) +(*_ WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS *) +(*_ FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License and *) +(*_ the file `NOTICE.md` at the root of this repository for more details. *) +(*_ *) +(*_ You should have received a copy of the GNU Lesser General Public License *) +(*_ and the LGPL-3.0 Linking Exception along with this library. If not, see *) +(*_ and , respectively. *) +(*_******************************************************************************)