forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
monopam quality: use ocaml-git for subtree tree hash
+39
-20
+11
-12
bin/cmd_quality.ml
+11
-12
bin/cmd_quality.ml
···
2
2
3
3
let run ~repo ~missing ~tools ~package () =
4
4
let root = match repo with Some r -> r | None -> Sys.getcwd () in
5
+
Eio_main.run @@ fun env ->
6
+
let fs = Eio.Stdenv.cwd env in
7
+
Eio.Switch.run @@ fun sw ->
8
+
let monorepo = Fpath.v root in
9
+
let repo = Git.Repository.open_repo ~sw ~fs monorepo in
5
10
match package with
6
11
| Some name ->
7
12
let pkg_dir = Filename.concat root name in
8
-
let r = Monopam.Quality.check ~tools pkg_dir name in
13
+
let r = Monopam.Quality.check ~repo ~tools pkg_dir name in
9
14
Fmt.pr "%a\n" Monopam.Quality.pp_entry r;
10
15
if r.missing <> [] then (
11
16
Fmt.pr "\nFAILED: %d required quality check(s) missing\n"
···
13
18
`Error (false, "quality policy violated"))
14
19
else `Ok ()
15
20
| None ->
16
-
let results = Monopam.Quality.check_all ~tools root in
21
+
let results = Monopam.Quality.check_all ~repo ~tools root in
17
22
(match missing with
18
23
| Some feature ->
19
24
let mrs = Monopam.Quality.query_missing feature results in
···
46
51
Arg.(value & opt (some string) None & info [ "r"; "repo" ] ~docv:"DIR" ~doc)
47
52
48
53
let tools_arg =
49
-
let doc = "Also run merlint, prune, and dupfind checks (slower)." in
54
+
let doc = "Also run merlint, prune, and dupfind checks." in
50
55
Arg.(value & flag & info [ "tools" ] ~doc)
51
56
52
57
let man =
53
58
[
54
59
`S Manpage.s_description;
55
60
`P
56
-
"Check packages against their quality policy. Each package declares \
57
-
required quality features in its dune-project via $(b,(x-quality build \
58
-
test fuzz ...)). This command checks whether the package actually has \
59
-
those features and fails if any are missing.";
60
-
`P "Without $(b,--tools), only checks directory structure.";
61
-
`P
62
-
"With $(b,--tools), also runs merlint, prune, and dupfind (uses $(b,dune \
63
-
exec -B) to reuse existing build artifacts).";
61
+
"Check packages against their quality policy. Policy is declared in \
62
+
*.opam.template via $(b,x-quality: [\"build\" \"test\" ...]). Fails if \
63
+
any declared feature is missing.";
64
64
`S Manpage.s_examples;
65
65
`Pre " monopam quality # check all against policy";
66
66
`Pre " monopam quality crdt # check one package";
67
67
`Pre " monopam quality --missing fuzz # packages without fuzz";
68
-
`Pre " monopam quality --tools crdt # include tool checks";
69
68
]
70
69
71
70
let cmd =
+24
-6
lib/quality.ml
+24
-6
lib/quality.ml
···
161
161
162
162
type result = {
163
163
package : string;
164
+
tree_hash : string; (** Subtree hash of the package directory. *)
164
165
policy : string list;
165
166
present : string list;
166
167
missing : string list; (** In policy but not present. *)
···
169
170
170
171
let tool_features = [ "merlint"; "prune"; "dupfind" ]
171
172
172
-
let check ?(tools = false) pkg_dir name =
173
+
(** Compute the subtree tree hash for a package prefix using ocaml-git. *)
174
+
let subtree_hash repo prefix =
175
+
Log.debug (fun m -> m "Looking up subtree hash for %s" prefix);
176
+
match Git.Repository.tree_hash_at_path repo ~rev:"HEAD" ~path:prefix with
177
+
| Some h ->
178
+
let hex = Git.Hash.to_hex h in
179
+
Log.debug (fun m -> m "subtree_hash %s = %s" prefix hex);
180
+
hex
181
+
| None ->
182
+
Log.debug (fun m -> m "subtree_hash %s = None" prefix);
183
+
""
184
+
185
+
let check ~repo ?(tools = false) pkg_dir name =
173
186
let policy = read_policy pkg_dir in
174
-
(* Run tools if explicitly requested OR if policy requires any tool feature *)
175
187
let need_tools =
176
188
tools || List.exists (fun f -> List.mem f policy) tool_features
177
189
in
178
190
let present = detect ~tools:need_tools pkg_dir in
179
191
let missing = List.filter (fun f -> not (List.mem f present)) policy in
180
192
let extra = List.filter (fun f -> not (List.mem f policy)) present in
181
-
{ package = name; policy; present; missing; extra }
193
+
let tree_hash = subtree_hash repo name in
194
+
{ package = name; tree_hash; policy; present; missing; extra }
182
195
183
-
let check_all ?(tools = false) root =
196
+
let check_all ~repo ?(tools = false) root =
184
197
let packages =
185
198
try
186
199
Sys.readdir root |> Array.to_list
···
195
208
List.map
196
209
(fun name ->
197
210
let pkg_dir = Filename.concat root name in
198
-
check ~tools pkg_dir name)
211
+
check ~repo ~tools pkg_dir name)
199
212
packages
200
213
201
214
(* ===== Output ===== *)
···
211
224
Fmt.pf ppf " [suggest: x-quality %s]"
212
225
(String.concat " " (r.policy @ r.extra))
213
226
214
-
let pp_entry ppf r = Fmt.pf ppf "%-30s%a" r.package pp_result r
227
+
let pp_entry ppf r =
228
+
let short_hash =
229
+
if String.length r.tree_hash >= 8 then String.sub r.tree_hash 0 8
230
+
else r.tree_hash
231
+
in
232
+
Fmt.pf ppf "%-30s %s%a" r.package short_hash pp_result r
215
233
216
234
let pp_summary ppf results =
217
235
let total = List.length results in
+4
-2
lib/quality.mli
+4
-2
lib/quality.mli
···
23
23
24
24
type result = {
25
25
package : string;
26
+
tree_hash : string;
26
27
policy : string list;
27
28
present : string list;
28
29
missing : string list;
29
30
extra : string list;
30
31
}
31
32
32
-
val check : ?tools:bool -> string -> string -> result
33
-
val check_all : ?tools:bool -> string -> result list
33
+
val subtree_hash : Git.Repository.t -> string -> string
34
+
val check : repo:Git.Repository.t -> ?tools:bool -> string -> string -> result
35
+
val check_all : repo:Git.Repository.t -> ?tools:bool -> string -> result list
34
36
val pp_entry : result Fmt.t
35
37
val pp_summary : result list Fmt.t
36
38
val has_failures : result list -> bool