forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
fix(lint): resolve E320, E331 in monopam
Rename find_other_repos to other_repos, make_local_member to
local_member (E331), fix push.ml shadowing bug, and extract helpers
to reduce complexity (E320).
+2094
-2337
+39
-43
bin/cmd_add.ml
+39
-43
bin/cmd_add.ml
···
1
1
open Cmdliner
2
2
3
+
let parse_source source =
4
+
if String.ends_with ~suffix:".lock" source then
5
+
Monopam.Import.Lock_file (Fpath.v source)
6
+
else
7
+
(* Parse opam URL syntax: URL#ref *)
8
+
let url, ref_ =
9
+
match String.rindex_opt source '#' with
10
+
| Some i ->
11
+
let url = String.sub source 0 i in
12
+
let ref_ = String.sub source (i + 1) (String.length source - i - 1) in
13
+
(url, Some ref_)
14
+
| None -> (source, None)
15
+
in
16
+
Monopam.Import.Git_url { url; branch = None; ref_ }
17
+
18
+
let run source dir dry_run () =
19
+
Eio_main.run @@ fun env ->
20
+
let fs = Eio.Stdenv.fs env in
21
+
let proc = Eio.Stdenv.process_mgr env in
22
+
let target = Fpath.v (Sys.getcwd ()) in
23
+
let source = parse_source source in
24
+
match Monopam.Import.run ~proc ~fs ~target ~source ~name:dir ~dry_run () with
25
+
| Ok results ->
26
+
if results = [] then Fmt.pr "Nothing added.@."
27
+
else begin
28
+
Fmt.pr "Added %d subtree%s:@." (List.length results)
29
+
(if List.length results = 1 then "" else "s");
30
+
List.iter
31
+
(fun r ->
32
+
Fmt.pr " %s (%s)@." r.Monopam.Import.name
33
+
(String.sub r.Monopam.Import.commit 0
34
+
(min 7 (String.length r.Monopam.Import.commit))))
35
+
results
36
+
end;
37
+
`Ok ()
38
+
| Error e ->
39
+
Fmt.epr "Error: %s@." e;
40
+
`Error (false, "add failed")
41
+
3
42
let cmd =
4
43
let doc = "Add a package from a git URL or lock file" in
5
44
let man =
···
52
91
let dry_run_arg =
53
92
let doc = "Show what would be added without making changes." in
54
93
Arg.(value & flag & info [ "dry-run"; "n" ] ~doc)
55
-
in
56
-
let run source dir dry_run () =
57
-
Eio_main.run @@ fun env ->
58
-
let fs = Eio.Stdenv.fs env in
59
-
let proc = Eio.Stdenv.process_mgr env in
60
-
let target = Fpath.v (Sys.getcwd ()) in
61
-
(* Auto-detect if source is a lock file or git URL *)
62
-
let source =
63
-
if String.ends_with ~suffix:".lock" source then
64
-
Monopam.Import.Lock_file (Fpath.v source)
65
-
else
66
-
(* Parse opam URL syntax: URL#ref *)
67
-
let url, ref_ =
68
-
match String.rindex_opt source '#' with
69
-
| Some i ->
70
-
let url = String.sub source 0 i in
71
-
let ref_ =
72
-
String.sub source (i + 1) (String.length source - i - 1)
73
-
in
74
-
(url, Some ref_)
75
-
| None -> (source, None)
76
-
in
77
-
Monopam.Import.Git_url { url; branch = None; ref_ }
78
-
in
79
-
match
80
-
Monopam.Import.run ~proc ~fs ~target ~source ~name:dir ~dry_run ()
81
-
with
82
-
| Ok results ->
83
-
if results = [] then Fmt.pr "Nothing added.@."
84
-
else begin
85
-
Fmt.pr "Added %d subtree%s:@." (List.length results)
86
-
(if List.length results = 1 then "" else "s");
87
-
List.iter
88
-
(fun r ->
89
-
Fmt.pr " %s (%s)@." r.Monopam.Import.name
90
-
(String.sub r.Monopam.Import.commit 0
91
-
(min 7 (String.length r.Monopam.Import.commit))))
92
-
results
93
-
end;
94
-
`Ok ()
95
-
| Error e ->
96
-
Fmt.epr "Error: %s@." e;
97
-
`Error (false, "add failed")
98
94
in
99
95
Cmd.v info
100
96
Term.(
+60
-68
bin/cmd_diff.ml
+60
-68
bin/cmd_diff.ml
···
1
1
open Cmdliner
2
2
3
+
let print_diff ~fs ~config status incoming =
4
+
let pkg = status.Monopam.Status.package in
5
+
let repo_name = Monopam.Package.repo_name pkg in
6
+
let checkouts_root = Monopam.Config.Paths.checkouts config in
7
+
let checkout_path = Fpath.(checkouts_root / repo_name) in
8
+
let fs_t = (fs :> Eio.Fs.dir_ty Eio.Path.t) in
9
+
if Eio.Path.is_directory Eio.Path.(fs_t / Fpath.to_string checkout_path) then
10
+
let base, tip =
11
+
if incoming then ("HEAD", "origin/main") else ("origin/main", "HEAD")
12
+
in
13
+
let repo = Git.Repository.open_repo ~fs:fs_t checkout_path in
14
+
match Git.Repository.log_range_refs repo ~base ~tip ~max_count:20 () with
15
+
| Ok [] -> false
16
+
| Ok entries ->
17
+
let direction = if incoming then "incoming" else "outgoing" in
18
+
Fmt.pr "@.%a (%s, %d commits):@."
19
+
Fmt.(styled `Bold string)
20
+
repo_name direction (List.length entries);
21
+
List.iter
22
+
(fun (e : Git.Repository.log_entry) ->
23
+
let short_hash = String.sub e.hash 0 7 in
24
+
Fmt.pr " %a %s@." Fmt.(styled `Yellow string) short_hash e.subject)
25
+
entries;
26
+
true
27
+
| Error _ -> false
28
+
else false
29
+
30
+
let run package incoming () =
31
+
Eio_main.run @@ fun env ->
32
+
Common.with_config env @@ fun config ->
33
+
let fs = Eio.Stdenv.fs env in
34
+
match Monopam.status ~fs:(fs :> Eio.Fs.dir_ty Eio.Path.t) ~config () with
35
+
| Error e ->
36
+
Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e;
37
+
`Error (false, "diff failed")
38
+
| Ok statuses ->
39
+
let statuses =
40
+
match package with
41
+
| Some name ->
42
+
List.filter
43
+
(fun s -> Monopam.Package.name s.Monopam.Status.package = name)
44
+
statuses
45
+
| None -> statuses
46
+
in
47
+
if statuses = [] then begin
48
+
(match package with
49
+
| Some name -> Fmt.epr "Package not found: %s@." name
50
+
| None -> Fmt.epr "No packages found@.");
51
+
`Error (false, "no packages")
52
+
end
53
+
else begin
54
+
let has_diff =
55
+
List.exists
56
+
(fun status -> print_diff ~fs ~config status incoming)
57
+
statuses
58
+
in
59
+
if not has_diff then Fmt.pr "No differences.@.";
60
+
`Ok ()
61
+
end
62
+
3
63
let cmd =
4
64
let doc = "Show diff between monorepo and upstream" in
5
65
let man =
···
26
86
let incoming_arg =
27
87
let doc = "Show incoming changes from upstream (what you would pull)." in
28
88
Arg.(value & flag & info [ "incoming"; "i" ] ~doc)
29
-
in
30
-
let run package incoming () =
31
-
Eio_main.run @@ fun env ->
32
-
Common.with_config env @@ fun config ->
33
-
let fs = Eio.Stdenv.fs env in
34
-
match Monopam.status ~fs ~config () with
35
-
| Error e ->
36
-
Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e;
37
-
`Error (false, "diff failed")
38
-
| Ok statuses ->
39
-
let statuses =
40
-
match package with
41
-
| Some name ->
42
-
List.filter
43
-
(fun s -> Monopam.Package.name s.Monopam.Status.package = name)
44
-
statuses
45
-
| None -> statuses
46
-
in
47
-
if statuses = [] then begin
48
-
(match package with
49
-
| Some name -> Fmt.epr "Package not found: %s@." name
50
-
| None -> Fmt.epr "No packages found@.");
51
-
`Error (false, "no packages")
52
-
end
53
-
else begin
54
-
let has_diff = ref false in
55
-
List.iter
56
-
(fun status ->
57
-
let pkg = status.Monopam.Status.package in
58
-
let repo_name = Monopam.Package.repo_name pkg in
59
-
let checkouts_root = Monopam.Config.Paths.checkouts config in
60
-
let checkout_path = Fpath.(checkouts_root / repo_name) in
61
-
let fs_t = (fs :> Eio.Fs.dir_ty Eio.Path.t) in
62
-
if
63
-
Eio.Path.is_directory
64
-
Eio.Path.(fs_t / Fpath.to_string checkout_path)
65
-
then begin
66
-
(* Use log_range to show commits *)
67
-
let base, tip =
68
-
if incoming then ("HEAD", "origin/main")
69
-
else ("origin/main", "HEAD")
70
-
in
71
-
let repo = Git.Repository.open_repo ~fs checkout_path in
72
-
match
73
-
Git.Repository.log_range_refs repo ~base ~tip ~max_count:20 ()
74
-
with
75
-
| Ok [] -> () (* No diff *)
76
-
| Ok entries ->
77
-
has_diff := true;
78
-
let direction =
79
-
if incoming then "incoming" else "outgoing"
80
-
in
81
-
Fmt.pr "@.%a (%s, %d commits):@."
82
-
Fmt.(styled `Bold string)
83
-
repo_name direction (List.length entries);
84
-
List.iter
85
-
(fun (e : Git.Repository.log_entry) ->
86
-
let short_hash = String.sub e.hash 0 7 in
87
-
Fmt.pr " %a %s@."
88
-
Fmt.(styled `Yellow string)
89
-
short_hash e.subject)
90
-
entries
91
-
| Error _ -> ()
92
-
end)
93
-
statuses;
94
-
if not !has_diff then Fmt.pr "No differences.@.";
95
-
`Ok ()
96
-
end
97
89
in
98
90
Cmd.v info
99
91
Term.(
+69
-70
bin/cmd_fetch.ml
+69
-70
bin/cmd_fetch.ml
···
1
1
open Cmdliner
2
2
3
+
let fetch_repos ~proc ~fs ~config statuses =
4
+
let seen = Hashtbl.create 32 in
5
+
let repos =
6
+
List.filter_map
7
+
(fun status ->
8
+
let pkg = status.Monopam.Status.package in
9
+
let repo_name = Monopam.Package.repo_name pkg in
10
+
if Hashtbl.mem seen repo_name then None
11
+
else begin
12
+
Hashtbl.add seen repo_name true;
13
+
Some pkg
14
+
end)
15
+
statuses
16
+
in
17
+
let total = List.length repos in
18
+
Fmt.pr "Fetching %d repositories...@." total;
19
+
let fs_t = (fs :> Eio.Fs.dir_ty Eio.Path.t) in
20
+
let fetched = ref 0 in
21
+
let errors = ref 0 in
22
+
List.iter
23
+
(fun pkg ->
24
+
let repo_name = Monopam.Package.repo_name pkg in
25
+
let checkouts_root = Monopam.Config.Paths.checkouts config in
26
+
let checkout_path = Fpath.(checkouts_root / repo_name) in
27
+
if Eio.Path.is_directory Eio.Path.(fs_t / Fpath.to_string checkout_path)
28
+
then (
29
+
match Monopam.Git_cli.fetch ~proc ~fs:fs_t checkout_path with
30
+
| Ok () ->
31
+
incr fetched;
32
+
Fmt.pr " %s: fetched@." repo_name
33
+
| Error e ->
34
+
incr errors;
35
+
Fmt.epr " %s: %a@." repo_name Monopam.Git_cli.pp_error e)
36
+
else Fmt.pr " %s: not cloned, skipping@." repo_name)
37
+
repos;
38
+
Fmt.pr "@.Fetched %d repositories" !fetched;
39
+
if !errors > 0 then Fmt.pr " (%d errors)" !errors;
40
+
Fmt.pr ".@.";
41
+
Fmt.pr "@.Run $(b,monopam diff --incoming) to see changes.@."
42
+
43
+
let run package () =
44
+
Eio_main.run @@ fun env ->
45
+
Common.with_config env @@ fun config ->
46
+
let fs = Eio.Stdenv.fs env in
47
+
let proc = Eio.Stdenv.process_mgr env in
48
+
match Monopam.Ctx.status ~fs ~config () with
49
+
| Error e ->
50
+
Fmt.epr "Error: %a@." Monopam.Ctx.pp_error_with_hint e;
51
+
`Error (false, "fetch failed")
52
+
| Ok statuses ->
53
+
let statuses =
54
+
match package with
55
+
| Some name ->
56
+
List.filter
57
+
(fun s -> Monopam.Package.name s.Monopam.Status.package = name)
58
+
statuses
59
+
| None -> statuses
60
+
in
61
+
if statuses = [] then begin
62
+
(match package with
63
+
| Some name -> Fmt.epr "Package not found: %s@." name
64
+
| None -> Fmt.epr "No packages found@.");
65
+
`Error (false, "no packages")
66
+
end
67
+
else begin
68
+
fetch_repos ~proc ~fs ~config statuses;
69
+
`Ok ()
70
+
end
71
+
3
72
let cmd =
4
73
let doc = "Fetch changes from upstream without merging" in
5
74
let man =
···
27
96
]
28
97
in
29
98
let info = Cmd.info "fetch" ~doc ~man in
30
-
let run package () =
31
-
Eio_main.run @@ fun env ->
32
-
Common.with_config env @@ fun config ->
33
-
let fs = Eio.Stdenv.fs env in
34
-
let proc = Eio.Stdenv.process_mgr env in
35
-
(* Get status to find packages *)
36
-
match Monopam.Ctx.status ~fs ~config () with
37
-
| Error e ->
38
-
Fmt.epr "Error: %a@." Monopam.Ctx.pp_error_with_hint e;
39
-
`Error (false, "fetch failed")
40
-
| Ok statuses ->
41
-
let statuses =
42
-
match package with
43
-
| Some name ->
44
-
List.filter
45
-
(fun s -> Monopam.Package.name s.Monopam.Status.package = name)
46
-
statuses
47
-
| None -> statuses
48
-
in
49
-
if statuses = [] then begin
50
-
(match package with
51
-
| Some name -> Fmt.epr "Package not found: %s@." name
52
-
| None -> Fmt.epr "No packages found@.");
53
-
`Error (false, "no packages")
54
-
end
55
-
else begin
56
-
(* Get unique repos *)
57
-
let seen = Hashtbl.create 32 in
58
-
let repos =
59
-
List.filter_map
60
-
(fun status ->
61
-
let pkg = status.Monopam.Status.package in
62
-
let repo_name = Monopam.Package.repo_name pkg in
63
-
if Hashtbl.mem seen repo_name then None
64
-
else begin
65
-
Hashtbl.add seen repo_name true;
66
-
Some pkg
67
-
end)
68
-
statuses
69
-
in
70
-
let total = List.length repos in
71
-
Fmt.pr "Fetching %d repositories...@." total;
72
-
let fs_t = (fs :> Eio.Fs.dir_ty Eio.Path.t) in
73
-
let fetched = ref 0 in
74
-
let errors = ref 0 in
75
-
List.iter
76
-
(fun pkg ->
77
-
let repo_name = Monopam.Package.repo_name pkg in
78
-
let checkouts_root = Monopam.Config.Paths.checkouts config in
79
-
let checkout_path = Fpath.(checkouts_root / repo_name) in
80
-
if
81
-
Eio.Path.is_directory
82
-
Eio.Path.(fs_t / Fpath.to_string checkout_path)
83
-
then (
84
-
match Monopam.Git_cli.fetch ~proc ~fs:fs_t checkout_path with
85
-
| Ok () ->
86
-
incr fetched;
87
-
Fmt.pr " %s: fetched@." repo_name
88
-
| Error e ->
89
-
incr errors;
90
-
Fmt.epr " %s: %a@." repo_name Monopam.Git_cli.pp_error e)
91
-
else Fmt.pr " %s: not cloned, skipping@." repo_name)
92
-
repos;
93
-
Fmt.pr "@.Fetched %d repositories" !fetched;
94
-
if !errors > 0 then Fmt.pr " (%d errors)" !errors;
95
-
Fmt.pr ".@.";
96
-
Fmt.pr "@.Run $(b,monopam diff --incoming) to see changes.@.";
97
-
`Ok ()
98
-
end
99
-
in
100
99
Cmd.v info Term.(ret (const run $ Common.package_arg $ Common.logging_term))
+22
-22
bin/cmd_init.ml
+22
-22
bin/cmd_init.ml
···
14
14
Arg.(
15
15
required & opt (some string) None & info [ "handle" ] ~docv:"HANDLE" ~doc)
16
16
17
+
let run root handle () =
18
+
Eio_main.run @@ fun env ->
19
+
let fs = Eio.Stdenv.fs env in
20
+
let proc = Eio.Stdenv.process_mgr env in
21
+
let root =
22
+
match root with
23
+
| Some r -> r
24
+
| None -> (
25
+
let cwd_path = Eio.Stdenv.cwd env in
26
+
let _, cwd_str = (cwd_path :> _ Eio.Path.t) in
27
+
match Fpath.of_string cwd_str with
28
+
| Ok p -> p
29
+
| Error (`Msg _) -> Fpath.v ".")
30
+
in
31
+
match Monopam.Verse.init ~proc ~fs ~root ~handle () with
32
+
| Ok () ->
33
+
Fmt.pr "Workspace initialized at %a@." Fpath.pp root;
34
+
`Ok ()
35
+
| Error e ->
36
+
Fmt.epr "Error: %a@." Monopam.Verse.pp_error_with_hint e;
37
+
`Error (false, "init failed")
38
+
17
39
let cmd =
18
40
let doc = "Initialize a new monopam workspace" in
19
41
let man =
···
64
86
]
65
87
in
66
88
let info = Cmd.info "init" ~doc ~man in
67
-
let run root handle () =
68
-
Eio_main.run @@ fun env ->
69
-
let fs = Eio.Stdenv.fs env in
70
-
let proc = Eio.Stdenv.process_mgr env in
71
-
let root =
72
-
match root with
73
-
| Some r -> r
74
-
| None -> (
75
-
let cwd_path = Eio.Stdenv.cwd env in
76
-
let _, cwd_str = (cwd_path :> _ Eio.Path.t) in
77
-
match Fpath.of_string cwd_str with
78
-
| Ok p -> p
79
-
| Error (`Msg _) -> Fpath.v ".")
80
-
in
81
-
match Monopam.Verse.init ~proc ~fs ~root ~handle () with
82
-
| Ok () ->
83
-
Fmt.pr "Workspace initialized at %a@." Fpath.pp root;
84
-
`Ok ()
85
-
| Error e ->
86
-
Fmt.epr "Error: %a@." Monopam.Verse.pp_error_with_hint e;
87
-
`Error (false, "init failed")
88
-
in
89
89
Cmd.v info
90
90
Term.(ret (const run $ root_arg $ handle_arg $ Common.logging_term))
+44
-50
bin/cmd_publish.ml
+44
-50
bin/cmd_publish.ml
···
1
1
open Cmdliner
2
2
3
+
let run packages opam_repo no_commit dry_run no_checkouts () =
4
+
Eio_main.run @@ fun env ->
5
+
let fs = Eio.Stdenv.fs env in
6
+
let proc = Eio.Stdenv.process_mgr env in
7
+
let source = Fpath.v (Sys.getcwd ()) in
8
+
let config_opt = Result.to_option (Common.load_config env) in
9
+
let target =
10
+
match opam_repo with
11
+
| Some path ->
12
+
if Filename.is_relative path then Fpath.(source / path)
13
+
else Fpath.v path
14
+
| None -> (
15
+
match config_opt with
16
+
| Some config -> Monopam.Config.Paths.opam_repo config
17
+
| None -> Fpath.(parent source / "opam-repo"))
18
+
in
19
+
if dry_run then
20
+
Fmt.pr "Dry run: publishing from %a to %a@." Fpath.pp source Fpath.pp target;
21
+
match
22
+
Monopam.Opam_sync.run_from_cwd ~fs ~proc ~source ~target ~packages
23
+
~no_commit ~dry_run ()
24
+
with
25
+
| Error (`Config_error e) ->
26
+
Fmt.epr "Error: %s@." e;
27
+
`Error (false, "publish failed")
28
+
| Ok opam_result ->
29
+
Fmt.pr "%a@." Monopam.Opam_sync.pp opam_result;
30
+
(match config_opt with
31
+
| Some config when (not no_checkouts) && not dry_run -> (
32
+
Fmt.pr "@.Exporting to checkouts...@.";
33
+
match
34
+
Monopam.Push.run ~proc ~fs ~config ~packages ~upstream:false
35
+
~clean:false ~force:false ()
36
+
with
37
+
| Ok () -> Fmt.pr "Checkouts updated.@."
38
+
| Error e ->
39
+
Fmt.epr "Warning: checkout export failed: %a@."
40
+
Monopam.Ctx.pp_error_with_hint e)
41
+
| Some _ when no_checkouts ->
42
+
Fmt.pr "(Skipping checkout export due to --no-checkouts)@."
43
+
| Some _ when dry_run -> Fmt.pr "(Would also export to checkouts)@."
44
+
| _ -> ());
45
+
`Ok ()
46
+
3
47
let cmd =
4
48
let doc = "Publish packages to opam-repo" in
5
49
let man =
···
61
105
let no_checkouts_arg =
62
106
let doc = "Skip exporting to checkouts (only publish opam files)." in
63
107
Arg.(value & flag & info [ "no-checkouts" ] ~doc)
64
-
in
65
-
let run packages opam_repo no_commit dry_run no_checkouts () =
66
-
Eio_main.run @@ fun env ->
67
-
let fs = Eio.Stdenv.fs env in
68
-
let proc = Eio.Stdenv.process_mgr env in
69
-
(* Determine source directory (CWD) *)
70
-
let source = Fpath.v (Sys.getcwd ()) in
71
-
(* Check if we have config (running from main mono) *)
72
-
let config_opt = Result.to_option (Common.load_config env) in
73
-
(* Determine target opam-repo *)
74
-
let target =
75
-
match opam_repo with
76
-
| Some path ->
77
-
if Filename.is_relative path then Fpath.(source / path)
78
-
else Fpath.v path
79
-
| None -> (
80
-
match config_opt with
81
-
| Some config -> Monopam.Config.Paths.opam_repo config
82
-
| None -> Fpath.(parent source / "opam-repo"))
83
-
in
84
-
if dry_run then
85
-
Fmt.pr "Dry run: publishing from %a to %a@." Fpath.pp source Fpath.pp
86
-
target;
87
-
(* Publish opam files *)
88
-
match
89
-
Monopam.Opam_sync.run_from_cwd ~fs ~proc ~source ~target ~packages
90
-
~no_commit ~dry_run ()
91
-
with
92
-
| Error (`Config_error e) ->
93
-
Fmt.epr "Error: %s@." e;
94
-
`Error (false, "publish failed")
95
-
| Ok opam_result ->
96
-
Fmt.pr "%a@." Monopam.Opam_sync.pp opam_result;
97
-
(* Also export to checkouts if we have config and not disabled *)
98
-
(match config_opt with
99
-
| Some config when (not no_checkouts) && not dry_run -> (
100
-
Fmt.pr "@.Exporting to checkouts...@.";
101
-
match
102
-
Monopam.Push.run ~proc ~fs ~config ~packages ~upstream:false
103
-
~clean:false ~force:false ()
104
-
with
105
-
| Ok () -> Fmt.pr "Checkouts updated.@."
106
-
| Error e ->
107
-
Fmt.epr "Warning: checkout export failed: %a@."
108
-
Monopam.Ctx.pp_error_with_hint e)
109
-
| Some _ when no_checkouts ->
110
-
Fmt.pr "(Skipping checkout export due to --no-checkouts)@."
111
-
| Some _ when dry_run -> Fmt.pr "(Would also export to checkouts)@."
112
-
| _ -> ());
113
-
`Ok ()
114
108
in
115
109
Cmd.v info
116
110
Term.(
+84
-85
bin/cmd_push.ml
+84
-85
bin/cmd_push.ml
···
1
1
open Cmdliner
2
2
3
+
let man =
4
+
[
5
+
`S Manpage.s_description;
6
+
`P
7
+
"Exports changes from your monorepo to upstream git repositories. This \
8
+
is how you publish your work.";
9
+
`S "WORKFLOW";
10
+
`P "After making and committing changes in mono/:";
11
+
`Pre
12
+
"# Edit files in mono/\n\
13
+
git add -A && git commit -m \"Add feature\"\n\
14
+
monopam push";
15
+
`S "WHAT IT DOES";
16
+
`I ("1.", "Validates that the monorepo has no uncommitted changes");
17
+
`I ("2.", "Exports subtree changes to checkouts (internal)");
18
+
`I ("3.", "Pushes checkouts to their upstream git remotes");
19
+
`S "OPTIONS";
20
+
`I
21
+
( "--local",
22
+
"Only export to checkouts without pushing to remotes. Useful for \
23
+
reviewing changes before pushing." );
24
+
`I
25
+
( "--clean",
26
+
"Clean commit history by removing empty commits from unrelated subtree \
27
+
merges." );
28
+
`I ("--force", "Force push to upstream (use with --clean).");
29
+
`S Manpage.s_examples;
30
+
`P "Push all changes to upstream:";
31
+
`Pre "monopam push";
32
+
`P "Push changes for a specific package:";
33
+
`Pre "monopam push eio";
34
+
`P "Export without pushing (for review):";
35
+
`Pre "monopam push --local";
36
+
`P "Push with cleaned history:";
37
+
`Pre "monopam push --clean";
38
+
]
39
+
40
+
let local_arg =
41
+
let doc =
42
+
"Only export to checkouts, don't push to remotes. Use to review changes."
43
+
in
44
+
Arg.(value & flag & info [ "local" ] ~doc)
45
+
46
+
let clean_arg =
47
+
let doc =
48
+
"Clean commit history before pushing. Removes empty commits from unrelated \
49
+
subtree merges while preserving tree content."
50
+
in
51
+
Arg.(value & flag & info [ "clean" ] ~doc)
52
+
53
+
let force_arg =
54
+
let doc = "Force push to upstream. Required when using --clean." in
55
+
Arg.(value & flag & info [ "force" ] ~doc)
56
+
57
+
let pp_success ~local_only ~elapsed =
58
+
if local_only then
59
+
Fmt.pr "@.%a Changes exported to checkouts in %a.@." Tty.Span.pp
60
+
(Tty.Span.styled Tty.Style.(fg Tty.Color.green) "✓")
61
+
Tty.Span.pp
62
+
(Tty.Span.styled Tty.Style.(fg Tty.Color.cyan) (Fmt.str "%.1fs" elapsed))
63
+
else
64
+
Fmt.pr "@.%a Changes pushed to upstream in %a.@." Tty.Span.pp
65
+
(Tty.Span.styled Tty.Style.(fg Tty.Color.green) "✓")
66
+
Tty.Span.pp
67
+
(Tty.Span.styled Tty.Style.(fg Tty.Color.cyan) (Fmt.str "%.1fs" elapsed))
68
+
69
+
let run packages local_only clean force () =
70
+
let t0 = Unix.gettimeofday () in
71
+
Eio_main.run @@ fun env ->
72
+
Common.with_config env @@ fun config ->
73
+
let fs = Eio.Stdenv.fs env in
74
+
let proc = Eio.Stdenv.process_mgr env in
75
+
match
76
+
Monopam.Push.run ~proc ~fs ~config ~packages ~upstream:(not local_only)
77
+
~clean ~force ()
78
+
with
79
+
| Ok () ->
80
+
let elapsed = Unix.gettimeofday () -. t0 in
81
+
pp_success ~local_only ~elapsed;
82
+
`Ok ()
83
+
| Error e ->
84
+
Fmt.epr "Error: %a@." Monopam.Ctx.pp_error_with_hint e;
85
+
`Error (false, "push failed")
86
+
3
87
let cmd =
4
88
let doc = "Push local changes to upstream repositories" in
5
-
let man =
6
-
[
7
-
`S Manpage.s_description;
8
-
`P
9
-
"Exports changes from your monorepo to upstream git repositories. This \
10
-
is how you publish your work.";
11
-
`S "WORKFLOW";
12
-
`P "After making and committing changes in mono/:";
13
-
`Pre
14
-
"# Edit files in mono/\n\
15
-
git add -A && git commit -m \"Add feature\"\n\
16
-
monopam push";
17
-
`S "WHAT IT DOES";
18
-
`I ("1.", "Validates that the monorepo has no uncommitted changes");
19
-
`I ("2.", "Exports subtree changes to checkouts (internal)");
20
-
`I ("3.", "Pushes checkouts to their upstream git remotes");
21
-
`S "OPTIONS";
22
-
`I
23
-
( "--local",
24
-
"Only export to checkouts without pushing to remotes. Useful for \
25
-
reviewing changes before pushing." );
26
-
`I
27
-
( "--clean",
28
-
"Clean commit history by removing empty commits from unrelated \
29
-
subtree merges." );
30
-
`I ("--force", "Force push to upstream (use with --clean).");
31
-
`S Manpage.s_examples;
32
-
`P "Push all changes to upstream:";
33
-
`Pre "monopam push";
34
-
`P "Push changes for a specific package:";
35
-
`Pre "monopam push eio";
36
-
`P "Export without pushing (for review):";
37
-
`Pre "monopam push --local";
38
-
`P "Push with cleaned history:";
39
-
`Pre "monopam push --clean";
40
-
]
41
-
in
42
89
let info = Cmd.info "push" ~doc ~man in
43
-
let local_arg =
44
-
let doc =
45
-
"Only export to checkouts, don't push to remotes. Use to review changes."
46
-
in
47
-
Arg.(value & flag & info [ "local" ] ~doc)
48
-
in
49
-
let clean_arg =
50
-
let doc =
51
-
"Clean commit history before pushing. Removes empty commits from \
52
-
unrelated subtree merges while preserving tree content."
53
-
in
54
-
Arg.(value & flag & info [ "clean" ] ~doc)
55
-
in
56
-
let force_arg =
57
-
let doc = "Force push to upstream. Required when using --clean." in
58
-
Arg.(value & flag & info [ "force" ] ~doc)
59
-
in
60
-
let run packages local_only clean force () =
61
-
let t0 = Unix.gettimeofday () in
62
-
Eio_main.run @@ fun env ->
63
-
Common.with_config env @@ fun config ->
64
-
let fs = Eio.Stdenv.fs env in
65
-
let proc = Eio.Stdenv.process_mgr env in
66
-
match
67
-
Monopam.Push.run ~proc ~fs ~config ~packages ~upstream:(not local_only)
68
-
~clean ~force ()
69
-
with
70
-
| Ok () ->
71
-
let elapsed = Unix.gettimeofday () -. t0 in
72
-
if local_only then
73
-
Fmt.pr "@.%a Changes exported to checkouts in %a.@." Tty.Span.pp
74
-
(Tty.Span.styled Tty.Style.(fg Tty.Color.green) "✓")
75
-
Tty.Span.pp
76
-
(Tty.Span.styled
77
-
Tty.Style.(fg Tty.Color.cyan)
78
-
(Fmt.str "%.1fs" elapsed))
79
-
else
80
-
Fmt.pr "@.%a Changes pushed to upstream in %a.@." Tty.Span.pp
81
-
(Tty.Span.styled Tty.Style.(fg Tty.Color.green) "✓")
82
-
Tty.Span.pp
83
-
(Tty.Span.styled
84
-
Tty.Style.(fg Tty.Color.cyan)
85
-
(Fmt.str "%.1fs" elapsed));
86
-
`Ok ()
87
-
| Error e ->
88
-
Fmt.epr "Error: %a@." Monopam.Ctx.pp_error_with_hint e;
89
-
`Error (false, "push failed")
90
-
in
91
90
Cmd.v info
92
91
Term.(
93
92
ret
+119
-116
bin/cmd_remove.ml
+119
-116
bin/cmd_remove.ml
···
1
1
open Cmdliner
2
2
3
-
let cmd =
4
-
let doc = "Remove a subtree from the current project" in
5
-
let man =
6
-
[
7
-
`S Manpage.s_description;
8
-
`P
9
-
"Removes a subtree directory from the current project and updates the \
10
-
mono.lock file.";
11
-
`S "WHAT IT DOES";
12
-
`I ("1.", "Checks if the directory exists");
13
-
`I ("2.", "Checks for uncommitted changes (unless --force)");
14
-
`I ("3.", "Removes the directory");
15
-
`I ("4.", "Updates mono.lock to remove the entry");
16
-
`I ("5.", "Stages and commits the removal (unless --no-commit)");
17
-
`S Manpage.s_examples;
18
-
`Pre "monopam remove eio";
19
-
`Pre "monopam remove my-eio --force";
20
-
`Pre "monopam remove eio --dry-run";
21
-
`S Manpage.s_see_also;
22
-
`P "$(b,monopam add)(1)";
23
-
]
24
-
in
25
-
let info = Cmd.info "remove" ~doc ~man in
26
-
let dir_arg =
27
-
let doc = "Directory to remove." in
28
-
Arg.(required & pos 0 (some string) None & info [] ~docv:"DIR" ~doc)
29
-
in
30
-
let force_arg =
31
-
let doc = "Remove even if there are uncommitted changes." in
32
-
Arg.(value & flag & info [ "force"; "f" ] ~doc)
33
-
in
34
-
let no_commit_arg =
35
-
let doc = "Skip automatic git commit." in
36
-
Arg.(value & flag & info [ "no-commit" ] ~doc)
37
-
in
38
-
let dry_run_arg =
39
-
let doc = "Show what would be removed without making changes." in
40
-
Arg.(value & flag & info [ "dry-run"; "n" ] ~doc)
41
-
in
42
-
let check_uncommitted ~proc ~cwd dir =
43
-
let buf = Buffer.create 256 in
44
-
Eio.Switch.run @@ fun sw ->
45
-
let child =
46
-
Eio.Process.spawn proc ~sw ~cwd ~stdout:(Eio.Flow.buffer_sink buf)
47
-
[ "git"; "status"; "--porcelain"; "--"; dir ]
48
-
in
49
-
match Eio.Process.await child with
50
-
| `Exited 0 ->
51
-
let output = Buffer.contents buf in
52
-
if String.trim output <> "" then begin
53
-
Fmt.epr
54
-
"Error: %s has uncommitted changes. Use --force to remove anyway.@."
55
-
dir;
56
-
Fmt.epr "Changes:@.%s@." output;
57
-
exit 1
58
-
end
59
-
| _ -> ()
3
+
let man =
4
+
[
5
+
`S Manpage.s_description;
6
+
`P
7
+
"Removes a subtree directory from the current project and updates the \
8
+
mono.lock file.";
9
+
`S "WHAT IT DOES";
10
+
`I ("1.", "Checks if the directory exists");
11
+
`I ("2.", "Checks for uncommitted changes (unless --force)");
12
+
`I ("3.", "Removes the directory");
13
+
`I ("4.", "Updates mono.lock to remove the entry");
14
+
`I ("5.", "Stages and commits the removal (unless --no-commit)");
15
+
`S Manpage.s_examples;
16
+
`Pre "monopam remove eio";
17
+
`Pre "monopam remove my-eio --force";
18
+
`Pre "monopam remove eio --dry-run";
19
+
`S Manpage.s_see_also;
20
+
`P "$(b,monopam add)(1)";
21
+
]
22
+
23
+
let dir_arg =
24
+
let doc = "Directory to remove." in
25
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"DIR" ~doc)
26
+
27
+
let force_arg =
28
+
let doc = "Remove even if there are uncommitted changes." in
29
+
Arg.(value & flag & info [ "force"; "f" ] ~doc)
30
+
31
+
let no_commit_arg =
32
+
let doc = "Skip automatic git commit." in
33
+
Arg.(value & flag & info [ "no-commit" ] ~doc)
34
+
35
+
let dry_run_arg =
36
+
let doc = "Show what would be removed without making changes." in
37
+
Arg.(value & flag & info [ "dry-run"; "n" ] ~doc)
38
+
39
+
let check_uncommitted ~proc ~cwd dir =
40
+
let buf = Buffer.create 256 in
41
+
Eio.Switch.run @@ fun sw ->
42
+
let child =
43
+
Eio.Process.spawn proc ~sw ~cwd ~stdout:(Eio.Flow.buffer_sink buf)
44
+
[ "git"; "status"; "--porcelain"; "--"; dir ]
60
45
in
61
-
let remove_dir ~proc ~cwd dir =
62
-
Eio.Switch.run @@ fun sw ->
63
-
let child = Eio.Process.spawn proc ~sw ~cwd [ "rm"; "-rf"; dir ] in
64
-
match Eio.Process.await child with
65
-
| `Exited 0 -> ()
66
-
| _ ->
67
-
Fmt.epr "Error: failed to remove %s@." dir;
46
+
match Eio.Process.await child with
47
+
| `Exited 0 ->
48
+
let output = Buffer.contents buf in
49
+
if String.trim output <> "" then begin
50
+
Fmt.epr
51
+
"Error: %s has uncommitted changes. Use --force to remove anyway.@."
52
+
dir;
53
+
Fmt.epr "Changes:@.%s@." output;
68
54
exit 1
55
+
end
56
+
| _ -> ()
57
+
58
+
let remove_dir ~proc ~cwd dir =
59
+
Eio.Switch.run @@ fun sw ->
60
+
let child = Eio.Process.spawn proc ~sw ~cwd [ "rm"; "-rf"; dir ] in
61
+
match Eio.Process.await child with
62
+
| `Exited 0 -> ()
63
+
| _ ->
64
+
Fmt.epr "Error: failed to remove %s@." dir;
65
+
exit 1
66
+
67
+
let update_lock ~fs ~target dir =
68
+
match Monopam.Mono_lock.load ~fs target with
69
+
| Ok lock -> (
70
+
let lock' = Monopam.Mono_lock.remove lock ~name:dir in
71
+
match Monopam.Mono_lock.save ~fs target lock' with
72
+
| Ok () -> Fmt.pr "Updated mono.lock@."
73
+
| Error e -> Fmt.epr "Warning: failed to update mono.lock: %s@." e)
74
+
| Error _ -> ()
75
+
76
+
let commit_removal ~proc ~cwd dir =
77
+
Eio.Switch.run @@ fun sw ->
78
+
let child =
79
+
Eio.Process.spawn proc ~sw ~cwd [ "git"; "add"; "-A"; dir; "mono.lock" ]
69
80
in
70
-
let update_lock ~fs ~target dir =
71
-
match Monopam.Mono_lock.load ~fs target with
72
-
| Ok lock -> (
73
-
let lock' = Monopam.Mono_lock.remove lock ~name:dir in
74
-
match Monopam.Mono_lock.save ~fs target lock' with
75
-
| Ok () -> Fmt.pr "Updated mono.lock@."
76
-
| Error e -> Fmt.epr "Warning: failed to update mono.lock: %s@." e)
77
-
| Error _ -> ()
81
+
(match Eio.Process.await child with `Exited 0 -> () | _ -> ());
82
+
let child =
83
+
Eio.Process.spawn proc ~sw ~cwd
84
+
[ "git"; "commit"; "-m"; Fmt.str "Remove subtree %s" dir ]
78
85
in
79
-
let commit_removal ~proc ~cwd dir =
80
-
Eio.Switch.run @@ fun sw ->
81
-
let child =
82
-
Eio.Process.spawn proc ~sw ~cwd [ "git"; "add"; "-A"; dir; "mono.lock" ]
83
-
in
84
-
(match Eio.Process.await child with `Exited 0 -> () | _ -> ());
85
-
let child =
86
-
Eio.Process.spawn proc ~sw ~cwd
87
-
[ "git"; "commit"; "-m"; Fmt.str "Remove subtree %s" dir ]
88
-
in
89
-
match Eio.Process.await child with
90
-
| `Exited 0 -> Fmt.pr "Committed removal.@."
91
-
| _ -> Fmt.pr "No changes to commit.@."
92
-
in
93
-
let run dir force no_commit dry_run () =
94
-
Eio_main.run @@ fun env ->
95
-
let fs = Eio.Stdenv.fs env in
96
-
let proc = Eio.Stdenv.process_mgr env in
97
-
let target = Fpath.v (Sys.getcwd ()) in
98
-
let dir_path = Fpath.(target / dir) in
99
-
let eio_path = Eio.Path.(fs / Fpath.to_string dir_path) in
100
-
(match Eio.Path.kind ~follow:true eio_path with
101
-
| `Directory -> ()
102
-
| _ ->
103
-
Fmt.epr "Error: %s is not a directory@." dir;
104
-
exit 1
105
-
| exception _ ->
106
-
Fmt.epr "Error: directory %s does not exist@." dir;
107
-
exit 1);
108
-
let target_eio = Eio.Path.(fs / Fpath.to_string target) in
109
-
if not force then check_uncommitted ~proc ~cwd:target_eio dir;
110
-
if dry_run then begin
111
-
Fmt.pr "Would remove: %s@." dir;
112
-
`Ok ()
113
-
end
114
-
else begin
115
-
Fmt.pr "Removing %s...@." dir;
116
-
remove_dir ~proc ~cwd:target_eio dir;
117
-
update_lock ~fs ~target dir;
118
-
if not no_commit then commit_removal ~proc ~cwd:target_eio dir;
119
-
Fmt.pr "Removed %s@." dir;
120
-
`Ok ()
121
-
end
122
-
in
86
+
match Eio.Process.await child with
87
+
| `Exited 0 -> Fmt.pr "Committed removal.@."
88
+
| _ -> Fmt.pr "No changes to commit.@."
89
+
90
+
let validate_dir_exists ~fs dir_path dir =
91
+
let eio_path = Eio.Path.(fs / Fpath.to_string dir_path) in
92
+
match Eio.Path.kind ~follow:true eio_path with
93
+
| `Directory -> ()
94
+
| _ ->
95
+
Fmt.epr "Error: %s is not a directory@." dir;
96
+
exit 1
97
+
| exception _ ->
98
+
Fmt.epr "Error: directory %s does not exist@." dir;
99
+
exit 1
100
+
101
+
let run dir force no_commit dry_run () =
102
+
Eio_main.run @@ fun env ->
103
+
let fs = Eio.Stdenv.fs env in
104
+
let proc = Eio.Stdenv.process_mgr env in
105
+
let target = Fpath.v (Sys.getcwd ()) in
106
+
let dir_path = Fpath.(target / dir) in
107
+
validate_dir_exists ~fs dir_path dir;
108
+
let target_eio = Eio.Path.(fs / Fpath.to_string target) in
109
+
if not force then check_uncommitted ~proc ~cwd:target_eio dir;
110
+
if dry_run then begin
111
+
Fmt.pr "Would remove: %s@." dir;
112
+
`Ok ()
113
+
end
114
+
else begin
115
+
Fmt.pr "Removing %s...@." dir;
116
+
remove_dir ~proc ~cwd:target_eio dir;
117
+
update_lock ~fs ~target dir;
118
+
if not no_commit then commit_removal ~proc ~cwd:target_eio dir;
119
+
Fmt.pr "Removed %s@." dir;
120
+
`Ok ()
121
+
end
122
+
123
+
let cmd =
124
+
let doc = "Remove a subtree from the current project" in
125
+
let info = Cmd.info "remove" ~doc ~man in
123
126
Cmd.v info
124
127
Term.(
125
128
ret
+143
-138
bin/cmd_verse.ml
+143
-138
bin/cmd_verse.ml
···
1
1
open Cmdliner
2
2
3
3
(* verse pull - pull from verse member *)
4
+
5
+
let pull_man =
6
+
[
7
+
`S Manpage.s_description;
8
+
`P
9
+
"Pulls commits from a verse member's forks into your local checkouts. \
10
+
This merges their changes into your checkout branches.";
11
+
`S "WORKFLOW";
12
+
`P "The typical workflow for incorporating changes from collaborators:";
13
+
`I ("1.", "$(b,monopam verse diff) - See what changes are available");
14
+
`I ("2.", "$(b,monopam verse pull <handle>) - Pull their changes");
15
+
`I ("3.", "$(b,monopam push) - Push merged changes upstream");
16
+
`S Manpage.s_examples;
17
+
`P "Pull all changes from a verse member:";
18
+
`Pre "monopam verse pull avsm.bsky.social";
19
+
`P "Pull changes for a specific repository:";
20
+
`Pre "monopam verse pull avsm.bsky.social eio";
21
+
]
22
+
23
+
let pull_handle_arg =
24
+
let doc = "The verse member handle to pull from (e.g., avsm.bsky.social)." in
25
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"HANDLE" ~doc)
26
+
27
+
let pull_repo_arg =
28
+
let doc = "Optional repository to pull from." in
29
+
Arg.(value & pos 1 (some string) None & info [] ~docv:"REPO" ~doc)
30
+
31
+
let pull_refresh_arg =
32
+
let doc = "Force fresh fetches from all remotes." in
33
+
Arg.(value & flag & info [ "refresh"; "r" ] ~doc)
34
+
35
+
let handle_pull_result (result : Monopam.handle_pull_result) handle =
36
+
Fmt.pr "%a" Monopam.pp_handle_pull_result result;
37
+
if result.repos_failed <> [] then `Error (false, "some repos failed to pull")
38
+
else if result.repos_pulled = [] then begin
39
+
Fmt.pr "Nothing to pull from %s@." handle;
40
+
`Ok ()
41
+
end
42
+
else begin
43
+
Fmt.pr "@.Run $(b,monopam push) to publish merged changes.@.";
44
+
`Ok ()
45
+
end
46
+
47
+
let pull_inner ~proc ~fs ~config ~verse_config ~handle ~repo ~refresh =
48
+
match
49
+
Monopam.pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo
50
+
~refresh ()
51
+
with
52
+
| Ok result -> handle_pull_result result handle
53
+
| Error e ->
54
+
Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e;
55
+
`Error (false, "pull failed")
56
+
57
+
let pull_run handle repo refresh () =
58
+
Eio_main.run @@ fun env ->
59
+
Common.with_config env @@ fun config ->
60
+
Common.with_verse_config env @@ fun verse_config ->
61
+
let fs = Eio.Stdenv.fs env in
62
+
let proc = Eio.Stdenv.process_mgr env in
63
+
pull_inner ~proc ~fs ~config ~verse_config ~handle ~repo ~refresh
64
+
4
65
let pull_cmd =
5
66
let doc = "Pull commits from a verse member's forks" in
6
-
let man =
7
-
[
8
-
`S Manpage.s_description;
9
-
`P
10
-
"Pulls commits from a verse member's forks into your local checkouts. \
11
-
This merges their changes into your checkout branches.";
12
-
`S "WORKFLOW";
13
-
`P "The typical workflow for incorporating changes from collaborators:";
14
-
`I ("1.", "$(b,monopam verse diff) - See what changes are available");
15
-
`I ("2.", "$(b,monopam verse pull <handle>) - Pull their changes");
16
-
`I ("3.", "$(b,monopam push) - Push merged changes upstream");
17
-
`S Manpage.s_examples;
18
-
`P "Pull all changes from a verse member:";
19
-
`Pre "monopam verse pull avsm.bsky.social";
20
-
`P "Pull changes for a specific repository:";
21
-
`Pre "monopam verse pull avsm.bsky.social eio";
22
-
]
67
+
let info = Cmd.info "pull" ~doc ~man:pull_man in
68
+
Cmd.v info
69
+
Term.(
70
+
ret
71
+
(const pull_run $ pull_handle_arg $ pull_repo_arg $ pull_refresh_arg
72
+
$ Common.logging_term))
73
+
74
+
(* verse diff - show diffs from verse members *)
75
+
76
+
let diff_man =
77
+
[
78
+
`S Manpage.s_description;
79
+
`P
80
+
"Shows commit diffs from verse members for repositories where they have \
81
+
commits you don't have.";
82
+
`S "OUTPUT";
83
+
`P "For each repository where a verse member is ahead:";
84
+
`I ("+N", "They have N commits you don't have");
85
+
`I ("+N/-M", "Diverged: they have N new commits, you have M new commits");
86
+
`S Manpage.s_examples;
87
+
`P "Show diffs for all repos:";
88
+
`Pre "monopam verse diff";
89
+
`P "Show diff for a specific repository:";
90
+
`Pre "monopam verse diff eio";
91
+
`P "Show patch for a specific commit:";
92
+
`Pre "monopam verse diff abc1234";
93
+
]
94
+
95
+
let diff_arg =
96
+
let doc =
97
+
"Repository name or commit SHA. If a 7+ character hex string, shows the \
98
+
patch for that commit."
23
99
in
24
-
let info = Cmd.info "pull" ~doc ~man in
25
-
let handle_arg =
26
-
let doc =
27
-
"The verse member handle to pull from (e.g., avsm.bsky.social)."
28
-
in
29
-
Arg.(required & pos 0 (some string) None & info [] ~docv:"HANDLE" ~doc)
100
+
Arg.(value & pos 0 (some string) None & info [] ~docv:"REPO|SHA" ~doc)
101
+
102
+
let diff_refresh_arg =
103
+
let doc = "Force fresh fetches from all remotes." in
104
+
Arg.(value & flag & info [ "refresh"; "r" ] ~doc)
105
+
106
+
let diff_patch_arg =
107
+
let doc = "Show full patch content for each commit." in
108
+
Arg.(value & flag & info [ "patch"; "p" ] ~doc)
109
+
110
+
let show_commit_info (info : Monopam.commit_info) =
111
+
let short_hash =
112
+
String.sub info.commit_hash 0 (min 7 (String.length info.commit_hash))
30
113
in
31
-
let repo_arg =
32
-
let doc = "Optional repository to pull from." in
33
-
Arg.(value & pos 1 (some string) None & info [] ~docv:"REPO" ~doc)
34
-
in
35
-
let refresh_arg =
36
-
let doc = "Force fresh fetches from all remotes." in
37
-
Arg.(value & flag & info [ "refresh"; "r" ] ~doc)
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;
114
+
Fmt.pr "%a %s (%s/%s)@.@.%s@."
115
+
Fmt.(styled `Yellow string)
116
+
short_hash info.commit_subject info.commit_repo info.commit_handle
117
+
info.commit_patch;
118
+
`Ok ()
119
+
120
+
let handle_sha ~proc ~fs ~config ~verse_config ~sha ~refresh =
121
+
match
122
+
Monopam.diff_show_commit ~proc ~fs ~config ~verse_config ~sha ~refresh ()
123
+
with
124
+
| Some info -> show_commit_info info
125
+
| None ->
126
+
Fmt.epr "Commit %s not found in any verse diff@." sha;
127
+
`Error (false, "commit not found")
128
+
129
+
let diff_inner ~proc ~fs ~config ~verse_config ~arg ~refresh ~patch =
130
+
match arg with
131
+
| Some sha when Monopam.is_commit_sha sha ->
132
+
handle_sha ~proc ~fs ~config ~verse_config ~sha ~refresh
133
+
| repo ->
134
+
let result =
135
+
Monopam.diff ~proc ~fs ~config ~verse_config ?repo ~refresh ~patch ()
136
+
in
137
+
Fmt.pr "%a" (Monopam.pp_diff_result ~show_patch:patch) result;
44
138
`Ok ()
45
-
end
46
-
else begin
47
-
Fmt.pr "@.Run $(b,monopam push) to publish merged changes.@.";
48
-
`Ok ()
49
-
end
50
-
in
51
-
let pull_inner ~proc ~fs ~config ~verse_config ~handle ~repo ~refresh =
52
-
match
53
-
Monopam.pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo
54
-
~refresh ()
55
-
with
56
-
| Ok result -> handle_pull_result result handle
57
-
| Error e ->
58
-
Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e;
59
-
`Error (false, "pull failed")
60
-
in
61
-
let run handle repo refresh () =
62
-
Eio_main.run @@ fun env ->
63
-
Common.with_config env @@ fun config ->
64
-
Common.with_verse_config env @@ fun verse_config ->
65
-
let fs = Eio.Stdenv.fs env in
66
-
let proc = Eio.Stdenv.process_mgr env in
67
-
pull_inner ~proc ~fs ~config ~verse_config ~handle ~repo ~refresh
68
-
in
69
-
Cmd.v info
70
-
Term.(
71
-
ret (const run $ handle_arg $ repo_arg $ refresh_arg $ Common.logging_term))
139
+
140
+
let diff_run arg refresh patch () =
141
+
Eio_main.run @@ fun env ->
142
+
Common.with_config env @@ fun config ->
143
+
Common.with_verse_config env @@ fun verse_config ->
144
+
let fs = Eio.Stdenv.fs env in
145
+
let proc = Eio.Stdenv.process_mgr env in
146
+
diff_inner ~proc ~fs ~config ~verse_config ~arg ~refresh ~patch
72
147
73
-
(* verse diff - show diffs from verse members *)
74
148
let diff_cmd =
75
149
let doc = "Show diffs from verse members" in
76
-
let man =
77
-
[
78
-
`S Manpage.s_description;
79
-
`P
80
-
"Shows commit diffs from verse members for repositories where they \
81
-
have commits you don't have.";
82
-
`S "OUTPUT";
83
-
`P "For each repository where a verse member is ahead:";
84
-
`I ("+N", "They have N commits you don't have");
85
-
`I ("+N/-M", "Diverged: they have N new commits, you have M new commits");
86
-
`S Manpage.s_examples;
87
-
`P "Show diffs for all repos:";
88
-
`Pre "monopam verse diff";
89
-
`P "Show diff for a specific repository:";
90
-
`Pre "monopam verse diff eio";
91
-
`P "Show patch for a specific commit:";
92
-
`Pre "monopam verse diff abc1234";
93
-
]
94
-
in
95
-
let info = Cmd.info "diff" ~doc ~man in
96
-
let arg =
97
-
let doc =
98
-
"Repository name or commit SHA. If a 7+ character hex string, shows the \
99
-
patch for that commit."
100
-
in
101
-
Arg.(value & pos 0 (some string) None & info [] ~docv:"REPO|SHA" ~doc)
102
-
in
103
-
let refresh_arg =
104
-
let doc = "Force fresh fetches from all remotes." in
105
-
Arg.(value & flag & info [ "refresh"; "r" ] ~doc)
106
-
in
107
-
let patch_arg =
108
-
let doc = "Show full patch content for each commit." in
109
-
Arg.(value & flag & info [ "patch"; "p" ] ~doc)
110
-
in
111
-
let show_commit_info ~sha (info : Monopam.commit_info) =
112
-
let short_hash =
113
-
String.sub info.commit_hash 0 (min 7 (String.length info.commit_hash))
114
-
in
115
-
Fmt.pr "%a %s (%s/%s)@.@.%s@."
116
-
Fmt.(styled `Yellow string)
117
-
short_hash info.commit_subject info.commit_repo info.commit_handle
118
-
info.commit_patch;
119
-
`Ok ()
120
-
in
121
-
let handle_sha ~proc ~fs ~config ~verse_config ~sha ~refresh =
122
-
match
123
-
Monopam.diff_show_commit ~proc ~fs ~config ~verse_config ~sha ~refresh ()
124
-
with
125
-
| Some info -> show_commit_info ~sha info
126
-
| None ->
127
-
Fmt.epr "Commit %s not found in any verse diff@." sha;
128
-
`Error (false, "commit not found")
129
-
in
130
-
let diff_inner ~proc ~fs ~config ~verse_config ~arg ~refresh ~patch =
131
-
match arg with
132
-
| Some sha when Monopam.is_commit_sha sha ->
133
-
handle_sha ~proc ~fs ~config ~verse_config ~sha ~refresh
134
-
| repo ->
135
-
let result =
136
-
Monopam.diff ~proc ~fs ~config ~verse_config ?repo ~refresh ~patch ()
137
-
in
138
-
Fmt.pr "%a" (Monopam.pp_diff_result ~show_patch:patch) result;
139
-
`Ok ()
140
-
in
141
-
let run arg refresh patch () =
142
-
Eio_main.run @@ fun env ->
143
-
Common.with_config env @@ fun config ->
144
-
Common.with_verse_config env @@ fun verse_config ->
145
-
let fs = Eio.Stdenv.fs env in
146
-
let proc = Eio.Stdenv.process_mgr env in
147
-
diff_inner ~proc ~fs ~config ~verse_config ~arg ~refresh ~patch
148
-
in
150
+
let info = Cmd.info "diff" ~doc ~man:diff_man in
149
151
Cmd.v info
150
-
Term.(ret (const run $ arg $ refresh_arg $ patch_arg $ Common.logging_term))
152
+
Term.(
153
+
ret
154
+
(const diff_run $ diff_arg $ diff_refresh_arg $ diff_patch_arg
155
+
$ Common.logging_term))
151
156
152
157
(* verse cherrypick - cherry-pick specific commit *)
153
158
let cherrypick_cmd =
+46
-46
bin/main.ml
+46
-46
bin/main.ml
···
4
4
5
5
(* Main entry point - compose all subcommands *)
6
6
7
+
let man =
8
+
[
9
+
`S Manpage.s_description;
10
+
`P
11
+
"$(b,monopam) manages OCaml packages in a monorepo structure. It syncs \
12
+
your monorepo with upstream git repositories.";
13
+
`S "QUICK START";
14
+
`P "Initialize a new workspace:";
15
+
`Pre "monopam init --handle yourname.bsky.social";
16
+
`P "Check the status of your packages:";
17
+
`Pre "monopam status";
18
+
`P "Pull latest changes from upstream:";
19
+
`Pre "monopam pull";
20
+
`P "Push your changes to upstream:";
21
+
`Pre "monopam push";
22
+
`S "CORE WORKFLOW";
23
+
`P "Commands match the git mental model:";
24
+
`I ("$(b,monopam add)", "Add a package (subtree) from a git URL");
25
+
`I ("$(b,monopam remove)", "Remove a package from the project");
26
+
`I ("$(b,monopam pull)", "Fetch and merge upstream changes into mono/");
27
+
`I ("$(b,monopam push)", "Push your mono/ changes to upstream remotes");
28
+
`I ("$(b,monopam fetch)", "Fetch upstream changes without merging");
29
+
`I ("$(b,monopam status)", "Show what's out of sync");
30
+
`I ("$(b,monopam diff)", "Show diff between mono/ and upstream");
31
+
`I ("$(b,monopam publish)", "Publish packages to opam-repo");
32
+
`S "TYPICAL SESSION";
33
+
`Pre
34
+
"# Start by pulling latest\n\
35
+
monopam pull\n\n\
36
+
# Make your changes\n\
37
+
vim mono/eio/lib/core.ml\n\n\
38
+
# Build and test\n\
39
+
dune build && dune test\n\n\
40
+
# Commit\n\
41
+
git add -A && git commit -m \"Add feature\"\n\n\
42
+
# Push to upstream\n\
43
+
monopam push";
44
+
`S "VERSE COLLABORATION";
45
+
`P "Collaborate with other developers via the verse system:";
46
+
`I ("$(b,monopam verse diff)", "See changes from collaborators");
47
+
`I ("$(b,monopam verse pull <handle>)", "Pull from a collaborator");
48
+
`I ("$(b,monopam verse status)", "Show verse member status");
49
+
`S Manpage.s_commands;
50
+
`P "Use $(b,monopam COMMAND --help) for help on a specific command.";
51
+
]
52
+
7
53
let cmd =
8
54
let doc = "Monorepo package manager for OCaml" in
9
-
let man =
10
-
[
11
-
`S Manpage.s_description;
12
-
`P
13
-
"$(b,monopam) manages OCaml packages in a monorepo structure. It syncs \
14
-
your monorepo with upstream git repositories.";
15
-
`S "QUICK START";
16
-
`P "Initialize a new workspace:";
17
-
`Pre "monopam init --handle yourname.bsky.social";
18
-
`P "Check the status of your packages:";
19
-
`Pre "monopam status";
20
-
`P "Pull latest changes from upstream:";
21
-
`Pre "monopam pull";
22
-
`P "Push your changes to upstream:";
23
-
`Pre "monopam push";
24
-
`S "CORE WORKFLOW";
25
-
`P "Commands match the git mental model:";
26
-
`I ("$(b,monopam add)", "Add a package (subtree) from a git URL");
27
-
`I ("$(b,monopam remove)", "Remove a package from the project");
28
-
`I ("$(b,monopam pull)", "Fetch and merge upstream changes into mono/");
29
-
`I ("$(b,monopam push)", "Push your mono/ changes to upstream remotes");
30
-
`I ("$(b,monopam fetch)", "Fetch upstream changes without merging");
31
-
`I ("$(b,monopam status)", "Show what's out of sync");
32
-
`I ("$(b,monopam diff)", "Show diff between mono/ and upstream");
33
-
`I ("$(b,monopam publish)", "Publish packages to opam-repo");
34
-
`S "TYPICAL SESSION";
35
-
`Pre
36
-
"# Start by pulling latest\n\
37
-
monopam pull\n\n\
38
-
# Make your changes\n\
39
-
vim mono/eio/lib/core.ml\n\n\
40
-
# Build and test\n\
41
-
dune build && dune test\n\n\
42
-
# Commit\n\
43
-
git add -A && git commit -m \"Add feature\"\n\n\
44
-
# Push to upstream\n\
45
-
monopam push";
46
-
`S "VERSE COLLABORATION";
47
-
`P "Collaborate with other developers via the verse system:";
48
-
`I ("$(b,monopam verse diff)", "See changes from collaborators");
49
-
`I ("$(b,monopam verse pull <handle>)", "Pull from a collaborator");
50
-
`I ("$(b,monopam verse status)", "Show verse member status");
51
-
`S Manpage.s_commands;
52
-
`P "Use $(b,monopam COMMAND --help) for help on a specific command.";
53
-
]
54
-
in
55
55
let info = Cmd.info "monopam" ~version ~doc ~man in
56
56
Cmd.group info
57
57
[
+170
-306
lib/changes.ml
+170
-306
lib/changes.ml
···
245
245
cf.entries;
246
246
Buffer.contents buf
247
247
248
-
let aggregate ~history (cfs : file list) =
249
-
(* Collect all entries from all files, tagged with repository *)
250
-
let all_entries =
251
-
List.concat_map
252
-
(fun (cf : file) ->
253
-
List.map (fun (e : weekly_entry) -> (cf.repository, e)) cf.entries)
254
-
cfs
255
-
in
256
-
(* Sort by week_start descending *)
257
-
let sorted =
258
-
List.sort
259
-
(fun (_, (e1 : weekly_entry)) (_, (e2 : weekly_entry)) ->
260
-
String.compare e2.week_start e1.week_start)
261
-
all_entries
262
-
in
263
-
(* Group by week *)
264
-
let rec group_by_week acc current_week current_group = function
248
+
let group_weekly_entries sorted =
249
+
let rec loop acc current_week current_group = function
265
250
| [] ->
266
251
if current_group <> [] then
267
252
(current_week, List.rev current_group) :: acc
···
269
254
| (repo, (entry : weekly_entry)) :: rest ->
270
255
let week_key = entry.week_start ^ " to " ^ entry.week_end in
271
256
if current_week = "" || current_week = week_key then
272
-
group_by_week acc week_key ((repo, entry) :: current_group) rest
257
+
loop acc week_key ((repo, entry) :: current_group) rest
273
258
else
274
-
group_by_week
259
+
loop
275
260
((current_week, List.rev current_group) :: acc)
276
261
week_key
277
262
[ (repo, entry) ]
278
263
rest
279
264
in
280
-
let grouped = List.rev (group_by_week [] "" [] sorted) in
281
-
(* Take only the requested number of weeks *)
265
+
List.rev (loop [] "" [] sorted)
266
+
267
+
let aggregate ~history (cfs : file list) =
268
+
let all_entries =
269
+
List.concat_map
270
+
(fun (cf : file) ->
271
+
List.map (fun (e : weekly_entry) -> (cf.repository, e)) cf.entries)
272
+
cfs
273
+
in
274
+
let sorted =
275
+
List.sort
276
+
(fun (_, (e1 : weekly_entry)) (_, (e2 : weekly_entry)) ->
277
+
String.compare e2.week_start e1.week_start)
278
+
all_entries
279
+
in
280
+
let grouped = group_weekly_entries sorted in
282
281
let limited =
283
282
if history > 0 then List.filteri (fun i _ -> i < history) grouped
284
283
else grouped
285
284
in
286
-
(* Generate markdown *)
287
285
let buf = Buffer.create 4096 in
288
286
Buffer.add_string buf "# Changelog\n\n";
289
287
List.iter
···
474
472
475
473
(* Claude prompt generation *)
476
474
477
-
let generate_weekly_prompt ~repository ~week_start ~week_end commits =
478
-
let buf = Buffer.create 4096 in
475
+
let format_commit_block buf (commit : Git.Repository.log_entry) =
479
476
Buffer.add_string buf
480
-
(Fmt.str "You are analyzing git commits for the OCaml library \"%s\".\n"
481
-
repository);
482
-
Buffer.add_string buf
483
-
(Fmt.str
484
-
"Generate a user-facing changelog entry for the week of %s to %s.\n\n"
485
-
week_start week_end);
486
-
Buffer.add_string buf "## Commits this week:\n\n";
487
-
List.iter
488
-
(fun (commit : Git.Repository.log_entry) ->
489
-
Buffer.add_string buf
490
-
(Fmt.str "### %s by %s (%s)\n"
491
-
(String.sub commit.hash 0 (min 7 (String.length commit.hash)))
492
-
commit.author commit.date);
493
-
Buffer.add_string buf (Fmt.str "%s\n\n" commit.subject);
494
-
if commit.body <> "" then begin
495
-
Buffer.add_string buf (Fmt.str "%s\n" commit.body)
496
-
end;
497
-
Buffer.add_string buf "---\n\n")
498
-
commits;
499
-
Buffer.add_string buf
500
-
{|## Instructions:
477
+
(Fmt.str "### %s by %s (%s)\n"
478
+
(String.sub commit.hash 0 (min 7 (String.length commit.hash)))
479
+
commit.author commit.date);
480
+
Buffer.add_string buf (Fmt.str "%s\n\n" commit.subject);
481
+
if commit.body <> "" then begin
482
+
Buffer.add_string buf (Fmt.str "%s\n" commit.body)
483
+
end;
484
+
Buffer.add_string buf "---\n\n"
485
+
486
+
let changelog_instructions =
487
+
{|## Instructions:
501
488
502
489
1. Focus on USER-FACING changes only. Skip:
503
490
- Internal refactoring with no API impact
···
525
512
- Action-oriented (start with verbs: Added, Fixed, Improved, Removed)
526
513
527
514
5. Maximum 5 bullet points. Group related changes if needed.
528
-
|};
515
+
|}
516
+
517
+
let generate_weekly_prompt ~repository ~week_start ~week_end commits =
518
+
let buf = Buffer.create 4096 in
519
+
Buffer.add_string buf
520
+
(Fmt.str "You are analyzing git commits for the OCaml library \"%s\".\n"
521
+
repository);
522
+
Buffer.add_string buf
523
+
(Fmt.str
524
+
"Generate a user-facing changelog entry for the week of %s to %s.\n\n"
525
+
week_start week_end);
526
+
Buffer.add_string buf "## Commits this week:\n\n";
527
+
List.iter (format_commit_block buf) commits;
528
+
Buffer.add_string buf changelog_instructions;
529
529
Buffer.contents buf
530
530
531
531
let generate_daily_prompt ~repository ~date commits =
···
536
536
Buffer.add_string buf
537
537
(Fmt.str "Generate a user-facing changelog entry for %s.\n\n" date);
538
538
Buffer.add_string buf "## Commits today:\n\n";
539
-
List.iter
540
-
(fun (commit : Git.Repository.log_entry) ->
541
-
Buffer.add_string buf
542
-
(Fmt.str "### %s by %s (%s)\n"
543
-
(String.sub commit.hash 0 (min 7 (String.length commit.hash)))
544
-
commit.author commit.date);
545
-
Buffer.add_string buf (Fmt.str "%s\n\n" commit.subject);
546
-
if commit.body <> "" then begin
547
-
Buffer.add_string buf (Fmt.str "%s\n" commit.body)
548
-
end;
549
-
Buffer.add_string buf "---\n\n")
550
-
commits;
551
-
Buffer.add_string buf
552
-
{|## Instructions:
553
-
554
-
1. Focus on USER-FACING changes only. Skip:
555
-
- Internal refactoring with no API impact
556
-
- CI/build system tweaks
557
-
- Typo fixes in code comments
558
-
- Dependency bumps (unless they add features)
559
-
560
-
2. IMPORTANT: If there are NO user-facing changes, output a blank entry with empty
561
-
summary and empty changes array. Do NOT write "no changes" or similar text.
562
-
Example for no changes: {"summary": "", "changes": []}
563
-
564
-
3. Otherwise, respond in this exact JSON format:
565
-
{
566
-
"summary": "One sentence describing the most important change",
567
-
"changes": [
568
-
"First user-facing change as a bullet point",
569
-
"Second change",
570
-
"..."
571
-
]
572
-
}
573
-
574
-
4. Write for developers using this library. Be:
575
-
- Concise (max 80 chars per bullet)
576
-
- Specific (mention function/module names)
577
-
- Action-oriented (start with verbs: Added, Fixed, Improved, Removed)
578
-
579
-
5. Maximum 5 bullet points. Group related changes if needed.
580
-
|};
539
+
List.iter (format_commit_block buf) commits;
540
+
Buffer.add_string buf changelog_instructions;
581
541
Buffer.contents buf
582
542
583
543
(* Backwards compatibility *)
···
608
568
609
569
(* Main analysis function *)
610
570
571
+
let changelog_output_schema =
572
+
let open Jsont in
573
+
Object
574
+
( [
575
+
(("type", Meta.none), String ("object", Meta.none));
576
+
( ("properties", Meta.none),
577
+
Object
578
+
( [
579
+
( ("summary", Meta.none),
580
+
Object
581
+
( [ (("type", Meta.none), String ("string", Meta.none)) ],
582
+
Meta.none ) );
583
+
( ("changes", Meta.none),
584
+
Object
585
+
( [
586
+
(("type", Meta.none), String ("array", Meta.none));
587
+
( ("items", Meta.none),
588
+
Object
589
+
( [
590
+
( ("type", Meta.none),
591
+
String ("string", Meta.none) );
592
+
],
593
+
Meta.none ) );
594
+
],
595
+
Meta.none ) );
596
+
],
597
+
Meta.none ) );
598
+
( ("required", Meta.none),
599
+
Array
600
+
( [ String ("summary", Meta.none); String ("changes", Meta.none) ],
601
+
Meta.none ) );
602
+
],
603
+
Meta.none )
604
+
605
+
let process_claude_responses responses =
606
+
let result = ref None in
607
+
List.iter
608
+
(function
609
+
| Claude.Response.Complete c -> (
610
+
match Claude.Response.Complete.structured_output c with
611
+
| Some json -> (
612
+
match Jsont.Json.decode claude_response_jsont json with
613
+
| Ok r ->
614
+
if r.summary = "" && r.changes = [] then
615
+
result := Some (Ok None)
616
+
else result := Some (Ok (Some r))
617
+
| Error e -> result := Some (err_decode e))
618
+
| None -> (
619
+
match Claude.Response.Complete.result_text c with
620
+
| Some text -> result := Some (parse_claude_response text)
621
+
| None -> result := Some (Ok None)))
622
+
| Claude.Response.Text t ->
623
+
let text = Claude.Response.Text.content t in
624
+
if String.trim text = "NO_CHANGES" then result := Some (Ok None)
625
+
| Claude.Response.Error e ->
626
+
result :=
627
+
Some
628
+
(Error
629
+
(Fmt.str "Claude error: %s" (Claude.Response.Error.message e)))
630
+
| _ -> ())
631
+
responses;
632
+
match !result with Some r -> r | None -> Ok None
633
+
634
+
let run_claude_analysis ~sw ~process_mgr ~clock prompt =
635
+
let output_format =
636
+
Claude.Proto.Structured_output.of_json_schema changelog_output_schema
637
+
in
638
+
let options =
639
+
Claude.Options.default
640
+
|> Claude.Options.with_output_format output_format
641
+
|> Claude.Options.with_max_turns 1
642
+
in
643
+
let client = Claude.Client.create ~sw ~process_mgr ~clock ~options () in
644
+
Claude.Client.query client prompt;
645
+
let responses = Claude.Client.receive_all client in
646
+
process_claude_responses responses
647
+
611
648
let analyze_commits ~sw ~process_mgr ~clock ~repository ~week_start ~week_end
612
649
commits =
613
650
if commits = [] then Ok None
614
-
else begin
651
+
else
615
652
let prompt = generate_prompt ~repository ~week_start ~week_end commits in
616
-
617
-
(* Create Claude options with structured output *)
618
-
let output_schema =
619
-
let open Jsont in
620
-
Object
621
-
( [
622
-
(("type", Meta.none), String ("object", Meta.none));
623
-
( ("properties", Meta.none),
624
-
Object
625
-
( [
626
-
( ("summary", Meta.none),
627
-
Object
628
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
629
-
Meta.none ) );
630
-
( ("changes", Meta.none),
631
-
Object
632
-
( [
633
-
(("type", Meta.none), String ("array", Meta.none));
634
-
( ("items", Meta.none),
635
-
Object
636
-
( [
637
-
( ("type", Meta.none),
638
-
String ("string", Meta.none) );
639
-
],
640
-
Meta.none ) );
641
-
],
642
-
Meta.none ) );
643
-
],
644
-
Meta.none ) );
645
-
( ("required", Meta.none),
646
-
Array
647
-
( [
648
-
String ("summary", Meta.none); String ("changes", Meta.none);
649
-
],
650
-
Meta.none ) );
651
-
],
652
-
Meta.none )
653
-
in
654
-
let output_format =
655
-
Claude.Proto.Structured_output.of_json_schema output_schema
656
-
in
657
-
let options =
658
-
Claude.Options.default
659
-
|> Claude.Options.with_output_format output_format
660
-
|> Claude.Options.with_max_turns 1
661
-
in
662
-
663
-
let client = Claude.Client.create ~sw ~process_mgr ~clock ~options () in
664
-
Claude.Client.query client prompt;
665
-
666
-
let responses = Claude.Client.receive_all client in
667
-
let result = ref None in
668
-
List.iter
669
-
(function
670
-
| Claude.Response.Complete c -> (
671
-
match Claude.Response.Complete.structured_output c with
672
-
| Some json -> (
673
-
match Jsont.Json.decode claude_response_jsont json with
674
-
| Ok r -> result := Some (Ok (Some r))
675
-
| Error e -> result := Some (err_decode e))
676
-
| None -> (
677
-
(* Try to get text and parse it as fallback *)
678
-
match Claude.Response.Complete.result_text c with
679
-
| Some text -> result := Some (parse_claude_response text)
680
-
| None -> result := Some (Ok None)))
681
-
| Claude.Response.Text t ->
682
-
let text = Claude.Response.Text.content t in
683
-
if String.trim text = "NO_CHANGES" then result := Some (Ok None)
684
-
| Claude.Response.Error e ->
685
-
result :=
686
-
Some
687
-
(Error
688
-
(Fmt.str "Claude error: %s"
689
-
(Claude.Response.Error.message e)))
690
-
| _ -> ())
691
-
responses;
692
-
693
-
match !result with Some r -> r | None -> Ok None
694
-
end
653
+
run_claude_analysis ~sw ~process_mgr ~clock prompt
695
654
696
655
(* Daily analysis function *)
697
656
let analyze_commits_daily ~sw ~process_mgr ~clock ~repository ~date commits =
698
657
if commits = [] then Ok None
699
-
else begin
658
+
else
700
659
let prompt = generate_daily_prompt ~repository ~date commits in
701
-
702
-
(* Create Claude options with structured output *)
703
-
let output_schema =
704
-
let open Jsont in
705
-
Object
706
-
( [
707
-
(("type", Meta.none), String ("object", Meta.none));
708
-
( ("properties", Meta.none),
709
-
Object
710
-
( [
711
-
( ("summary", Meta.none),
712
-
Object
713
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
714
-
Meta.none ) );
715
-
( ("changes", Meta.none),
716
-
Object
717
-
( [
718
-
(("type", Meta.none), String ("array", Meta.none));
719
-
( ("items", Meta.none),
720
-
Object
721
-
( [
722
-
( ("type", Meta.none),
723
-
String ("string", Meta.none) );
724
-
],
725
-
Meta.none ) );
726
-
],
727
-
Meta.none ) );
728
-
],
729
-
Meta.none ) );
730
-
( ("required", Meta.none),
731
-
Array
732
-
( [
733
-
String ("summary", Meta.none); String ("changes", Meta.none);
734
-
],
735
-
Meta.none ) );
736
-
],
737
-
Meta.none )
738
-
in
739
-
let output_format =
740
-
Claude.Proto.Structured_output.of_json_schema output_schema
741
-
in
742
-
let options =
743
-
Claude.Options.default
744
-
|> Claude.Options.with_output_format output_format
745
-
|> Claude.Options.with_max_turns 1
746
-
in
747
-
748
-
let client = Claude.Client.create ~sw ~process_mgr ~clock ~options () in
749
-
Claude.Client.query client prompt;
750
-
751
-
let responses = Claude.Client.receive_all client in
752
-
let result = ref None in
753
-
List.iter
754
-
(function
755
-
| Claude.Response.Complete c -> (
756
-
match Claude.Response.Complete.structured_output c with
757
-
| Some json -> (
758
-
match Jsont.Json.decode claude_response_jsont json with
759
-
| Ok r ->
760
-
(* Treat empty response as no changes *)
761
-
if r.summary = "" && r.changes = [] then
762
-
result := Some (Ok None)
763
-
else result := Some (Ok (Some r))
764
-
| Error e -> result := Some (err_decode e))
765
-
| None -> (
766
-
(* Try to get text and parse it as fallback *)
767
-
match Claude.Response.Complete.result_text c with
768
-
| Some text -> result := Some (parse_claude_response text)
769
-
| None -> result := Some (Ok None)))
770
-
| Claude.Response.Text t ->
771
-
let text = Claude.Response.Text.content t in
772
-
if String.trim text = "NO_CHANGES" then result := Some (Ok None)
773
-
| Claude.Response.Error e ->
774
-
result :=
775
-
Some
776
-
(Error
777
-
(Fmt.str "Claude error: %s"
778
-
(Claude.Response.Error.message e)))
779
-
| _ -> ())
780
-
responses;
781
-
782
-
match !result with Some r -> r | None -> Ok None
783
-
end
660
+
run_claude_analysis ~sw ~process_mgr ~clock prompt
784
661
785
662
(* Refine daily changelog markdown to be more narrative *)
786
663
let refine_daily_changelog ~sw ~process_mgr ~clock markdown =
···
893
770
then Changes_aggregated.Feature
894
771
else Changes_aggregated.Unknown
895
772
773
+
let load_daily_entries_for_date changes_dir daily_files date_suffix_len =
774
+
List.concat_map
775
+
(fun filename ->
776
+
let repo_name =
777
+
String.sub filename 0 (String.length filename - date_suffix_len)
778
+
in
779
+
let path = Eio.Path.(changes_dir / filename) in
780
+
try
781
+
let content = Eio.Path.load path in
782
+
match Jsont_bytesrw.decode_string daily_file_jsont content with
783
+
| Ok dcf ->
784
+
List.filter_map
785
+
(fun (e : daily_entry) ->
786
+
if e.changes <> [] then Some (repo_name, e) else None)
787
+
dcf.entries
788
+
| Error _ -> []
789
+
with Eio.Io _ -> [])
790
+
daily_files
791
+
792
+
let daily_entry_to_aggregated (repo_name, (e : daily_entry)) =
793
+
let change_type = infer_change_type e.summary in
794
+
Changes_aggregated.
795
+
{
796
+
repository = repo_name;
797
+
hour = e.hour;
798
+
timestamp = e.timestamp;
799
+
summary = e.summary;
800
+
changes = e.changes;
801
+
commit_range =
802
+
{
803
+
from_hash = e.commit_range.from_hash;
804
+
to_hash = e.commit_range.to_hash;
805
+
count = e.commit_range.count;
806
+
};
807
+
contributors = e.contributors;
808
+
repo_url = e.repo_url;
809
+
change_type;
810
+
}
811
+
896
812
(** Generate an aggregated daily file from individual daily json files. This
897
813
creates a YYYYMMDD.json file in the .changes directory. *)
898
814
let generate_aggregated ~fs ~monorepo ~date ~git_head ~now =
899
815
let changes_dir = Eio.Path.(fs / Fpath.to_string monorepo / ".changes") in
900
-
901
-
(* List all *-<date>.json files (new per-day format) *)
902
816
let files = try Eio.Path.read_dir changes_dir with Eio.Io _ -> [] in
903
-
(* Match files like "<repo>-2026-01-19.json" for the given date *)
904
817
let date_suffix = "-" ^ date ^ ".json" in
905
818
let date_suffix_len = String.length date_suffix in
906
819
let daily_files =
···
910
823
&& String.length f > date_suffix_len)
911
824
files
912
825
in
913
-
914
-
(* Load all daily files for this date and collect entries *)
915
826
let entries =
916
-
List.concat_map
917
-
(fun filename ->
918
-
(* Extract repo name: filename is "<repo>-<date>.json" *)
919
-
let repo_name =
920
-
String.sub filename 0 (String.length filename - date_suffix_len)
921
-
in
922
-
let path = Eio.Path.(changes_dir / filename) in
923
-
try
924
-
let content = Eio.Path.load path in
925
-
match Jsont_bytesrw.decode_string daily_file_jsont content with
926
-
| Ok dcf ->
927
-
List.filter_map
928
-
(fun (e : daily_entry) ->
929
-
if e.changes <> [] then Some (repo_name, e) else None)
930
-
dcf.entries
931
-
| Error _ -> []
932
-
with Eio.Io _ -> [])
933
-
daily_files
827
+
load_daily_entries_for_date changes_dir daily_files date_suffix_len
934
828
in
935
-
936
-
(* Convert to aggregated format *)
937
-
let agg_entries =
938
-
List.map
939
-
(fun (repo_name, (e : daily_entry)) ->
940
-
let change_type = infer_change_type e.summary in
941
-
Changes_aggregated.
942
-
{
943
-
repository = repo_name;
944
-
hour = e.hour;
945
-
timestamp = e.timestamp;
946
-
summary = e.summary;
947
-
changes = e.changes;
948
-
commit_range =
949
-
{
950
-
from_hash = e.commit_range.from_hash;
951
-
to_hash = e.commit_range.to_hash;
952
-
count = e.commit_range.count;
953
-
};
954
-
contributors = e.contributors;
955
-
repo_url = e.repo_url;
956
-
change_type;
957
-
})
958
-
entries
959
-
in
960
-
961
-
(* Collect all unique authors *)
829
+
let agg_entries = List.map daily_entry_to_aggregated entries in
962
830
let authors =
963
831
entries
964
832
|> List.concat_map (fun (_, (e : daily_entry)) -> e.contributors)
965
833
|> List.sort_uniq String.compare
966
834
in
967
-
968
-
(* Create the aggregated structure *)
969
835
let aggregated : Changes_aggregated.t =
970
836
{ date; generated_at = now; git_head; entries = agg_entries; authors }
971
837
in
972
-
973
-
(* Save to YYYYMMDD.json *)
974
838
let changes_dir_fpath = Fpath.(v (Fpath.to_string monorepo) / ".changes") in
975
839
Changes_aggregated.save ~fs ~changes_dir:changes_dir_fpath aggregated
+35
-48
lib/changes_daily.ml
+35
-48
lib/changes_daily.ml
···
184
184
let dates = list_dates ~fs ~changes_dir ~repo in
185
185
List.concat_map (fun date -> load_file ~fs ~changes_dir ~repo ~date) dates
186
186
187
+
let build_by_repo_map (days : day list) : day list String_map.t =
188
+
let by_repo =
189
+
List.fold_left
190
+
(fun acc (d : day) ->
191
+
let existing =
192
+
String_map.find_opt d.repository acc |> Option.value ~default:[]
193
+
in
194
+
String_map.add d.repository (d :: existing) acc)
195
+
String_map.empty days
196
+
in
197
+
String_map.map
198
+
(fun (ds : day list) ->
199
+
List.sort (fun (d1 : day) (d2 : day) -> String.compare d2.date d1.date) ds)
200
+
by_repo
201
+
202
+
let build_by_date_map (days : day list) : day list String_map.t =
203
+
let by_date =
204
+
List.fold_left
205
+
(fun acc (d : day) ->
206
+
let existing =
207
+
String_map.find_opt d.date acc |> Option.value ~default:[]
208
+
in
209
+
String_map.add d.date (d :: existing) acc)
210
+
String_map.empty days
211
+
in
212
+
String_map.map
213
+
(fun (ds : day list) ->
214
+
List.sort
215
+
(fun (d1 : day) (d2 : day) ->
216
+
String.compare d1.repository d2.repository)
217
+
ds)
218
+
by_date
219
+
187
220
let load_all ~fs ~changes_dir =
188
221
let dir_path = Eio.Path.(fs / Fpath.to_string changes_dir) in
189
222
match Eio.Path.kind ~follow:true dir_path with
190
223
| `Directory ->
191
224
let files = Eio.Path.read_dir dir_path in
192
225
let parsed_files = List.filter_map parse_daily_filename files in
193
-
194
-
(* Load all files and build days *)
195
226
let days : day list =
196
227
List.filter_map
197
228
(fun (repo, date) ->
···
209
240
Some ({ repository = repo; date; entries = sorted_entries } : day))
210
241
parsed_files
211
242
in
212
-
213
-
(* Build by_repo map *)
214
-
let by_repo : day list String_map.t =
215
-
List.fold_left
216
-
(fun acc (d : day) ->
217
-
let existing =
218
-
String_map.find_opt d.repository acc |> Option.value ~default:[]
219
-
in
220
-
String_map.add d.repository (d :: existing) acc)
221
-
String_map.empty days
222
-
in
223
-
224
-
(* Sort each repo's days by date descending *)
225
-
let by_repo : day list String_map.t =
226
-
String_map.map
227
-
(fun (ds : day list) ->
228
-
List.sort
229
-
(fun (d1 : day) (d2 : day) -> String.compare d2.date d1.date)
230
-
ds)
231
-
by_repo
232
-
in
233
-
234
-
(* Build by_date map *)
235
-
let by_date : day list String_map.t =
236
-
List.fold_left
237
-
(fun acc (d : day) ->
238
-
let existing =
239
-
String_map.find_opt d.date acc |> Option.value ~default:[]
240
-
in
241
-
String_map.add d.date (d :: existing) acc)
242
-
String_map.empty days
243
-
in
244
-
245
-
(* Sort each date's days by repo name *)
246
-
let by_date : day list String_map.t =
247
-
String_map.map
248
-
(fun (ds : day list) ->
249
-
List.sort
250
-
(fun (d1 : day) (d2 : day) ->
251
-
String.compare d1.repository d2.repository)
252
-
ds)
253
-
by_date
254
-
in
255
-
256
-
(* Collect all entries sorted by timestamp *)
243
+
let by_repo = build_by_repo_map days in
244
+
let by_date = build_by_date_map days in
257
245
let all_entries : entry list =
258
246
days
259
247
|> List.concat_map (fun (d : day) -> d.entries)
260
248
|> List.sort (fun (e1 : entry) (e2 : entry) ->
261
249
Ptime.compare e1.timestamp e2.timestamp)
262
250
in
263
-
264
251
{ by_repo; by_date; all_entries }
265
252
| _ -> empty
266
253
| exception Eio.Io _ -> empty
+48
-60
lib/clean.ml
+48
-60
lib/clean.ml
···
29
29
Log.app (fun m -> m " ✓ %s cleaned" name);
30
30
Some issue_count
31
31
32
+
(** {1 Helpers} *)
33
+
34
+
let check_and_fix ~fs_t ~dry_run ~name ~check_fn ~fix_fn path =
35
+
if not (Git.Repository.is_repo ~fs:fs_t path) then None
36
+
else
37
+
let repo = Git.Repository.open_repo ~fs:fs_t path in
38
+
match Git.Repository.head repo with
39
+
| None -> None
40
+
| Some head ->
41
+
let checked, issues = check_fn repo ~head in
42
+
if issues = [] then None
43
+
else begin
44
+
Log.app (fun m ->
45
+
m "%s: %d issues (of %d checked)" name (List.length issues)
46
+
checked);
47
+
apply_fix ~name ~repo ~dry_run
48
+
~fix_fn:(fun () -> fix_fn repo ~head)
49
+
~issue_count:(List.length issues)
50
+
end
51
+
52
+
let force_push_checkouts ~proc ~fs_t ~checkouts_path ~checkouts =
53
+
Log.app (fun m -> m "Force-pushing cleaned histories to upstream...");
54
+
let push name =
55
+
let path = Fpath.(checkouts / name) in
56
+
if Git.Repository.is_repo ~fs:fs_t path then
57
+
match
58
+
Git_cli.push_remote ~proc ~fs:(fs_t :> _ Eio.Path.t) ~force:true path
59
+
with
60
+
| Ok () -> Log.app (fun m -> m " ✓ %s" name)
61
+
| Error e -> Log.app (fun m -> m " ✗ %s: %a" name Git_cli.pp_error e)
62
+
in
63
+
try Eio.Path.read_dir checkouts_path |> List.iter push with Eio.Io _ -> ()
64
+
32
65
(** {1 Main Clean Operation} *)
33
66
34
67
let run ~proc ~fs ~config ~dry_run ~force () =
35
68
let fs_t = Ctx.fs_typed fs in
36
69
let mono = Config.Paths.monorepo config in
37
70
let checkouts = Config.Paths.checkouts config in
71
+
let checkouts_path = Eio.Path.(fs_t / Fpath.to_string checkouts) in
38
72
39
-
let clean_mono () =
40
-
if not (Git.Repository.is_repo ~fs:fs_t mono) then None
41
-
else
42
-
let repo = Git.Repository.open_repo ~fs:fs_t mono in
43
-
match Git.Repository.head repo with
44
-
| None -> None
45
-
| Some head ->
46
-
let checked, issues = Git.Subtree.check_mono repo ~head () in
47
-
if issues = [] then None
48
-
else begin
49
-
Log.app (fun m ->
50
-
m "mono: %d empty commits (of %d checked)" (List.length issues)
51
-
checked);
52
-
apply_fix ~name:"mono" ~repo ~dry_run
53
-
~fix_fn:(fun () -> Git.Subtree.fix_mono repo ~head ())
54
-
~issue_count:(List.length issues)
55
-
end
56
-
in
57
-
58
-
let clean_checkout name =
59
-
let path = Fpath.(checkouts / name) in
60
-
if not (Git.Repository.is_repo ~fs:fs_t path) then None
61
-
else
62
-
let repo = Git.Repository.open_repo ~fs:fs_t path in
63
-
match Git.Repository.head repo with
64
-
| None -> None
65
-
| Some head ->
66
-
let checked, issues = Git.Subtree.check repo ~prefix:name ~head () in
67
-
if issues = [] then None
68
-
else begin
69
-
Log.app (fun m ->
70
-
m "%s: %d unrelated merges (of %d checked)" name
71
-
(List.length issues) checked);
72
-
apply_fix ~name ~repo ~dry_run
73
-
~fix_fn:(fun () -> Git.Subtree.fix repo ~prefix:name ~head ())
74
-
~issue_count:(List.length issues)
75
-
end
73
+
let mono_cleaned =
74
+
check_and_fix ~fs_t ~dry_run ~name:"mono"
75
+
~check_fn:(fun repo ~head -> Git.Subtree.check_mono repo ~head ())
76
+
~fix_fn:(fun repo ~head -> Git.Subtree.fix_mono repo ~head ())
77
+
mono
76
78
in
77
-
78
-
let mono_cleaned = clean_mono () in
79
-
80
-
let checkouts_path = Eio.Path.(fs_t / Fpath.to_string checkouts) in
81
79
let checkout_results =
80
+
let clean_checkout name =
81
+
check_and_fix ~fs_t ~dry_run ~name
82
+
~check_fn:(fun repo ~head ->
83
+
Git.Subtree.check repo ~prefix:name ~head ())
84
+
~fix_fn:(fun repo ~head -> Git.Subtree.fix repo ~prefix:name ~head ())
85
+
Fpath.(checkouts / name)
86
+
in
82
87
try Eio.Path.read_dir checkouts_path |> List.filter_map clean_checkout
83
88
with Eio.Io _ -> []
84
89
in
···
87
92
Option.value ~default:0 mono_cleaned
88
93
+ List.fold_left ( + ) 0 checkout_results
89
94
in
90
-
91
95
if total_cleaned = 0 then begin
92
96
Log.app (fun m -> m "No empty commits found");
93
97
Ok ()
···
100
104
end
101
105
else begin
102
106
Log.app (fun m -> m "Removed %d commits" total_cleaned);
103
-
if force then begin
104
-
Log.app (fun m -> m "Force-pushing cleaned histories to upstream...");
105
-
let push_checkout name =
106
-
let path = Fpath.(checkouts / name) in
107
-
if Git.Repository.is_repo ~fs:fs_t path then
108
-
match
109
-
Git_cli.push_remote ~proc
110
-
~fs:(fs_t :> _ Eio.Path.t)
111
-
~force:true path
112
-
with
113
-
| Ok () -> Log.app (fun m -> m " ✓ %s" name)
114
-
| Error e -> Log.app (fun m -> m " ✗ %s: %a" name Git_cli.pp_error e)
115
-
in
116
-
(try Eio.Path.read_dir checkouts_path |> List.iter push_checkout
117
-
with Eio.Io _ -> ());
118
-
Ok ()
119
-
end
120
-
else Ok ()
107
+
if force then force_push_checkouts ~proc ~fs_t ~checkouts_path ~checkouts;
108
+
Ok ()
121
109
end
+39
-54
lib/cross_status.ml
+39
-54
lib/cross_status.ml
···
202
202
Diverged { my_ahead; their_ahead })
203
203
end
204
204
205
-
(** Compute cross-user status comparing my monorepo against all verse members.
206
-
*)
205
+
let compare_my_repo ~fs ~my_mono ~checkouts ~verse_subtrees repo_name =
206
+
let my_info = subtree_info ~fs ~monorepo_path:my_mono ~prefix:repo_name () in
207
+
let checkout_path = Fpath.(checkouts / repo_name) in
208
+
let others_with_repo =
209
+
try Hashtbl.find verse_subtrees repo_name with Not_found -> []
210
+
in
211
+
if others_with_repo = [] then None
212
+
else begin
213
+
let others =
214
+
List.map
215
+
(fun (handle, their_mono) ->
216
+
let their_info =
217
+
subtree_info ~fs ~monorepo_path:their_mono ~prefix:repo_name ()
218
+
in
219
+
let rel =
220
+
compare_commits ~fs ~checkout_path
221
+
~my_commit:my_info.upstream_commit
222
+
~their_commit:their_info.upstream_commit ()
223
+
in
224
+
(handle, their_info, rel))
225
+
others_with_repo
226
+
in
227
+
Some { repo_name; my_info = Some my_info; others }
228
+
end
229
+
230
+
let other_repos ~my_subtrees ~verse_subtrees =
231
+
let my_subtrees_set = Hashtbl.create 64 in
232
+
List.iter (fun s -> Hashtbl.add my_subtrees_set s ()) my_subtrees;
233
+
Hashtbl.fold
234
+
(fun repo_name handles_and_paths acc ->
235
+
if Hashtbl.mem my_subtrees_set repo_name then acc
236
+
else
237
+
let handles = List.map fst handles_and_paths in
238
+
(repo_name, handles) :: acc)
239
+
verse_subtrees []
240
+
|> List.sort (fun (a, _) (b, _) -> String.compare a b)
241
+
207
242
let compute ~fs ~verse_config ~monopam_config () =
208
243
let my_mono = Verse_config.mono_path verse_config in
209
244
let checkouts = Config.Paths.checkouts monopam_config in
210
-
211
-
(* Get my subtrees *)
212
245
let my_subtrees = Verse.scan_subtrees ~fs my_mono in
213
-
214
-
(* Get verse subtrees (map: repo_name -> [(handle, monorepo_path)]) *)
215
246
let verse_subtrees = Verse.subtrees ~fs ~config:verse_config () in
216
-
217
-
(* Build comparisons for repos I have *)
218
247
let my_repos =
219
248
List.filter_map
220
-
(fun repo_name ->
221
-
let my_info =
222
-
subtree_info ~fs ~monorepo_path:my_mono ~prefix:repo_name ()
223
-
in
224
-
let checkout_path = Fpath.(checkouts / repo_name) in
225
-
226
-
(* Find others who have this repo *)
227
-
let others_with_repo =
228
-
try Hashtbl.find verse_subtrees repo_name with Not_found -> []
229
-
in
230
-
231
-
if others_with_repo = [] then None (* No one else has this repo, skip *)
232
-
else begin
233
-
let others =
234
-
List.map
235
-
(fun (handle, their_mono) ->
236
-
let their_info =
237
-
subtree_info ~fs ~monorepo_path:their_mono ~prefix:repo_name
238
-
()
239
-
in
240
-
let rel =
241
-
compare_commits ~fs ~checkout_path
242
-
~my_commit:my_info.upstream_commit
243
-
~their_commit:their_info.upstream_commit ()
244
-
in
245
-
(handle, their_info, rel))
246
-
others_with_repo
247
-
in
248
-
Some { repo_name; my_info = Some my_info; others }
249
-
end)
249
+
(compare_my_repo ~fs ~my_mono ~checkouts ~verse_subtrees)
250
250
my_subtrees
251
251
in
252
-
253
-
(* Find repos others have that I don't *)
254
-
let my_subtrees_set = Hashtbl.create 64 in
255
-
List.iter (fun s -> Hashtbl.add my_subtrees_set s ()) my_subtrees;
256
-
257
-
let other_repos =
258
-
Hashtbl.fold
259
-
(fun repo_name handles_and_paths acc ->
260
-
if Hashtbl.mem my_subtrees_set repo_name then acc
261
-
else
262
-
let handles = List.map fst handles_and_paths in
263
-
(repo_name, handles) :: acc)
264
-
verse_subtrees []
265
-
|> List.sort (fun (a, _) (b, _) -> String.compare a b)
266
-
in
267
-
252
+
let other_repos = other_repos ~my_subtrees ~verse_subtrees in
268
253
{ my_repos; other_repos }
+100
-101
lib/diff.ml
+100
-101
lib/diff.ml
···
111
111
112
112
(** {1 Diff Operations} *)
113
113
114
+
let check_source ~fs ~checkouts_path ~patch ~repo_name (handle, _src, rel) =
115
+
let checkout_path = Fpath.(checkouts_path / repo_name) in
116
+
if not (Git.Repository.is_repo ~fs checkout_path) then None
117
+
else begin
118
+
let repo = Git.Repository.open_repo ~fs checkout_path in
119
+
let remote_name = "verse/" ^ handle in
120
+
let my_ref = "origin/main" in
121
+
let their_ref = remote_name ^ "/main" in
122
+
match
123
+
Git.Repository.log_range_refs repo ~base:my_ref ~tip:their_ref
124
+
~max_count:20 ()
125
+
with
126
+
| Error _ -> None
127
+
| Ok commits when commits = [] -> None
128
+
| Ok commits ->
129
+
let patches =
130
+
if patch then
131
+
List.filter_map
132
+
(fun (c : Git.Repository.log_entry) ->
133
+
match Git.Repository.show_patch repo ~commit:c.hash with
134
+
| Ok p -> Some (c.hash, p)
135
+
| Error _ -> None)
136
+
commits
137
+
else []
138
+
in
139
+
Some { repo_name; handle; relationship = rel; commits; patches }
140
+
end
141
+
142
+
let check_repo ~fs ~checkouts_path ~patch (r : Forks.repo_analysis) =
143
+
let actionable =
144
+
List.filter
145
+
(fun (_, _, rel) ->
146
+
match rel with
147
+
| Forks.I_am_behind _ -> true
148
+
| Forks.Diverged _ -> true
149
+
| _ -> false)
150
+
r.verse_sources
151
+
in
152
+
match actionable with
153
+
| [] -> None
154
+
| sources -> (
155
+
let entries =
156
+
List.filter_map
157
+
(check_source ~fs ~checkouts_path ~patch ~repo_name:r.repo_name)
158
+
sources
159
+
in
160
+
match entries with [] -> None | _ -> Some entries)
161
+
114
162
let compute ~proc ~fs ~config ~verse_config ?repo ?(refresh = false)
115
163
?(patch = false) () =
116
164
let checkouts_path = Config.Paths.checkouts config in
···
123
171
| Some name -> List.filter (fun r -> r.Forks.repo_name = name) forks.repos
124
172
in
125
173
let entries =
126
-
List.filter_map
127
-
(fun (r : Forks.repo_analysis) ->
128
-
let actionable =
129
-
List.filter
130
-
(fun (_, _, rel) ->
131
-
match rel with
132
-
| Forks.I_am_behind _ -> true
133
-
| Forks.Diverged _ -> true
134
-
| _ -> false)
135
-
r.verse_sources
136
-
in
137
-
match actionable with
138
-
| [] -> None
139
-
| sources -> (
140
-
let entries =
141
-
List.filter_map
142
-
(fun (handle, _src, rel) ->
143
-
let checkout_path = Fpath.(checkouts_path / r.repo_name) in
144
-
if not (Git.Repository.is_repo ~fs checkout_path) then None
145
-
else begin
146
-
let repo = Git.Repository.open_repo ~fs checkout_path in
147
-
let remote_name = "verse/" ^ handle in
148
-
let my_ref = "origin/main" in
149
-
let their_ref = remote_name ^ "/main" in
150
-
match
151
-
Git.Repository.log_range_refs repo ~base:my_ref
152
-
~tip:their_ref ~max_count:20 ()
153
-
with
154
-
| Error _ -> None
155
-
| Ok commits when commits = [] -> None
156
-
| Ok commits ->
157
-
let patches =
158
-
if patch then
159
-
List.filter_map
160
-
(fun (c : Git.Repository.log_entry) ->
161
-
match
162
-
Git.Repository.show_patch repo ~commit:c.hash
163
-
with
164
-
| Ok p -> Some (c.hash, p)
165
-
| Error _ -> None)
166
-
commits
167
-
else []
168
-
in
169
-
Some
170
-
{
171
-
repo_name = r.repo_name;
172
-
handle;
173
-
relationship = rel;
174
-
commits;
175
-
patches;
176
-
}
177
-
end)
178
-
sources
179
-
in
180
-
match entries with [] -> None | _ -> Some entries))
181
-
repos_to_check
174
+
List.filter_map (check_repo ~fs ~checkouts_path ~patch) repos_to_check
182
175
|> List.flatten
183
176
in
184
177
{ entries; forks }
···
237
230
238
231
(** {1 Pull from Handle} *)
239
232
233
+
type pull_action =
234
+
| Pulled of string * int
235
+
| Skipped of string
236
+
| Failed of string * string
237
+
238
+
let pull_one_repo ~fs ~checkouts_path ~handle (r : Forks.repo_analysis) =
239
+
let handle_source =
240
+
List.find_opt (fun (h, _, _) -> h = handle) r.verse_sources
241
+
in
242
+
match handle_source with
243
+
| None -> []
244
+
| Some (_, _, rel) ->
245
+
let checkout_path = Fpath.(checkouts_path / r.repo_name) in
246
+
if not (Git.Repository.is_repo ~fs checkout_path) then
247
+
[ Skipped r.repo_name ]
248
+
else begin
249
+
let git_repo = Git.Repository.open_repo ~fs checkout_path in
250
+
match rel with
251
+
| Forks.Same_url | Forks.Same_commit | Forks.I_am_ahead _
252
+
| Forks.Not_fetched | Forks.Unrelated ->
253
+
[ Skipped r.repo_name ]
254
+
| Forks.I_am_behind count -> (
255
+
let remote_ref = "verse/" ^ handle ^ "/main" in
256
+
match
257
+
Git.Repository.merge git_repo ~ref_name:remote_ref ~ff_only:true
258
+
with
259
+
| Ok () -> [ Pulled (r.repo_name, count) ]
260
+
| Error (`Msg msg) -> [ Failed (r.repo_name, msg) ])
261
+
| Forks.Diverged { their_ahead; _ } -> (
262
+
let remote_ref = "verse/" ^ handle ^ "/main" in
263
+
match
264
+
Git.Repository.merge git_repo ~ref_name:remote_ref ~ff_only:false
265
+
with
266
+
| Ok () -> [ Pulled (r.repo_name, their_ahead) ]
267
+
| Error (`Msg msg) -> [ Failed (r.repo_name, msg) ])
268
+
end
269
+
240
270
let pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo
241
271
?(refresh = false) () =
242
272
let checkouts_path = Config.Paths.checkouts config in
···
248
278
| None -> forks.repos
249
279
| Some name -> List.filter (fun r -> r.Forks.repo_name = name) forks.repos
250
280
in
251
-
let repos_pulled = ref [] in
252
-
let repos_skipped = ref [] in
253
-
let repos_failed = ref [] in
254
-
List.iter
255
-
(fun (r : Forks.repo_analysis) ->
256
-
let handle_source =
257
-
List.find_opt (fun (h, _, _) -> h = handle) r.verse_sources
258
-
in
259
-
match handle_source with
260
-
| None -> ()
261
-
| Some (_, _, rel) ->
262
-
let checkout_path = Fpath.(checkouts_path / r.repo_name) in
263
-
if not (Git.Repository.is_repo ~fs checkout_path) then
264
-
repos_skipped := r.repo_name :: !repos_skipped
265
-
else begin
266
-
let git_repo = Git.Repository.open_repo ~fs checkout_path in
267
-
match rel with
268
-
| Forks.Same_url | Forks.Same_commit | Forks.I_am_ahead _ ->
269
-
repos_skipped := r.repo_name :: !repos_skipped
270
-
| Forks.Not_fetched | Forks.Unrelated ->
271
-
repos_skipped := r.repo_name :: !repos_skipped
272
-
| Forks.I_am_behind count -> (
273
-
let remote_ref = "verse/" ^ handle ^ "/main" in
274
-
match
275
-
Git.Repository.merge git_repo ~ref_name:remote_ref
276
-
~ff_only:true
277
-
with
278
-
| Ok () -> repos_pulled := (r.repo_name, count) :: !repos_pulled
279
-
| Error (`Msg msg) ->
280
-
repos_failed := (r.repo_name, msg) :: !repos_failed)
281
-
| Forks.Diverged { their_ahead; _ } -> (
282
-
let remote_ref = "verse/" ^ handle ^ "/main" in
283
-
match
284
-
Git.Repository.merge git_repo ~ref_name:remote_ref
285
-
~ff_only:false
286
-
with
287
-
| Ok () ->
288
-
repos_pulled := (r.repo_name, their_ahead) :: !repos_pulled
289
-
| Error (`Msg msg) ->
290
-
repos_failed := (r.repo_name, msg) :: !repos_failed)
291
-
end)
292
-
repos_to_check;
281
+
let actions =
282
+
List.concat_map (pull_one_repo ~fs ~checkouts_path ~handle) repos_to_check
283
+
in
284
+
let repos_pulled, repos_skipped, repos_failed =
285
+
List.fold_left
286
+
(fun (pulled, skipped, failed) -> function
287
+
| Pulled (name, count) -> ((name, count) :: pulled, skipped, failed)
288
+
| Skipped name -> (pulled, name :: skipped, failed)
289
+
| Failed (name, msg) -> (pulled, skipped, (name, msg) :: failed))
290
+
([], [], []) actions
291
+
in
293
292
Ok
294
293
{
295
-
repos_pulled = List.rev !repos_pulled;
296
-
repos_skipped = List.rev !repos_skipped;
297
-
repos_failed = List.rev !repos_failed;
294
+
repos_pulled = List.rev repos_pulled;
295
+
repos_skipped = List.rev repos_skipped;
296
+
repos_failed = List.rev repos_failed;
298
297
}
299
298
300
299
(** {1 Cherry-pick} *)
+121
-119
lib/doctor.ml
+121
-119
lib/doctor.ml
···
566
566
],
567
567
Meta.none )
568
568
569
+
let prop name schema =
570
+
let open Jsont in
571
+
((name, Meta.none), schema)
572
+
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
+
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
+
595
+
let repo_schema () =
596
+
object_with_props
597
+
[
598
+
prop "name" string_type;
599
+
prop "verse_analyses" (array_of (verse_schema ()));
600
+
]
601
+
602
+
let action_schema () =
603
+
object_with_props
604
+
[
605
+
prop "priority" string_type;
606
+
prop "action" string_type;
607
+
prop "command" string_type;
608
+
]
609
+
569
610
(** JSON schema for doctor output *)
570
611
let output_schema () =
571
612
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
613
Object
608
614
( [
609
615
(("type", Meta.none), String ("object", Meta.none));
610
616
( ("properties", Meta.none),
611
617
Object
612
618
( [
613
-
prop "repos" (array_of repo_schema);
614
-
prop "recommendations" (array_of action_schema);
619
+
prop "repos" (array_of (repo_schema ()));
620
+
prop "recommendations" (array_of (action_schema ()));
615
621
prop "warnings" (array_of string_type);
616
622
],
617
623
Meta.none ) );
···
882
888
(priority_order b.action_priority))
883
889
!recommendations
884
890
885
-
(** Run the doctor analysis *)
886
-
let analyze ~proc ~fs ~config ~verse_config ~clock ?package ?(no_sync = false)
887
-
() =
888
-
let _ = no_sync in
889
-
let now = Eio.Time.now clock in
890
-
let now_ptime =
891
-
Ptime.of_float_s now |> Option.value ~default:(Ptime.v (0, 0L))
892
-
in
893
-
let timestamp = Ptime.to_rfc3339 now_ptime ~tz_offset_s:0 in
894
-
let workspace = Fpath.to_string (Verse_config.root verse_config) in
895
-
891
+
let compute_statuses ~fs ~config ?package () =
896
892
let packages =
897
893
match
898
894
Opam_repo.scan ~fs:(fs :> _ Eio.Path.t) (Config.Paths.opam_repo config)
···
901
897
| Error _ -> []
902
898
in
903
899
let statuses = Status.compute_all ~fs ~config packages in
904
-
let statuses =
905
-
match package with
906
-
| None -> statuses
907
-
| Some name ->
908
-
List.filter
909
-
(fun (s : Status.t) -> Package.name s.package = name)
910
-
statuses
911
-
in
912
-
913
-
let warnings = check_dirty_repos ~fs ~config in
900
+
match package with
901
+
| None -> statuses
902
+
| Some name ->
903
+
List.filter (fun (s : Status.t) -> Package.name s.package = name) statuses
914
904
915
-
Log.app (fun m ->
916
-
m "Analyzing remotes for %d repositories..." (List.length statuses));
905
+
let collect_remotes_by_repo ~fs ~config statuses =
917
906
let checkouts_root = Config.Paths.checkouts config in
918
-
let remotes_by_repo =
919
-
List.filter_map
920
-
(fun (status : Status.t) ->
921
-
let name = Package.repo_name status.package in
922
-
let checkout_dir = Fpath.(checkouts_root / name) in
923
-
match status.checkout with
924
-
| Status.Missing | Status.Not_a_repo -> None
925
-
| _ -> Some (name, analyze_checkout_remotes ~fs ~checkout_dir))
926
-
statuses
927
-
in
928
-
929
-
let repos_with_incoming =
930
-
List.filter
931
-
(fun (_name, remotes) -> List.exists (fun r -> r.behind > 0) remotes)
932
-
remotes_by_repo
933
-
in
907
+
List.filter_map
908
+
(fun (status : Status.t) ->
909
+
let name = Package.repo_name status.package in
910
+
let checkout_dir = Fpath.(checkouts_root / name) in
911
+
match status.checkout with
912
+
| Status.Missing | Status.Not_a_repo -> None
913
+
| _ -> Some (name, analyze_checkout_remotes ~fs ~checkout_dir))
914
+
statuses
934
915
935
-
let base_repos = build_base_repos statuses in
916
+
let merge_claude_repos ~base_repos claude_repos =
917
+
List.map
918
+
(fun base_repo ->
919
+
match List.find_opt (fun cr -> cr.name = base_repo.name) claude_repos with
920
+
| Some cr -> { base_repo with verse_analyses = cr.verse_analyses }
921
+
| None -> base_repo)
922
+
base_repos
936
923
937
-
let repos, claude_recommendations, claude_warnings =
938
-
if repos_with_incoming <> [] then begin
939
-
Log.app (fun m ->
940
-
m "Found %d repos with incoming changes, analyzing with Claude..."
941
-
(List.length repos_with_incoming));
942
-
let status_summary = build_status_summary statuses in
943
-
let incoming_summary = build_incoming_summary remotes_by_repo in
944
-
match
945
-
Eio.Switch.run (fun sw ->
946
-
analyze_with_claude ~sw ~process_mgr:proc ~clock ~status_summary
947
-
~incoming_summary)
948
-
with
949
-
| Some json ->
950
-
let claude_repos, recs, warns = parse_claude_response json in
951
-
let merged_repos =
952
-
List.map
953
-
(fun base_repo ->
954
-
match
955
-
List.find_opt
956
-
(fun cr -> cr.name = base_repo.name)
957
-
claude_repos
958
-
with
959
-
| Some cr ->
960
-
{ base_repo with verse_analyses = cr.verse_analyses }
961
-
| None -> base_repo)
962
-
base_repos
963
-
in
964
-
(merged_repos, recs, warns)
965
-
| None ->
966
-
Log.warn (fun m -> m "Claude analysis failed, using basic status");
967
-
(base_repos, [], [])
968
-
end
969
-
else begin
970
-
Log.app (fun m -> m "No incoming changes from remotes");
971
-
(base_repos, [], [])
972
-
end
973
-
in
924
+
let analyze_incoming ~proc ~clock ~statuses ~remotes_by_repo ~base_repos
925
+
repos_with_incoming =
926
+
if repos_with_incoming <> [] then begin
927
+
Log.app (fun m ->
928
+
m "Found %d repos with incoming changes, analyzing with Claude..."
929
+
(List.length repos_with_incoming));
930
+
let status_summary = build_status_summary statuses in
931
+
let incoming_summary = build_incoming_summary remotes_by_repo in
932
+
match
933
+
Eio.Switch.run (fun sw ->
934
+
analyze_with_claude ~sw ~process_mgr:proc ~clock ~status_summary
935
+
~incoming_summary)
936
+
with
937
+
| Some json ->
938
+
let claude_repos, recs, warns = parse_claude_response json in
939
+
(merge_claude_repos ~base_repos claude_repos, recs, warns)
940
+
| None ->
941
+
Log.warn (fun m -> m "Claude analysis failed, using basic status");
942
+
(base_repos, [], [])
943
+
end
944
+
else begin
945
+
Log.app (fun m -> m "No incoming changes from remotes");
946
+
(base_repos, [], [])
947
+
end
974
948
949
+
let build_report_summary repos =
975
950
let repos_need_sync =
976
951
List.length (List.filter (fun r -> r.local_sync <> `In_sync) repos)
977
952
in
···
981
956
let verse_divergences =
982
957
List.fold_left (fun acc r -> acc + List.length r.verse_analyses) 0 repos
983
958
in
984
-
let report_summary =
985
-
{
959
+
( {
986
960
repos_total = List.length repos;
987
961
repos_need_sync;
988
962
repos_behind_upstream;
989
963
verse_divergences;
990
-
}
991
-
in
964
+
},
965
+
repos_need_sync,
966
+
repos_behind_upstream )
992
967
968
+
(** Run the doctor analysis *)
969
+
let analyze ~proc ~fs ~config ~verse_config ~clock ?package ?(no_sync = false)
970
+
() =
971
+
let _ = no_sync in
972
+
let now = Eio.Time.now clock in
973
+
let now_ptime =
974
+
Ptime.of_float_s now |> Option.value ~default:(Ptime.v (0, 0L))
975
+
in
976
+
let timestamp = Ptime.to_rfc3339 now_ptime ~tz_offset_s:0 in
977
+
let workspace = Fpath.to_string (Verse_config.root verse_config) in
978
+
let statuses = compute_statuses ~fs ~config ?package () in
979
+
let warnings = check_dirty_repos ~fs ~config in
980
+
Log.app (fun m ->
981
+
m "Analyzing remotes for %d repositories..." (List.length statuses));
982
+
let remotes_by_repo = collect_remotes_by_repo ~fs ~config statuses in
983
+
let repos_with_incoming =
984
+
List.filter
985
+
(fun (_name, remotes) -> List.exists (fun r -> r.behind > 0) remotes)
986
+
remotes_by_repo
987
+
in
988
+
let base_repos = build_base_repos statuses in
989
+
let repos, claude_recommendations, claude_warnings =
990
+
analyze_incoming ~proc ~clock ~statuses ~remotes_by_repo ~base_repos
991
+
repos_with_incoming
992
+
in
993
+
let report_summary, repos_need_sync, repos_behind_upstream =
994
+
build_report_summary repos
995
+
in
993
996
let recommendations =
994
997
build_recommendations ~repos_need_sync ~repos_behind_upstream
995
998
claude_recommendations
996
999
in
997
-
998
1000
{
999
1001
timestamp;
1000
1002
workspace;
+183
-208
lib/fork_join.ml
+183
-208
lib/fork_join.ml
···
678
678
in
679
679
base_actions @ sources_actions
680
680
681
-
(** Build a join plan - handles both URL and local path *)
682
-
let plan_join ~proc ~fs ~config ~source ?name ?upstream ?(dry_run = false) () =
683
-
let is_local = is_local_path source in
684
-
let name = match name with Some n -> n | None -> name_from_url source in
685
-
let monorepo = Verse_config.mono_path config in
686
-
let checkouts = Verse_config.src_path config in
687
-
let prefix = name in
688
-
let src_path = Fpath.(checkouts / name) in
689
-
let branch = Verse_config.default_branch in
690
-
681
+
let join_discovery ~fs ~is_local ~source ~monorepo ~prefix ~src_path =
691
682
let subtree_exists = is_directory ~fs Fpath.(monorepo / prefix) in
692
683
let src_exists = is_directory ~fs src_path in
693
684
let local_is_repo =
···
697
688
| Error _ -> Some false
698
689
else None
699
690
in
700
-
let discovery =
701
-
{
691
+
( {
702
692
mono_exists = subtree_exists;
703
693
src_exists;
704
694
has_subtree_history = false;
705
695
remote_accessible = None;
706
696
opam_files = [];
707
697
local_path_is_repo = local_is_repo;
708
-
}
698
+
},
699
+
subtree_exists,
700
+
local_is_repo )
701
+
702
+
let join_select_actions ~is_local ~source ~local_is_repo ~checkouts ~monorepo
703
+
~src_path ~prefix ~name ~upstream ~branch =
704
+
if is_local then
705
+
match Fpath.of_string source with
706
+
| Error (`Msg msg) -> raise (Invalid_argument msg)
707
+
| Ok local_path ->
708
+
if Option.value ~default:false local_is_repo then
709
+
join_local_repo_actions ~checkouts ~monorepo ~local_path ~src_path
710
+
~prefix ~branch
711
+
else
712
+
join_local_dir_actions ~checkouts ~monorepo ~local_path ~src_path
713
+
~prefix ~name ~branch
714
+
else
715
+
join_url_actions ~checkouts ~monorepo ~src_path ~prefix ~source ~upstream
716
+
~name ~branch
717
+
718
+
(** Build a join plan - handles both URL and local path *)
719
+
let plan_join ~proc ~fs ~config ~source ?name ?upstream ?(dry_run = false) () =
720
+
let is_local = is_local_path source in
721
+
let name = match name with Some n -> n | None -> name_from_url source in
722
+
let monorepo = Verse_config.mono_path config in
723
+
let checkouts = Verse_config.src_path config in
724
+
let prefix = name in
725
+
let src_path = Fpath.(checkouts / name) in
726
+
let branch = Verse_config.default_branch in
727
+
let discovery, subtree_exists, local_is_repo =
728
+
join_discovery ~fs ~is_local ~source ~monorepo ~prefix ~src_path
709
729
in
710
-
711
730
if subtree_exists then Error (Subtree_already_exists name)
712
731
else begin
713
732
let actions =
714
-
if is_local then
715
-
match Fpath.of_string source with
716
-
| Error (`Msg msg) -> raise (Invalid_argument msg)
717
-
| Ok local_path ->
718
-
if Option.value ~default:false local_is_repo then
719
-
join_local_repo_actions ~checkouts ~monorepo ~local_path ~src_path
720
-
~prefix ~branch
721
-
else
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
733
+
join_select_actions ~is_local ~source ~local_is_repo ~checkouts ~monorepo
734
+
~src_path ~prefix ~name ~upstream ~branch
727
735
in
728
736
let opam_preview =
729
737
if is_local then
···
750
758
}
751
759
end
752
760
753
-
(** Build a rejoin plan - add existing src/<name> back into mono/<name> *)
754
-
let plan_rejoin ~proc ~fs ~config ~name ?(dry_run = false) () =
755
-
let monorepo = Verse_config.mono_path config in
756
-
let checkouts = Verse_config.src_path config in
757
-
let prefix = name in
758
-
let src_path = Fpath.(checkouts / name) in
759
-
760
-
(* Gather discovery information *)
761
+
let rejoin_discovery ~fs ~monorepo ~prefix ~src_path =
761
762
let subtree_exists = is_directory ~fs Fpath.(monorepo / prefix) in
762
763
let src_exists = is_directory ~fs src_path in
763
764
let src_is_repo =
764
765
if src_exists then Git.Repository.is_repo ~fs src_path else false
765
766
in
766
-
let opam_files = if src_exists then opam_files ~fs src_path else [] in
767
-
767
+
let opam_files_list = if src_exists then opam_files ~fs src_path else [] in
768
768
let discovery =
769
769
{
770
770
mono_exists = subtree_exists;
771
771
src_exists;
772
772
has_subtree_history = false;
773
773
remote_accessible = None;
774
-
opam_files;
774
+
opam_files = opam_files_list;
775
775
local_path_is_repo = Some src_is_repo;
776
776
}
777
777
in
778
+
(discovery, subtree_exists, src_exists, src_is_repo, opam_files_list)
778
779
779
-
(* Validation *)
780
+
(** Build a rejoin plan - add existing src/<name> back into mono/<name> *)
781
+
let plan_rejoin ~proc ~fs ~config ~name ?(dry_run = false) () =
782
+
let monorepo = Verse_config.mono_path config in
783
+
let checkouts = Verse_config.src_path config in
784
+
let prefix = name in
785
+
let src_path = Fpath.(checkouts / name) in
786
+
let discovery, subtree_exists, src_exists, src_is_repo, opam_files_list =
787
+
rejoin_discovery ~fs ~monorepo ~prefix ~src_path
788
+
in
780
789
if subtree_exists then Error (Subtree_already_exists name)
781
790
else if not src_exists then Error (Src_not_found name)
782
791
else if not src_is_repo then
···
795
804
};
796
805
]
797
806
in
798
-
799
807
let result =
800
808
{
801
809
name;
802
810
source_url = Fpath.to_string src_path;
803
811
upstream_url = None;
804
-
packages_added = opam_files;
812
+
packages_added = opam_files_list;
805
813
from_handle = None;
806
814
}
807
815
in
808
-
809
816
Ok { discovery; actions; result; dry_run }
810
817
end
811
818
···
990
997
991
998
(** {1 Legacy API (using plans internally)} *)
992
999
1000
+
let fork_update_sources ~fs ~monorepo ~name ~push_url =
1001
+
match push_url with
1002
+
| Some url -> (
1003
+
let sources_path = Fpath.(monorepo / "sources.toml") in
1004
+
let sources =
1005
+
match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with
1006
+
| Ok s -> s
1007
+
| Error _ -> Sources_registry.empty
1008
+
in
1009
+
let entry =
1010
+
Sources_registry.
1011
+
{
1012
+
url = normalize_git_url url;
1013
+
upstream = None;
1014
+
branch = Some "main";
1015
+
reason = None;
1016
+
origin = Some Fork;
1017
+
}
1018
+
in
1019
+
let sources = Sources_registry.add sources ~subtree:name entry in
1020
+
match
1021
+
Sources_registry.save ~fs:(fs :> _ Eio.Path.t) sources_path sources
1022
+
with
1023
+
| Ok () -> ()
1024
+
| Error msg ->
1025
+
Logs.warn (fun m -> m "Failed to update sources.toml: %s" msg))
1026
+
| None -> ()
1027
+
1028
+
let fork_add_push_remote ~fs ~src_path ~push_url =
1029
+
let checkout_repo = Git.Repository.open_repo ~fs src_path in
1030
+
match push_url with
1031
+
| Some url ->
1032
+
Git.Repository.add_remote checkout_repo ~name:"origin" ~url ()
1033
+
|> Result.map_error (fun (`Msg msg) -> Git_error (Git_cli.Io_error msg))
1034
+
| None -> Ok ()
1035
+
1036
+
let fork_init_and_push ~proc ~fs ~monorepo ~checkouts ~src_path ~split_commit =
1037
+
ensure_dir ~fs checkouts;
1038
+
let git_repo = Git.Repository.init ~fs src_path in
1039
+
let mono_str = Fpath.to_string monorepo in
1040
+
match Git.Repository.add_remote git_repo ~name:"mono" ~url:mono_str () with
1041
+
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
1042
+
| Ok () -> (
1043
+
let ref_spec = split_commit ^ ":refs/heads/main" in
1044
+
match
1045
+
Git_cli.push_ref ~proc ~fs ~repo:monorepo
1046
+
~target:(Fpath.to_string src_path) ~ref_spec ()
1047
+
with
1048
+
| Error e -> Error (Git_error e)
1049
+
| Ok () ->
1050
+
let checkout_repo = Git.Repository.open_repo ~fs src_path in
1051
+
Git.Repository.checkout_ref checkout_repo "main"
1052
+
|> Result.map_error (fun (`Msg msg) ->
1053
+
Git_error (Git_cli.Io_error msg)))
1054
+
993
1055
let fork ~proc ~fs ~config ~name ?push_url ?(dry_run = false) () =
994
1056
let monorepo = Verse_config.mono_path config in
995
1057
let checkouts = Verse_config.src_path config in
996
1058
let prefix = name in
997
1059
let subtree_path = Fpath.(monorepo / prefix) in
998
1060
let src_path = Fpath.(checkouts / name) in
999
-
(* Validate: mono/<name>/ must exist *)
1000
1061
if not (is_directory ~fs Fpath.(monorepo / prefix)) then
1001
-
Error (Subtree_not_found name) (* Validate: src/<name>/ must not exist *)
1062
+
Error (Subtree_not_found name)
1002
1063
else if is_directory ~fs src_path then Error (Src_already_exists name)
1003
1064
else begin
1004
-
(* Find .opam files in subtree *)
1005
1065
let packages = opam_files ~fs subtree_path in
1006
1066
if packages = [] then Error (No_opam_files name)
1007
1067
else if dry_run then
···
1014
1074
packages_created = packages;
1015
1075
}
1016
1076
else begin
1017
-
(* Split the subtree to get history *)
1018
1077
let git_repo = Git.Repository.open_repo ~fs monorepo in
1019
1078
match Git.Repository.read_ref git_repo "HEAD" with
1020
1079
| None -> Error (Git_error (Git_cli.Io_error "no HEAD ref found"))
···
1024
1083
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
1025
1084
| Ok (Some split_hash) -> (
1026
1085
let split_commit = Git.Hash.to_hex split_hash in
1027
-
(* Ensure src/ exists *)
1028
-
ensure_dir ~fs checkouts;
1029
-
(* Initialize new git repo at src/<name>/ *)
1030
-
let git_repo = Git.Repository.init ~fs src_path in
1031
-
(* Add 'origin' remote pointing to monorepo path temporarily *)
1032
-
let mono_str = Fpath.to_string monorepo in
1033
1086
match
1034
-
Git.Repository.add_remote git_repo ~name:"mono" ~url:mono_str ()
1087
+
fork_init_and_push ~proc ~fs ~monorepo ~checkouts ~src_path
1088
+
~split_commit
1035
1089
with
1036
-
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
1090
+
| Error _ as e -> e
1037
1091
| Ok () -> (
1038
-
(* Push split commit to local repo *)
1039
-
let ref_spec = split_commit ^ ":refs/heads/main" in
1040
-
match
1041
-
Git_cli.push_ref ~proc ~fs ~repo:monorepo
1042
-
~target:(Fpath.to_string src_path) ~ref_spec ()
1043
-
with
1044
-
| Error e -> Error (Git_error e)
1045
-
| Ok () -> (
1046
-
(* Checkout main branch *)
1047
-
let checkout_repo =
1048
-
Git.Repository.open_repo ~fs src_path
1049
-
in
1050
-
match
1051
-
Git.Repository.checkout_ref checkout_repo "main"
1052
-
with
1053
-
| Error (`Msg msg) ->
1054
-
Error (Git_error (Git_cli.Io_error msg))
1055
-
| Ok () -> (
1056
-
(* Set push URL if provided *)
1057
-
let push_result =
1058
-
match push_url with
1059
-
| Some url ->
1060
-
Git.Repository.add_remote checkout_repo
1061
-
~name:"origin" ~url ()
1062
-
|> Result.map_error (fun (`Msg msg) ->
1063
-
Git_error (Git_cli.Io_error msg))
1064
-
| None -> Ok ()
1065
-
in
1066
-
match push_result with
1067
-
| Error _ as e -> e
1068
-
| Ok () ->
1069
-
(* Only update sources.toml if there's a push URL *)
1070
-
(match push_url with
1071
-
| Some url -> (
1072
-
let sources_path =
1073
-
Fpath.(monorepo / "sources.toml")
1074
-
in
1075
-
let sources =
1076
-
match
1077
-
Sources_registry.load
1078
-
~fs:(fs :> _ Eio.Path.t)
1079
-
sources_path
1080
-
with
1081
-
| Ok s -> s
1082
-
| Error _ -> Sources_registry.empty
1083
-
in
1084
-
let entry =
1085
-
Sources_registry.
1086
-
{
1087
-
url = normalize_git_url url;
1088
-
upstream = None;
1089
-
branch = Some "main";
1090
-
reason = None;
1091
-
origin = Some Fork;
1092
-
}
1093
-
in
1094
-
let sources =
1095
-
Sources_registry.add sources ~subtree:name
1096
-
entry
1097
-
in
1098
-
match
1099
-
Sources_registry.save
1100
-
~fs:(fs :> _ Eio.Path.t)
1101
-
sources_path sources
1102
-
with
1103
-
| Ok () -> ()
1104
-
| Error msg ->
1105
-
Logs.warn (fun m ->
1106
-
m "Failed to update sources.toml: %s"
1107
-
msg))
1108
-
| None -> ());
1109
-
Ok
1110
-
{
1111
-
name;
1112
-
split_commit;
1113
-
src_path;
1114
-
push_url;
1115
-
packages_created = packages;
1116
-
})))))
1092
+
match fork_add_push_remote ~fs ~src_path ~push_url with
1093
+
| Error _ as e -> e
1094
+
| Ok () ->
1095
+
fork_update_sources ~fs ~monorepo ~name ~push_url;
1096
+
Ok
1097
+
{
1098
+
name;
1099
+
split_commit;
1100
+
src_path;
1101
+
push_url;
1102
+
packages_created = packages;
1103
+
})))
1117
1104
end
1118
1105
end
1119
1106
1107
+
let join_update_sources ~fs ~monorepo ~name ~url ~upstream ~branch =
1108
+
match upstream with
1109
+
| Some _ -> (
1110
+
let sources_path = Fpath.(monorepo / "sources.toml") in
1111
+
let sources =
1112
+
match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with
1113
+
| Ok s -> s
1114
+
| Error _ -> Sources_registry.empty
1115
+
in
1116
+
let entry =
1117
+
Sources_registry.
1118
+
{
1119
+
url = normalize_git_url url;
1120
+
upstream = Option.map normalize_git_url upstream;
1121
+
branch = Some branch;
1122
+
reason = None;
1123
+
origin = Some Join;
1124
+
}
1125
+
in
1126
+
let sources = Sources_registry.add sources ~subtree:name entry in
1127
+
match
1128
+
Sources_registry.save ~fs:(fs :> _ Eio.Path.t) sources_path sources
1129
+
with
1130
+
| Ok () -> ()
1131
+
| Error msg ->
1132
+
Logs.warn (fun m -> m "Failed to update sources.toml: %s" msg))
1133
+
| None -> ()
1134
+
1135
+
let join_add_subtree ~proc ~fs ~monorepo ~prefix ~url ~branch =
1136
+
let uri = Uri.of_string url in
1137
+
match Git_cli.fetch_url ~proc ~fs ~repo:monorepo ~url:uri ~branch () with
1138
+
| Error e -> Error (Git_error e)
1139
+
| Ok hash_hex ->
1140
+
let git_repo = Git.Repository.open_repo ~fs monorepo in
1141
+
let commit = Git.Hash.of_hex hash_hex in
1142
+
let user =
1143
+
match Git_cli.global_git_user ~fs () with
1144
+
| Some u -> u
1145
+
| None ->
1146
+
Git.User.v ~name:"monopam" ~email:"monopam@localhost"
1147
+
~date:(Int64.of_float (Unix.time ()))
1148
+
()
1149
+
in
1150
+
let message =
1151
+
Fmt.str "Add '%s' from %s\n\ngit-subtree-dir: %s\n" prefix url prefix
1152
+
in
1153
+
Git.Subtree.add git_repo ~prefix ~commit ~author:user ~committer:user
1154
+
~message ()
1155
+
|> Result.map_error (fun (`Msg msg) -> Git_error (Git_cli.Io_error msg))
1156
+
1120
1157
let join ~proc ~fs ~config ~url ?name ?upstream ?(dry_run = false) () =
1121
1158
let name = match name with Some n -> n | None -> name_from_url url in
1122
1159
let monorepo = Verse_config.mono_path config in
···
1124
1161
let prefix = name in
1125
1162
let subtree_path = Fpath.(monorepo / prefix) in
1126
1163
let src_path = Fpath.(checkouts / name) in
1127
-
(* Validate: mono/<name>/ must not exist *)
1128
1164
if is_directory ~fs Fpath.(monorepo / prefix) then
1129
1165
Error (Subtree_already_exists name)
1130
1166
else if dry_run then
···
1137
1173
from_handle = None;
1138
1174
}
1139
1175
else begin
1140
-
(* Ensure src/ exists *)
1141
1176
ensure_dir ~fs checkouts;
1142
-
(* Clone to src/<name>/ *)
1143
1177
let branch = Verse_config.default_branch in
1144
1178
let uri = Uri.of_string url in
1145
1179
match Git_cli.clone ~proc ~fs ~url:uri ~branch src_path with
1146
1180
| Error e -> Error (Git_error e)
1147
1181
| Ok () -> (
1148
-
(* Add subtree to monorepo - first fetch to get the commit *)
1149
-
match
1150
-
Git_cli.fetch_url ~proc ~fs ~repo:monorepo ~url:uri ~branch ()
1151
-
with
1152
-
| Error e -> Error (Git_error e)
1153
-
| Ok hash_hex -> (
1154
-
let git_repo = Git.Repository.open_repo ~fs monorepo in
1155
-
let commit = Git.Hash.of_hex hash_hex in
1156
-
let user =
1157
-
match Git_cli.global_git_user ~fs () with
1158
-
| Some u -> u
1159
-
| None ->
1160
-
Git.User.v ~name:"monopam" ~email:"monopam@localhost"
1161
-
~date:(Int64.of_float (Unix.time ()))
1162
-
()
1163
-
in
1164
-
let message =
1165
-
Fmt.str "Add '%s' from %s\n\ngit-subtree-dir: %s\n" prefix url
1166
-
prefix
1167
-
in
1168
-
match
1169
-
Git.Subtree.add git_repo ~prefix ~commit ~author:user
1170
-
~committer:user ~message ()
1171
-
with
1172
-
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
1173
-
| Ok _ ->
1174
-
(* Find .opam files in the new subtree *)
1175
-
let packages = opam_files ~fs subtree_path in
1176
-
(* Only update sources.toml if there's an upstream to track *)
1177
-
(match upstream with
1178
-
| Some _ -> (
1179
-
let sources_path = Fpath.(monorepo / "sources.toml") in
1180
-
let sources =
1181
-
match
1182
-
Sources_registry.load
1183
-
~fs:(fs :> _ Eio.Path.t)
1184
-
sources_path
1185
-
with
1186
-
| Ok s -> s
1187
-
| Error _ -> Sources_registry.empty
1188
-
in
1189
-
let entry =
1190
-
Sources_registry.
1191
-
{
1192
-
url = normalize_git_url url;
1193
-
upstream = Option.map normalize_git_url upstream;
1194
-
branch = Some branch;
1195
-
reason = None;
1196
-
origin = Some Join;
1197
-
}
1198
-
in
1199
-
let sources =
1200
-
Sources_registry.add sources ~subtree:name entry
1201
-
in
1202
-
match
1203
-
Sources_registry.save
1204
-
~fs:(fs :> _ Eio.Path.t)
1205
-
sources_path sources
1206
-
with
1207
-
| Ok () -> ()
1208
-
| Error msg ->
1209
-
Logs.warn (fun m ->
1210
-
m "Failed to update sources.toml: %s" msg))
1211
-
| None -> ());
1212
-
Ok
1213
-
{
1214
-
name;
1215
-
source_url = url;
1216
-
upstream_url = upstream;
1217
-
packages_added = packages;
1218
-
from_handle = None;
1219
-
}))
1182
+
match join_add_subtree ~proc ~fs ~monorepo ~prefix ~url ~branch with
1183
+
| Error _ as e -> e
1184
+
| Ok _ ->
1185
+
let packages = opam_files ~fs subtree_path in
1186
+
join_update_sources ~fs ~monorepo ~name ~url ~upstream ~branch;
1187
+
Ok
1188
+
{
1189
+
name;
1190
+
source_url = url;
1191
+
upstream_url = upstream;
1192
+
packages_added = packages;
1193
+
from_handle = None;
1194
+
})
1220
1195
end
1221
1196
1222
1197
let join_from_verse ~proc ~fs ~config ~verse_config ~package ~handle ~fork_url
+54
-68
lib/forks.ml
+54
-68
lib/forks.ml
···
686
686
their_ahead;
687
687
}))
688
688
689
+
let compute_source_rel ~proc ~fs ~my_source ~checkout_path ~have_checkout
690
+
~refresh src =
691
+
let rel =
692
+
match my_source with
693
+
| Some my when urls_equal my.url src.url -> Same_url
694
+
| _ when not have_checkout -> Not_fetched
695
+
| _ -> (
696
+
let remote_name = verse_remote_name src.handle in
697
+
if not (remote_exists ~proc ~fs ~repo:checkout_path remote_name) then begin
698
+
Log.info (fun m ->
699
+
m "Adding remote %s -> %a" remote_name Uri.pp src.url);
700
+
ignore
701
+
(add_remote ~proc ~fs ~repo:checkout_path ~name:remote_name
702
+
~url:src.url ())
703
+
end;
704
+
match
705
+
fetch_remote ~proc ~fs ~repo:checkout_path ~remote:remote_name
706
+
~refresh ()
707
+
with
708
+
| Error _ -> Not_fetched
709
+
| Ok () ->
710
+
let my_ref = "origin/main" in
711
+
let their_ref = remote_name ^ "/main" in
712
+
compare_refs ~fs ~repo:checkout_path ~my_ref ~their_ref ())
713
+
in
714
+
(src.handle, src, rel)
715
+
716
+
let analyze_repo ~proc ~fs ~checkouts_path ~refresh ~my_repos ~verse_repos
717
+
repo_name acc =
718
+
let my_source =
719
+
match Hashtbl.find_opt my_repos repo_name with
720
+
| None -> None
721
+
| Some (url, pkgs) -> Some { handle = "me"; url; packages = pkgs }
722
+
in
723
+
let verse_sources =
724
+
match Hashtbl.find_opt verse_repos repo_name with
725
+
| None -> []
726
+
| Some sources -> sources
727
+
in
728
+
if verse_sources = [] then acc
729
+
else begin
730
+
let checkout_path = Fpath.(checkouts_path / repo_name) in
731
+
let have_checkout = Git.Repository.is_repo ~fs checkout_path in
732
+
let verse_with_rel =
733
+
List.map
734
+
(compute_source_rel ~proc ~fs ~my_source ~checkout_path ~have_checkout
735
+
~refresh)
736
+
verse_sources
737
+
in
738
+
{ repo_name; my_source; verse_sources = verse_with_rel } :: acc
739
+
end
740
+
689
741
(** Compute fork analysis for all repos *)
690
742
let compute ~proc ~fs ~verse_config ~monopam_config ?(refresh = false) () =
691
743
let verse_path = Verse_config.verse_path verse_config in
692
744
let opam_repo_path = Config.Paths.opam_repo monopam_config in
693
745
let checkouts_path = Config.Paths.checkouts monopam_config in
694
-
695
-
(* Scan my opam repo *)
696
746
Log.info (fun m -> m "Scanning my opam repo");
697
747
let my_repos = scan_my_opam_repo ~fs ~opam_repo_path () in
698
-
699
-
(* Scan verse opam repos *)
700
748
Log.info (fun m -> m "Scanning verse opam repos");
701
749
let verse_repos =
702
750
scan_all_verse_opam_repos ~proc ~fs ~verse_path ~refresh ()
703
751
in
704
-
705
-
(* Build combined list of all repo names *)
706
752
let all_repos = Hashtbl.create 64 in
707
753
Hashtbl.iter (fun repo _ -> Hashtbl.replace all_repos repo ()) my_repos;
708
754
Hashtbl.iter (fun repo _ -> Hashtbl.replace all_repos repo ()) verse_repos;
709
-
710
-
(* Analyze each repo *)
711
755
let analyses =
712
756
Hashtbl.fold
713
757
(fun repo_name () acc ->
714
-
let my_source =
715
-
match Hashtbl.find_opt my_repos repo_name with
716
-
| None -> None
717
-
| Some (url, pkgs) -> Some { handle = "me"; url; packages = pkgs }
718
-
in
719
-
let verse_sources =
720
-
match Hashtbl.find_opt verse_repos repo_name with
721
-
| None -> []
722
-
| Some sources -> sources
723
-
in
724
-
(* Skip if no verse sources *)
725
-
if verse_sources = [] then acc
726
-
else begin
727
-
(* Check if we have a local checkout *)
728
-
let checkout_path = Fpath.(checkouts_path / repo_name) in
729
-
let have_checkout = Git.Repository.is_repo ~fs checkout_path in
730
-
731
-
(* Process each verse source *)
732
-
let verse_with_rel =
733
-
List.map
734
-
(fun src ->
735
-
(* Check if URL is same as mine *)
736
-
let rel =
737
-
match my_source with
738
-
| Some my when urls_equal my.url src.url -> Same_url
739
-
| _ when not have_checkout -> Not_fetched
740
-
| _ -> (
741
-
let remote_name = verse_remote_name src.handle in
742
-
(* Add remote if needed *)
743
-
if
744
-
not
745
-
(remote_exists ~proc ~fs ~repo:checkout_path
746
-
remote_name)
747
-
then begin
748
-
Log.info (fun m ->
749
-
m "Adding remote %s -> %a" remote_name Uri.pp
750
-
src.url);
751
-
ignore
752
-
(add_remote ~proc ~fs ~repo:checkout_path
753
-
~name:remote_name ~url:src.url ())
754
-
end;
755
-
(* Fetch remote (respecting cache unless refresh) *)
756
-
match
757
-
fetch_remote ~proc ~fs ~repo:checkout_path
758
-
~remote:remote_name ~refresh ()
759
-
with
760
-
| Error _ -> Not_fetched
761
-
| Ok () ->
762
-
(* Compare refs *)
763
-
let my_ref = "origin/main" in
764
-
let their_ref = remote_name ^ "/main" in
765
-
compare_refs ~fs ~repo:checkout_path ~my_ref
766
-
~their_ref ())
767
-
in
768
-
(src.handle, src, rel))
769
-
verse_sources
770
-
in
771
-
{ repo_name; my_source; verse_sources = verse_with_rel } :: acc
772
-
end)
758
+
analyze_repo ~proc ~fs ~checkouts_path ~refresh ~my_repos ~verse_repos
759
+
repo_name acc)
773
760
all_repos []
774
761
in
775
-
(* Sort by repo name *)
776
762
let repos =
777
763
List.sort (fun a b -> String.compare a.repo_name b.repo_name) analyses
778
764
in
+75
-65
lib/init.ml
+75
-65
lib/init.ml
···
9
9
10
10
(** {1 Content Templates} *)
11
11
12
-
let claude_md_content =
12
+
let claude_md_header =
13
13
{|# Monorepo Development Guide
14
14
15
15
This is a monorepo managed by `monopam`. Each subdirectory is a git subtree
···
28
28
| Sync one repo | `monopam sync <repo-name>` |
29
29
| Build | `opam exec -- dune build` |
30
30
| Test | `opam exec -- dune test` |
31
+
|}
31
32
32
-
## Daily Workflow
33
+
let claude_md_workflow =
34
+
{|## Daily Workflow
33
35
34
36
```bash
35
37
# 1. Check what needs syncing
···
72
74
- **Always commit before sync**: `monopam sync` only exports committed changes
73
75
- **Check status first**: Run `monopam status` to see what needs attention
74
76
- **One repo per directory**: Each subdirectory maps to exactly one git remote
77
+
|}
75
78
76
-
## Troubleshooting
79
+
let claude_md_troubleshooting =
80
+
{|## Troubleshooting
77
81
78
82
### "Dirty packages" Error
79
83
Commit your changes first:
···
109
113
monopam status --help # Status command help
110
114
```
111
115
|}
116
+
117
+
let claude_md_content =
118
+
String.concat "\n"
119
+
[ claude_md_header; claude_md_workflow; claude_md_troubleshooting ]
112
120
113
121
let gitignore_content = {|_build
114
122
*.install
···
305
313
306
314
(** {1 Monorepo Initialization} *)
307
315
308
-
let ensure ~proc ~fs ~config =
309
-
let monorepo = Config.Paths.monorepo config in
310
-
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
311
-
let init_and_commit () =
312
-
Log.info (fun m -> m "Initializing monorepo at %a" Fpath.pp monorepo);
313
-
let (_ : Git.Repository.t) = Git.Repository.init ~fs monorepo in
314
-
let dune_project = Eio.Path.(monorepo_eio / "dune-project") in
315
-
Log.debug (fun m -> m "Creating dune-project file");
316
-
Eio.Path.save ~create:(`Or_truncate 0o644) dune_project "(lang dune 3.20)\n";
317
-
let claude_md = Eio.Path.(monorepo_eio / "CLAUDE.md") in
318
-
Log.debug (fun m -> m "Creating CLAUDE.md");
319
-
Eio.Path.save ~create:(`Or_truncate 0o644) claude_md claude_md_content;
320
-
let gitignore = Eio.Path.(monorepo_eio / ".gitignore") in
321
-
Log.debug (fun m -> m "Creating .gitignore");
322
-
Eio.Path.save ~create:(`Or_truncate 0o644) gitignore gitignore_content;
323
-
Log.debug (fun m -> m "Staging and committing initial files");
324
-
let repo = Git.Repository.open_repo ~fs monorepo in
325
-
Result.bind
326
-
(Git.Repository.add_to_index repo
327
-
[ "dune-project"; "CLAUDE.md"; ".gitignore" ]
316
+
let create_and_commit ~fs ~monorepo ~monorepo_eio =
317
+
Log.info (fun m -> m "Initializing monorepo at %a" Fpath.pp monorepo);
318
+
let (_ : Git.Repository.t) = Git.Repository.init ~fs monorepo in
319
+
let dune_project = Eio.Path.(monorepo_eio / "dune-project") in
320
+
Log.debug (fun m -> m "Creating dune-project file");
321
+
Eio.Path.save ~create:(`Or_truncate 0o644) dune_project "(lang dune 3.20)\n";
322
+
let claude_md = Eio.Path.(monorepo_eio / "CLAUDE.md") in
323
+
Log.debug (fun m -> m "Creating CLAUDE.md");
324
+
Eio.Path.save ~create:(`Or_truncate 0o644) claude_md claude_md_content;
325
+
let gitignore = Eio.Path.(monorepo_eio / ".gitignore") in
326
+
Log.debug (fun m -> m "Creating .gitignore");
327
+
Eio.Path.save ~create:(`Or_truncate 0o644) gitignore gitignore_content;
328
+
Log.debug (fun m -> m "Staging and committing initial files");
329
+
let repo = Git.Repository.open_repo ~fs monorepo in
330
+
Result.bind
331
+
(Git.Repository.add_to_index repo
332
+
[ "dune-project"; "CLAUDE.md"; ".gitignore" ]
333
+
|> Result.map_error (fun (`Msg msg) -> Ctx.Git_error (Git_cli.Io_error msg))
334
+
)
335
+
(fun () ->
336
+
let user =
337
+
match Git_cli.global_git_user ~fs () with
338
+
| Some u -> u
339
+
| None ->
340
+
Git.User.v ~name:"monopam" ~email:"monopam@localhost"
341
+
~date:(Int64.of_float (Unix.time ()))
342
+
()
343
+
in
344
+
Git.Repository.commit_index repo ~author:user ~committer:user
345
+
~message:"Initial commit with dune-project, CLAUDE.md, and .gitignore"
346
+
()
347
+
|> Result.map ignore
328
348
|> Result.map_error (fun (`Msg msg) ->
329
349
Ctx.Git_error (Git_cli.Io_error msg)))
330
-
(fun () ->
331
-
let user =
332
-
match Git_cli.global_git_user ~fs () with
333
-
| Some u -> u
334
-
| None ->
335
-
Git.User.v ~name:"monopam" ~email:"monopam@localhost"
336
-
~date:(Int64.of_float (Unix.time ()))
337
-
()
338
-
in
339
-
Git.Repository.commit_index repo ~author:user ~committer:user
340
-
~message:"Initial commit with dune-project, CLAUDE.md, and .gitignore"
341
-
()
342
-
|> Result.map ignore
343
-
|> Result.map_error (fun (`Msg msg) ->
344
-
Ctx.Git_error (Git_cli.Io_error msg)))
350
+
351
+
let ensure_file ~proc ~monorepo_eio ~filename ~content =
352
+
let file_path = Eio.Path.(monorepo_eio / filename) in
353
+
let exists =
354
+
match Eio.Path.kind ~follow:true file_path with
355
+
| `Regular_file -> true
356
+
| _ | (exception Eio.Io _) -> false
345
357
in
346
-
let ensure_file ~filename ~content =
347
-
let file_path = Eio.Path.(monorepo_eio / filename) in
348
-
let exists =
349
-
match Eio.Path.kind ~follow:true file_path with
350
-
| `Regular_file -> true
351
-
| _ | (exception Eio.Io _) -> false
352
-
in
353
-
if not exists then begin
354
-
Log.info (fun m -> m "Adding %s to monorepo" filename);
355
-
Eio.Path.save ~create:(`Or_truncate 0o644) file_path content;
356
-
Eio.Switch.run (fun sw ->
357
-
let child =
358
-
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
359
-
[ "git"; "add"; filename ]
360
-
in
361
-
ignore (Eio.Process.await child));
362
-
Eio.Switch.run (fun sw ->
363
-
let child =
364
-
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
365
-
[ "git"; "commit"; "-m"; "Add " ^ filename ]
366
-
in
367
-
ignore (Eio.Process.await child))
368
-
end
369
-
in
358
+
if not exists then begin
359
+
Log.info (fun m -> m "Adding %s to monorepo" filename);
360
+
Eio.Path.save ~create:(`Or_truncate 0o644) file_path content;
361
+
Eio.Switch.run (fun sw ->
362
+
let child =
363
+
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
364
+
[ "git"; "add"; filename ]
365
+
in
366
+
ignore (Eio.Process.await child));
367
+
Eio.Switch.run (fun sw ->
368
+
let child =
369
+
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
370
+
[ "git"; "commit"; "-m"; "Add " ^ filename ]
371
+
in
372
+
ignore (Eio.Process.await child))
373
+
end
374
+
375
+
let ensure ~proc ~fs ~config =
376
+
let monorepo = Config.Paths.monorepo config in
377
+
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
370
378
let is_directory =
371
379
match Eio.Path.kind ~follow:true monorepo_eio with
372
380
| `Directory -> true
···
376
384
if is_directory && Git.Repository.is_repo ~fs monorepo then begin
377
385
Log.debug (fun m ->
378
386
m "Monorepo already initialized at %a" Fpath.pp monorepo);
379
-
ensure_file ~filename:"CLAUDE.md" ~content:claude_md_content;
380
-
ensure_file ~filename:".gitignore" ~content:gitignore_content;
387
+
ensure_file ~proc ~monorepo_eio ~filename:"CLAUDE.md"
388
+
~content:claude_md_content;
389
+
ensure_file ~proc ~monorepo_eio ~filename:".gitignore"
390
+
~content:gitignore_content;
381
391
Ok ()
382
392
end
383
393
else begin
···
385
395
Log.debug (fun m -> m "Creating monorepo directory %a" Fpath.pp monorepo);
386
396
Ctx.mkdirs monorepo_eio
387
397
end;
388
-
init_and_commit ()
398
+
create_and_commit ~fs ~monorepo ~monorepo_eio
389
399
end
+87
-83
lib/opam_sync.ml
+87
-83
lib/opam_sync.ml
···
126
126
orphaned;
127
127
orphaned
128
128
129
+
let filter_packages ~packages all_pkgs =
130
+
match packages with
131
+
| [] -> all_pkgs
132
+
| names ->
133
+
List.filter
134
+
(fun p -> List.exists (fun n -> Pkg.matches_name n p) names)
135
+
all_pkgs
136
+
137
+
let sync_packages_with_progress ~fs ~opam_repo ~label pkgs =
138
+
let total = List.length pkgs in
139
+
let progress = Tty.Progress.create ~total label in
140
+
let sync_results =
141
+
List.mapi
142
+
(fun i pkg ->
143
+
Tty.Progress.message progress (Pkg.name pkg);
144
+
Tty.Progress.set progress (i + 1);
145
+
sync_package ~fs ~opam_repo pkg)
146
+
pkgs
147
+
in
148
+
Tty.Progress.finish progress;
149
+
sync_results
150
+
151
+
let commit_sync_result ~fs ~opam_repo result =
152
+
if result.synced <> [] || result.orphaned <> [] then begin
153
+
let repo = Git.Repository.open_repo ~fs opam_repo in
154
+
let msg = commit_message result in
155
+
match Git_cli.global_git_user ~fs () with
156
+
| Some user -> (
157
+
match
158
+
Git.Repository.commit_index repo ~author:user ~committer:user
159
+
~message:msg ()
160
+
with
161
+
| Ok _ -> ()
162
+
| Error (`Msg e) -> Log.warn (fun m -> m "Failed to commit: %s" e))
163
+
| None -> Log.warn (fun m -> m "No git user config found, skipping commit")
164
+
end
165
+
129
166
let run ~fs ~config ?(packages = []) () =
130
167
let monorepo = Config.Paths.monorepo config in
131
168
let sources = load_sources ~fs ~dir:monorepo in
132
169
match Pkg.discover ~fs ~config ~sources () with
133
170
| Error (`Config_error e) -> Error (`Config_error e)
134
171
| Ok all_pkgs ->
135
-
let pkgs =
136
-
match packages with
137
-
| [] -> all_pkgs
138
-
| names ->
139
-
List.filter
140
-
(fun p -> List.exists (fun n -> Pkg.matches_name n p) names)
141
-
all_pkgs
142
-
in
143
-
let total = List.length pkgs in
144
-
let progress = Tty.Progress.create ~total "Split" in
172
+
let pkgs = filter_packages ~packages all_pkgs in
145
173
let opam_repo = Config.Paths.opam_repo config in
146
174
let sync_results =
147
-
List.mapi
148
-
(fun i pkg ->
149
-
Tty.Progress.message progress (Pkg.name pkg);
150
-
Tty.Progress.set progress (i + 1);
151
-
sync_package ~fs ~opam_repo pkg)
152
-
pkgs
175
+
sync_packages_with_progress ~fs ~opam_repo ~label:"Split" pkgs
153
176
in
154
-
Tty.Progress.finish progress;
155
177
let synced, unchanged =
156
178
List.fold_left
157
179
(fun (s, u) r ->
···
173
195
orphaned = deleted;
174
196
}
175
197
in
176
-
if result.synced <> [] || result.orphaned <> [] then begin
177
-
let repo = Git.Repository.open_repo ~fs opam_repo in
178
-
let msg = commit_message result in
179
-
match Git_cli.global_git_user ~fs () with
180
-
| Some user -> (
181
-
match
182
-
Git.Repository.commit_index repo ~author:user ~committer:user
183
-
~message:msg ()
184
-
with
185
-
| Ok _ -> ()
186
-
| Error (`Msg e) -> Log.warn (fun m -> m "Failed to commit: %s" e))
187
-
| None ->
188
-
Log.warn (fun m -> m "No git user config found, skipping commit")
189
-
end;
198
+
commit_sync_result ~fs ~opam_repo result;
190
199
Ok result
191
200
192
201
(** {1 CWD-based Export} *)
···
367
376
| None -> Log.warn (fun m -> m "No git user config found, skipping commit")
368
377
end
369
378
379
+
let delete_orphaned_at ~fs ~target ~packages ~generated_names ~dry_run =
380
+
if packages = [] && not dry_run then begin
381
+
let existing = list_opam_repo_packages_at ~fs target in
382
+
let orphaned =
383
+
List.filter (fun name -> not (List.mem name generated_names)) existing
384
+
in
385
+
List.iter
386
+
(fun name ->
387
+
Log.info (fun m -> m "Removing orphaned package: %s" name);
388
+
ignore (delete_opam_repo_package_at ~fs target name))
389
+
orphaned;
390
+
orphaned
391
+
end
392
+
else []
393
+
394
+
let export_packages ~fs ~target ~packages ~dry_run ~no_commit pkgs =
395
+
let total = List.length pkgs in
396
+
let progress = Tty.Progress.create ~total "Export" in
397
+
let sync_results =
398
+
List.mapi
399
+
(fun i pkg ->
400
+
Tty.Progress.message progress (Pkg.name pkg);
401
+
Tty.Progress.set progress (i + 1);
402
+
sync_package_to ~fs ~opam_repo:target ~dry_run pkg)
403
+
pkgs
404
+
in
405
+
Tty.Progress.finish progress;
406
+
let synced, unchanged = partition_sync_results sync_results in
407
+
let generated_names =
408
+
List.map Pkg.name pkgs |> List.sort_uniq String.compare
409
+
in
410
+
let deleted =
411
+
delete_orphaned_at ~fs ~target ~packages ~generated_names ~dry_run
412
+
in
413
+
let result =
414
+
{
415
+
synced = List.rev synced;
416
+
unchanged = List.rev unchanged;
417
+
missing = [];
418
+
orphaned = deleted;
419
+
}
420
+
in
421
+
commit_if_needed ~fs ~target ~no_commit ~dry_run result;
422
+
Ok result
423
+
370
424
let run_from_cwd ~fs ~proc:_ ~source ~target ?(packages = [])
371
425
?(no_commit = false) ?(dry_run = false) () =
372
426
match discover_from_cwd ~fs ~source with
373
427
| Error e -> Error e
374
428
| Ok all_pkgs ->
375
-
let pkgs =
376
-
match packages with
377
-
| [] -> all_pkgs
378
-
| names ->
379
-
List.filter
380
-
(fun p -> List.exists (fun n -> Pkg.matches_name n p) names)
381
-
all_pkgs
382
-
in
429
+
let pkgs = filter_packages ~packages all_pkgs in
383
430
if pkgs = [] then begin
384
431
Log.info (fun m -> m "No packages found to export");
385
432
Ok { synced = []; unchanged = []; missing = []; orphaned = [] }
386
433
end
387
-
else begin
388
-
let total = List.length pkgs in
389
-
let progress = Tty.Progress.create ~total "Export" in
390
-
let sync_results =
391
-
List.mapi
392
-
(fun i pkg ->
393
-
Tty.Progress.message progress (Pkg.name pkg);
394
-
Tty.Progress.set progress (i + 1);
395
-
sync_package_to ~fs ~opam_repo:target ~dry_run pkg)
396
-
pkgs
397
-
in
398
-
Tty.Progress.finish progress;
399
-
let synced, unchanged = partition_sync_results sync_results in
400
-
let generated_names =
401
-
List.map Pkg.name pkgs |> List.sort_uniq String.compare
402
-
in
403
-
let deleted =
404
-
if packages = [] && not dry_run then begin
405
-
let existing = list_opam_repo_packages_at ~fs target in
406
-
let orphaned =
407
-
List.filter
408
-
(fun name -> not (List.mem name generated_names))
409
-
existing
410
-
in
411
-
List.iter
412
-
(fun name ->
413
-
Log.info (fun m -> m "Removing orphaned package: %s" name);
414
-
ignore (delete_opam_repo_package_at ~fs target name))
415
-
orphaned;
416
-
orphaned
417
-
end
418
-
else []
419
-
in
420
-
let result =
421
-
{
422
-
synced = List.rev synced;
423
-
unchanged = List.rev unchanged;
424
-
missing = [];
425
-
orphaned = deleted;
426
-
}
427
-
in
428
-
commit_if_needed ~fs ~target ~no_commit ~dry_run result;
429
-
Ok result
430
-
end
434
+
else export_packages ~fs ~target ~packages ~dry_run ~no_commit pkgs
+121
-139
lib/pull.ml
+121
-139
lib/pull.ml
···
17
17
18
18
(** {1 Subtree Operations} *)
19
19
20
+
let subtree_merge_or_add ~git_repo ~prefix ~commit ~user ~url ~hash_hex
21
+
~subtree_exists =
22
+
let verb, fn, added =
23
+
if subtree_exists then ("Merge", Git.Subtree.merge, false)
24
+
else ("Add", Git.Subtree.add, true)
25
+
in
26
+
let message =
27
+
Fmt.str
28
+
"%s '%s/' from %s\n\ngit-subtree-dir: %s\ngit-subtree-mainline: %s\n" verb
29
+
prefix (Uri.to_string url) prefix hash_hex
30
+
in
31
+
match
32
+
fn git_repo ~prefix ~commit ~author:user ~committer:user ~message ()
33
+
with
34
+
| Ok _ -> Ok added
35
+
| Error (`Msg msg) -> Error (Ctx.Git_error (Git_cli.Io_error msg))
36
+
20
37
let subtree ~proc ~fs ~config pkg =
21
38
let fs = Ctx.fs_typed fs in
22
39
let monorepo = Config.Paths.monorepo config in
···
39
56
~date:(Int64.of_float (Unix.time ()))
40
57
()
41
58
in
42
-
if subtree_exists then begin
43
-
Log.info (fun m ->
44
-
m "Pulling subtree %s from %a" prefix Fpath.pp checkout_dir);
45
-
let message =
46
-
Fmt.str
47
-
"Merge '%s/' from %s\n\n\
48
-
git-subtree-dir: %s\n\
49
-
git-subtree-mainline: %s\n"
50
-
prefix (Uri.to_string url) prefix hash_hex
51
-
in
52
-
match
53
-
Git.Subtree.merge git_repo ~prefix ~commit ~author:user
54
-
~committer:user ~message ()
55
-
with
56
-
| Ok _ -> Ok false
57
-
| Error (`Msg msg) -> Error (Ctx.Git_error (Git_cli.Io_error msg))
58
-
end
59
-
else begin
60
-
Log.info (fun m ->
61
-
m "Adding subtree %s from %a" prefix Fpath.pp checkout_dir);
62
-
let message =
63
-
Fmt.str
64
-
"Add '%s/' from %s\n\n\
65
-
git-subtree-dir: %s\n\
66
-
git-subtree-mainline: %s\n"
67
-
prefix (Uri.to_string url) prefix hash_hex
68
-
in
69
-
match
70
-
Git.Subtree.add git_repo ~prefix ~commit ~author:user ~committer:user
71
-
~message ()
72
-
with
73
-
| Ok _ -> Ok true
74
-
| Error (`Msg msg) -> Error (Ctx.Git_error (Git_cli.Io_error msg))
75
-
end
59
+
Log.info (fun m ->
60
+
m "%s subtree %s from %a"
61
+
(if subtree_exists then "Pulling" else "Adding")
62
+
prefix Fpath.pp checkout_dir);
63
+
subtree_merge_or_add ~git_repo ~prefix ~commit ~user ~url ~hash_hex
64
+
~subtree_exists
76
65
77
66
(** {1 Main Pull Operation} *)
78
67
79
-
let run ~proc ~fs ~config ?(packages = []) ?opam_repo_url () =
80
-
let fs_t = Ctx.fs_typed fs in
81
-
let opam_repo = Config.Paths.opam_repo config in
82
-
if Git.Repository.is_repo ~fs:fs_t opam_repo then begin
68
+
let ensure_opam_repo ~proc ~fs ~opam_repo ~opam_repo_url =
69
+
if Git.Repository.is_repo ~fs opam_repo then begin
83
70
Log.info (fun m -> m "Updating opam repo at %a" Fpath.pp opam_repo);
84
71
let result =
85
72
let ( let* ) = Result.bind in
86
-
let* () = Git_cli.fetch ~proc ~fs:fs_t opam_repo in
87
-
Git_cli.merge_ff ~proc ~fs:fs_t opam_repo
73
+
let* () = Git_cli.fetch ~proc ~fs opam_repo in
74
+
Git_cli.merge_ff ~proc ~fs opam_repo
88
75
in
89
76
match result with
90
77
| Ok () -> ()
···
99
86
m "Cloning opam repo from %s to %a" url Fpath.pp opam_repo);
100
87
let url = Uri.of_string url in
101
88
let branch = Config.default_branch in
102
-
match Git_cli.clone ~proc ~fs:fs_t ~url ~branch opam_repo with
89
+
match Git_cli.clone ~proc ~fs ~url ~branch opam_repo with
103
90
| Ok () -> Log.info (fun m -> m "Opam repo cloned successfully")
104
91
| Error e ->
105
92
Log.warn (fun m ->
···
108
95
Log.info (fun m ->
109
96
m "Opam repo at %a does not exist and no URL provided" Fpath.pp
110
97
opam_repo)
111
-
end;
98
+
end
99
+
100
+
let clone_repos ~proc ~fs ~config repos =
101
+
let total = List.length repos in
102
+
let progress = Tty.Progress.create ~total "Fetch" in
103
+
let rec loop acc = function
104
+
| [] ->
105
+
Tty.Progress.clear progress;
106
+
Ok (List.rev acc)
107
+
| pkg :: rest -> (
108
+
let repo_name = Package.repo_name pkg in
109
+
Tty.Progress.message progress
110
+
(Fmt.str "Fetch: %s (%d/%d)" repo_name (List.length acc + 1) total);
111
+
Log.info (fun m -> m "Fetching repo %s" repo_name);
112
+
let existed = Ctx.checkout_exists ~fs ~config pkg in
113
+
let behind_before = if existed then Ctx.behind ~fs ~config pkg else 0 in
114
+
match Ctx.ensure_checkout ~proc ~fs ~config pkg with
115
+
| Error e ->
116
+
Tty.Progress.clear progress;
117
+
Error (Ctx.Git_error e)
118
+
| Ok () ->
119
+
Tty.Progress.tick progress;
120
+
let result =
121
+
{
122
+
repo_name;
123
+
cloned = not existed;
124
+
commits_pulled = behind_before;
125
+
subtree_added = false;
126
+
}
127
+
in
128
+
loop (result :: acc) rest)
129
+
in
130
+
loop [] repos
131
+
132
+
let process_subtrees ~proc ~fs ~config repos checkout_results =
133
+
let total = List.length repos in
134
+
let progress = Tty.Progress.create ~total "Subtree" in
135
+
let rec loop results_acc repos_left checkout_results_left =
136
+
match (repos_left, checkout_results_left) with
137
+
| [], [] ->
138
+
Tty.Progress.clear progress;
139
+
Ok (List.rev results_acc)
140
+
| pkg :: rest_repos, cr :: rest_cr -> (
141
+
let name = Package.subtree_prefix pkg in
142
+
Tty.Progress.message progress
143
+
(Fmt.str "Subtree: %s (%d/%d)" name
144
+
(List.length results_acc + 1)
145
+
total);
146
+
Log.info (fun m -> m "Subtree %s" name);
147
+
match subtree ~proc ~fs ~config pkg with
148
+
| Ok subtree_added ->
149
+
Tty.Progress.tick progress;
150
+
let result = { cr with subtree_added } in
151
+
loop (result :: results_acc) rest_repos rest_cr
152
+
| Error e ->
153
+
Tty.Progress.clear progress;
154
+
Error e)
155
+
| _ ->
156
+
Tty.Progress.clear progress;
157
+
Ok (List.rev results_acc)
158
+
in
159
+
loop [] repos checkout_results
160
+
161
+
let log_pull_results results =
162
+
let cloned = List.filter (fun r -> r.cloned) results in
163
+
let updated =
164
+
List.filter (fun r -> (not r.cloned) && r.commits_pulled > 0) results
165
+
in
166
+
let added = List.filter (fun r -> r.subtree_added) results in
167
+
List.iter (fun r -> Log.app (fun m -> m " + %s (cloned)" r.repo_name)) cloned;
168
+
List.iter
169
+
(fun r ->
170
+
Log.app (fun m -> m " ✓ %s (%d commits)" r.repo_name r.commits_pulled))
171
+
updated;
172
+
List.iter (fun r -> Log.app (fun m -> m " + %s (added)" r.repo_name)) added;
173
+
let unchanged =
174
+
List.length results - List.length cloned - List.length updated
175
+
- List.length added
176
+
in
177
+
if cloned = [] && updated = [] && added = [] then
178
+
Log.app (fun m ->
179
+
m " All %d repositories up to date." (List.length results))
180
+
else if unchanged > 0 then Log.app (fun m -> m " %d unchanged." unchanged)
181
+
182
+
let run ~proc ~fs ~config ?(packages = []) ?opam_repo_url () =
183
+
let fs_t = Ctx.fs_typed fs in
184
+
let opam_repo = Config.Paths.opam_repo config in
185
+
ensure_opam_repo ~proc ~fs:fs_t ~opam_repo ~opam_repo_url;
112
186
Ctx.ensure_checkouts_dir ~fs:fs_t ~config;
113
187
match Init.ensure ~proc ~fs:fs_t ~config with
114
188
| Error e -> Error e
···
141
215
Log.info (fun m ->
142
216
m "Cloning/fetching %d unique repositories"
143
217
(List.length repos));
144
-
let clone_repos () =
145
-
let total = List.length repos in
146
-
let progress = Tty.Progress.create ~total "Fetch" in
147
-
let rec loop acc = function
148
-
| [] ->
149
-
Tty.Progress.clear progress;
150
-
Ok (List.rev acc)
151
-
| pkg :: rest -> (
152
-
let repo_name = Package.repo_name pkg in
153
-
Tty.Progress.message progress
154
-
(Fmt.str "Fetch: %s (%d/%d)" repo_name
155
-
(List.length acc + 1)
156
-
total);
157
-
Log.info (fun m -> m "Fetching repo %s" repo_name);
158
-
let existed = Ctx.checkout_exists ~fs:fs_t ~config pkg in
159
-
let behind_before =
160
-
if existed then Ctx.behind ~fs:fs_t ~config pkg else 0
161
-
in
162
-
match Ctx.ensure_checkout ~proc ~fs:fs_t ~config pkg with
163
-
| Error e ->
164
-
Tty.Progress.clear progress;
165
-
Error (Ctx.Git_error e)
166
-
| Ok () ->
167
-
Tty.Progress.tick progress;
168
-
let result =
169
-
{
170
-
repo_name;
171
-
cloned = not existed;
172
-
commits_pulled = behind_before;
173
-
subtree_added = false;
174
-
}
175
-
in
176
-
loop (result :: acc) rest)
177
-
in
178
-
loop [] repos
179
-
in
180
-
match clone_repos () with
218
+
match clone_repos ~proc ~fs:fs_t ~config repos with
181
219
| Error e -> Error e
182
220
| Ok checkout_results -> (
183
221
Log.info (fun m ->
184
222
m "Processing %d unique subtrees" (List.length repos));
185
-
let total = List.length repos in
186
-
let progress = Tty.Progress.create ~total "Subtree" in
187
-
let rec loop results_acc repos_left checkout_results_left =
188
-
match (repos_left, checkout_results_left) with
189
-
| [], [] ->
190
-
Tty.Progress.clear progress;
191
-
Ok (List.rev results_acc)
192
-
| pkg :: rest_repos, cr :: rest_cr -> (
193
-
let name = Package.subtree_prefix pkg in
194
-
Tty.Progress.message progress
195
-
(Fmt.str "Subtree: %s (%d/%d)" name
196
-
(List.length results_acc + 1)
197
-
total);
198
-
Log.info (fun m -> m "Subtree %s" name);
199
-
match subtree ~proc ~fs ~config pkg with
200
-
| Ok subtree_added ->
201
-
Tty.Progress.tick progress;
202
-
let result = { cr with subtree_added } in
203
-
loop (result :: results_acc) rest_repos rest_cr
204
-
| Error e ->
205
-
Tty.Progress.clear progress;
206
-
Error e)
207
-
| _ ->
208
-
Tty.Progress.clear progress;
209
-
Ok (List.rev results_acc)
210
-
in
211
-
match loop [] repos checkout_results with
223
+
match
224
+
process_subtrees ~proc ~fs ~config repos checkout_results
225
+
with
212
226
| Error e -> Error e
213
227
| Ok results ->
214
-
let cloned = List.filter (fun r -> r.cloned) results in
215
-
let updated =
216
-
List.filter
217
-
(fun r -> (not r.cloned) && r.commits_pulled > 0)
218
-
results
219
-
in
220
-
let added =
221
-
List.filter (fun r -> r.subtree_added) results
222
-
in
223
-
List.iter
224
-
(fun r ->
225
-
Log.app (fun m -> m " + %s (cloned)" r.repo_name))
226
-
cloned;
227
-
List.iter
228
-
(fun r ->
229
-
Log.app (fun m ->
230
-
m " ✓ %s (%d commits)" r.repo_name
231
-
r.commits_pulled))
232
-
updated;
233
-
List.iter
234
-
(fun r ->
235
-
Log.app (fun m -> m " + %s (added)" r.repo_name))
236
-
added;
237
-
let unchanged =
238
-
List.length results - List.length cloned
239
-
- List.length updated - List.length added
240
-
in
241
-
if cloned = [] && updated = [] && added = [] then
242
-
Log.app (fun m ->
243
-
m " All %d repositories up to date."
244
-
(List.length results))
245
-
else if unchanged > 0 then
246
-
Log.app (fun m -> m " %d unchanged." unchanged);
228
+
log_pull_results results;
247
229
Init.write_readme ~proc ~fs:fs_t ~config all_pkgs;
248
230
Init.write_claude_md ~proc ~fs:fs_t ~config;
249
231
Init.write_dune_project ~proc ~fs:fs_t ~config all_pkgs;
+147
-149
lib/push.ml
+147
-149
lib/push.ml
···
9
9
10
10
(** {1 Single Package Push} *)
11
11
12
+
let checkout_tree_hash ~fs checkout_dir =
13
+
let checkout_repo = Git.Repository.open_repo ~fs checkout_dir in
14
+
match Git.Repository.head checkout_repo with
15
+
| None -> None
16
+
| Some h -> (
17
+
match Git.Repository.read checkout_repo h with
18
+
| Ok (Git.Value.Commit c) -> Some (Git.Commit.tree c)
19
+
| _ -> None)
20
+
21
+
let split_and_push ~proc ~fs ~monorepo ~git_repo ~prefix ~checkout_url ~clean
22
+
~branch =
23
+
let _checked, errors = Git.Subtree.verify git_repo ~prefix () in
24
+
if errors <> [] then begin
25
+
Log.info (fun m ->
26
+
m "Clearing invalid cache for %s (%d errors)" prefix
27
+
(List.length errors));
28
+
Git.Subtree.Cache.clear git_repo ~prefix
29
+
end;
30
+
match Git.Repository.read_ref git_repo "HEAD" with
31
+
| None -> Error (Ctx.Git_error (Git_cli.Io_error "no HEAD ref found"))
32
+
| Some head -> (
33
+
match Git.Subtree.split git_repo ~prefix ~head () with
34
+
| Ok None -> Error (Ctx.Git_error (Git_cli.Subtree_prefix_missing prefix))
35
+
| Error (`Msg msg) -> Error (Ctx.Git_error (Git_cli.Io_error msg))
36
+
| Ok (Some split_hash) -> (
37
+
let final_hash =
38
+
if clean then (
39
+
match Git.Subtree.fix git_repo ~prefix ~head:split_hash () with
40
+
| Ok (Some h) ->
41
+
Log.info (fun m -> m "Cleaned history for %s" prefix);
42
+
h
43
+
| Ok None -> split_hash
44
+
| Error (`Msg msg) ->
45
+
Log.warn (fun m -> m "Failed to clean %s: %s" prefix msg);
46
+
split_hash)
47
+
else split_hash
48
+
in
49
+
let refspec = Git.Hash.to_hex final_hash ^ ":refs/heads/" ^ branch in
50
+
match
51
+
Git_cli.push_refspec ~proc ~fs ~repo:monorepo ~url:checkout_url
52
+
~refspec ~force:clean ()
53
+
with
54
+
| Ok () -> Ok ()
55
+
| Error e -> Error (Ctx.Git_error e)))
56
+
12
57
let one ~proc ~fs ~config ~clean pkg =
13
58
let ( let* ) r f =
14
59
Result.bind (Result.map_error (fun e -> Ctx.Git_error e) r) f
···
40
85
in
41
86
let checkout_url = Uri.of_string (Fpath.to_string checkout_dir) in
42
87
let git_repo = Git.Repository.open_repo ~fs monorepo in
43
-
let checkout_repo = Git.Repository.open_repo ~fs checkout_dir in
44
88
let mono_tree =
45
89
Git.Repository.tree_hash_at_path git_repo ~rev:"HEAD" ~path:prefix
46
90
in
47
-
let checkout_tree =
48
-
match Git.Repository.head checkout_repo with
49
-
| None -> None
50
-
| Some h -> (
51
-
match Git.Repository.read checkout_repo h with
52
-
| Ok (Git.Value.Commit c) -> Some (Git.Commit.tree c)
53
-
| _ -> None)
54
-
in
91
+
let checkout_tree = checkout_tree_hash ~fs checkout_dir in
55
92
if mono_tree = checkout_tree && mono_tree <> None then begin
56
93
Log.debug (fun m -> m "Skipping %s (trees match)" prefix);
57
94
Ok ()
58
95
end
59
96
else begin
60
97
Log.info (fun m -> m "Subtree push %s -> %a" prefix Fpath.pp checkout_dir);
61
-
let _checked, errors = Git.Subtree.verify git_repo ~prefix () in
62
-
if errors <> [] then begin
63
-
Log.info (fun m ->
64
-
m "Clearing invalid cache for %s (%d errors)" prefix
65
-
(List.length errors));
66
-
Git.Subtree.Cache.clear git_repo ~prefix
67
-
end;
68
-
match Git.Repository.read_ref git_repo "HEAD" with
69
-
| None -> Error (Ctx.Git_error (Git_cli.Io_error "no HEAD ref found"))
70
-
| Some head -> (
71
-
match Git.Subtree.split git_repo ~prefix ~head () with
72
-
| Ok None ->
73
-
Error (Ctx.Git_error (Git_cli.Subtree_prefix_missing prefix))
74
-
| Error (`Msg msg) -> Error (Ctx.Git_error (Git_cli.Io_error msg))
75
-
| Ok (Some split_hash) -> (
76
-
let final_hash =
77
-
if clean then (
78
-
match
79
-
Git.Subtree.fix git_repo ~prefix ~head:split_hash ()
80
-
with
81
-
| Ok (Some h) ->
82
-
Log.info (fun m -> m "Cleaned history for %s" prefix);
83
-
h
84
-
| Ok None -> split_hash
85
-
| Error (`Msg msg) ->
86
-
Log.warn (fun m -> m "Failed to clean %s: %s" prefix msg);
87
-
split_hash)
88
-
else split_hash
89
-
in
90
-
let refspec =
91
-
Git.Hash.to_hex final_hash ^ ":refs/heads/" ^ branch
92
-
in
93
-
match
94
-
Git_cli.push_refspec ~proc ~fs ~repo:monorepo ~url:checkout_url
95
-
~refspec ~force:clean ()
96
-
with
97
-
| Ok () -> Ok ()
98
-
| Error e -> Error (Ctx.Git_error e)))
98
+
split_and_push ~proc ~fs ~monorepo ~git_repo ~prefix ~checkout_url ~clean
99
+
~branch
99
100
end
100
101
end
101
102
···
127
128
128
129
(** {1 Main Push Operation} *)
129
130
131
+
let export_repos ~proc ~fs ~config ~clean ~progress repos =
132
+
let update_progress name =
133
+
Tty.Progress.update progress ~phase:"Export" ~msg:name
134
+
in
135
+
let rec loop pushed_repos = function
136
+
| [] -> Ok (List.rev pushed_repos)
137
+
| pkg :: rest -> (
138
+
let name = Package.subtree_prefix pkg in
139
+
update_progress name;
140
+
Log.debug (fun m -> m "Subtree push %s" name);
141
+
match one ~proc ~fs ~config ~clean pkg with
142
+
| Ok () -> loop (pkg :: pushed_repos) rest
143
+
| Error e ->
144
+
Tty.Progress.clear progress;
145
+
Error e)
146
+
in
147
+
loop [] repos
148
+
149
+
let to_upstream ~proc ~fs ~config ~force ~progress pushed_repos =
150
+
Log.info (fun m ->
151
+
m "Pushing %d repos to upstream (parallel)" (List.length pushed_repos));
152
+
let checkouts_root = Config.Paths.checkouts config in
153
+
Eio.Fiber.List.map ~max_fibers:8
154
+
(fun pkg ->
155
+
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
156
+
let name = Package.repo_name pkg in
157
+
Tty.Progress.update progress ~phase:"Push" ~msg:name;
158
+
let branch = Ctx.branch ~config pkg in
159
+
let knot = Config.knot config in
160
+
let push_url = Ctx.url_to_push_url ~knot (Package.dev_repo pkg) in
161
+
Log.info (fun m -> m "Pushing %s to %s" name push_url);
162
+
let repo = Git.Repository.open_repo ~fs checkout_dir in
163
+
(match Git.Repository.set_push_url repo ~name:"origin" ~url:push_url with
164
+
| Ok () -> ()
165
+
| Error (`Msg msg) ->
166
+
Log.warn (fun m -> m "Failed to set push URL: %s" msg));
167
+
match Git_cli.push_remote ~proc ~fs ~branch ~force checkout_dir with
168
+
| Ok () -> Ok name
169
+
| Error e -> Error (name, Ctx.Git_error e))
170
+
pushed_repos
171
+
172
+
let log_push_results push_results =
173
+
let successes, failures =
174
+
List.partition_map
175
+
(function Ok name -> Left name | Error (name, _) -> Right name)
176
+
push_results
177
+
in
178
+
List.iter (fun name -> Log.app (fun m -> m " ✓ %s" name)) successes;
179
+
List.iter (fun name -> Log.app (fun m -> m " ✗ %s" name)) failures;
180
+
match List.find_opt Result.is_error push_results with
181
+
| Some (Error (_, e)) -> Error e
182
+
| _ -> Ok ()
183
+
184
+
let repos_to_push statuses pkgs =
185
+
let status_by_prefix =
186
+
List.fold_left
187
+
(fun acc s ->
188
+
let prefix = Package.subtree_prefix s.Status.package in
189
+
(prefix, s) :: acc)
190
+
[] statuses
191
+
in
192
+
let needs_export pkg =
193
+
let prefix = Package.subtree_prefix pkg in
194
+
match List.assoc_opt prefix status_by_prefix with
195
+
| Some s -> not (Status.is_fully_synced s)
196
+
| None -> true
197
+
in
198
+
let all_repos = Ctx.unique_repos pkgs in
199
+
let repos = List.filter needs_export all_repos in
200
+
let skipped = List.length all_repos - List.length repos in
201
+
if skipped > 0 then
202
+
Log.info (fun m -> m "Skipping %d already-synced repos" skipped);
203
+
repos
204
+
205
+
let export_and_push ~proc ~fs ~fs_t ~config ~upstream ~clean ~force repos =
206
+
let n_repos = List.length repos in
207
+
let total = if upstream then n_repos * 2 else n_repos in
208
+
let progress = Tty.Progress.create ~total "Push" in
209
+
match export_repos ~proc ~fs ~config ~clean ~progress repos with
210
+
| Error e -> Error e
211
+
| Ok pushed_repos -> (
212
+
let push_results =
213
+
if upstream && pushed_repos <> [] then
214
+
to_upstream ~proc ~fs:fs_t ~config ~force ~progress pushed_repos
215
+
else List.map (fun p -> Ok (Package.repo_name p)) pushed_repos
216
+
in
217
+
Tty.Progress.clear progress;
218
+
match log_push_results push_results with
219
+
| Error e -> Error e
220
+
| Ok () ->
221
+
if upstream then workspace_repos ~proc ~fs:fs_t ~config ~force;
222
+
Ok ())
223
+
130
224
let run ~proc ~fs ~config ?(packages = []) ?(upstream = false) ?(clean = false)
131
225
?(force = false) () =
132
226
let fs_t = Ctx.fs_typed fs in
···
154
248
in
155
249
if dirty <> [] then Error (Ctx.Dirty_state dirty)
156
250
else begin
157
-
let status_by_prefix =
158
-
List.fold_left
159
-
(fun acc s ->
160
-
let prefix = Package.subtree_prefix s.Status.package in
161
-
(prefix, s) :: acc)
162
-
[] statuses
163
-
in
164
-
let needs_export pkg =
165
-
let prefix = Package.subtree_prefix pkg in
166
-
match List.assoc_opt prefix status_by_prefix with
167
-
| Some s -> not (Status.is_fully_synced s)
168
-
| None -> true
169
-
in
170
-
let all_repos = Ctx.unique_repos pkgs in
171
-
let repos = List.filter needs_export all_repos in
172
-
let skipped = List.length all_repos - List.length repos in
173
-
if skipped > 0 then
174
-
Log.info (fun m -> m "Skipping %d already-synced repos" skipped);
175
-
Log.info (fun m -> m "Pushing %d unique repos" (List.length repos));
176
-
let n_repos = List.length repos in
177
-
if n_repos = 0 then begin
251
+
let to_push = repos_to_push statuses pkgs in
252
+
Log.info (fun m -> m "Pushing %d unique repos" (List.length to_push));
253
+
if to_push = [] then begin
178
254
Log.app (fun m -> m "Nothing to push (all repos in sync)");
179
255
Ok ()
180
256
end
181
-
else begin
182
-
let total = if upstream then n_repos * 2 else n_repos in
183
-
let progress = Tty.Progress.create ~total "Push" in
184
-
let update_progress phase name =
185
-
Tty.Progress.update progress ~phase ~msg:name
186
-
in
187
-
let rec loop pushed_repos = function
188
-
| [] -> Ok (List.rev pushed_repos)
189
-
| pkg :: rest -> (
190
-
let name = Package.subtree_prefix pkg in
191
-
update_progress "Export" name;
192
-
Log.debug (fun m -> m "Subtree push %s" name);
193
-
match one ~proc ~fs ~config ~clean pkg with
194
-
| Ok () -> loop (pkg :: pushed_repos) rest
195
-
| Error e ->
196
-
Tty.Progress.clear progress;
197
-
Error e)
198
-
in
199
-
match loop [] repos with
200
-
| Error e -> Error e
201
-
| Ok pushed_repos -> (
202
-
let push_results =
203
-
if upstream && pushed_repos <> [] then begin
204
-
Log.info (fun m ->
205
-
m "Pushing %d repos to upstream (parallel)"
206
-
(List.length pushed_repos));
207
-
let checkouts_root = Config.Paths.checkouts config in
208
-
Eio.Fiber.List.map ~max_fibers:8
209
-
(fun pkg ->
210
-
let checkout_dir =
211
-
Package.checkout_dir ~checkouts_root pkg
212
-
in
213
-
let name = Package.repo_name pkg in
214
-
update_progress "Push" name;
215
-
let branch = Ctx.branch ~config pkg in
216
-
let knot = Config.knot config in
217
-
let push_url =
218
-
Ctx.url_to_push_url ~knot (Package.dev_repo pkg)
219
-
in
220
-
Log.info (fun m -> m "Pushing %s to %s" name push_url);
221
-
let repo =
222
-
Git.Repository.open_repo ~fs:fs_t checkout_dir
223
-
in
224
-
(match
225
-
Git.Repository.set_push_url repo ~name:"origin"
226
-
~url:push_url
227
-
with
228
-
| Ok () -> ()
229
-
| Error (`Msg msg) ->
230
-
Log.warn (fun m ->
231
-
m "Failed to set push URL: %s" msg));
232
-
match
233
-
Git_cli.push_remote ~proc ~fs:fs_t ~branch ~force
234
-
checkout_dir
235
-
with
236
-
| Ok () -> Ok name
237
-
| Error e -> Error (name, Ctx.Git_error e))
238
-
pushed_repos
239
-
end
240
-
else List.map (fun p -> Ok (Package.repo_name p)) pushed_repos
241
-
in
242
-
Tty.Progress.clear progress;
243
-
let successes, failures =
244
-
List.partition_map
245
-
(function
246
-
| Ok name -> Left name | Error (name, _) -> Right name)
247
-
push_results
248
-
in
249
-
List.iter
250
-
(fun name -> Log.app (fun m -> m " ✓ %s" name))
251
-
successes;
252
-
List.iter
253
-
(fun name -> Log.app (fun m -> m " ✗ %s" name))
254
-
failures;
255
-
match List.find_opt Result.is_error push_results with
256
-
| Some (Error (_, e)) -> Error e
257
-
| _ ->
258
-
if upstream then
259
-
workspace_repos ~proc ~fs:fs_t ~config ~force;
260
-
Ok ())
261
-
end
257
+
else
258
+
export_and_push ~proc ~fs ~fs_t ~config ~upstream ~clean ~force
259
+
to_push
262
260
end
263
261
end
+89
-68
lib/site.ml
+89
-68
lib/site.ml
···
196
196
let cmp = compare b.ri_dep_count a.ri_dep_count in
197
197
if cmp <> 0 then cmp else String.compare a.ri_name b.ri_name)
198
198
199
+
let local_member ~registry ~handle_to_name ~local_handle ~local_pkgs =
200
+
let member = Verse_registry.member registry ~handle:local_handle in
201
+
let display_name =
202
+
try Hashtbl.find handle_to_name local_handle
203
+
with Not_found -> local_handle
204
+
in
205
+
{
206
+
handle = local_handle;
207
+
display_name;
208
+
monorepo_url = (match member with Some m -> m.monorepo | None -> "");
209
+
opam_url = (match member with Some m -> m.opamrepo | None -> "");
210
+
package_count = List.length local_pkgs;
211
+
unique_packages = [];
212
+
}
213
+
214
+
let compute_unique_packages all_packages =
215
+
let unique_by_handle = Hashtbl.create 32 in
216
+
List.iter
217
+
(fun (pkg : pkg_info) ->
218
+
if List.length pkg.owners = 1 then begin
219
+
let handle = List.hd pkg.owners in
220
+
let existing =
221
+
try Hashtbl.find unique_by_handle handle with Not_found -> []
222
+
in
223
+
Hashtbl.replace unique_by_handle handle (pkg.name :: existing)
224
+
end)
225
+
all_packages;
226
+
unique_by_handle
227
+
228
+
let apply_unique_packages unique_by_handle members =
229
+
List.map
230
+
(fun m ->
231
+
let unique =
232
+
try Hashtbl.find unique_by_handle m.handle with Not_found -> []
233
+
in
234
+
{ m with unique_packages = List.sort String.compare unique })
235
+
members
236
+
199
237
(** Collect site data from the workspace *)
200
238
let collect_data ~fs ~config ?forks ~registry () =
201
239
let local_handle = Verse_config.handle config in
···
210
248
211
249
let pkg_map = Hashtbl.create 256 in
212
250
add_packages_to_map pkg_map local_handle local_pkgs;
213
-
214
251
let handle_to_name = build_handle_names registry in
215
-
216
252
let member_infos =
217
253
scan_tracked_members ~fs ~verse_path ~local_handle ~pkg_map ~registry
218
254
~handle_to_name
219
255
in
220
-
221
256
let local_member =
222
-
let member = Verse_registry.member registry ~handle:local_handle in
223
-
let display_name =
224
-
try Hashtbl.find handle_to_name local_handle
225
-
with Not_found -> local_handle
226
-
in
227
-
{
228
-
handle = local_handle;
229
-
display_name;
230
-
monorepo_url = (match member with Some m -> m.monorepo | None -> "");
231
-
opam_url = (match member with Some m -> m.opamrepo | None -> "");
232
-
package_count = List.length local_pkgs;
233
-
unique_packages = [];
234
-
}
257
+
local_member ~registry ~handle_to_name ~local_handle ~local_pkgs
235
258
in
236
-
237
259
let all_packages = build_all_packages pkg_map in
238
260
let all_repos = build_all_repos all_packages forks in
239
261
let common_repos =
···
242
264
let unique_repos =
243
265
List.filter (fun r -> List.length r.ri_owners = 1) all_repos
244
266
in
245
-
246
-
let unique_by_handle = Hashtbl.create 32 in
247
-
List.iter
248
-
(fun (pkg : pkg_info) ->
249
-
if List.length pkg.owners = 1 then begin
250
-
let handle = List.hd pkg.owners in
251
-
let existing =
252
-
try Hashtbl.find unique_by_handle handle with Not_found -> []
253
-
in
254
-
Hashtbl.replace unique_by_handle handle (pkg.name :: existing)
255
-
end)
256
-
all_packages;
257
-
258
-
let update_member m =
259
-
let unique =
260
-
try Hashtbl.find unique_by_handle m.handle with Not_found -> []
261
-
in
262
-
{ m with unique_packages = List.sort String.compare unique }
267
+
let unique_by_handle = compute_unique_packages all_packages in
268
+
let members =
269
+
apply_unique_packages unique_by_handle (local_member :: member_infos)
263
270
in
264
-
265
-
let members = List.map update_member (local_member :: member_infos) in
266
-
267
271
{
268
272
local_handle;
269
273
registry_name = registry.Verse_registry.name;
···
302
306
| Forks.Unrelated -> "unrel"
303
307
| Forks.Not_fetched -> "?"
304
308
305
-
(** CSS styles for the site *)
306
-
let css =
309
+
let css_base =
307
310
{|* { margin: 0; padding: 0; box-sizing: border-box; }
308
311
body { font: 10pt/1.4 -apple-system, BlinkMacSystemFont, "Segoe UI", Roboto, sans-serif; color: #333; max-width: 900px; margin: 0 auto; padding: 12px; }
309
312
h1 { font-size: 14pt; font-weight: 600; margin-bottom: 4px; }
···
327
330
.summary-title { font-weight: 600; margin-bottom: 8px; }
328
331
.summary-list { font-size: 9pt; color: #555; line-height: 1.6; }
329
332
.summary-item { display: inline-block; background: #fff; border: 1px solid #ddd; padding: 1px 6px; border-radius: 3px; margin: 2px 2px; }
330
-
.summary-item a { color: #333; }
331
-
.repo { margin-bottom: 12px; padding: 8px; background: #fafafa; border-radius: 4px; }
333
+
.summary-item a { color: #333; }|}
334
+
335
+
let css_components =
336
+
{|.repo { margin-bottom: 12px; padding: 8px; background: #fafafa; border-radius: 4px; }
332
337
.repo-header { display: flex; align-items: baseline; gap: 8px; margin-bottom: 4px; }
333
338
.repo-name { font-weight: 600; }
334
339
.repo-name a { color: #333; }
···
354
359
.unique-list { font-size: 9pt; color: #666; margin-top: 2px; }
355
360
.intro { background: #f0f7ff; border: 1px solid #d0e3f5; border-radius: 4px; padding: 10px 12px; margin-bottom: 16px; font-size: 9pt; line-height: 1.5; color: #444; }
356
361
footer { margin-top: 20px; padding-top: 8px; border-top: 1px solid #ddd; font-size: 9pt; color: #888; }|}
362
+
363
+
let css = css_base ^ "\n" ^ css_components
357
364
358
365
(** Generate member card HTML *)
359
366
let generate_member_card buf m =
···
472
479
end;
473
480
add "</div>\n"
474
481
475
-
(** Generate HTML from site data *)
476
-
let generate_html data =
477
-
let buf = Buffer.create 16384 in
478
-
let add = Buffer.add_string buf in
479
-
482
+
let build_member_lookups members =
480
483
let member_urls = Hashtbl.create 16 in
481
484
let member_names = Hashtbl.create 16 in
482
485
List.iter
483
486
(fun m ->
484
487
Hashtbl.replace member_urls m.handle (m.monorepo_url, m.opam_url);
485
488
Hashtbl.replace member_names m.handle m.display_name)
486
-
data.members;
487
-
489
+
members;
488
490
let get_name handle =
489
491
try Hashtbl.find member_names handle with Not_found -> handle
490
492
in
493
+
(member_urls, get_name)
491
494
495
+
let generate_html_head buf data =
496
+
let add = Buffer.add_string buf in
492
497
add "<!DOCTYPE html>\n<html lang=\"en\">\n<head>\n";
493
498
add "<meta charset=\"UTF-8\">\n";
494
499
add
···
497
502
add "<style>\n";
498
503
add css;
499
504
add "\n</style>\n</head>\n<body>\n";
500
-
501
505
add (Fmt.str "<h1>%s</h1>\n" (html_escape data.registry_name));
502
506
(match data.registry_description with
503
507
| Some desc ->
504
508
add (Fmt.str "<div class=\"subtitle\">%s</div>\n" (html_escape desc))
505
509
| None -> add "<div class=\"subtitle\"></div>\n");
506
-
507
510
add
508
511
{|<div class="intro">
509
512
This is an experiment in large-scale agentic coding using OCaml and OxCaml, where we're building environments to exchange vibe code at scale.
···
515
518
add external_link_icon;
516
519
add {|</a>.
517
520
</div>
518
-
|};
521
+
|}
519
522
520
-
add "<div class=\"section\">\n<h2>Members</h2>\n<div class=\"members\">\n";
521
-
List.iter (generate_member_card buf) data.members;
522
-
add "</div>\n</div>\n";
523
-
523
+
let generate_common_summary buf data =
524
+
let add = Buffer.add_string buf in
524
525
add "<div class=\"section\">\n<div class=\"summary\">\n";
525
526
add
526
527
(Fmt.str
···
540
541
(html_escape r.ri_name) (html_escape r.ri_name)
541
542
(List.length r.ri_packages)))
542
543
data.common_repos;
543
-
add "</div>\n</div>\n";
544
+
add "</div>\n</div>\n"
544
545
546
+
let generate_unique_summary buf data =
547
+
let add = Buffer.add_string buf in
545
548
let members_with_unique =
546
549
List.filter (fun m -> m.unique_packages <> []) data.members
547
550
in
···
563
566
add "</span>\n</div>\n")
564
567
members_with_unique;
565
568
add "</div>\n</div>\n"
566
-
end;
567
-
add "</div>\n";
568
-
569
-
if data.common_repos <> [] then begin
570
-
add "<div class=\"section\">\n<h2>Repository Details</h2>\n";
571
-
List.iter
572
-
(generate_repo_detail buf ~member_urls ~get_name)
573
-
data.common_repos;
574
-
add "</div>\n"
575
-
end;
569
+
end
576
570
571
+
let generate_html_footer buf data =
572
+
let add = Buffer.add_string buf in
577
573
let now = Unix.gettimeofday () in
578
574
let tm = Unix.gmtime now in
579
575
let date_str =
···
587
583
date_str (List.length data.members)
588
584
(List.length data.common_repos + List.length data.unique_repos)
589
585
(List.length data.all_packages));
586
+
add "</body>\n</html>\n"
590
587
591
-
add "</body>\n</html>\n";
588
+
(** Generate HTML from site data *)
589
+
let generate_html data =
590
+
let buf = Buffer.create 16384 in
591
+
let add = Buffer.add_string buf in
592
+
let member_urls, get_name = build_member_lookups data.members in
593
+
594
+
generate_html_head buf data;
595
+
596
+
add "<div class=\"section\">\n<h2>Members</h2>\n<div class=\"members\">\n";
597
+
List.iter (generate_member_card buf) data.members;
598
+
add "</div>\n</div>\n";
599
+
600
+
generate_common_summary buf data;
601
+
generate_unique_summary buf data;
602
+
add "</div>\n";
603
+
604
+
if data.common_repos <> [] then begin
605
+
add "<div class=\"section\">\n<h2>Repository Details</h2>\n";
606
+
List.iter
607
+
(generate_repo_detail buf ~member_urls ~get_name)
608
+
data.common_repos;
609
+
add "</div>\n"
610
+
end;
611
+
612
+
generate_html_footer buf data;
592
613
Buffer.contents buf
593
614
594
615
(** Generate the site and return the HTML content *)
+31
-29
lib/status.ml
+31
-29
lib/status.ml
···
383
383
Tty.Span.styled Tty.Style.(fg Tty.Color.cyan) "v:"
384
384
| Some _ -> Tty.Span.empty
385
385
386
-
let pp_table ?sources ppf statuses =
386
+
let pp_status_header ppf statuses =
387
387
let total = List.length statuses in
388
-
let actionable = filter_actionable statuses in
389
388
let synced = List.filter is_fully_synced statuses |> List.length in
390
389
let dirty = List.filter has_local_changes statuses |> List.length in
391
390
let local_sync_needed =
392
391
List.filter needs_local_sync statuses |> List.length
393
392
in
394
393
let remote_needed = List.filter needs_remote_action statuses |> List.length in
395
-
let action_count = List.length actionable in
396
-
(* Header line with colors *)
394
+
let action_count = List.length (filter_actionable statuses) in
397
395
if dirty > 0 then
398
396
Fmt.pf ppf "%a %d total, %a synced, %a dirty\n"
399
397
Fmt.(styled `Bold string)
···
419
417
Fmt.(styled `Bold string)
420
418
"Packages:" total
421
419
Fmt.(styled `Green string)
422
-
"all synced";
423
-
(* Show actionable items in a table *)
424
-
if actionable <> [] then begin
425
-
let columns =
426
-
[
427
-
Tty.Table.column "Package";
428
-
Tty.Table.column ~align:`Center "Local";
429
-
Tty.Table.column ~align:`Center "Remote";
430
-
Tty.Table.column "Origin";
431
-
]
432
-
in
433
-
let rows =
434
-
List.map
435
-
(fun t ->
436
-
[
437
-
Tty.Span.text (Package.name t.package);
438
-
local_status_span t;
439
-
remote_status_span t;
440
-
origin_span ?sources t;
441
-
])
442
-
actionable
443
-
in
444
-
let table = Tty.Table.of_rows ~border:Tty.Border.rounded columns rows in
445
-
Fmt.pf ppf "%a" Tty.Table.pp table
446
-
end
420
+
"all synced"
421
+
422
+
let pp_actionable_table ?sources ppf actionable =
423
+
let columns =
424
+
[
425
+
Tty.Table.column "Package";
426
+
Tty.Table.column ~align:`Center "Local";
427
+
Tty.Table.column ~align:`Center "Remote";
428
+
Tty.Table.column "Origin";
429
+
]
430
+
in
431
+
let rows =
432
+
List.map
433
+
(fun t ->
434
+
[
435
+
Tty.Span.text (Package.name t.package);
436
+
local_status_span t;
437
+
remote_status_span t;
438
+
origin_span ?sources t;
439
+
])
440
+
actionable
441
+
in
442
+
let table = Tty.Table.of_rows ~border:Tty.Border.rounded columns rows in
443
+
Fmt.pf ppf "%a" Tty.Table.pp table
444
+
445
+
let pp_table ?sources ppf statuses =
446
+
pp_status_header ppf statuses;
447
+
let actionable = filter_actionable statuses in
448
+
if actionable <> [] then pp_actionable_table ?sources ppf actionable
+168
-202
lib/verse.ml
+168
-202
lib/verse.ml
···
137
137
|> List.filter (fun name -> is_directory ~fs Fpath.(verse_path / name))
138
138
with Eio.Io _ -> []
139
139
140
+
let resolve_root ~fs root =
141
+
if Fpath.is_abs root then root
142
+
else
143
+
let root_str = Fpath.to_string root in
144
+
let eio_path = Eio.Path.(fs / root_str) in
145
+
(try Eio.Path.mkdirs ~perm:0o755 eio_path with Eio.Io _ -> ());
146
+
match Unix.realpath root_str with
147
+
| abs_str -> (
148
+
match Fpath.of_string abs_str with Ok p -> p | Error _ -> root)
149
+
| exception _ -> root
150
+
151
+
let clone_workspace_repos ~proc ~fs ~config ~member =
152
+
ensure_dir ~fs (Verse_config.root config);
153
+
ensure_dir ~fs (Verse_config.src_path config);
154
+
ensure_dir ~fs (Verse_config.verse_path config);
155
+
let mono_path = Verse_config.mono_path config in
156
+
Logs.info (fun m -> m "Cloning monorepo to %a" Fpath.pp mono_path);
157
+
let mono_url = Uri.of_string member.Verse_registry.monorepo in
158
+
match
159
+
Git_cli.clone ~proc ~fs ~url:mono_url ~branch:Verse_config.default_branch
160
+
mono_path
161
+
with
162
+
| Error e ->
163
+
Logs.err (fun m -> m "Monorepo clone failed: %a" Git_cli.pp_error e);
164
+
Error (Git_error e)
165
+
| Ok () -> (
166
+
Logs.info (fun m -> m "Monorepo cloned");
167
+
let opam_path = Verse_config.opam_repo_path config in
168
+
Logs.info (fun m -> m "Cloning opam repo to %a" Fpath.pp opam_path);
169
+
let opam_url = Uri.of_string member.Verse_registry.opamrepo in
170
+
match
171
+
Git_cli.clone ~proc ~fs ~url:opam_url
172
+
~branch:Verse_config.default_branch opam_path
173
+
with
174
+
| Error e ->
175
+
Logs.err (fun m -> m "Opam repo clone failed: %a" Git_cli.pp_error e);
176
+
Error (Git_error e)
177
+
| Ok () ->
178
+
Logs.info (fun m -> m "Opam repo cloned");
179
+
Ok ())
180
+
140
181
let init ~proc ~fs ~root ~handle () =
141
-
(* Check if config already exists in XDG *)
142
182
let config_file = Verse_config.file () in
143
183
Logs.info (fun m -> m "Config file: %a" Fpath.pp config_file);
144
184
if is_file ~fs config_file then begin
···
146
186
Error (Workspace_exists root)
147
187
end
148
188
else
149
-
(* Resolve root to absolute path *)
150
-
let root =
151
-
if Fpath.is_abs root then root
152
-
else
153
-
(* Get absolute path via realpath *)
154
-
let root_str = Fpath.to_string root in
155
-
let eio_path = Eio.Path.(fs / root_str) in
156
-
(* Ensure the directory exists first so realpath works *)
157
-
(try Eio.Path.mkdirs ~perm:0o755 eio_path with Eio.Io _ -> ());
158
-
match Unix.realpath root_str with
159
-
| abs_str -> (
160
-
match Fpath.of_string abs_str with Ok p -> p | Error _ -> root)
161
-
| exception _ -> root
162
-
in
189
+
let root = resolve_root ~fs root in
163
190
Logs.info (fun m -> m "Workspace root: %a" Fpath.pp root);
164
-
(* Create config - need this temporarily to get paths *)
165
191
let config = Verse_config.v ~root ~handle () in
166
-
(* Clone registry first to look up user's repos *)
167
192
Logs.info (fun m -> m "Cloning registry...");
168
193
match Verse_registry.clone_or_pull ~proc ~fs ~config () with
169
194
| Error msg ->
···
171
196
Error (Registry_error msg)
172
197
| Ok registry -> (
173
198
Logs.info (fun m -> m "Registry loaded");
174
-
(* Look up user in registry - this validates the handle *)
175
199
match Verse_registry.member registry ~handle with
176
200
| None ->
177
201
Logs.err (fun m -> m "Handle %s not found in registry" handle);
···
180
204
Logs.info (fun m ->
181
205
m "Found member: mono=%s opam=%s" member.monorepo
182
206
member.opamrepo);
183
-
(* Create workspace directories *)
184
207
Logs.info (fun m -> m "Creating workspace directories...");
185
-
ensure_dir ~fs root;
186
-
ensure_dir ~fs (Verse_config.src_path config);
187
-
ensure_dir ~fs (Verse_config.verse_path config);
188
-
(* Clone user's monorepo *)
189
-
let mono_path = Verse_config.mono_path config in
190
-
Logs.info (fun m -> m "Cloning monorepo to %a" Fpath.pp mono_path);
191
-
let mono_url = Uri.of_string member.monorepo in
192
-
match
193
-
Git_cli.clone ~proc ~fs ~url:mono_url
194
-
~branch:Verse_config.default_branch mono_path
195
-
with
196
-
| Error e ->
197
-
Logs.err (fun m ->
198
-
m "Monorepo clone failed: %a" Git_cli.pp_error e);
199
-
Error (Git_error e)
208
+
match clone_workspace_repos ~proc ~fs ~config ~member with
209
+
| Error e -> Error e
200
210
| Ok () -> (
201
-
Logs.info (fun m -> m "Monorepo cloned");
202
-
(* Clone user's opam repo *)
203
-
let opam_path = Verse_config.opam_repo_path config in
204
211
Logs.info (fun m ->
205
-
m "Cloning opam repo to %a" Fpath.pp opam_path);
206
-
let opam_url = Uri.of_string member.opamrepo in
207
-
match
208
-
Git_cli.clone ~proc ~fs ~url:opam_url
209
-
~branch:Verse_config.default_branch opam_path
210
-
with
211
-
| Error e ->
212
-
Logs.err (fun m ->
213
-
m "Opam repo clone failed: %a" Git_cli.pp_error e);
214
-
Error (Git_error e)
215
-
| Ok () -> (
216
-
Logs.info (fun m -> m "Opam repo cloned");
217
-
(* Save config to XDG *)
218
-
Logs.info (fun m ->
219
-
m "Saving config to %a" Fpath.pp config_file);
220
-
match Verse_config.save ~fs config with
221
-
| Error msg ->
222
-
Logs.err (fun m -> m "Failed to save config: %s" msg);
223
-
Error (Config_error msg)
224
-
| Ok () ->
225
-
Logs.info (fun m ->
226
-
m "Workspace initialized successfully");
227
-
Ok ()))))
212
+
m "Saving config to %a" Fpath.pp config_file);
213
+
match Verse_config.save ~fs config with
214
+
| Error msg ->
215
+
Logs.err (fun m -> m "Failed to save config: %s" msg);
216
+
Error (Config_error msg)
217
+
| Ok () ->
218
+
Logs.info (fun m -> m "Workspace initialized successfully");
219
+
Ok ())))
228
220
229
221
let status ~proc ~fs ~config () =
230
222
(* Load registry *)
···
301
293
| Ok () -> Ok true
302
294
end
303
295
296
+
let sync_repo_result ~label h result =
297
+
match result with
298
+
| Ok true ->
299
+
Logs.info (fun m -> m " Cloned %s %s" h label);
300
+
None
301
+
| Ok false ->
302
+
Logs.info (fun m -> m " Reset %s %s" h label);
303
+
None
304
+
| Error e ->
305
+
Logs.warn (fun m -> m " Failed %s %s: %a" h label Git_cli.pp_error e);
306
+
Some (Fmt.str "%s %s: %a" h label Git_cli.pp_error e)
307
+
308
+
let sync_member ~proc ~fs ~verse_dir (member : Verse_registry.member) =
309
+
let h = member.handle in
310
+
let mono_path = Fpath.(verse_dir / h) in
311
+
let opam_path = Fpath.(verse_dir / (h ^ "-opam")) in
312
+
Logs.info (fun m -> m "Syncing %s monorepo" h);
313
+
let mono_branch =
314
+
Option.value ~default:Verse_config.default_branch member.monorepo_branch
315
+
in
316
+
let mono_result =
317
+
clone_or_reset_repo ~proc ~fs ~url:member.monorepo ~branch:mono_branch
318
+
mono_path
319
+
in
320
+
let mono_err = sync_repo_result ~label:"monorepo" h mono_result in
321
+
Logs.info (fun m -> m "Syncing %s opam repo" h);
322
+
let opam_branch =
323
+
Option.value ~default:Verse_config.default_branch member.opamrepo_branch
324
+
in
325
+
let opam_result =
326
+
clone_or_reset_repo ~proc ~fs ~url:member.opamrepo ~branch:opam_branch
327
+
opam_path
328
+
in
329
+
let opam_err = sync_repo_result ~label:"opam repo" h opam_result in
330
+
match (mono_err, opam_err) with
331
+
| None, None -> None
332
+
| Some e, None | None, Some e -> Some e
333
+
| Some e1, Some e2 -> Some (e1 ^ "; " ^ e2)
334
+
304
335
let pull ~proc ~fs ~config ?handle () =
305
-
(* Load registry to get all members *)
306
336
match Verse_registry.clone_or_pull ~proc ~fs ~config () with
307
337
| Error msg -> Error (Registry_error msg)
308
338
| Ok registry ->
···
320
350
let verse_dir = Verse_config.verse_path config in
321
351
ensure_dir ~fs verse_dir;
322
352
Logs.info (fun m -> m "Syncing %d members" (List.length members));
323
-
(* Sync all members in parallel *)
324
353
let errors =
325
354
Eio.Fiber.List.filter_map ~max_fibers:4
326
-
(fun (member : Verse_registry.member) ->
327
-
let h = member.handle in
328
-
let mono_path = Fpath.(verse_dir / h) in
329
-
let opam_path = Fpath.(verse_dir / (h ^ "-opam")) in
330
-
(* Clone or fetch+reset monorepo *)
331
-
Logs.info (fun m -> m "Syncing %s monorepo" h);
332
-
let mono_branch =
333
-
Option.value ~default:Verse_config.default_branch
334
-
member.monorepo_branch
335
-
in
336
-
let mono_result =
337
-
clone_or_reset_repo ~proc ~fs ~url:member.monorepo
338
-
~branch:mono_branch mono_path
339
-
in
340
-
let mono_err =
341
-
match mono_result with
342
-
| Ok true ->
343
-
Logs.info (fun m -> m " Cloned %s monorepo" h);
344
-
None
345
-
| Ok false ->
346
-
Logs.info (fun m -> m " Reset %s monorepo" h);
347
-
None
348
-
| Error e ->
349
-
Logs.warn (fun m ->
350
-
m " Failed %s monorepo: %a" h Git_cli.pp_error e);
351
-
Some (Fmt.str "%s monorepo: %a" h Git_cli.pp_error e)
352
-
in
353
-
(* Clone or fetch+reset opam repo *)
354
-
Logs.info (fun m -> m "Syncing %s opam repo" h);
355
-
let opam_branch =
356
-
Option.value ~default:Verse_config.default_branch
357
-
member.opamrepo_branch
358
-
in
359
-
let opam_result =
360
-
clone_or_reset_repo ~proc ~fs ~url:member.opamrepo
361
-
~branch:opam_branch opam_path
362
-
in
363
-
let opam_err =
364
-
match opam_result with
365
-
| Ok true ->
366
-
Logs.info (fun m -> m " Cloned %s opam repo" h);
367
-
None
368
-
| Ok false ->
369
-
Logs.info (fun m -> m " Reset %s opam repo" h);
370
-
None
371
-
| Error e ->
372
-
Logs.warn (fun m ->
373
-
m " Failed %s opam repo: %a" h Git_cli.pp_error e);
374
-
Some (Fmt.str "%s opam: %a" h Git_cli.pp_error e)
375
-
in
376
-
match (mono_err, opam_err) with
377
-
| None, None -> None
378
-
| Some e, None | None, Some e -> Some e
379
-
| Some e1, Some e2 -> Some (e1 ^ "; " ^ e2))
355
+
(sync_member ~proc ~fs ~verse_dir)
380
356
members
381
357
in
382
358
if errors = [] then Ok ()
···
482
458
@param package Package name to fork
483
459
@param fork_url Git URL of your fork
484
460
@param dry_run If true, show what would be done without making changes *)
461
+
let fork_package_to_repo ~fs ~member_opam_repo ~user_opam_repo ~fork_url p =
462
+
let name = Package.name p in
463
+
let version = Package.version p in
464
+
let opam_path =
465
+
Fpath.(
466
+
member_opam_repo / "packages" / name / (name ^ "." ^ version) / "opam")
467
+
in
468
+
match Opam_repo.read_opam_file ~fs opam_path with
469
+
| Error e -> Error (Opam_repo_error e)
470
+
| Ok content -> (
471
+
let new_content =
472
+
Opam_repo.replace_dev_repo_url content ~new_url:fork_url
473
+
in
474
+
match
475
+
Opam_repo.write_package ~fs ~repo_path:user_opam_repo ~name ~version
476
+
~content:new_content
477
+
with
478
+
| Error e -> Error (Opam_repo_error e)
479
+
| Ok () -> Ok name)
480
+
481
+
let execute_fork ~fs ~member_opam_repo ~user_opam_repo ~fork_url ~handle
482
+
~upstream_url ~subtree_name related_pkgs =
483
+
let results =
484
+
List.map
485
+
(fork_package_to_repo ~fs ~member_opam_repo ~user_opam_repo ~fork_url)
486
+
related_pkgs
487
+
in
488
+
match List.find_opt Result.is_error results with
489
+
| Some (Error e) -> Error e
490
+
| _ ->
491
+
let forked_names =
492
+
List.filter_map (function Ok n -> Some n | Error _ -> None) results
493
+
in
494
+
Ok
495
+
{
496
+
packages_forked = forked_names;
497
+
source_handle = handle;
498
+
fork_url;
499
+
upstream_url;
500
+
subtree_name;
501
+
}
502
+
503
+
let prepare_fork ~fs ~config ~handle ~package ~fork_url ~dry_run
504
+
member_opam_repo =
505
+
let pkgs, _errors = Opam_repo.scan_all ~fs member_opam_repo in
506
+
match List.find_opt (fun p -> Package.name p = package) pkgs with
507
+
| None -> Error (Package_not_found (package, handle))
508
+
| Some pkg ->
509
+
let related_pkgs = List.filter (fun p -> Package.same_repo p pkg) pkgs in
510
+
let pkg_names = List.map Package.name related_pkgs in
511
+
let upstream_url = Uri.to_string (Package.dev_repo pkg) in
512
+
let subtree_name = subtree_name_from_url fork_url in
513
+
let user_opam_repo = Verse_config.opam_repo_path config in
514
+
let conflicts =
515
+
List.filter
516
+
(fun name ->
517
+
Opam_repo.package_exists ~fs ~repo_path:user_opam_repo ~name)
518
+
pkg_names
519
+
in
520
+
if conflicts <> [] then Error (Package_already_exists conflicts)
521
+
else if dry_run then
522
+
Ok
523
+
{
524
+
packages_forked = pkg_names;
525
+
source_handle = handle;
526
+
fork_url;
527
+
upstream_url;
528
+
subtree_name;
529
+
}
530
+
else
531
+
execute_fork ~fs ~member_opam_repo ~user_opam_repo ~fork_url ~handle
532
+
~upstream_url ~subtree_name related_pkgs
533
+
485
534
let fork ~proc ~fs ~config ~handle ~package ~fork_url ?(dry_run = false) () =
486
-
(* Ensure the member exists and their opam-repo is synced *)
487
535
match Verse_registry.clone_or_pull ~proc ~fs ~config () with
488
536
| Error msg -> Error (Registry_error msg)
489
537
| Ok registry -> (
490
538
match Verse_registry.member registry ~handle with
491
539
| None -> Error (Member_not_found handle)
492
-
| Some _member -> (
540
+
| Some _member ->
493
541
let verse_path = Verse_config.verse_path config in
494
542
let member_opam_repo = Fpath.(verse_path / (handle ^ "-opam")) in
495
-
(* Check if their opam repo exists locally *)
496
543
if not (is_directory ~fs member_opam_repo) then
497
544
Error
498
545
(Config_error
···
500
547
"Member's opam repo not synced. Run: monopam verse pull %s"
501
548
handle))
502
549
else
503
-
(* Scan their opam repo to find the package *)
504
-
let pkgs, _errors = Opam_repo.scan_all ~fs member_opam_repo in
505
-
(* Find the requested package *)
506
-
match List.find_opt (fun p -> Package.name p = package) pkgs with
507
-
| None -> Error (Package_not_found (package, handle))
508
-
| Some pkg ->
509
-
(* Find all packages from the same dev-repo *)
510
-
let related_pkgs =
511
-
List.filter (fun p -> Package.same_repo p pkg) pkgs
512
-
in
513
-
let pkg_names = List.map Package.name related_pkgs in
514
-
(* Get upstream URL and subtree name *)
515
-
let upstream_url = Uri.to_string (Package.dev_repo pkg) in
516
-
let subtree_name = subtree_name_from_url fork_url in
517
-
(* Check for conflicts in user's opam-repo *)
518
-
let user_opam_repo = Verse_config.opam_repo_path config in
519
-
let conflicts =
520
-
List.filter
521
-
(fun name ->
522
-
Opam_repo.package_exists ~fs ~repo_path:user_opam_repo
523
-
~name)
524
-
pkg_names
525
-
in
526
-
if conflicts <> [] then Error (Package_already_exists conflicts)
527
-
else if dry_run then
528
-
(* Dry run - just report what would be done *)
529
-
Ok
530
-
{
531
-
packages_forked = pkg_names;
532
-
source_handle = handle;
533
-
fork_url;
534
-
upstream_url;
535
-
subtree_name;
536
-
}
537
-
else begin
538
-
(* Fork each package *)
539
-
let results =
540
-
List.map
541
-
(fun p ->
542
-
let name = Package.name p in
543
-
let version = Package.version p in
544
-
let opam_path =
545
-
Fpath.(
546
-
member_opam_repo / "packages" / name
547
-
/ (name ^ "." ^ version)
548
-
/ "opam")
549
-
in
550
-
match Opam_repo.read_opam_file ~fs opam_path with
551
-
| Error e -> Error (Opam_repo_error e)
552
-
| Ok content -> (
553
-
(* Replace dev-repo and url with fork URL *)
554
-
let new_content =
555
-
Opam_repo.replace_dev_repo_url content
556
-
~new_url:fork_url
557
-
in
558
-
(* Write to user's opam-repo *)
559
-
match
560
-
Opam_repo.write_package ~fs
561
-
~repo_path:user_opam_repo ~name ~version
562
-
~content:new_content
563
-
with
564
-
| Error e -> Error (Opam_repo_error e)
565
-
| Ok () -> Ok name))
566
-
related_pkgs
567
-
in
568
-
(* Check for errors *)
569
-
match List.find_opt Result.is_error results with
570
-
| Some (Error e) -> Error e
571
-
| _ ->
572
-
let forked_names =
573
-
List.filter_map
574
-
(function Ok n -> Some n | Error _ -> None)
575
-
results
576
-
in
577
-
Ok
578
-
{
579
-
packages_forked = forked_names;
580
-
source_handle = handle;
581
-
fork_url;
582
-
upstream_url;
583
-
subtree_name;
584
-
}
585
-
end))
550
+
prepare_fork ~fs ~config ~handle ~package ~fork_url ~dry_run
551
+
member_opam_repo)