Installs pre-commit hooks for OCaml projects that run dune fmt automatically
1(** CLI for pre-commit hook initialisation. *)
2
3open Cmdliner
4
5let setup =
6 Term.(
7 const (fun () () -> ())
8 $ Vlog.setup ~json_reporter:None "precommit"
9 $ Memtrace.term)
10
11(* {1 Styled output} *)
12
13let success fmt =
14 Fmt.pf Fmt.stdout ("%a " ^^ fmt ^^ "@.") Fmt.(styled (`Fg `Green) string) "✓"
15
16let error fmt =
17 Fmt.pf Fmt.stderr ("%a " ^^ fmt ^^ "@.") Fmt.(styled (`Fg `Red) string) "✗"
18
19let info fmt =
20 Fmt.pf Fmt.stdout ("%a " ^^ fmt ^^ "@.") Fmt.(styled (`Fg `Cyan) string) "ℹ"
21
22(* {1 Common arguments} *)
23
24let chdir =
25 let doc = "Change to $(docv) before running. Equivalent to cd $(docv)." in
26 Arg.(value & opt (some dir) None & info [ "C" ] ~docv:"DIR" ~doc)
27
28let dirs =
29 let doc =
30 "Root directories to scan for git projects. Defaults to the current \
31 directory. Each directory is scanned recursively for repositories \
32 containing a $(b,.git) entry."
33 in
34 Arg.(value & pos_all dir [ "." ] & info [] ~docv:"DIR" ~doc)
35
36let dry_run =
37 let doc = "Show what would be done without making changes." in
38 Arg.(value & flag & info [ "n"; "dry-run" ] ~doc)
39
40let force =
41 let doc = "Install hooks even if no dune-project is found." in
42 Arg.(value & flag & info [ "f"; "force" ] ~doc)
43
44let hooks_conv =
45 let parse s =
46 let parts = String.split_on_char ',' s in
47 let fmt = List.mem "fmt" parts in
48 let ai = List.mem "ai" parts in
49 if fmt || ai then Ok Precommit.{ fmt; ai }
50 else Error (`Msg "expected comma-separated list of: fmt, ai")
51 in
52 let print ppf h =
53 let parts =
54 (if h.Precommit.fmt then [ "fmt" ] else [])
55 @ if h.Precommit.ai then [ "ai" ] else []
56 in
57 Fmt.string ppf (String.concat "," parts)
58 in
59 Arg.conv (parse, print)
60
61let hooks =
62 let doc =
63 "Which hooks to install. Comma-separated list of: $(b,fmt) (pre-commit \
64 hook running dune fmt), $(b,ai) (commit-msg hook removing Claude \
65 attribution). Default: all."
66 in
67 Arg.(
68 value
69 & opt hooks_conv Precommit.all_hooks
70 & info [ "hooks" ] ~doc ~docv:"HOOKS")
71
72(* {1 Helpers} *)
73
74let or_die = function
75 | Ok () -> ()
76 | Error msg ->
77 error "%s" msg;
78 exit 1
79
80let collect_dirs ctx dirs =
81 let result = List.concat_map (fun d -> Precommit.git_projects ctx d) dirs in
82 if result = [] then begin
83 error "No git repositories found";
84 exit 1
85 end;
86 result
87
88let with_ctx chdir f =
89 Eio_main.run @@ fun env ->
90 let fs = Eio.Stdenv.fs env in
91 let cwd =
92 match chdir with None -> Eio.Stdenv.cwd env | Some d -> Eio.Path.(fs / d)
93 in
94 f (Precommit.ctx ~cwd ~fs)
95
96(* {1 Init command} *)
97
98let init_impl ctx ~dry_run ~force hooks dirs =
99 let dirs = collect_dirs ctx dirs in
100 let count = ref 0 in
101 let skipped_not_ocaml = ref 0 in
102 let already_configured = ref 0 in
103 List.iter
104 (fun d ->
105 let s = Precommit.status_in_dir ctx d in
106 if not s.is_git_repo then ()
107 else if not (force || s.is_ocaml_project) then incr skipped_not_ocaml
108 else
109 let needs_fmt = hooks.Precommit.fmt && not s.has_pre_commit in
110 let needs_ai = hooks.Precommit.ai && not s.has_commit_msg in
111 if needs_fmt || needs_ai then begin
112 or_die (Precommit.init_in_dir ctx ~dry_run ~force ~hooks d);
113 incr count;
114 if dry_run then info "Would initialise %a" Fmt.(styled `Bold string) d
115 else success "Initialised %a" Fmt.(styled `Bold string) d
116 end
117 else incr already_configured)
118 dirs;
119 if !count > 0 then
120 success "Processed %d director%s" !count (if !count = 1 then "y" else "ies")
121 else if !already_configured > 0 then
122 info "All directories already have hooks installed"
123 else if !skipped_not_ocaml > 0 then begin
124 info "No OCaml projects found (use --force to install anyway)";
125 exit 1
126 end
127
128let init_cmd =
129 let doc = "Initialise pre-commit hooks for OCaml projects." in
130 let man =
131 [
132 `S Manpage.s_description;
133 `P
134 "Install git hooks that run $(b,dune fmt) before commit and remove \
135 Claude attribution from commit messages. Also creates \
136 $(b,.ocamlformat) if missing (unless $(b,--force) is used).";
137 `S Manpage.s_examples;
138 `P "Initialise hooks in the current directory:";
139 `Pre " precommit init";
140 `P "Initialise hooks in all projects under src/:";
141 `Pre " precommit init src/";
142 `P "Preview what would be done:";
143 `Pre " precommit init -n";
144 `P "Install only the AI attribution hook in a non-OCaml project:";
145 `Pre " precommit init -f --hooks ai";
146 `P "Install only the dune fmt hook:";
147 `Pre " precommit init --hooks fmt";
148 ]
149 in
150 let info = Cmd.info "init" ~doc ~man in
151 Cmd.v info
152 Term.(
153 const (fun chdir dry_run force hooks dirs () ->
154 with_ctx chdir (fun ctx -> init_impl ctx ~dry_run ~force hooks dirs))
155 $ chdir $ dry_run $ force $ hooks $ dirs $ setup)
156
157(* {1 Status command} *)
158
159let check_span b =
160 if b then Tty.Span.styled Tty.Style.(fg Tty.Color.green) "+"
161 else Tty.Span.styled Tty.Style.(fg Tty.Color.red) "-"
162
163let status_impl ctx dirs =
164 let dirs = collect_dirs ctx dirs in
165 let missing = ref 0 in
166 let ok = ref 0 in
167 let rows =
168 List.map
169 (fun d ->
170 let s = Precommit.status_in_dir ctx d in
171 if s.is_ocaml_project && s.is_git_repo then
172 begin if
173 not (s.has_pre_commit && s.has_commit_msg && s.has_ocamlformat)
174 then incr missing
175 else if s.formatting_disabled then incr missing
176 else incr ok
177 end;
178 [
179 Tty.Span.text d;
180 check_span s.has_pre_commit;
181 check_span s.has_commit_msg;
182 check_span s.has_ocamlformat;
183 check_span (not s.formatting_disabled);
184 ])
185 dirs
186 in
187 let table =
188 Tty.Table.(
189 of_rows ~border:Tty.Border.rounded
190 [
191 column "directory";
192 column ~align:`Center "pre-commit";
193 column ~align:`Center "commit-msg";
194 column ~align:`Center "ocamlformat";
195 column ~align:`Center "formatting";
196 ]
197 rows)
198 in
199 Tty.Table.pp Format.std_formatter table;
200 Format.pp_print_newline Format.std_formatter ();
201 (* Summary *)
202 if !missing > 0 then begin
203 Fmt.pf Fmt.stdout "%a %d project%s with missing hooks@."
204 Fmt.(styled (`Fg `Red) string)
205 "✗" !missing
206 (if !missing = 1 then "" else "s");
207 exit 1
208 end
209 else if !ok > 0 then
210 success "%d project%s properly configured" !ok (if !ok = 1 then "" else "s")
211
212let status chdir dirs () = with_ctx chdir (fun ctx -> status_impl ctx dirs)
213
214let status_cmd =
215 let doc = "Check pre-commit hook status." in
216 let man =
217 [
218 `S Manpage.s_description;
219 `P "Show which directories have hooks installed.";
220 `P
221 "Columns show: pre-commit hook, commit-msg hook, .ocamlformat file, \
222 formatting enabled. Exit code is 1 if any OCaml project is missing \
223 hooks, .ocamlformat, or has formatting disabled.";
224 `S Manpage.s_examples;
225 `P "Check status of all projects under src/:";
226 `Pre " precommit status src/";
227 ]
228 in
229 let info = Cmd.info "status" ~doc ~man in
230 Cmd.v info Term.(const status $ chdir $ dirs $ setup)
231
232(* {1 Check command} *)
233
234let terminal_width () =
235 try
236 let ic = Unix.open_process_in "tput cols 2>/dev/null" in
237 let width = int_of_string (String.trim (input_line ic)) in
238 ignore (Unix.close_process_in ic);
239 width
240 with Failure _ | End_of_file | Unix.Unix_error _ -> 80
241
242let truncate_subject max_len s =
243 if String.length s <= max_len then s else String.sub s 0 (max_len - 1) ^ "…"
244
245(* Shared: find AI commits across dirs and display a unified table.
246 Returns [(affected_dirs, total_commits, repos_with_issues)]. *)
247let commit_row subject_max d first (c : Precommit.ai_commit) =
248 let project_cell =
249 if !first then begin
250 first := false;
251 Tty.Span.styled Tty.Style.bold d
252 end
253 else Tty.Span.text ""
254 in
255 [
256 project_cell;
257 Tty.Span.styled Tty.Style.(fg Tty.Color.yellow) c.hash;
258 Tty.Span.text (truncate_subject subject_max c.subject);
259 ]
260
261let display_ai_commits ctx dirs =
262 let term_width = terminal_width () in
263 let subject_max = max 20 (term_width - 35) in
264 let total_commits = ref 0 in
265 let repos_with_issues = ref 0 in
266 let all_rows = ref [] in
267 let affected_dirs = ref [] in
268 List.iter
269 (fun d ->
270 let commits = Precommit.check_ai_attribution ctx d in
271 if commits <> [] then begin
272 incr repos_with_issues;
273 total_commits := !total_commits + List.length commits;
274 affected_dirs := d :: !affected_dirs;
275 let first = ref true in
276 let rows = List.map (commit_row subject_max d first) commits in
277 all_rows := !all_rows @ rows
278 end)
279 dirs;
280 if !all_rows <> [] then begin
281 let table =
282 Tty.Table.(
283 of_rows ~border:Tty.Border.rounded
284 [
285 column ~align:`Left "project";
286 column ~align:`Left "hash";
287 column ~align:`Left "subject";
288 ]
289 !all_rows)
290 in
291 Tty.Table.pp Format.std_formatter table;
292 Format.pp_print_newline Format.std_formatter ()
293 end;
294 (List.rev !affected_dirs, !total_commits, !repos_with_issues)
295
296let check_impl ctx dirs =
297 let dirs = collect_dirs ctx dirs in
298 let _affected, total_commits, repos_with_issues =
299 display_ai_commits ctx dirs
300 in
301 if total_commits > 0 then begin
302 error "%d commit%s with AI attribution in %d repo%s" total_commits
303 (if total_commits = 1 then "" else "s")
304 repos_with_issues
305 (if repos_with_issues = 1 then "" else "s");
306 exit 1
307 end
308 else success "No AI attribution found in commit history"
309
310let check chdir dirs () = with_ctx chdir (fun ctx -> check_impl ctx dirs)
311
312let check_cmd =
313 let doc = "Check git history for commits with AI attribution." in
314 let man =
315 [
316 `S Manpage.s_description;
317 `P
318 "Scan git history for commits by the configured user that contain \
319 'claude' in the commit message. Exit code is 1 if any are found.";
320 `S Manpage.s_examples;
321 `P "Check all projects under src/:";
322 `Pre " precommit check src/";
323 `P "Check a specific directory:";
324 `Pre " precommit check -C ../src/ocaml-requests";
325 ]
326 in
327 let info = Cmd.info "check" ~doc ~man in
328 Cmd.v info Term.(const check $ chdir $ dirs $ setup)
329
330(* {1 Fix command} *)
331
332let confirm_prompt n_repos =
333 let warning =
334 Tty.Panel.lines
335 ~border:
336 (Tty.Border.with_style
337 Tty.Style.(fg Tty.Color.yellow)
338 Tty.Border.rounded)
339 ~title:(Tty.Span.styled Tty.Style.(fg Tty.Color.yellow) "Warning")
340 [
341 Tty.Span.text
342 (Fmt.str "This will rewrite git history in %d repositor%s." n_repos
343 (if n_repos = 1 then "y" else "ies"));
344 Tty.Span.text "Branches will be backed up before rewriting.";
345 ]
346 in
347 Tty.Panel.pp Format.std_formatter warning;
348 Format.pp_print_newline Format.std_formatter ();
349 Fmt.pf Fmt.stdout "Continue? [y/N] %!";
350 let line = try input_line stdin with End_of_file -> "" in
351 let answer = String.trim line in
352 answer = "y" || answer = "Y"
353
354let plural n = if n = 1 then "" else "s"
355
356let run_fixes ctx affected =
357 let fixed = Atomic.make 0 in
358 let errors = Atomic.make 0 in
359 Eio.Fiber.all
360 (List.map
361 (fun d () ->
362 let backup = Precommit.backup_branch ctx d in
363 success "%s: backed up to %s" d backup;
364 match Precommit.rewrite_ai_attribution ctx d with
365 | Ok _ ->
366 Atomic.incr fixed;
367 success "%s: attribution removed" d
368 | Error msg ->
369 Atomic.incr errors;
370 error "%s" msg)
371 affected);
372 (Atomic.get fixed, Atomic.get errors)
373
374let fix_impl ctx ~dry_run ~yes dirs =
375 let dirs = collect_dirs ctx dirs in
376 let affected, total_commits, repos_with_issues =
377 display_ai_commits ctx dirs
378 in
379 if total_commits = 0 then success "No AI attribution found in commit history"
380 else if dry_run then begin
381 info "Would rewrite %d commit%s in %d repo%s" total_commits
382 (plural total_commits) repos_with_issues (plural repos_with_issues);
383 List.iter
384 (fun d ->
385 let branch = Precommit.current_branch ctx d in
386 let name = Option.value ~default:"HEAD" branch in
387 info "Would backup %s:%s before rewriting" d name)
388 affected
389 end
390 else begin
391 if not yes then
392 if not (confirm_prompt repos_with_issues) then begin
393 info "Aborted";
394 exit 0
395 end;
396 Format.pp_print_newline Format.std_formatter ();
397 let n_fixed, n_errors = run_fixes ctx affected in
398 if n_errors > 0 then begin
399 error "%d repo%s fixed, %d error%s" n_fixed (plural n_fixed) n_errors
400 (plural n_errors);
401 exit 1
402 end
403 else success "%d repo%s fixed" n_fixed (plural n_fixed)
404 end
405
406let yes =
407 let doc = "Skip interactive confirmation prompt." in
408 Arg.(value & flag & info [ "y"; "yes" ] ~doc)
409
410let fix_cmd =
411 let doc = "Remove AI attribution from commit history." in
412 let man =
413 [
414 `S Manpage.s_description;
415 `P
416 "Scan git history for commits with AI attribution (Co-Authored-By: \
417 Claude) and rewrite them to remove the attribution lines. This \
418 rewrites git history using $(b,git filter-branch).";
419 `P
420 "Before rewriting, the current branch is backed up to \
421 $(b,backup/<branch>-before-fix-<timestamp>). Use $(b,--yes) to skip \
422 the interactive confirmation prompt.";
423 `S Manpage.s_examples;
424 `P "Fix all projects under the current directory:";
425 `Pre " precommit fix";
426 `P "Preview what would be done:";
427 `Pre " precommit fix -n";
428 `P "Fix without confirmation prompt:";
429 `Pre " precommit fix -y";
430 ]
431 in
432 let info = Cmd.info "fix" ~doc ~man in
433 Cmd.v info
434 Term.(
435 const (fun chdir dry_run yes dirs () ->
436 with_ctx chdir (fun ctx -> fix_impl ctx ~dry_run ~yes dirs))
437 $ chdir $ dry_run $ yes $ dirs $ setup)
438
439(* {1 Main} *)
440
441let cmd =
442 let doc = "Manage pre-commit hooks for OCaml projects." in
443 let man =
444 [
445 `S Manpage.s_description;
446 `P
447 "$(tname) installs git hooks that enforce code formatting and commit \
448 message hygiene for OCaml projects.";
449 `S "ENVIRONMENT";
450 `P
451 "$(b,PRECOMMIT_LOG) can be set to configure logging levels (e.g., \
452 $(b,debug) or $(b,info)).";
453 `S Manpage.s_bugs;
454 `P "Report issues at https://github.com/gazagnaire.org/ocaml-precommit";
455 `S "EXIT STATUS";
456 `P "$(b,0) on success.";
457 `P "$(b,1) if hooks are missing (status) or initialisation failed.";
458 ]
459 in
460 let info = Cmd.info "precommit" ~version:Monopam_info.version ~doc ~man in
461 let default = setup in
462 Cmd.group info ~default [ init_cmd; status_cmd; check_cmd; fix_cmd ]
463
464let () = exit (Cmd.eval cmd)