mbarbin / vcs / 26

Committed 14 Jul 2024 02:17PM UTC coverage: 99.876% (-0.1%) from 100.0%

Build # 26

Build Type

Pull #3

github

Committed by

mbarbin

Commit Message

Improve test

Pull Request Pull Request #3: Rework rev parse

Run Details

81 of 82 new or added lines in 6 files covered. (98.78%)

1 existing line in 1 file now uncovered.

1615 of 1617 relevant lines covered (99.88%)

26.42 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

98.53

/lib/vcs_param/src/vcs_param.ml

(*******************************************************************************)
(*  Vcs - a versatile OCaml library for Git interaction                        *)
(*  Copyright (C) 2024 Mathieu Barbin <mathieu.barbin@gmail.com>               *)
(*                                                                             *)
(*  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    *)
(*  <http://www.gnu.org/licenses/> and <https://spdx.org>, 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 param =
    let%map_open.Command () = return () in
    let t = { unit = () } in
    silence_w69_unused_field t;
    t
  ;;
end

let config = Config.param

module Create_vcs_backend = struct
  let repo_root (dir : _ Eio.Path.t) =
    dir
    |> snd
    |> Absolute_path.of_string
    |> Or_error.ok_exn
    |> 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.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.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%bind vcs, repo_root =
      match Create_vcs_backend.from_cwd ~env ~cwd ~config with
      | Some x -> Ok x
      | None -> Or_error.error_string "Not in a supported version control repo"
    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;
    return t
  ;;
end

module Initialized = struct
  type t =
    { vcs : Vcs_git.t'
    ; repo_root : Vcs.Repo_root.t
    ; context : Context.t
    }
end

let initialize ~env ~config =
  let%bind c = Context.create ~env ~config () in
  return { Initialized.vcs = c.vcs; repo_root = c.repo_root; context = c }
;;

type 'a t = Context.t -> 'a Or_error.t

let resolve t ~context = t context

let anon_branch_name =
  let%map_open.Command branch_name = anon ("branch" %: string) in
  Vcs.Branch_name.of_string branch_name
;;

let anon_branch_name_opt =
  let%map_open.Command branch_name = anon (maybe ("branch" %: string)) in
  branch_name |> Option.map ~f:Vcs.Branch_name.of_string
;;

let anon_path =
  let%map_open.Command path = anon ("file" %: string) in
  fun (c : Context.t) ->
    Or_error.try_with (fun () -> Absolute_path.relativize ~root:c.cwd (path |> Fpath.v))
;;

let anon_path_in_repo =
  let%map_open.Command path = anon ("file" %: string) in
  fun (c : Context.t) ->
    let repo_root = Vcs.Repo_root.to_absolute_path c.repo_root in
    Or_error.try_with_join (fun () ->
      let path = Absolute_path.relativize ~root:c.cwd (path |> Fpath.v) in
      let%bind relative_path = Absolute_path.chop_prefix ~prefix:repo_root path in
      return (Vcs.Path_in_repo.of_relative_path relative_path))
;;

let anon_rev =
  let%map_open.Command rev = anon ("rev" %: string) in
  Vcs.Rev.of_string rev
;;

let below_path_in_repo =
  let%map_open.Command path =
    flag "--below" (optional string) ~doc:"PATH only below path"
  in
  fun (c : Context.t) ->
    let repo_root = Vcs.Repo_root.to_absolute_path c.repo_root in
    Or_error.try_with_join (fun () ->
      match path with
      | None -> return None
      | Some path ->
        let path = Absolute_path.relativize ~root:c.cwd (path |> Fpath.v) in
        let%bind relative_path = Absolute_path.chop_prefix ~prefix:repo_root path in
        return (Some (Vcs.Path_in_repo.of_relative_path relative_path)))
;;

let commit_message =
  let%map_open.Command commit_message =
    flag "--message" ~aliases:[ "-m" ] (required string) ~doc:"MSG commit message"
  in
  Vcs.Commit_message.of_string commit_message
;;

let quiet =
  let%map_open.Command quiet =
    flag "--quiet" ~aliases:[ "-q" ] no_arg ~doc:" suppress output on success"
  in
  quiet
;;

let rev =
  let%map_open.Command rev =
    flag "--rev" ~aliases:[ "-r" ] (required string) ~doc:"REV revision"
  in
  Vcs.Rev.of_string rev
;;

let user_name =
  let%map_open.Command user_name =
    flag "--user.name" (required string) ~doc:"USER user name"
  in
  Vcs.User_name.of_string user_name
;;

let user_email =
  let%map_open.Command user_email =
    flag "--user.email" (required string) ~doc:"EMAIL user email"
  in
  Vcs.User_email.of_string user_email
;;

1	(*******************************************************************************)
2	(* Vcs - a versatile OCaml library for Git interaction *)
3	(* Copyright (C) 2024 Mathieu Barbin <mathieu.barbin@gmail.com> *)
4	(* *)
5	(* This file is part of Vcs. *)
6	(* *)
7	(* Vcs is free software; you can redistribute it and/or modify it under *)
8	(* the terms of the GNU Lesser General Public License as published by the *)
9	(* Free Software Foundation either version 3 of the License, or any later *)
10	(* version, with the LGPL-3.0 Linking Exception. *)
11	(* *)
12	(* Vcs is distributed in the hope that it will be useful, but WITHOUT ANY *)
13	(* WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS *)
14	(* FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License and *)
15	(* the file `NOTICE.md` at the root of this repository for more details. *)
16	(* *)
17	(* You should have received a copy of the GNU Lesser General Public License *)
18	(* and the LGPL-3.0 Linking Exception along with this library. If not, see *)
19	(* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively. *)
20	(*******************************************************************************)
21
22	module Config = struct
23	(* This is boilerplate code to be used when we'll have things to select, such
24	as several backends, or backend modifiers. *)
25	type t = { unit : unit }
26
27	let silence_w69_unused_field t =
28	ignore (t.unit : unit);	26✔
29	()
30	;;
31
32	let default = { unit = () }
33
34	let param =
35	let%map_open.Command () = return () in	30✔
36	let t = { unit = () } in	26✔
37	silence_w69_unused_field t;
38	t	26✔
39	;;
40	end
41
42	let config = Config.param
43
44	module Create_vcs_backend = struct
45	let repo_root (dir : _ Eio.Path.t) =
46	dir	26✔
47	\|> snd
48	\|> Absolute_path.of_string	26✔
49	\|> Or_error.ok_exn	26✔
50	\|> Vcs.Repo_root.of_absolute_path	26✔
51	;;
52
53	let from_cwd ~env ~cwd ~config:_ =
54	let fs = Eio.Stdenv.fs env in	27✔
55	match	27✔
56	With_return.with_return_option (fun { return } ->
57	let rec visit dir =	27✔
58	List.iter (Eio.Path.read_dir dir) ~f:(fun entry ->	31✔
59	match entry with	56✔
60	\| ".git" ->	26✔
61	(* We don't check whether [".git"] is a directory, because this
62	breaks for git worktrees. Indeed, the file [".git"] at the root
63	of a repository created with [git worktree add] is a regular
64	file. *)
65	return (`Git, dir)
66	\| _ -> ());	30✔
67	match Eio.Path.split dir with	5✔
68	\| None -> ()	1✔
69	\| Some (parent_dir, _) -> visit parent_dir	4✔
70	in
71	visit Eio.Path.(fs / (cwd \|> Absolute_path.to_string)))	27✔
72	with
73	\| None -> None	1✔
74	\| Some ((`Git as vcs), dir) ->	26✔
75	let vcs =
76	match vcs with
77	\| `Git -> Vcs_git.create ~env	26✔
78	in
79	let repo_root = repo_root dir in
80	Some (vcs, repo_root)	26✔
81	;;
82	end
83
84	module Context = struct
85	type t =
86	{ config : Config.t
87	; fs : Eio.Fs.dir_ty Eio.Path.t
88	; cwd : Absolute_path.t
89	; vcs : Vcs_git.t'
90	; repo_root : Vcs.Repo_root.t
91	}
92
93	let silence_w69_unused_field t =
94	ignore (t.config : Config.t);	26✔
95	ignore (t.fs : Eio.Fs.dir_ty Eio.Path.t);
96	()
97	;;
98
99	let create ?cwd ~env ~config () =
100	let cwd =	27✔
101	match cwd with
102	\| Some cwd -> cwd	1✔
103	\| None -> Unix.getcwd () \|> Absolute_path.v	26✔
104	in
105	let%bind vcs, repo_root =
106	match Create_vcs_backend.from_cwd ~env ~cwd ~config with
107	\| Some x -> Ok x	26✔
108	\| None -> Or_error.error_string "Not in a supported version control repo"	1✔
109	in
110	let t =	26✔
111	{ config
112	; fs = (Eio.Stdenv.fs env :> Eio.Fs.dir_ty Eio.Path.t)	26✔
113	; cwd
114	; vcs
115	; repo_root
116	}
117	in
118	silence_w69_unused_field t;
119	return t	26✔
120	;;
121	end
122
123	module Initialized = struct
124	type t =
125	{ vcs : Vcs_git.t'
126	; repo_root : Vcs.Repo_root.t
127	; context : Context.t
128	}
129	end
130
131	let initialize ~env ~config =
132	let%bind c = Context.create ~env ~config () in	26✔
133	return { Initialized.vcs = c.vcs; repo_root = c.repo_root; context = c }	26✔
134	;;
135
136	type 'a t = Context.t -> 'a Or_error.t
137
138	let resolve t ~context = t context	11✔
139
140	let anon_branch_name =
141	let%map_open.Command branch_name = anon ("branch" %: string) in	30✔
142	Vcs.Branch_name.of_string branch_name	1✔
143	;;
144
145	let anon_branch_name_opt =
146	let%map_open.Command branch_name = anon (maybe ("branch" %: string)) in	30✔
UNCOV 147	branch_name \|> Option.map ~f:Vcs.Branch_name.of_string	×
148	;;
149
150	let anon_path =
151	let%map_open.Command path = anon ("file" %: string) in	30✔
152	fun (c : Context.t) ->
153	Or_error.try_with (fun () -> Absolute_path.relativize ~root:c.cwd (path \|> Fpath.v))	3✔
154	;;
155
156	let anon_path_in_repo =
157	let%map_open.Command path = anon ("file" %: string) in	30✔
158	fun (c : Context.t) ->
159	let repo_root = Vcs.Repo_root.to_absolute_path c.repo_root in	4✔
160	Or_error.try_with_join (fun () ->	4✔
161	let path = Absolute_path.relativize ~root:c.cwd (path \|> Fpath.v) in	4✔
162	let%bind relative_path = Absolute_path.chop_prefix ~prefix:repo_root path in	4✔
163	return (Vcs.Path_in_repo.of_relative_path relative_path))	4✔
164	;;
165
166	let anon_rev =
167	let%map_open.Command rev = anon ("rev" %: string) in	30✔
168	Vcs.Rev.of_string rev	4✔
169	;;
170
171	let below_path_in_repo =
172	let%map_open.Command path =
173	flag "--below" (optional string) ~doc:"PATH only below path"	30✔
174	in
175	fun (c : Context.t) ->
176	let repo_root = Vcs.Repo_root.to_absolute_path c.repo_root in	4✔
177	Or_error.try_with_join (fun () ->	4✔
178	match path with	4✔
179	\| None -> return None	3✔
180	\| Some path ->	1✔
181	let path = Absolute_path.relativize ~root:c.cwd (path \|> Fpath.v) in	1✔
182	let%bind relative_path = Absolute_path.chop_prefix ~prefix:repo_root path in	1✔
183	return (Some (Vcs.Path_in_repo.of_relative_path relative_path)))	1✔
184	;;
185
186	let commit_message =
187	let%map_open.Command commit_message =
188	flag "--message" ~aliases:[ "-m" ] (required string) ~doc:"MSG commit message"	30✔
189	in
190	Vcs.Commit_message.of_string commit_message	2✔
191	;;
192
193	let quiet =
194	let%map_open.Command quiet =
195	flag "--quiet" ~aliases:[ "-q" ] no_arg ~doc:" suppress output on success"	30✔
196	in
197	quiet	3✔
198	;;
199
200	let rev =
201	let%map_open.Command rev =
202	flag "--rev" ~aliases:[ "-r" ] (required string) ~doc:"REV revision"	30✔
203	in
204	Vcs.Rev.of_string rev	2✔
205	;;
206
207	let user_name =
208	let%map_open.Command user_name =
209	flag "--user.name" (required string) ~doc:"USER user name"	30✔
210	in
211	Vcs.User_name.of_string user_name	1✔
212	;;
213
214	let user_email =
215	let%map_open.Command user_email =
216	flag "--user.email" (required string) ~doc:"EMAIL user email"	30✔
217	in
218	Vcs.User_email.of_string user_email	1✔
219	;;

mbarbin / vcs / 26

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous