forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
Refactor long functions in monopam
Extract helpers to reduce function length:
- doctor.ml: analyze_with_claude, parse_claude_response
- fork_join.ml: plan_fork, plan_join, execute_action
- cmd_status.ml: cmd
- cmd_verse.ml: fork_cmd
Reduces [E005] Long Functions from 48 to 43 issues.
+769
-881
+106
-116
bin/cmd_status.ml
+106
-116
bin/cmd_status.ml
···
1
1
open Cmdliner
2
2
3
+
let man =
4
+
[
5
+
`S Manpage.s_description;
6
+
`P
7
+
"Displays package status showing both local sync state (monorepo vs \
8
+
checkout) and remote sync state (checkout vs upstream).";
9
+
`S "STATUS COLUMNS";
10
+
`P "Each repository shows two sync indicators:";
11
+
`I ("local:", "Sync between your monorepo (mono/) and checkout (src/)");
12
+
`I ("remote:", "Sync between your checkout (src/) and upstream git remote");
13
+
`S "LOCAL SYNC INDICATORS";
14
+
`I ("local:=", "Monorepo and checkout are in sync");
15
+
`I
16
+
( "local:+N",
17
+
"Monorepo has N commits not yet in checkout (run $(b,monopam sync))" );
18
+
`I
19
+
( "local:-N",
20
+
"Checkout has N commits not yet in monorepo (run $(b,monopam sync))" );
21
+
`I ("local:sync", "Trees differ, needs sync (run $(b,monopam sync))");
22
+
`S "REMOTE SYNC INDICATORS";
23
+
`I ("remote:=", "Checkout and upstream remote are in sync");
24
+
`I
25
+
( "remote:+N",
26
+
"Checkout has N commits to push (run $(b,monopam sync --remote))" );
27
+
`I ("remote:-N", "Upstream has N commits to pull (run $(b,monopam sync))");
28
+
`I ("remote:+N/-M", "Diverged: checkout +N ahead, upstream +M ahead");
29
+
`S "FORK ANALYSIS";
30
+
`P "If tracking other members via verse, shows fork comparison:";
31
+
`I ("+N", "They have N commits you don't have");
32
+
`I ("-N", "You have N commits they don't have");
33
+
`I ("=", "Same commit or same URL");
34
+
`I ("~", "Not in your workspace (use --all to list)");
35
+
`S "NEXT STEPS";
36
+
`P "Based on the status output:";
37
+
`I ("local:+N or local:-N", "Run $(b,monopam sync) to synchronize");
38
+
`I ("remote:-N", "Run $(b,monopam sync) to pull upstream changes");
39
+
`I ("remote:+N", "Run $(b,monopam sync --remote) to push to upstream");
40
+
]
41
+
42
+
let abbrev_handle h =
43
+
match String.split_on_char '.' h with
44
+
| first :: _ ->
45
+
if String.length first <= 4 then first else String.sub first 0 3
46
+
| [] -> h
47
+
48
+
let load_sources ~fs ~config =
49
+
let sources_path =
50
+
Fpath.(Monopam.Config.Paths.monorepo config / "sources.toml")
51
+
in
52
+
match Monopam.Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with
53
+
| Ok s -> Some s
54
+
| Error _ -> None
55
+
56
+
let print_unregistered ~fs ~config pkgs =
57
+
let unregistered = Monopam.unregistered_opam_files ~fs ~config pkgs in
58
+
if unregistered <> [] then begin
59
+
let handle_abbrev =
60
+
match Monopam.Verse_config.load ~fs () with
61
+
| Ok vc -> abbrev_handle (Monopam.Verse_config.handle vc)
62
+
| Error _ -> "local"
63
+
in
64
+
Fmt.pr "%a %a\n"
65
+
Fmt.(styled `Bold string)
66
+
"Unregistered:"
67
+
Fmt.(styled `Faint int)
68
+
(List.length unregistered);
69
+
List.iter
70
+
(fun (_r, p) ->
71
+
Fmt.pr " %-22s %a\n" p
72
+
Fmt.(styled `Faint (fun ppf s -> pf ppf "%s~" s))
73
+
handle_abbrev)
74
+
unregistered
75
+
end
76
+
77
+
let print_forks ~proc ~fs ~config ~show_all =
78
+
match Monopam.Verse_config.load ~fs () with
79
+
| Error _ -> ()
80
+
| Ok verse_config ->
81
+
let forks =
82
+
Monopam.Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ()
83
+
in
84
+
if forks.repos <> [] then
85
+
Fmt.pr "%a" (Monopam.Forks.pp_summary' ~show_all) forks
86
+
87
+
let run show_all show_forks () =
88
+
Eio_main.run @@ fun env ->
89
+
Common.with_config env @@ fun config ->
90
+
let fs = Eio.Stdenv.fs env in
91
+
let proc = Eio.Stdenv.process_mgr env in
92
+
match Monopam.status ~proc ~fs ~config () with
93
+
| Ok statuses ->
94
+
let sources = load_sources ~fs ~config in
95
+
let pp =
96
+
if Tty.is_tty () then Monopam.Status.pp_table
97
+
else Monopam.Status.pp_summary
98
+
in
99
+
Fmt.pr "%a" (pp ?sources) statuses;
100
+
(match Monopam.discover_packages ~fs ~config () with
101
+
| Ok pkgs -> print_unregistered ~fs ~config pkgs
102
+
| Error _ -> ());
103
+
if show_forks then print_forks ~proc ~fs ~config ~show_all;
104
+
`Ok ()
105
+
| Error e ->
106
+
Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e;
107
+
`Error (false, "status failed")
108
+
3
109
let cmd =
4
110
let doc = "Show synchronization status of all packages" in
5
-
let man =
6
-
[
7
-
`S Manpage.s_description;
8
-
`P
9
-
"Displays package status showing both local sync state (monorepo vs \
10
-
checkout) and remote sync state (checkout vs upstream).";
11
-
`S "STATUS COLUMNS";
12
-
`P "Each repository shows two sync indicators:";
13
-
`I ("local:", "Sync between your monorepo (mono/) and checkout (src/)");
14
-
`I ("remote:", "Sync between your checkout (src/) and upstream git remote");
15
-
`S "LOCAL SYNC INDICATORS";
16
-
`I ("local:=", "Monorepo and checkout are in sync");
17
-
`I
18
-
( "local:+N",
19
-
"Monorepo has N commits not yet in checkout (run $(b,monopam sync))"
20
-
);
21
-
`I
22
-
( "local:-N",
23
-
"Checkout has N commits not yet in monorepo (run $(b,monopam sync))"
24
-
);
25
-
`I ("local:sync", "Trees differ, needs sync (run $(b,monopam sync))");
26
-
`S "REMOTE SYNC INDICATORS";
27
-
`I ("remote:=", "Checkout and upstream remote are in sync");
28
-
`I
29
-
( "remote:+N",
30
-
"Checkout has N commits to push (run $(b,monopam sync --remote))" );
31
-
`I ("remote:-N", "Upstream has N commits to pull (run $(b,monopam sync))");
32
-
`I ("remote:+N/-M", "Diverged: checkout +N ahead, upstream +M ahead");
33
-
`S "FORK ANALYSIS";
34
-
`P "If tracking other members via verse, shows fork comparison:";
35
-
`I ("+N", "They have N commits you don't have");
36
-
`I ("-N", "You have N commits they don't have");
37
-
`I ("=", "Same commit or same URL");
38
-
`I ("~", "Not in your workspace (use --all to list)");
39
-
`S "NEXT STEPS";
40
-
`P "Based on the status output:";
41
-
`I ("local:+N or local:-N", "Run $(b,monopam sync) to synchronize");
42
-
`I ("remote:-N", "Run $(b,monopam sync) to pull upstream changes");
43
-
`I ("remote:+N", "Run $(b,monopam sync --remote) to push to upstream");
44
-
]
45
-
in
46
111
let info = Cmd.info "status" ~doc ~man in
47
112
let all_arg =
48
113
let doc = "Show all repos including those not in your workspace." in
···
51
116
let forks_arg =
52
117
let doc = "Include fork analysis from verse members (slower)." in
53
118
Arg.(value & flag & info [ "forks"; "f" ] ~doc)
54
-
in
55
-
(* Helper: abbreviate handle to first part before dot, max 4 chars *)
56
-
let abbrev_handle h =
57
-
match String.split_on_char '.' h with
58
-
| first :: _ ->
59
-
if String.length first <= 4 then first else String.sub first 0 3
60
-
| [] -> h
61
-
in
62
-
(* Helper: load sources.toml *)
63
-
let load_sources ~fs ~config =
64
-
let sources_path =
65
-
Fpath.(Monopam.Config.Paths.monorepo config / "sources.toml")
66
-
in
67
-
match
68
-
Monopam.Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path
69
-
with
70
-
| Ok s -> Some s
71
-
| Error _ -> None
72
-
in
73
-
(* Helper: print unregistered opam files if any *)
74
-
let print_unregistered ~fs ~config pkgs =
75
-
let unregistered = Monopam.find_unregistered_opam_files ~fs ~config pkgs in
76
-
if unregistered <> [] then begin
77
-
let handle_abbrev =
78
-
match Monopam.Verse_config.load ~fs () with
79
-
| Ok vc -> abbrev_handle (Monopam.Verse_config.handle vc)
80
-
| Error _ -> "local"
81
-
in
82
-
Fmt.pr "%a %a\n"
83
-
Fmt.(styled `Bold string)
84
-
"Unregistered:"
85
-
Fmt.(styled `Faint int)
86
-
(List.length unregistered);
87
-
List.iter
88
-
(fun (_r, p) ->
89
-
Fmt.pr " %-22s %a\n" p
90
-
Fmt.(styled `Faint (fun ppf s -> pf ppf "%s~" s))
91
-
handle_abbrev)
92
-
unregistered
93
-
end
94
-
in
95
-
(* Helper: run fork analysis if requested *)
96
-
let print_forks ~proc ~fs ~config ~show_all =
97
-
match Monopam.Verse_config.load ~fs () with
98
-
| Error _ -> ()
99
-
| Ok verse_config ->
100
-
let forks =
101
-
Monopam.Forks.compute ~proc ~fs ~verse_config ~monopam_config:config
102
-
()
103
-
in
104
-
if forks.repos <> [] then
105
-
Fmt.pr "%a" (Monopam.Forks.pp_summary' ~show_all) forks
106
-
in
107
-
let run show_all show_forks () =
108
-
Eio_main.run @@ fun env ->
109
-
Common.with_config env @@ fun config ->
110
-
let fs = Eio.Stdenv.fs env in
111
-
let proc = Eio.Stdenv.process_mgr env in
112
-
match Monopam.status ~proc ~fs ~config () with
113
-
| Ok statuses ->
114
-
let sources = load_sources ~fs ~config in
115
-
(* Use table format when output is a TTY for nicer display *)
116
-
let pp =
117
-
if Tty.is_tty () then Monopam.Status.pp_table
118
-
else Monopam.Status.pp_summary
119
-
in
120
-
Fmt.pr "%a" (pp ?sources) statuses;
121
-
(match Monopam.discover_packages ~fs ~config () with
122
-
| Ok pkgs -> print_unregistered ~fs ~config pkgs
123
-
| Error _ -> ());
124
-
if show_forks then print_forks ~proc ~fs ~config ~show_all;
125
-
`Ok ()
126
-
| Error e ->
127
-
Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e;
128
-
`Error (false, "status failed")
129
119
in
130
120
Cmd.v info Term.(ret (const run $ all_arg $ forks_arg $ Common.logging_term))
+120
-118
bin/cmd_verse.ml
+120
-118
bin/cmd_verse.ml
···
36
36
let doc = "Force fresh fetches from all remotes." in
37
37
Arg.(value & flag & info [ "refresh"; "r" ] ~doc)
38
38
in
39
+
let handle_pull_result (result : Monopam.handle_pull_result) handle =
40
+
Fmt.pr "%a" Monopam.pp_handle_pull_result result;
41
+
if result.repos_failed <> [] then `Error (false, "some repos failed to pull")
42
+
else if result.repos_pulled = [] then begin
43
+
Fmt.pr "Nothing to pull from %s@." handle;
44
+
`Ok ()
45
+
end
46
+
else begin
47
+
Fmt.pr "@.Run $(b,monopam push) to publish merged changes.@.";
48
+
`Ok ()
49
+
end
50
+
in
39
51
let run handle repo refresh () =
40
52
Eio_main.run @@ fun env ->
41
53
Common.with_config env @@ fun config ->
···
46
58
Monopam.pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo
47
59
~refresh ()
48
60
with
49
-
| Ok result ->
50
-
Fmt.pr "%a" Monopam.pp_handle_pull_result result;
51
-
if result.repos_failed <> [] then
52
-
`Error (false, "some repos failed to pull")
53
-
else if result.repos_pulled = [] then begin
54
-
Fmt.pr "Nothing to pull from %s@." handle;
55
-
`Ok ()
56
-
end
57
-
else begin
58
-
Fmt.pr "@.Run $(b,monopam push) to publish merged changes.@.";
59
-
`Ok ()
60
-
end
61
+
| Ok result -> handle_pull_result result handle
61
62
| Error e ->
62
63
Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e;
63
64
`Error (false, "pull failed")
···
104
105
let doc = "Show full patch content for each commit." in
105
106
Arg.(value & flag & info [ "patch"; "p" ] ~doc)
106
107
in
108
+
let show_commit_info ~sha (info : Monopam.commit_info) =
109
+
let short_hash =
110
+
String.sub info.commit_hash 0 (min 7 (String.length info.commit_hash))
111
+
in
112
+
Fmt.pr "%a %s (%s/%s)@.@.%s@."
113
+
Fmt.(styled `Yellow string)
114
+
short_hash info.commit_subject info.commit_repo info.commit_handle
115
+
info.commit_patch;
116
+
`Ok ()
117
+
in
118
+
let handle_sha ~proc ~fs ~config ~verse_config ~sha ~refresh =
119
+
match
120
+
Monopam.diff_show_commit ~proc ~fs ~config ~verse_config ~sha ~refresh ()
121
+
with
122
+
| Some info -> show_commit_info ~sha info
123
+
| None ->
124
+
Fmt.epr "Commit %s not found in any verse diff@." sha;
125
+
`Error (false, "commit not found")
126
+
in
107
127
let run arg refresh patch () =
108
128
Eio_main.run @@ fun env ->
109
129
Common.with_config env @@ fun config ->
···
111
131
let fs = Eio.Stdenv.fs env in
112
132
let proc = Eio.Stdenv.process_mgr env in
113
133
match arg with
114
-
| Some sha when Monopam.is_commit_sha sha -> (
115
-
match
116
-
Monopam.diff_show_commit ~proc ~fs ~config ~verse_config ~sha ~refresh
117
-
()
118
-
with
119
-
| Some info ->
120
-
let short_hash =
121
-
String.sub info.commit_hash 0
122
-
(min 7 (String.length info.commit_hash))
123
-
in
124
-
Fmt.pr "%a %s (%s/%s)@.@.%s@."
125
-
Fmt.(styled `Yellow string)
126
-
short_hash info.commit_subject info.commit_repo info.commit_handle
127
-
info.commit_patch;
128
-
`Ok ()
129
-
| None ->
130
-
Fmt.epr "Commit %s not found in any verse diff@." sha;
131
-
`Error (false, "commit not found"))
134
+
| Some sha when Monopam.is_commit_sha sha ->
135
+
handle_sha ~proc ~fs ~config ~verse_config ~sha ~refresh
132
136
| repo ->
133
137
let result =
134
138
Monopam.diff ~proc ~fs ~config ~verse_config ?repo ~refresh ~patch ()
···
262
266
Cmd.v info Term.(ret (const run $ Common.logging_term))
263
267
264
268
(* verse fork - fork a package *)
269
+
let fork_man =
270
+
[
271
+
`S Manpage.s_description;
272
+
`P
273
+
"Fork a package from a verse member's opam repository into your \
274
+
workspace.";
275
+
`S "WHAT IT DOES";
276
+
`I ("1.", "Looks up the package in the member's opam-repo");
277
+
`I ("2.", "Finds all packages from the same git repository");
278
+
`I ("3.", "Creates entries in your opam-repo with your fork URL");
279
+
`S Manpage.s_examples;
280
+
`P "Fork a package:";
281
+
`Pre
282
+
"monopam verse fork cohttp --from avsm.bsky.social --url \
283
+
git@github.com:me/cohttp.git";
284
+
`P "Preview what would be forked:";
285
+
`Pre
286
+
"monopam verse fork cohttp --from avsm.bsky.social --url \
287
+
git@github.com:me/cohttp.git --dry-run";
288
+
]
289
+
290
+
let handle_fork_success ~fs ~config ~dry_run result =
291
+
if dry_run then begin
292
+
Fmt.pr "Would fork %d package(s) from %s:@."
293
+
(List.length result.Monopam.Verse.packages_forked)
294
+
result.source_handle;
295
+
List.iter (fun p -> Fmt.pr " %s@." p) result.packages_forked
296
+
end
297
+
else begin
298
+
let mono_path = Monopam.Verse_config.mono_path config in
299
+
let sources_path = Fpath.(mono_path / "sources.toml") in
300
+
let sources =
301
+
match
302
+
Monopam.Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path
303
+
with
304
+
| Ok s -> s
305
+
| Error _ -> Monopam.Sources_registry.empty
306
+
in
307
+
let entry =
308
+
Monopam.Sources_registry.
309
+
{
310
+
url = result.Monopam.Verse.fork_url;
311
+
upstream = Some result.upstream_url;
312
+
branch = None;
313
+
reason = Some (Fmt.str "Forked from %s" result.source_handle);
314
+
origin = Some Join;
315
+
}
316
+
in
317
+
let sources =
318
+
Monopam.Sources_registry.add sources ~subtree:result.subtree_name entry
319
+
in
320
+
(match
321
+
Monopam.Sources_registry.save
322
+
~fs:(fs :> _ Eio.Path.t)
323
+
sources_path sources
324
+
with
325
+
| Ok () ->
326
+
Fmt.pr "Updated sources.toml with fork entry for %s@."
327
+
result.subtree_name
328
+
| Error msg -> Fmt.epr "Warning: Failed to update sources.toml: %s@." msg);
329
+
Fmt.pr "Forked %d package(s): %a@."
330
+
(List.length result.packages_forked)
331
+
Fmt.(list ~sep:(any ", ") string)
332
+
result.packages_forked;
333
+
Fmt.pr "@.Next steps:@.";
334
+
Fmt.pr " 1. cd opam-repo && git add -A && git commit@.";
335
+
Fmt.pr " 2. monopam pull@."
336
+
end
337
+
338
+
let fork_run package handle fork_url dry_run () =
339
+
Eio_main.run @@ fun env ->
340
+
Common.with_verse_config env @@ fun config ->
341
+
let fs = Eio.Stdenv.fs env in
342
+
let proc = Eio.Stdenv.process_mgr env in
343
+
match
344
+
Monopam.Verse.fork ~proc ~fs ~config ~handle ~package ~fork_url ~dry_run ()
345
+
with
346
+
| Ok result ->
347
+
handle_fork_success ~fs ~config ~dry_run result;
348
+
`Ok ()
349
+
| Error e ->
350
+
Fmt.epr "Error: %a@." Monopam.Verse.pp_error_with_hint e;
351
+
`Error (false, "fork failed")
352
+
265
353
let fork_cmd =
266
354
let doc = "Fork a package from a verse member" in
267
-
let man =
268
-
[
269
-
`S Manpage.s_description;
270
-
`P
271
-
"Fork a package from a verse member's opam repository into your \
272
-
workspace.";
273
-
`S "WHAT IT DOES";
274
-
`I ("1.", "Looks up the package in the member's opam-repo");
275
-
`I ("2.", "Finds all packages from the same git repository");
276
-
`I ("3.", "Creates entries in your opam-repo with your fork URL");
277
-
`S Manpage.s_examples;
278
-
`P "Fork a package:";
279
-
`Pre
280
-
"monopam verse fork cohttp --from avsm.bsky.social --url \
281
-
git@github.com:me/cohttp.git";
282
-
`P "Preview what would be forked:";
283
-
`Pre
284
-
"monopam verse fork cohttp --from avsm.bsky.social --url \
285
-
git@github.com:me/cohttp.git --dry-run";
286
-
]
287
-
in
288
-
let info = Cmd.info "fork" ~doc ~man in
355
+
let info = Cmd.info "fork" ~doc ~man:fork_man in
289
356
let package_arg =
290
357
let doc = "Package name to fork" in
291
358
Arg.(required & pos 0 (some string) None & info [] ~docv:"PACKAGE" ~doc)
···
303
370
let doc = "Show what would be forked without making changes" in
304
371
Arg.(value & flag & info [ "dry-run"; "n" ] ~doc)
305
372
in
306
-
let run package handle fork_url dry_run () =
307
-
Eio_main.run @@ fun env ->
308
-
Common.with_verse_config env @@ fun config ->
309
-
let fs = Eio.Stdenv.fs env in
310
-
let proc = Eio.Stdenv.process_mgr env in
311
-
match
312
-
Monopam.Verse.fork ~proc ~fs ~config ~handle ~package ~fork_url ~dry_run
313
-
()
314
-
with
315
-
| Ok result ->
316
-
if dry_run then begin
317
-
Fmt.pr "Would fork %d package(s) from %s:@."
318
-
(List.length result.packages_forked)
319
-
result.source_handle;
320
-
List.iter (fun p -> Fmt.pr " %s@." p) result.packages_forked
321
-
end
322
-
else begin
323
-
let mono_path = Monopam.Verse_config.mono_path config in
324
-
let sources_path = Fpath.(mono_path / "sources.toml") in
325
-
let sources =
326
-
match
327
-
Monopam.Sources_registry.load
328
-
~fs:(fs :> _ Eio.Path.t)
329
-
sources_path
330
-
with
331
-
| Ok s -> s
332
-
| Error _ -> Monopam.Sources_registry.empty
333
-
in
334
-
let entry =
335
-
Monopam.Sources_registry.
336
-
{
337
-
url = result.fork_url;
338
-
upstream = Some result.upstream_url;
339
-
branch = None;
340
-
reason = Some (Fmt.str "Forked from %s" result.source_handle);
341
-
origin = Some Join;
342
-
}
343
-
in
344
-
let sources =
345
-
Monopam.Sources_registry.add sources ~subtree:result.subtree_name
346
-
entry
347
-
in
348
-
(match
349
-
Monopam.Sources_registry.save
350
-
~fs:(fs :> _ Eio.Path.t)
351
-
sources_path sources
352
-
with
353
-
| Ok () ->
354
-
Fmt.pr "Updated sources.toml with fork entry for %s@."
355
-
result.subtree_name
356
-
| Error msg ->
357
-
Fmt.epr "Warning: Failed to update sources.toml: %s@." msg);
358
-
Fmt.pr "Forked %d package(s): %a@."
359
-
(List.length result.packages_forked)
360
-
Fmt.(list ~sep:(any ", ") string)
361
-
result.packages_forked;
362
-
Fmt.pr "@.Next steps:@.";
363
-
Fmt.pr " 1. cd opam-repo && git add -A && git commit@.";
364
-
Fmt.pr " 2. monopam pull@."
365
-
end;
366
-
`Ok ()
367
-
| Error e ->
368
-
Fmt.epr "Error: %a@." Monopam.Verse.pp_error_with_hint e;
369
-
`Error (false, "fork failed")
370
-
in
371
373
Cmd.v info
372
374
Term.(
373
375
ret
374
-
(const run $ package_arg $ from_arg $ url_arg $ dry_run_arg
376
+
(const fork_run $ package_arg $ from_arg $ url_arg $ dry_run_arg
375
377
$ Common.logging_term))
376
378
377
379
(* Main verse command group *)
+250
-352
lib/doctor.ml
+250
-352
lib/doctor.ml
···
494
494
remotes_by_repo;
495
495
Buffer.contents buf
496
496
497
-
(** Analyze all incoming commits using Claude *)
498
-
let analyze_with_claude ~sw ~process_mgr ~clock ~status_summary
499
-
~incoming_summary =
500
-
let prompt = Buffer.create 16384 in
501
-
Buffer.add_string prompt
502
-
{|You are analyzing a monorepo workspace to provide actionable recommendations.
503
-
504
-
IMPORTANT: The workspace has already been synced and the status output is provided below.
505
-
You do NOT need to run `monopam status` or `monopam sync` - this has already been done.
506
-
Use the status information provided to inform your analysis.
507
-
508
-
|};
509
-
Buffer.add_string prompt status_summary;
510
-
Buffer.add_string prompt incoming_summary;
511
-
Buffer.add_string prompt
512
-
{|
513
-
497
+
(** Prompt instructions for doctor analysis *)
498
+
let doctor_instructions =
499
+
{|
514
500
## Instructions
515
501
516
502
Analyze the workspace state and incoming commits. For each repository with incoming commits,
···
539
525
- action: description of what to do
540
526
- command: optional command to run
541
527
- warnings: array of warning strings for any issues detected
528
+
|}
529
+
530
+
(** Build doctor analysis prompt *)
531
+
let build_doctor_prompt ~status_summary ~incoming_summary =
532
+
let buf = Buffer.create 16384 in
533
+
Buffer.add_string buf
534
+
{|You are analyzing a monorepo workspace to provide actionable recommendations.
535
+
536
+
IMPORTANT: The workspace has already been synced and the status output is provided below.
537
+
You do NOT need to run `monopam status` or `monopam sync` - this has already been done.
538
+
Use the status information provided to inform your analysis.
539
+
542
540
|};
541
+
Buffer.add_string buf status_summary;
542
+
Buffer.add_string buf incoming_summary;
543
+
Buffer.add_string buf doctor_instructions;
544
+
Buffer.contents buf
543
545
544
-
let output_schema =
545
-
let open Jsont in
546
-
let commit_schema =
547
-
Object
548
-
( [
549
-
(("type", Meta.none), String ("object", Meta.none));
550
-
( ("properties", Meta.none),
551
-
Object
552
-
( [
553
-
( ("hash", Meta.none),
554
-
Object
555
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
556
-
Meta.none ) );
557
-
( ("subject", Meta.none),
558
-
Object
559
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
560
-
Meta.none ) );
561
-
( ("author", Meta.none),
562
-
Object
563
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
564
-
Meta.none ) );
565
-
( ("date", Meta.none),
566
-
Object
567
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
568
-
Meta.none ) );
569
-
( ("category", Meta.none),
570
-
Object
571
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
572
-
Meta.none ) );
573
-
( ("priority", Meta.none),
574
-
Object
575
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
576
-
Meta.none ) );
577
-
( ("recommendation", Meta.none),
578
-
Object
579
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
580
-
Meta.none ) );
581
-
( ("conflict_risk", Meta.none),
582
-
Object
583
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
584
-
Meta.none ) );
585
-
( ("summary", Meta.none),
586
-
Object
587
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
588
-
Meta.none ) );
589
-
],
590
-
Meta.none ) );
591
-
],
592
-
Meta.none )
593
-
in
594
-
let verse_schema =
595
-
Object
596
-
( [
597
-
(("type", Meta.none), String ("object", Meta.none));
598
-
( ("properties", Meta.none),
599
-
Object
600
-
( [
601
-
( ("handle", Meta.none),
602
-
Object
603
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
604
-
Meta.none ) );
605
-
( ("commits", Meta.none),
606
-
Object
607
-
( [
608
-
(("type", Meta.none), String ("array", Meta.none));
609
-
(("items", Meta.none), commit_schema);
610
-
],
611
-
Meta.none ) );
612
-
( ("suggested_action", Meta.none),
613
-
Object
614
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
615
-
Meta.none ) );
616
-
],
617
-
Meta.none ) );
618
-
],
619
-
Meta.none )
620
-
in
621
-
let repo_schema =
622
-
Object
623
-
( [
624
-
(("type", Meta.none), String ("object", Meta.none));
625
-
( ("properties", Meta.none),
626
-
Object
627
-
( [
628
-
( ("name", Meta.none),
629
-
Object
630
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
631
-
Meta.none ) );
632
-
( ("verse_analyses", Meta.none),
633
-
Object
634
-
( [
635
-
(("type", Meta.none), String ("array", Meta.none));
636
-
(("items", Meta.none), verse_schema);
637
-
],
638
-
Meta.none ) );
639
-
],
640
-
Meta.none ) );
641
-
],
642
-
Meta.none )
643
-
in
644
-
let action_schema =
645
-
Object
646
-
( [
647
-
(("type", Meta.none), String ("object", Meta.none));
648
-
( ("properties", Meta.none),
649
-
Object
650
-
( [
651
-
( ("priority", Meta.none),
652
-
Object
653
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
654
-
Meta.none ) );
655
-
( ("action", Meta.none),
656
-
Object
657
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
658
-
Meta.none ) );
659
-
( ("command", Meta.none),
660
-
Object
661
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
662
-
Meta.none ) );
663
-
],
664
-
Meta.none ) );
665
-
],
666
-
Meta.none )
667
-
in
668
-
Object
669
-
( [
670
-
(("type", Meta.none), String ("object", Meta.none));
671
-
( ("properties", Meta.none),
672
-
Object
673
-
( [
674
-
( ("repos", Meta.none),
675
-
Object
676
-
( [
677
-
(("type", Meta.none), String ("array", Meta.none));
678
-
(("items", Meta.none), repo_schema);
679
-
],
680
-
Meta.none ) );
681
-
( ("recommendations", Meta.none),
682
-
Object
683
-
( [
684
-
(("type", Meta.none), String ("array", Meta.none));
685
-
(("items", Meta.none), action_schema);
686
-
],
687
-
Meta.none ) );
688
-
( ("warnings", Meta.none),
689
-
Object
690
-
( [
691
-
(("type", Meta.none), String ("array", Meta.none));
692
-
( ("items", Meta.none),
693
-
Object
694
-
( [
695
-
( ("type", Meta.none),
696
-
String ("string", Meta.none) );
697
-
],
698
-
Meta.none ) );
699
-
],
700
-
Meta.none ) );
701
-
],
702
-
Meta.none ) );
703
-
( ("required", Meta.none),
704
-
Array
705
-
( [
706
-
String ("repos", Meta.none);
707
-
String ("recommendations", Meta.none);
708
-
String ("warnings", Meta.none);
709
-
],
710
-
Meta.none ) );
711
-
],
712
-
Meta.none )
546
+
(** JSON schema helpers *)
547
+
let string_type =
548
+
let open Jsont in
549
+
Object ([ (("type", Meta.none), String ("string", Meta.none)) ], Meta.none)
550
+
551
+
let array_of items =
552
+
let open Jsont in
553
+
Object
554
+
( [
555
+
(("type", Meta.none), String ("array", Meta.none));
556
+
(("items", Meta.none), items);
557
+
],
558
+
Meta.none )
559
+
560
+
let object_with_props props =
561
+
let open Jsont in
562
+
Object
563
+
( [
564
+
(("type", Meta.none), String ("object", Meta.none));
565
+
(("properties", Meta.none), Object (props, Meta.none));
566
+
],
567
+
Meta.none )
568
+
569
+
(** JSON schema for doctor output *)
570
+
let doctor_output_schema () =
571
+
let open Jsont in
572
+
let prop name schema = ((name, Meta.none), schema) in
573
+
let commit_schema =
574
+
object_with_props
575
+
[
576
+
prop "hash" string_type;
577
+
prop "subject" string_type;
578
+
prop "author" string_type;
579
+
prop "date" string_type;
580
+
prop "category" string_type;
581
+
prop "priority" string_type;
582
+
prop "recommendation" string_type;
583
+
prop "conflict_risk" string_type;
584
+
prop "summary" string_type;
585
+
]
586
+
in
587
+
let verse_schema =
588
+
object_with_props
589
+
[
590
+
prop "handle" string_type;
591
+
prop "commits" (array_of commit_schema);
592
+
prop "suggested_action" string_type;
593
+
]
594
+
in
595
+
let repo_schema =
596
+
object_with_props
597
+
[ prop "name" string_type; prop "verse_analyses" (array_of verse_schema) ]
598
+
in
599
+
let action_schema =
600
+
object_with_props
601
+
[
602
+
prop "priority" string_type;
603
+
prop "action" string_type;
604
+
prop "command" string_type;
605
+
]
606
+
in
607
+
Object
608
+
( [
609
+
(("type", Meta.none), String ("object", Meta.none));
610
+
( ("properties", Meta.none),
611
+
Object
612
+
( [
613
+
prop "repos" (array_of repo_schema);
614
+
prop "recommendations" (array_of action_schema);
615
+
prop "warnings" (array_of string_type);
616
+
],
617
+
Meta.none ) );
618
+
( ("required", Meta.none),
619
+
Array
620
+
( [
621
+
String ("repos", Meta.none);
622
+
String ("recommendations", Meta.none);
623
+
String ("warnings", Meta.none);
624
+
],
625
+
Meta.none ) );
626
+
],
627
+
Meta.none )
628
+
629
+
(** Log tool use for Claude handler *)
630
+
let log_tool_use name input =
631
+
let get key =
632
+
Claude.Tool_input.get_string input key |> Option.value ~default:""
713
633
in
634
+
match name with
635
+
| "Bash" ->
636
+
let cmd = get "command" in
637
+
let short =
638
+
if String.length cmd > 60 then String.sub cmd 0 57 ^ "..." else cmd
639
+
in
640
+
Log.app (fun m -> m " [Bash] %s" short)
641
+
| "Read" -> Log.app (fun m -> m " [Read] %s" (get "file_path"))
642
+
| "Grep" -> Log.app (fun m -> m " [Grep] %s" (get "pattern"))
643
+
| "Glob" -> Log.app (fun m -> m " [Glob] %s" (get "pattern"))
644
+
| _ -> Log.app (fun m -> m " [%s]" name)
645
+
646
+
(** Create Claude handler for doctor analysis *)
647
+
let make_doctor_handler result =
648
+
object
649
+
inherit Claude.Handler.default
650
+
651
+
method! on_text t =
652
+
let content = Claude.Response.Text.content t in
653
+
if String.length content > 0 then
654
+
Log.app (fun m -> m "Claude: %s" content)
655
+
656
+
method! on_tool_use t =
657
+
log_tool_use
658
+
(Claude.Response.Tool_use.name t)
659
+
(Claude.Response.Tool_use.input t)
660
+
661
+
method! on_complete c =
662
+
match Claude.Response.Complete.structured_output c with
663
+
| Some json -> result := Some json
664
+
| None -> Log.warn (fun m -> m "No structured output from Claude")
665
+
666
+
method! on_error e =
667
+
Log.warn (fun m -> m "Claude error: %s" (Claude.Response.Error.message e))
668
+
end
669
+
670
+
(** Analyze all incoming commits using Claude *)
671
+
let analyze_with_claude ~sw ~process_mgr ~clock ~status_summary
672
+
~incoming_summary =
673
+
let prompt = build_doctor_prompt ~status_summary ~incoming_summary in
714
674
let output_format =
715
-
Claude.Proto.Structured_output.of_json_schema output_schema
675
+
Claude.Proto.Structured_output.of_json_schema (doctor_output_schema ())
716
676
in
717
677
let options =
718
678
Claude.Options.default |> Claude.Options.with_output_format output_format
719
679
in
720
-
721
680
let client = Claude.Client.create ~sw ~process_mgr ~clock ~options () in
722
-
Claude.Client.query client (Buffer.contents prompt);
723
-
724
-
(* Stream Claude's activity to console *)
681
+
Claude.Client.query client prompt;
725
682
let result = ref None in
726
-
let handler =
727
-
object
728
-
inherit Claude.Handler.default
683
+
Claude.Client.run client ~handler:(make_doctor_handler result);
684
+
!result
729
685
730
-
method! on_text t =
731
-
let content = Claude.Response.Text.content t in
732
-
if String.length content > 0 then
733
-
Log.app (fun m -> m "Claude: %s" content)
686
+
(** {2 JSON Parsing Helpers} *)
734
687
735
-
method! on_tool_use t =
736
-
let name = Claude.Response.Tool_use.name t in
737
-
let input = Claude.Response.Tool_use.input t in
738
-
(* Show tool being used with key parameters *)
739
-
match name with
740
-
| "Bash" ->
741
-
let cmd =
742
-
Claude.Tool_input.get_string input "command"
743
-
|> Option.value ~default:""
744
-
in
745
-
let short_cmd =
746
-
if String.length cmd > 60 then String.sub cmd 0 57 ^ "..."
747
-
else cmd
748
-
in
749
-
Log.app (fun m -> m " [Bash] %s" short_cmd)
750
-
| "Read" ->
751
-
let path =
752
-
Claude.Tool_input.get_string input "file_path"
753
-
|> Option.value ~default:""
754
-
in
755
-
Log.app (fun m -> m " [Read] %s" path)
756
-
| "Grep" ->
757
-
let pattern =
758
-
Claude.Tool_input.get_string input "pattern"
759
-
|> Option.value ~default:""
760
-
in
761
-
Log.app (fun m -> m " [Grep] %s" pattern)
762
-
| "Glob" ->
763
-
let pattern =
764
-
Claude.Tool_input.get_string input "pattern"
765
-
|> Option.value ~default:""
766
-
in
767
-
Log.app (fun m -> m " [Glob] %s" pattern)
768
-
| _ -> Log.app (fun m -> m " [%s]" name)
688
+
(** Find a member by key in a Jsont object. *)
689
+
let json_find_member key obj =
690
+
List.find_map (fun ((k, _meta), v) -> if k = key then Some v else None) obj
769
691
770
-
method! on_complete c =
771
-
match Claude.Response.Complete.structured_output c with
772
-
| Some json -> result := Some json
773
-
| None -> Log.warn (fun m -> m "No structured output from Claude")
692
+
(** Get optional string from JSON object. *)
693
+
let json_get_string_opt obj key =
694
+
match json_find_member key obj with
695
+
| Some (Jsont.String (s, _)) -> Some s
696
+
| _ -> None
774
697
775
-
method! on_error e =
776
-
Log.warn (fun m ->
777
-
m "Claude error: %s" (Claude.Response.Error.message e))
778
-
end
779
-
in
698
+
(** Get string from JSON object with default. *)
699
+
let json_get_string obj key default =
700
+
Option.value ~default (json_get_string_opt obj key)
780
701
781
-
Claude.Client.run client ~handler;
782
-
!result
702
+
(** Get array from JSON object. *)
703
+
let json_get_array obj key =
704
+
match json_find_member key obj with
705
+
| Some (Jsont.Array (arr, _)) -> arr
706
+
| _ -> []
783
707
784
-
(** Parse Claude's JSON response into our types *)
785
-
let parse_claude_response json =
786
-
let repos = ref [] in
787
-
let recommendations = ref [] in
788
-
let warnings = ref [] in
708
+
(** Parse a commit from JSON. *)
709
+
let parse_commit_json c_json =
710
+
match c_json with
711
+
| Jsont.Object (c_obj, _) ->
712
+
Some
713
+
{
714
+
hash = json_get_string c_obj "hash" "";
715
+
subject = json_get_string c_obj "subject" "";
716
+
author = json_get_string c_obj "author" "";
717
+
date = json_get_string c_obj "date" "";
718
+
category =
719
+
change_category_of_string (json_get_string c_obj "category" "other");
720
+
priority = priority_of_string (json_get_string c_obj "priority" "low");
721
+
recommendation =
722
+
recommendation_of_string
723
+
(json_get_string c_obj "recommendation" "review-first");
724
+
conflict_risk =
725
+
conflict_risk_of_string
726
+
(json_get_string c_obj "conflict_risk" "low");
727
+
commit_summary = json_get_string c_obj "summary" "";
728
+
}
729
+
| _ -> None
789
730
790
-
(* Jsont objects use (name * meta, value) pairs where name is (string * meta) *)
791
-
let find_member key obj =
792
-
List.find_map (fun ((k, _meta), v) -> if k = key then Some v else None) obj
793
-
in
794
-
let get_string_opt obj key =
795
-
match find_member key obj with
796
-
| Some (Jsont.String (s, _)) -> Some s
797
-
| _ -> None
798
-
in
799
-
let get_string obj key default =
800
-
Option.value ~default (get_string_opt obj key)
801
-
in
802
-
let get_array obj key =
803
-
match find_member key obj with
804
-
| Some (Jsont.Array (arr, _)) -> arr
805
-
| _ -> []
806
-
in
731
+
(** Parse a verse analysis from JSON. *)
732
+
let parse_verse_analysis_json va_json =
733
+
match va_json with
734
+
| Jsont.Object (va_obj, _) ->
735
+
let handle = json_get_string va_obj "handle" "" in
736
+
let commits =
737
+
List.filter_map parse_commit_json (json_get_array va_obj "commits")
738
+
in
739
+
let suggested_action = json_get_string_opt va_obj "suggested_action" in
740
+
Some { handle; commits; suggested_action }
741
+
| _ -> None
807
742
808
-
(match json with
809
-
| Jsont.Object (obj, _) ->
810
-
(* Parse repos *)
811
-
List.iter
812
-
(fun repo_json ->
813
-
match repo_json with
814
-
| Jsont.Object (repo_obj, _) ->
815
-
let name = get_string repo_obj "name" "" in
816
-
let verse_analyses =
817
-
List.filter_map
818
-
(fun va_json ->
819
-
match va_json with
820
-
| Jsont.Object (va_obj, _) ->
821
-
let handle = get_string va_obj "handle" "" in
822
-
let commits =
823
-
List.filter_map
824
-
(fun c_json ->
825
-
match c_json with
826
-
| Jsont.Object (c_obj, _) ->
827
-
Some
828
-
{
829
-
hash = get_string c_obj "hash" "";
830
-
subject = get_string c_obj "subject" "";
831
-
author = get_string c_obj "author" "";
832
-
date = get_string c_obj "date" "";
833
-
category =
834
-
change_category_of_string
835
-
(get_string c_obj "category" "other");
836
-
priority =
837
-
priority_of_string
838
-
(get_string c_obj "priority" "low");
839
-
recommendation =
840
-
recommendation_of_string
841
-
(get_string c_obj "recommendation"
842
-
"review-first");
843
-
conflict_risk =
844
-
conflict_risk_of_string
845
-
(get_string c_obj "conflict_risk"
846
-
"low");
847
-
commit_summary =
848
-
get_string c_obj "summary" "";
849
-
}
850
-
| _ -> None)
851
-
(get_array va_obj "commits")
852
-
in
853
-
let suggested_action =
854
-
get_string_opt va_obj "suggested_action"
855
-
in
856
-
Some { handle; commits; suggested_action }
857
-
| _ -> None)
858
-
(get_array repo_obj "verse_analyses")
859
-
in
860
-
if verse_analyses <> [] then
861
-
repos :=
862
-
{
863
-
name;
864
-
local_sync = `In_sync;
865
-
remote_ahead = 0;
866
-
remote_behind = 0;
867
-
verse_analyses;
868
-
}
869
-
:: !repos
870
-
| _ -> ())
871
-
(get_array obj "repos");
743
+
(** Parse a repo from JSON. *)
744
+
let parse_repo_json repo_json =
745
+
match repo_json with
746
+
| Jsont.Object (repo_obj, _) ->
747
+
let name = json_get_string repo_obj "name" "" in
748
+
let verse_analyses =
749
+
List.filter_map parse_verse_analysis_json
750
+
(json_get_array repo_obj "verse_analyses")
751
+
in
752
+
if verse_analyses <> [] then
753
+
Some
754
+
{
755
+
name;
756
+
local_sync = `In_sync;
757
+
remote_ahead = 0;
758
+
remote_behind = 0;
759
+
verse_analyses;
760
+
}
761
+
else None
762
+
| _ -> None
872
763
873
-
(* Parse recommendations *)
874
-
List.iter
875
-
(fun rec_json ->
876
-
match rec_json with
877
-
| Jsont.Object (rec_obj, _) ->
878
-
let action_priority =
879
-
priority_of_string (get_string rec_obj "priority" "low")
880
-
in
881
-
let description = get_string rec_obj "action" "" in
882
-
let command = get_string_opt rec_obj "command" in
883
-
recommendations :=
884
-
{ action_priority; description; command } :: !recommendations
885
-
| _ -> ())
886
-
(get_array obj "recommendations");
764
+
(** Parse a recommendation from JSON. *)
765
+
let parse_recommendation_json rec_json =
766
+
match rec_json with
767
+
| Jsont.Object (rec_obj, _) ->
768
+
let action_priority =
769
+
priority_of_string (json_get_string rec_obj "priority" "low")
770
+
in
771
+
let description = json_get_string rec_obj "action" "" in
772
+
let command = json_get_string_opt rec_obj "command" in
773
+
Some { action_priority; description; command }
774
+
| _ -> None
887
775
888
-
(* Parse warnings *)
889
-
List.iter
890
-
(fun w_json ->
891
-
match w_json with
892
-
| Jsont.String (s, _) -> warnings := s :: !warnings
893
-
| _ -> ())
894
-
(get_array obj "warnings")
895
-
| _ -> ());
776
+
(** Parse a warning from JSON. *)
777
+
let parse_warning_json w_json =
778
+
match w_json with Jsont.String (s, _) -> Some s | _ -> None
896
779
897
-
(List.rev !repos, List.rev !recommendations, List.rev !warnings)
780
+
(** Parse Claude's JSON response into our types *)
781
+
let parse_claude_response json =
782
+
match json with
783
+
| Jsont.Object (obj, _) ->
784
+
let repos =
785
+
List.filter_map parse_repo_json (json_get_array obj "repos")
786
+
in
787
+
let recommendations =
788
+
List.filter_map parse_recommendation_json
789
+
(json_get_array obj "recommendations")
790
+
in
791
+
let warnings =
792
+
List.filter_map parse_warning_json (json_get_array obj "warnings")
793
+
in
794
+
(repos, recommendations, warnings)
795
+
| _ -> ([], [], [])
898
796
899
797
(** {1 Main Analysis} *)
900
798
+293
-295
lib/fork_join.ml
+293
-295
lib/fork_join.ml
···
236
236
try Eio.Path.mkdirs ~perm:0o755 eio_path with Eio.Io _ -> ()
237
237
238
238
(** Scan a directory for .opam files *)
239
-
let find_opam_files ~fs path =
239
+
let opam_files ~fs path =
240
240
let eio_path = Eio.Path.(fs / Fpath.to_string path) in
241
241
try
242
242
Eio.Path.read_dir eio_path
···
445
445
446
446
(** {1 Plan Builders} *)
447
447
448
+
(** {2 Fork Plan Helpers} *)
449
+
450
+
(** Gather discovery info for fork. *)
451
+
let fork_discovery ~fs ~monorepo ~prefix ~subtree_path ~src_path =
452
+
let mono_exists = is_directory ~fs Fpath.(monorepo / prefix) in
453
+
let src_exists = is_directory ~fs src_path in
454
+
let has_subtree_hist =
455
+
if mono_exists then
456
+
let repo = Git.Repository.open_repo ~fs monorepo in
457
+
Git.Repository.has_subtree_history repo ~prefix
458
+
else false
459
+
in
460
+
let files = if mono_exists then opam_files ~fs subtree_path else [] in
461
+
( {
462
+
mono_exists;
463
+
src_exists;
464
+
has_subtree_history = has_subtree_hist;
465
+
remote_accessible = None;
466
+
opam_files = files;
467
+
local_path_is_repo = None;
468
+
},
469
+
has_subtree_hist,
470
+
files )
471
+
472
+
(** Build actions to create src directory with subtree history. *)
473
+
let fork_actions_with_history ~checkouts ~monorepo ~src_path ~prefix ~branch =
474
+
[
475
+
Create_directory checkouts;
476
+
Git_subtree_split { repo = monorepo; prefix };
477
+
Git_init src_path;
478
+
Git_config
479
+
{
480
+
repo = src_path;
481
+
key = "receive.denyCurrentBranch";
482
+
value = "updateInstead";
483
+
};
484
+
Git_add_remote
485
+
{ repo = src_path; name = "mono"; url = Fpath.to_string monorepo };
486
+
Git_push_ref
487
+
{
488
+
repo = monorepo;
489
+
target = Fpath.to_string src_path;
490
+
ref_spec = "SPLIT_COMMIT:refs/heads/main";
491
+
};
492
+
Git_checkout { repo = src_path; branch };
493
+
]
494
+
495
+
(** Build actions to create src directory as fresh package. *)
496
+
let fork_actions_fresh ~checkouts ~subtree_path ~src_path ~name ~branch =
497
+
[
498
+
Create_directory checkouts;
499
+
Create_directory src_path;
500
+
Git_init src_path;
501
+
Git_config
502
+
{
503
+
repo = src_path;
504
+
key = "receive.denyCurrentBranch";
505
+
value = "updateInstead";
506
+
};
507
+
Git_branch_rename { repo = src_path; new_name = branch };
508
+
Copy_directory { src = subtree_path; dest = src_path };
509
+
Git_add_all src_path;
510
+
Git_commit
511
+
{ repo = src_path; message = Fmt.str "Initial commit of %s" name };
512
+
]
513
+
514
+
(** Build actions to remove from mono and re-add as subtree. *)
515
+
let fork_rejoin_actions ~monorepo ~src_path ~prefix ~name ~branch =
516
+
[
517
+
Git_rm { repo = monorepo; path = prefix; recursive = true };
518
+
Git_commit { repo = monorepo; message = Fmt.str "Remove %s for fork" name };
519
+
Git_subtree_add
520
+
{
521
+
repo = monorepo;
522
+
prefix;
523
+
url = Uri.of_string (Fpath.to_string src_path);
524
+
branch;
525
+
};
526
+
]
527
+
528
+
(** Build sources.toml update actions for fork. *)
529
+
let fork_sources_actions ~monorepo ~name ~handle ~push_url ~branch =
530
+
match push_url with
531
+
| Some url when not (is_own_namespace ~handle url) ->
532
+
[
533
+
Update_sources_toml
534
+
{
535
+
path = Fpath.(monorepo / "sources.toml");
536
+
name;
537
+
entry =
538
+
Sources_registry.
539
+
{
540
+
url = normalize_git_url url;
541
+
upstream = None;
542
+
branch = Some branch;
543
+
reason = None;
544
+
origin = Some Fork;
545
+
};
546
+
};
547
+
]
548
+
| Some _ -> []
549
+
| None -> []
550
+
448
551
(** Build a fork plan - handles both subtree and fresh package scenarios.
449
552
450
553
The fork workflow: 1. Create src/<name>/ with the package content (split or
···
459
562
let subtree_path = Fpath.(monorepo / prefix) in
460
563
let src_path = Fpath.(checkouts / name) in
461
564
let branch = Verse_config.default_branch in
462
-
463
-
(* Gather discovery information *)
464
-
let mono_exists = is_directory ~fs Fpath.(monorepo / prefix) in
465
-
let src_exists = is_directory ~fs src_path in
466
-
let has_subtree_hist =
467
-
if mono_exists then
468
-
let repo = Git.Repository.open_repo ~fs monorepo in
469
-
Git.Repository.has_subtree_history repo ~prefix
470
-
else false
471
-
in
472
-
let opam_files =
473
-
if mono_exists then find_opam_files ~fs subtree_path else []
474
-
in
565
+
let handle = Verse_config.handle config in
475
566
476
-
let discovery =
477
-
{
478
-
mono_exists;
479
-
src_exists;
480
-
has_subtree_history = has_subtree_hist;
481
-
remote_accessible = None;
482
-
(* Could check if push_url is accessible *)
483
-
opam_files;
484
-
local_path_is_repo = None;
485
-
}
567
+
let discovery, has_subtree_hist, files =
568
+
fork_discovery ~fs ~monorepo ~prefix ~subtree_path ~src_path
486
569
in
487
570
488
-
(* Validation *)
489
-
if not mono_exists then Error (Subtree_not_found name)
490
-
else if src_exists then Error (Src_already_exists name)
491
-
else if opam_files = [] then Error (No_opam_files name)
571
+
if not discovery.mono_exists then Error (Subtree_not_found name)
572
+
else if discovery.src_exists then Error (Src_already_exists name)
573
+
else if files = [] then Error (No_opam_files name)
492
574
else begin
493
-
(* Build actions for complete fork workflow:
494
-
1. Create src/<name>/ with content
495
-
2. Remove mono/<name>/ and commit
496
-
3. Re-add as subtree from src/<name>/ *)
497
575
let create_src_actions =
498
576
if has_subtree_hist then
499
-
(* Subtree with history: split and push to new repo *)
500
-
[
501
-
Create_directory checkouts;
502
-
Git_subtree_split { repo = monorepo; prefix };
503
-
Git_init src_path;
504
-
(* Allow pushing to checked-out branch (for monopam sync) *)
505
-
Git_config
506
-
{
507
-
repo = src_path;
508
-
key = "receive.denyCurrentBranch";
509
-
value = "updateInstead";
510
-
};
511
-
Git_add_remote
512
-
{ repo = src_path; name = "mono"; url = Fpath.to_string monorepo };
513
-
Git_push_ref
514
-
{
515
-
repo = monorepo;
516
-
target = Fpath.to_string src_path;
517
-
ref_spec = "SPLIT_COMMIT:refs/heads/main";
518
-
};
519
-
Git_checkout { repo = src_path; branch };
520
-
]
521
-
else
522
-
(* Fresh package: copy files and create initial commit *)
523
-
[
524
-
Create_directory checkouts;
525
-
Create_directory src_path;
526
-
Git_init src_path;
527
-
(* Allow pushing to checked-out branch (for monopam sync) *)
528
-
Git_config
529
-
{
530
-
repo = src_path;
531
-
key = "receive.denyCurrentBranch";
532
-
value = "updateInstead";
533
-
};
534
-
Git_branch_rename { repo = src_path; new_name = branch };
535
-
Copy_directory { src = subtree_path; dest = src_path };
536
-
Git_add_all src_path;
537
-
Git_commit
538
-
{ repo = src_path; message = Fmt.str "Initial commit of %s" name };
539
-
]
577
+
fork_actions_with_history ~checkouts ~monorepo ~src_path ~prefix ~branch
578
+
else fork_actions_fresh ~checkouts ~subtree_path ~src_path ~name ~branch
540
579
in
541
-
542
-
(* Add remote if push_url provided *)
543
580
let remote_actions =
544
581
match push_url with
545
582
| Some url -> [ Git_add_remote { repo = src_path; name = "origin"; url } ]
546
583
| None -> []
547
584
in
548
-
549
-
(* Remove from mono and re-add as subtree *)
550
585
let rejoin_actions =
551
-
[
552
-
Git_rm { repo = monorepo; path = prefix; recursive = true };
553
-
Git_commit
554
-
{ repo = monorepo; message = Fmt.str "Remove %s for fork" name };
555
-
Git_subtree_add
556
-
{
557
-
repo = monorepo;
558
-
prefix;
559
-
url = Uri.of_string (Fpath.to_string src_path);
560
-
branch;
561
-
};
562
-
]
586
+
fork_rejoin_actions ~monorepo ~src_path ~prefix ~name ~branch
563
587
in
564
-
565
-
(* Update sources.toml only if push_url is a true fork (different namespace) *)
566
-
let handle = Verse_config.handle config in
567
588
let sources_actions =
568
-
match push_url with
569
-
| Some url when not (is_own_namespace ~handle url) ->
570
-
[
571
-
Update_sources_toml
572
-
{
573
-
path = Fpath.(monorepo / "sources.toml");
574
-
name;
575
-
entry =
576
-
Sources_registry.
577
-
{
578
-
url = normalize_git_url url;
579
-
upstream = None;
580
-
branch = Some branch;
581
-
reason = None;
582
-
origin = Some Fork;
583
-
};
584
-
};
585
-
]
586
-
| Some _ -> [] (* Own namespace - no sources.toml entry needed *)
587
-
| None -> []
589
+
fork_sources_actions ~monorepo ~name ~handle ~push_url ~branch
588
590
in
589
-
590
591
let actions =
591
592
create_src_actions @ remote_actions @ rejoin_actions @ sources_actions
592
593
in
593
-
594
594
let result =
595
595
{
596
596
name;
···
598
598
(if has_subtree_hist then "(will be computed)" else "(fresh package)");
599
599
src_path;
600
600
push_url;
601
-
packages_created = opam_files;
601
+
packages_created = files;
602
602
}
603
603
in
604
-
605
604
Ok { discovery; actions; result; dry_run }
606
605
end
607
606
608
607
(** Build a join plan - handles both URL and local path *)
608
+
609
+
(** {2 Join Plan Helpers} *)
610
+
611
+
(** Build join actions from local git repo. *)
612
+
let join_local_repo_actions ~checkouts ~monorepo ~local_path ~src_path ~prefix
613
+
~branch =
614
+
[
615
+
Create_directory checkouts;
616
+
Copy_directory { src = local_path; dest = src_path };
617
+
Git_subtree_add
618
+
{
619
+
repo = monorepo;
620
+
prefix;
621
+
url = Uri.of_string (Fpath.to_string src_path);
622
+
branch;
623
+
};
624
+
]
625
+
626
+
(** Build join actions from local directory without git. *)
627
+
let join_local_dir_actions ~checkouts ~monorepo ~local_path ~src_path ~prefix
628
+
~name ~branch =
629
+
[
630
+
Create_directory checkouts;
631
+
Create_directory src_path;
632
+
Git_init src_path;
633
+
Copy_directory { src = local_path; dest = src_path };
634
+
Git_add_all src_path;
635
+
Git_commit
636
+
{ repo = src_path; message = Fmt.str "Initial commit of %s" name };
637
+
Git_branch_rename { repo = src_path; new_name = branch };
638
+
Git_subtree_add
639
+
{
640
+
repo = monorepo;
641
+
prefix;
642
+
url = Uri.of_string (Fpath.to_string src_path);
643
+
branch;
644
+
};
645
+
]
646
+
647
+
(** Build join actions from URL. *)
648
+
let join_url_actions ~checkouts ~monorepo ~src_path ~prefix ~source ~upstream
649
+
~name ~branch =
650
+
let url_uri = Uri.of_string source in
651
+
let base_actions =
652
+
[
653
+
Create_directory checkouts;
654
+
Git_clone { url = source; dest = src_path; branch };
655
+
Git_subtree_add { repo = monorepo; prefix; url = url_uri; branch };
656
+
]
657
+
in
658
+
let sources_actions =
659
+
match upstream with
660
+
| Some _ ->
661
+
[
662
+
Update_sources_toml
663
+
{
664
+
path = Fpath.(monorepo / "sources.toml");
665
+
name;
666
+
entry =
667
+
Sources_registry.
668
+
{
669
+
url = normalize_git_url source;
670
+
upstream = Option.map normalize_git_url upstream;
671
+
branch = Some branch;
672
+
reason = None;
673
+
origin = Some Join;
674
+
};
675
+
};
676
+
]
677
+
| None -> []
678
+
in
679
+
base_actions @ sources_actions
680
+
681
+
(** Build a join plan - handles both URL and local path *)
609
682
let plan_join ~proc ~fs ~config ~source ?name ?upstream ?(dry_run = false) () =
610
683
let is_local = is_local_path source in
611
684
let name = match name with Some n -> n | None -> name_from_url source in
···
613
686
let checkouts = Verse_config.src_path config in
614
687
let prefix = name in
615
688
let src_path = Fpath.(checkouts / name) in
689
+
let branch = Verse_config.default_branch in
616
690
617
-
(* Gather discovery information *)
618
691
let subtree_exists = is_directory ~fs Fpath.(monorepo / prefix) in
619
692
let src_exists = is_directory ~fs src_path in
620
693
let local_is_repo =
621
-
if is_local then begin
694
+
if is_local then
622
695
match Fpath.of_string source with
623
696
| Ok path -> Some (Git.Repository.is_repo ~fs path)
624
697
| Error _ -> Some false
625
-
end
626
698
else None
627
699
in
628
-
629
700
let discovery =
630
701
{
631
702
mono_exists = subtree_exists;
···
633
704
has_subtree_history = false;
634
705
remote_accessible = None;
635
706
opam_files = [];
636
-
(* Will be discovered after join *)
637
707
local_path_is_repo = local_is_repo;
638
708
}
639
709
in
640
710
641
-
(* Validation *)
642
711
if subtree_exists then Error (Subtree_already_exists name)
643
712
else begin
644
-
let branch = Verse_config.default_branch in
645
713
let actions =
646
-
if is_local then begin
647
-
(* Join from local directory *)
714
+
if is_local then
648
715
match Fpath.of_string source with
649
716
| Error (`Msg msg) -> raise (Invalid_argument msg)
650
717
| Ok local_path ->
651
-
let has_repo = Option.value ~default:false local_is_repo in
652
-
if has_repo then
653
-
(* Local git repo - use it directly *)
654
-
[
655
-
Create_directory checkouts;
656
-
Copy_directory { src = local_path; dest = src_path };
657
-
Git_subtree_add
658
-
{
659
-
repo = monorepo;
660
-
prefix;
661
-
url = Uri.of_string (Fpath.to_string src_path);
662
-
branch;
663
-
};
664
-
]
718
+
if Option.value ~default:false local_is_repo then
719
+
join_local_repo_actions ~checkouts ~monorepo ~local_path ~src_path
720
+
~prefix ~branch
665
721
else
666
-
(* Local directory without git - init and commit first *)
667
-
[
668
-
Create_directory checkouts;
669
-
Create_directory src_path;
670
-
Git_init src_path;
671
-
Copy_directory { src = local_path; dest = src_path };
672
-
Git_add_all src_path;
673
-
Git_commit
674
-
{
675
-
repo = src_path;
676
-
message = Fmt.str "Initial commit of %s" name;
677
-
};
678
-
Git_branch_rename { repo = src_path; new_name = branch };
679
-
(* Ensure branch is named correctly *)
680
-
Git_subtree_add
681
-
{
682
-
repo = monorepo;
683
-
prefix;
684
-
url = Uri.of_string (Fpath.to_string src_path);
685
-
branch;
686
-
};
687
-
]
688
-
end
689
-
else begin
690
-
(* Join from URL (existing behavior) *)
691
-
let url_uri = Uri.of_string source in
692
-
let base_actions =
693
-
[
694
-
Create_directory checkouts;
695
-
Git_clone { url = source; dest = src_path; branch };
696
-
Git_subtree_add { repo = monorepo; prefix; url = url_uri; branch };
697
-
]
698
-
in
699
-
let sources_actions =
700
-
match upstream with
701
-
| Some _ ->
702
-
[
703
-
Update_sources_toml
704
-
{
705
-
path = Fpath.(monorepo / "sources.toml");
706
-
name;
707
-
entry =
708
-
Sources_registry.
709
-
{
710
-
url = normalize_git_url source;
711
-
upstream = Option.map normalize_git_url upstream;
712
-
branch = Some branch;
713
-
reason = None;
714
-
origin = Some Join;
715
-
};
716
-
};
717
-
]
718
-
| None -> []
719
-
in
720
-
base_actions @ sources_actions
721
-
end
722
+
join_local_dir_actions ~checkouts ~monorepo ~local_path ~src_path
723
+
~prefix ~name ~branch
724
+
else
725
+
join_url_actions ~checkouts ~monorepo ~src_path ~prefix ~source
726
+
~upstream ~name ~branch
722
727
in
723
-
724
-
(* Peek at opam files if local *)
725
728
let opam_preview =
726
729
if is_local then
727
730
match Fpath.of_string source with
728
-
| Ok path -> find_opam_files ~fs path
731
+
| Ok path -> opam_files ~fs path
729
732
| Error _ -> []
730
733
else []
731
734
in
732
-
733
735
let result =
734
736
{
735
737
name;
···
739
741
from_handle = None;
740
742
}
741
743
in
742
-
743
744
Ok
744
745
{
745
746
discovery = { discovery with opam_files = opam_preview };
···
762
763
let src_is_repo =
763
764
if src_exists then Git.Repository.is_repo ~fs src_path else false
764
765
in
765
-
let opam_files = if src_exists then find_opam_files ~fs src_path else [] in
766
+
let opam_files = if src_exists then opam_files ~fs src_path else [] in
766
767
767
768
let discovery =
768
769
{
···
813
814
type exec_state = { mutable split_commit : string option }
814
815
(** State tracked during plan execution *)
815
816
817
+
(** {2 Action Execution Helpers} *)
818
+
819
+
(** Execute git config action. *)
820
+
let exec_git_config ~fs ~repo ~key ~value =
821
+
let git_repo = Git.Repository.open_repo ~fs repo in
822
+
let config =
823
+
match Git.Repository.read_config git_repo with
824
+
| Some c -> c
825
+
| None -> Git.Config.empty
826
+
in
827
+
let section, key_name =
828
+
match String.split_on_char '.' key with
829
+
| [ s; k ] -> (Git.Config.section s, k)
830
+
| _ -> (Git.Config.section "core", key)
831
+
in
832
+
let config = Git.Config.set config ~section ~key:key_name ~value in
833
+
Git.Repository.write_config git_repo config;
834
+
Ok ()
835
+
836
+
(** Execute git subtree split action. *)
837
+
let exec_subtree_split ~fs ~state ~repo ~prefix =
838
+
let git_repo = Git.Repository.open_repo ~fs repo in
839
+
match Git.Repository.read_ref git_repo "HEAD" with
840
+
| None -> Error (Git_error (Git_cli.Io_error "no HEAD ref found"))
841
+
| Some head -> (
842
+
match Git.Subtree.split git_repo ~prefix ~head () with
843
+
| Ok None -> Error (Git_error (Git_cli.Subtree_prefix_missing prefix))
844
+
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
845
+
| Ok (Some split_hash) ->
846
+
state.split_commit <- Some (Git.Hash.to_hex split_hash);
847
+
Ok ())
848
+
849
+
(** Execute git subtree add action. *)
850
+
let exec_subtree_add ~proc ~fs ~repo ~prefix ~url ~branch =
851
+
match Git_cli.fetch_url ~proc ~fs ~repo ~url ~branch () with
852
+
| Error e -> Error (Git_error e)
853
+
| Ok hash_hex -> (
854
+
let git_repo = Git.Repository.open_repo ~fs repo in
855
+
let commit = Git.Hash.of_hex hash_hex in
856
+
let user =
857
+
match Git_cli.global_git_user () with
858
+
| Some u -> u
859
+
| None ->
860
+
Git.User.v ~name:"monopam" ~email:"monopam@localhost"
861
+
~date:(Int64.of_float (Unix.time ()))
862
+
()
863
+
in
864
+
let message =
865
+
Fmt.str "Add '%s' from %s\n\ngit-subtree-dir: %s\n" prefix
866
+
(Uri.to_string url) prefix
867
+
in
868
+
match
869
+
Git.Subtree.add git_repo ~prefix ~commit ~author:user ~committer:user
870
+
~message ()
871
+
with
872
+
| Ok _ -> Ok ()
873
+
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg)))
874
+
875
+
(** Replace SPLIT_COMMIT placeholder in refspec. *)
876
+
let replace_split_commit ~state ref_spec =
877
+
match state.split_commit with
878
+
| Some commit when String.length ref_spec >= 12 ->
879
+
if String.sub ref_spec 0 12 = "SPLIT_COMMIT" then
880
+
commit ^ String.sub ref_spec 12 (String.length ref_spec - 12)
881
+
else ref_spec
882
+
| _ -> ref_spec
883
+
884
+
(** Execute update sources.toml action. *)
885
+
let exec_update_sources ~fs ~path ~name ~entry =
886
+
let sources =
887
+
match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) path with
888
+
| Ok s -> s
889
+
| Error _ -> Sources_registry.empty
890
+
in
891
+
let sources = Sources_registry.add sources ~subtree:name entry in
892
+
match Sources_registry.save ~fs:(fs :> _ Eio.Path.t) path sources with
893
+
| Ok () -> Ok ()
894
+
| Error msg ->
895
+
Error (Config_error (Fmt.str "Failed to update sources.toml: %s" msg))
896
+
816
897
(** Execute a single action *)
817
898
let execute_action ~proc ~fs ~state action =
818
899
match action with
819
-
| Check_remote_exists _url ->
820
-
(* Informational only - always succeeds *)
821
-
Ok ()
900
+
| Check_remote_exists _url -> Ok ()
822
901
| Create_directory path ->
823
902
ensure_dir ~fs path;
824
903
Ok ()
825
904
| Git_init path ->
826
905
let (_ : Git.Repository.t) = Git.Repository.init ~fs path in
827
906
Ok ()
828
-
| Git_config { repo; key; value } ->
829
-
let git_repo = Git.Repository.open_repo ~fs repo in
830
-
let config =
831
-
match Git.Repository.read_config git_repo with
832
-
| Some c -> c
833
-
| None -> Git.Config.empty
834
-
in
835
-
(* Parse key as "section.key" format *)
836
-
let section, key_name =
837
-
match String.split_on_char '.' key with
838
-
| [ s; k ] -> (Git.Config.section s, k)
839
-
| _ -> (Git.Config.section "core", key)
840
-
in
841
-
let config = Git.Config.set config ~section ~key:key_name ~value in
842
-
Git.Repository.write_config git_repo config;
843
-
Ok ()
907
+
| Git_config { repo; key; value } -> exec_git_config ~fs ~repo ~key ~value
844
908
| Git_clone { url; dest; branch } ->
845
909
Git_cli.clone ~proc ~fs ~url:(Uri.of_string url) ~branch dest
846
910
|> Result.map_error (fun e -> Git_error e)
847
-
| Git_subtree_split { repo; prefix } -> (
848
-
let git_repo = Git.Repository.open_repo ~fs repo in
849
-
match Git.Repository.read_ref git_repo "HEAD" with
850
-
| None -> Error (Git_error (Git_cli.Io_error "no HEAD ref found"))
851
-
| Some head -> (
852
-
match Git.Subtree.split git_repo ~prefix ~head () with
853
-
| Ok None -> Error (Git_error (Git_cli.Subtree_prefix_missing prefix))
854
-
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
855
-
| Ok (Some split_hash) ->
856
-
state.split_commit <- Some (Git.Hash.to_hex split_hash);
857
-
Ok ()))
858
-
| Git_subtree_add { repo; prefix; url; branch } -> (
859
-
(* Fetch the branch first to get the commit *)
860
-
match Git_cli.fetch_url ~proc ~fs ~repo ~url ~branch () with
861
-
| Error e -> Error (Git_error e)
862
-
| Ok hash_hex -> (
863
-
let git_repo = Git.Repository.open_repo ~fs repo in
864
-
let commit = Git.Hash.of_hex hash_hex in
865
-
let user =
866
-
match Git_cli.global_git_user () with
867
-
| Some u -> u
868
-
| None ->
869
-
Git.User.v ~name:"monopam" ~email:"monopam@localhost"
870
-
~date:(Int64.of_float (Unix.time ()))
871
-
()
872
-
in
873
-
let message =
874
-
Fmt.str "Add '%s' from %s\n\ngit-subtree-dir: %s\n" prefix
875
-
(Uri.to_string url) prefix
876
-
in
877
-
match
878
-
Git.Subtree.add git_repo ~prefix ~commit ~author:user
879
-
~committer:user ~message ()
880
-
with
881
-
| Ok _ -> Ok ()
882
-
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))))
911
+
| Git_subtree_split { repo; prefix } ->
912
+
exec_subtree_split ~fs ~state ~repo ~prefix
913
+
| Git_subtree_add { repo; prefix; url; branch } ->
914
+
exec_subtree_add ~proc ~fs ~repo ~prefix ~url ~branch
883
915
| Git_add_remote { repo; name; url } ->
884
916
let git_repo = Git.Repository.open_repo ~fs repo in
885
917
Git.Repository.add_remote git_repo ~name ~url ()
886
918
|> Result.map_error (fun (`Msg msg) -> Git_error (Git_cli.Io_error msg))
887
919
| Git_push_ref { repo; target; ref_spec } ->
888
-
(* Replace SPLIT_COMMIT placeholder with actual commit if available *)
889
-
let ref_spec =
890
-
match state.split_commit with
891
-
| Some commit ->
892
-
String.concat ""
893
-
(String.split_on_char 'S'
894
-
(String.concat commit (String.split_on_char 'S' ref_spec)))
895
-
|> fun s ->
896
-
if String.starts_with ~prefix:"PLIT_COMMIT" s then
897
-
Option.value ~default:ref_spec state.split_commit
898
-
^ String.sub s 11 (String.length s - 11)
899
-
else s
900
-
| None -> ref_spec
901
-
in
902
-
(* Better replacement: look for SPLIT_COMMIT literal *)
903
-
let ref_spec =
904
-
match state.split_commit with
905
-
| Some commit ->
906
-
if
907
-
String.length ref_spec >= 12
908
-
&& String.sub ref_spec 0 12 = "SPLIT_COMMIT"
909
-
then commit ^ String.sub ref_spec 12 (String.length ref_spec - 12)
910
-
else ref_spec
911
-
| None -> ref_spec
912
-
in
920
+
let ref_spec = replace_split_commit ~state ref_spec in
913
921
Git_cli.push_ref ~proc ~fs ~repo ~target ~ref_spec ()
914
922
|> Result.map_error (fun e -> Git_error e)
915
923
| Git_checkout { repo; branch } ->
···
936
944
let git_repo = Git.Repository.open_repo ~fs repo in
937
945
Git.Repository.rm git_repo ~recursive path
938
946
|> Result.map_error (fun (`Msg msg) -> Git_error (Git_cli.Io_error msg))
939
-
| Update_sources_toml { path; name; entry } -> (
940
-
let sources =
941
-
match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) path with
942
-
| Ok s -> s
943
-
| Error _ -> Sources_registry.empty
944
-
in
945
-
let sources = Sources_registry.add sources ~subtree:name entry in
946
-
match Sources_registry.save ~fs:(fs :> _ Eio.Path.t) path sources with
947
-
| Ok () -> Ok ()
948
-
| Error msg ->
949
-
Error (Config_error (Fmt.str "Failed to update sources.toml: %s" msg))
950
-
)
947
+
| Update_sources_toml { path; name; entry } ->
948
+
exec_update_sources ~fs ~path ~name ~entry
951
949
952
950
(** Execute a complete fork action plan *)
953
951
let execute_fork_plan ~proc ~fs plan =
···
1004
1002
else if is_directory ~fs src_path then Error (Src_already_exists name)
1005
1003
else begin
1006
1004
(* Find .opam files in subtree *)
1007
-
let packages = find_opam_files ~fs subtree_path in
1005
+
let packages = opam_files ~fs subtree_path in
1008
1006
if packages = [] then Error (No_opam_files name)
1009
1007
else if dry_run then
1010
1008
Ok
···
1174
1172
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
1175
1173
| Ok _ ->
1176
1174
(* Find .opam files in the new subtree *)
1177
-
let packages = find_opam_files ~fs subtree_path in
1175
+
let packages = opam_files ~fs subtree_path in
1178
1176
(* Only update sources.toml if there's an upstream to track *)
1179
1177
(match upstream with
1180
1178
| Some _ -> (