forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
monopam: fix merlint issues
Split cmd_verse.ml into six sibling files (cmd_verse_pull.ml,
cmd_verse_diff.ml, cmd_verse_cherrypick.ml, cmd_verse_status.ml,
cmd_verse_members.ml, cmd_verse_fork.ml) so each Cmd.v lives in its
own file; cmd_verse.ml is now just the Cmd.group aggregator.
Refactor cmd_lint.ml run() into short helpers (filter_dep_issues,
filter_source_issues, scanned_label, count_kind, issue_subtrees,
summary_parts, print_summary, print_issues) so neither nesting depth
nor length crosses merlint thresholds.
Refactor cmd_status.ml print_remote_block into small pure helpers
(configured_url, canonical_url, classify_subtree, print_remote_list).
Extend --remote output: now reports three buckets.
- Remote missing (configured): the URL monopam would push to does
not resolve (push would fail).
- Remote missing (canonical,
needs provisioning): the default-origin URL for this
subtree does not exist on tangled
yet -- create it, then update
sources.toml and drop the override.
- Remote duplicates (old repo,
consider deleting): variants of the canonical URL
(suffix t/wt/io/rw) that still
exist on your origin, likely
leftover forks to delete after
convergence on the canonical name.
Rename make_prober -> prober to drop the redundant make_ prefix.
+542
-485
+66
-58
bin/cmd_lint.ml
+66
-58
bin/cmd_lint.ml
···
113
113
source_issues
114
114
end
115
115
116
+
let filter_dep_issues filter issues =
117
+
match filter with
118
+
| [] -> issues
119
+
| dirs ->
120
+
List.filter
121
+
(fun (i : Monopam.Lint.issue) -> List.mem i.subtree dirs)
122
+
issues
123
+
124
+
let filter_source_issues filter source_issues =
125
+
match filter with
126
+
| [] -> source_issues
127
+
| dirs ->
128
+
List.filter
129
+
(fun (i : Monopam.Lint.source_issue) -> List.mem i.subtree dirs)
130
+
source_issues
131
+
132
+
let scanned_label filter packages_scanned =
133
+
match filter with
134
+
| [] -> Fmt.str "%d scanned" packages_scanned
135
+
| dirs -> String.concat ", " dirs
136
+
137
+
let count_kind kind issues =
138
+
List.filter (fun (i : Monopam.Lint.issue) -> i.kind = kind) issues
139
+
|> List.length
140
+
141
+
let issue_subtrees issues source_issues =
142
+
List.map (fun (i : Monopam.Lint.issue) -> i.subtree) issues
143
+
|> List.append
144
+
(List.map
145
+
(fun (i : Monopam.Lint.source_issue) -> i.subtree)
146
+
source_issues)
147
+
|> List.sort_uniq String.compare
148
+
149
+
let summary_parts ~issues ~source_issues =
150
+
let n_missing = count_kind Monopam.Lint.Missing issues in
151
+
let n_unused = count_kind Monopam.Lint.Unused issues in
152
+
let n_source = List.length source_issues in
153
+
List.filter_map Fun.id
154
+
[
155
+
(if n_missing > 0 then Some (Fmt.str "%d missing" n_missing) else None);
156
+
(if n_unused > 0 then Some (Fmt.str "%d unused" n_unused) else None);
157
+
(if n_source > 0 then Some (Fmt.str "%d source" n_source) else None);
158
+
]
159
+
160
+
let print_summary ~issues ~source_issues ~label =
161
+
let parts = summary_parts ~issues ~source_issues in
162
+
let pkgs = issue_subtrees issues source_issues in
163
+
Fmt.pr "%a %s in %d packages (%s)@."
164
+
Fmt.(styled (`Fg `Red) string)
165
+
"✗" (String.concat ", " parts) (List.length pkgs) label
166
+
167
+
let print_issues issues source_issues =
168
+
if issues <> [] then
169
+
if Tty.is_tty () then pp_table issues else pp_plain issues;
170
+
pp_source_issues source_issues
171
+
116
172
let run filter () =
117
173
Eio_main.run @@ fun env ->
118
174
Common.with_config env @@ fun config ->
···
121
177
let { Monopam.Lint.issues; source_issues; packages_scanned } =
122
178
Monopam.Lint.run ~fs:(fs :> Eio.Fs.dir_ty Eio.Path.t) ~monorepo ()
123
179
in
124
-
let issues =
125
-
match filter with
126
-
| [] -> issues
127
-
| dirs ->
128
-
List.filter
129
-
(fun (i : Monopam.Lint.issue) -> List.mem i.subtree dirs)
130
-
issues
131
-
in
132
-
let source_issues =
133
-
match filter with
134
-
| [] -> source_issues
135
-
| dirs ->
136
-
List.filter
137
-
(fun (i : Monopam.Lint.source_issue) -> List.mem i.subtree dirs)
138
-
source_issues
139
-
in
140
-
let scanned_label =
141
-
match filter with
142
-
| [] -> Fmt.str "%d scanned" packages_scanned
143
-
| dirs -> Fmt.str "%s" (String.concat ", " dirs)
144
-
in
145
-
if issues = [] && source_issues = [] then begin
180
+
let issues = filter_dep_issues filter issues in
181
+
let source_issues = filter_source_issues filter source_issues in
182
+
let label = scanned_label filter packages_scanned in
183
+
if issues = [] && source_issues = [] then (
146
184
Fmt.pr "%a All checks passed (%s).@."
147
185
Fmt.(styled (`Fg `Green) string)
148
-
"✓" scanned_label;
149
-
`Ok ()
150
-
end
151
-
else begin
152
-
if issues <> [] then
153
-
if Tty.is_tty () then pp_table issues else pp_plain issues;
154
-
pp_source_issues source_issues;
155
-
let n_missing =
156
-
List.filter (fun i -> i.Monopam.Lint.kind = Missing) issues |> List.length
157
-
in
158
-
let n_unused =
159
-
List.filter (fun i -> i.Monopam.Lint.kind = Unused) issues |> List.length
160
-
in
161
-
let n_source = List.length source_issues in
162
-
let n_pkgs =
163
-
List.map (fun (i : Monopam.Lint.issue) -> i.subtree) issues
164
-
|> List.append
165
-
(List.map
166
-
(fun (i : Monopam.Lint.source_issue) -> i.subtree)
167
-
source_issues)
168
-
|> List.sort_uniq String.compare
169
-
|> List.length
170
-
in
171
-
let parts =
172
-
List.filter_map Fun.id
173
-
[
174
-
(if n_missing > 0 then Some (Fmt.str "%d missing" n_missing) else None);
175
-
(if n_unused > 0 then Some (Fmt.str "%d unused" n_unused) else None);
176
-
(if n_source > 0 then Some (Fmt.str "%d source" n_source) else None);
177
-
]
178
-
in
179
-
Fmt.pr "%a %s in %d packages (%s)@."
180
-
Fmt.(styled (`Fg `Red) string)
181
-
"✗" (String.concat ", " parts) n_pkgs scanned_label;
182
-
`Ok ()
183
-
end
186
+
"✓" label;
187
+
`Ok ())
188
+
else (
189
+
print_issues issues source_issues;
190
+
print_summary ~issues ~source_issues ~label;
191
+
`Ok ())
184
192
185
193
let cmd =
186
194
let doc = "Check library dependencies are declared in dune-project" in
+87
-31
bin/cmd_status.ml
+87
-31
bin/cmd_status.ml
···
148
148
in
149
149
Fmt.pr "%a" (pp ?sources) statuses
150
150
151
+
let strip_git_plus url =
152
+
if String.starts_with ~prefix:"git+" url then
153
+
String.sub url 4 (String.length url - 4)
154
+
else url
155
+
156
+
let configured_url sources subtree =
157
+
Option.bind sources (fun s ->
158
+
Monopam.Sources_registry.derive_source s ~subtree)
159
+
|> Option.map strip_git_plus
160
+
161
+
let canonical_url origin_base subtree =
162
+
Option.map (fun b -> strip_git_plus b ^ "/" ^ subtree) origin_base
163
+
164
+
let prober ~proc ~fs =
165
+
let cache = ref [] in
166
+
fun url ->
167
+
match List.assoc_opt url !cache with
168
+
| Some r -> r
169
+
| None ->
170
+
let r = Monopam.Git_cli.ls_remote_exists ~proc ~fs ~url in
171
+
cache := (url, r) :: !cache;
172
+
r
173
+
174
+
let obsolete_suffix_variants = [ "t"; "wt"; "io"; "rw" ]
175
+
176
+
let classify_subtree ~probe ~sources ~origin_base subtree =
177
+
let cfg = configured_url sources subtree in
178
+
let canon = canonical_url origin_base subtree in
179
+
let cfg_missing =
180
+
match cfg with Some url when not (probe url) -> Some url | _ -> None
181
+
in
182
+
let canon_missing =
183
+
match (canon, cfg) with
184
+
| Some c, cfg_opt when Some c <> cfg_opt && not (probe c) -> Some c
185
+
| _ -> None
186
+
in
187
+
let duplicates =
188
+
List.filter_map
189
+
(fun suf ->
190
+
match canon with
191
+
| Some c ->
192
+
let variant = c ^ suf in
193
+
if probe variant then Some variant else None
194
+
| None -> None)
195
+
obsolete_suffix_variants
196
+
in
197
+
(subtree, cfg_missing, canon_missing, duplicates)
198
+
199
+
let print_remote_list ~style ~label rows =
200
+
if rows <> [] then (
201
+
Fmt.pr "%a %a\n"
202
+
Fmt.(styled `Bold string)
203
+
label
204
+
Fmt.(styled style int)
205
+
(List.length rows);
206
+
List.iter
207
+
(fun (name, url) ->
208
+
Fmt.pr " %-22s %a\n" name Fmt.(styled `Faint string) url)
209
+
rows)
210
+
151
211
let print_remote_block ~proc ~fs ~config =
152
212
let sources = load_sources ~fs ~config in
153
213
match Monopam.discover_packages ~fs ~config () with
···
157
217
List.map Monopam.Package.subtree_prefix pkgs
158
218
|> List.sort_uniq String.compare
159
219
in
160
-
let missing = ref [] in
161
-
List.iter
162
-
(fun subtree ->
163
-
match
164
-
Option.bind sources (fun s ->
165
-
Monopam.Sources_registry.derive_source s ~subtree)
166
-
with
167
-
| None -> ()
168
-
| Some url ->
169
-
let clean =
170
-
if String.starts_with ~prefix:"git+" url then
171
-
String.sub url 4 (String.length url - 4)
172
-
else url
173
-
in
174
-
if not (Monopam.Git_cli.ls_remote_exists ~proc ~fs ~url:clean)
175
-
then missing := (subtree, clean) :: !missing)
176
-
subtrees;
177
-
let missing = List.rev !missing in
178
-
if missing <> [] then begin
179
-
Fmt.pr "%a %a\n"
180
-
Fmt.(styled `Bold string)
181
-
"Remote missing:"
182
-
Fmt.(styled `Red int)
183
-
(List.length missing);
184
-
List.iter
185
-
(fun (name, url) ->
186
-
Fmt.pr " %-22s %a\n" name
187
-
Fmt.(styled `Faint (fun ppf s -> pf ppf "%s" s))
188
-
url)
189
-
missing
190
-
end
220
+
let origin_base = Option.bind sources Monopam.Sources_registry.origin in
221
+
let probe = prober ~proc ~fs in
222
+
let classified =
223
+
List.map (classify_subtree ~probe ~sources ~origin_base) subtrees
224
+
in
225
+
let configured_missing =
226
+
List.filter_map
227
+
(fun (s, cfg, _, _) -> Option.map (fun u -> (s, u)) cfg)
228
+
classified
229
+
in
230
+
let canonical_missing =
231
+
List.filter_map
232
+
(fun (s, _, canon, _) -> Option.map (fun u -> (s, u)) canon)
233
+
classified
234
+
in
235
+
let duplicates =
236
+
List.concat_map
237
+
(fun (s, _, _, dups) -> List.map (fun u -> (s, u)) dups)
238
+
classified
239
+
in
240
+
print_remote_list ~style:`Red ~label:"Remote missing (configured):"
241
+
configured_missing;
242
+
print_remote_list ~style:`Yellow
243
+
~label:"Remote missing (canonical, needs provisioning):"
244
+
canonical_missing;
245
+
print_remote_list ~style:`Cyan
246
+
~label:"Remote duplicates (old repo, consider deleting):" duplicates
191
247
192
248
let run_status ~sw ~proc ~fs ~config ~show_all ~show_forks ~show_remote =
193
249
match Monopam.status ~sw ~fs ~config () with
+8
-396
bin/cmd_verse.ml
+8
-396
bin/cmd_verse.ml
···
1
1
open Cmdliner
2
2
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 ~sw ~proc ~fs ~config ~verse_config ~handle ~repo ~refresh =
48
-
match
49
-
Monopam.pull_from_handle ~sw ~proc ~fs ~config ~verse_config ~handle ?repo
50
-
~refresh ()
51
-
with
52
-
| Ok result -> handle_pull_result result handle
53
-
| Error e -> Common.fail_ctx e
54
-
55
-
let pull_run handle repo refresh () =
56
-
Common.with_eio_verse (fun ~sw ~proc ~fs ~config ~verse_config ->
57
-
pull_inner ~sw ~proc ~fs ~config ~verse_config ~handle ~repo ~refresh)
58
-
59
-
let pull_cmd =
60
-
let doc = "Pull commits from a verse member's forks" in
61
-
let info = Cmd.info "pull" ~doc ~man:pull_man in
62
-
Cmd.v info
63
-
Term.(
64
-
ret
65
-
(const pull_run $ pull_handle_arg $ pull_repo_arg $ pull_refresh_arg
66
-
$ Common.logging_term))
67
-
68
-
(* verse diff - show diffs from verse members *)
69
-
70
-
let diff_man =
71
-
[
72
-
`S Manpage.s_description;
73
-
`P
74
-
"Shows commit diffs from verse members for repositories where they have \
75
-
commits you don't have.";
76
-
`S "OUTPUT";
77
-
`P "For each repository where a verse member is ahead:";
78
-
`I ("+N", "They have N commits you don't have");
79
-
`I ("+N/-M", "Diverged: they have N new commits, you have M new commits");
80
-
`S Manpage.s_examples;
81
-
`P "Show diffs for all repos:";
82
-
`Pre "monopam verse diff";
83
-
`P "Show diff for a specific repository:";
84
-
`Pre "monopam verse diff eio";
85
-
`P "Show patch for a specific commit:";
86
-
`Pre "monopam verse diff abc1234";
87
-
]
88
-
89
-
let diff_arg =
90
-
let doc =
91
-
"Repository name or commit SHA. If a 7+ character hex string, shows the \
92
-
patch for that commit."
93
-
in
94
-
Arg.(value & pos 0 (some string) None & info [] ~docv:"REPO|SHA" ~doc)
95
-
96
-
let diff_refresh_arg =
97
-
let doc = "Force fresh fetches from all remotes." in
98
-
Arg.(value & flag & info [ "refresh"; "r" ] ~doc)
99
-
100
-
let diff_patch_arg =
101
-
let doc = "Show full patch content for each commit." in
102
-
Arg.(value & flag & info [ "patch"; "p" ] ~doc)
103
-
104
-
let show_commit_info (info : Monopam.commit_info) =
105
-
let short_hash =
106
-
String.sub info.commit_hash 0 (min 7 (String.length info.commit_hash))
107
-
in
108
-
Fmt.pr "%a %s (%s/%s)@.@.%s@."
109
-
Fmt.(styled `Yellow string)
110
-
short_hash info.commit_subject info.commit_repo info.commit_handle
111
-
info.commit_patch;
112
-
`Ok ()
113
-
114
-
let handle_sha ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh =
115
-
match
116
-
Monopam.diff_show_commit ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh
117
-
()
118
-
with
119
-
| Some info -> show_commit_info info
120
-
| None ->
121
-
Fmt.epr "Commit %s not found in any verse diff@." sha;
122
-
`Error (false, "commit not found")
123
-
124
-
let diff_inner ~sw ~proc ~fs ~config ~verse_config ~arg ~refresh ~patch =
125
-
match arg with
126
-
| Some sha when Monopam.is_commit_sha sha ->
127
-
handle_sha ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh
128
-
| repo ->
129
-
let result =
130
-
Monopam.diff ~sw ~proc ~fs ~config ~verse_config ?repo ~refresh ~patch
131
-
()
132
-
in
133
-
Fmt.pr "%a" (Monopam.pp_diff_result ~show_patch:patch) result;
134
-
`Ok ()
135
-
136
-
let diff_run arg ~refresh ~patch () =
137
-
Common.with_eio_verse (fun ~sw ~proc ~fs ~config ~verse_config ->
138
-
diff_inner ~sw ~proc ~fs ~config ~verse_config ~arg ~refresh ~patch)
139
-
140
-
let diff_cmd =
141
-
let doc = "Show diffs from verse members" in
142
-
let info = Cmd.info "diff" ~doc ~man:diff_man in
143
-
Cmd.v info
144
-
Term.(
145
-
ret
146
-
(const (fun arg refresh patch () -> diff_run arg ~refresh ~patch ())
147
-
$ diff_arg $ diff_refresh_arg $ diff_patch_arg $ Common.logging_term))
148
-
149
-
(* verse cherry-pick - cherry-pick specific commit. Hyphenated to match
150
-
git's own vocabulary. *)
151
-
152
-
let cherrypick_inner ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh =
153
-
match
154
-
Monopam.cherrypick ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh ()
155
-
with
156
-
| Ok result ->
157
-
Fmt.pr "%a" Monopam.pp_cherrypick_result result;
158
-
Fmt.pr "Run $(b,monopam push) to publish this change.@.";
159
-
`Ok ()
160
-
| Error e -> Common.fail_ctx e
161
-
162
-
let cherrypick_run sha refresh () =
163
-
Common.with_eio_verse (fun ~sw ~proc ~fs ~config ~verse_config ->
164
-
cherrypick_inner ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh)
165
-
166
-
let cherrypick_cmd =
167
-
let doc = "Cherry-pick a specific commit from a verse member" in
168
-
let man =
169
-
[
170
-
`S Manpage.s_description;
171
-
`P
172
-
"Applies a specific commit from a verse member's fork to your local \
173
-
checkout.";
174
-
`S "WORKFLOW";
175
-
`I ("1.", "$(b,monopam verse diff) - See available commits");
176
-
`I ("2.", "$(b,monopam verse diff <sha>) - View the patch");
177
-
`I ("3.", "$(b,monopam verse cherry-pick <sha>) - Apply that commit");
178
-
`I ("4.", "$(b,monopam push) - Push changes upstream");
179
-
`S Manpage.s_examples;
180
-
`P "Cherry-pick a commit:";
181
-
`Pre "monopam verse cherry-pick abc1234";
182
-
]
183
-
in
184
-
let info = Cmd.info "cherry-pick" ~doc ~man in
185
-
let sha_arg =
186
-
let doc = "The commit SHA (or prefix) to cherry-pick (at least 7 chars)." in
187
-
Arg.(required & pos 0 (some string) None & info [] ~docv:"SHA" ~doc)
188
-
in
189
-
let refresh_arg =
190
-
let doc = "Force fresh fetches from all remotes." in
191
-
Arg.(value & flag & info [ "refresh"; "r" ] ~doc)
192
-
in
193
-
Cmd.v info
194
-
Term.(
195
-
ret (const cherrypick_run $ sha_arg $ refresh_arg $ Common.logging_term))
196
-
197
-
(* verse status - show verse member status *)
198
-
199
-
let status_inner ~sw ~proc ~fs ~config ~show_all =
200
-
match Monopam.Verse_config.load ~fs () with
201
-
| Error _ ->
202
-
Fmt.epr "No verse configuration found. Run: monopam init@.";
203
-
`Error (false, "no verse config")
204
-
| Ok verse_config ->
205
-
let forks =
206
-
Monopam.Forks.compute ~sw ~proc ~fs ~verse_config ~monopam_config:config
207
-
()
208
-
in
209
-
if forks.repos <> [] then
210
-
Fmt.pr "%a" (Monopam.Forks.pp_summary' ~show_all) forks;
211
-
`Ok ()
212
-
213
-
let status_run show_all () =
214
-
Eio_main.run @@ fun env ->
215
-
Common.with_config env @@ fun config ->
216
-
let fs = Eio.Stdenv.fs env in
217
-
let proc = Eio.Stdenv.process_mgr env in
218
-
Eio.Switch.run @@ fun sw -> status_inner ~sw ~proc ~fs ~config ~show_all
219
-
220
-
let status_cmd =
221
-
let doc = "Show status of verse members" in
222
-
let man =
223
-
[
224
-
`S Manpage.s_description;
225
-
`P "Shows the sync status between you and verse members.";
226
-
`S "STATUS INDICATORS";
227
-
`I ("+N", "They have N commits you don't have");
228
-
`I ("-N", "You have N commits they don't have");
229
-
`I ("=", "Same commit");
230
-
`I ("~", "Not in your workspace");
231
-
`S Manpage.s_examples;
232
-
`P "Show verse status:";
233
-
`Pre "monopam verse status";
234
-
`P "Show all repos including those not in workspace:";
235
-
`Pre "monopam verse status --all";
236
-
]
237
-
in
238
-
let info = Cmd.info "status" ~doc ~man in
239
-
let all_arg =
240
-
let doc = "Show all repos including those not in your workspace." in
241
-
Arg.(value & flag & info [ "all"; "a" ] ~doc)
242
-
in
243
-
Cmd.v info Term.(ret (const status_run $ all_arg $ Common.logging_term))
244
-
245
-
(* verse members - list registry members *)
246
-
247
-
let members_inner ~sw ~proc ~fs ~config =
248
-
match Monopam.Verse.members ~sw ~proc ~fs ~config () with
249
-
| Ok members ->
250
-
Fmt.pr "@[<v>%a@]@."
251
-
Fmt.(list ~sep:cut Monopam.Verse_registry.pp_member)
252
-
members;
253
-
`Ok ()
254
-
| Error e ->
255
-
let msg = Fmt.str "%a" Monopam.Verse.pp_error_with_hint e in
256
-
Common.fail_ctx (Monopam.Ctx.err msg)
257
-
258
-
let members_run () =
259
-
Eio_main.run @@ fun env ->
260
-
Common.with_verse_config env @@ fun config ->
261
-
let fs = Eio.Stdenv.fs env in
262
-
let proc = Eio.Stdenv.process_mgr env in
263
-
Eio.Switch.run @@ fun sw -> members_inner ~sw ~proc ~fs ~config
264
-
265
-
let members_cmd =
266
-
let doc = "List registry members" in
267
-
let man =
268
-
[
269
-
`S Manpage.s_description;
270
-
`P "Lists all members registered in the verse community registry.";
271
-
`S Manpage.s_examples;
272
-
`P "List all community members:";
273
-
`Pre "monopam verse members";
274
-
]
275
-
in
276
-
let info = Cmd.info "members" ~doc ~man in
277
-
Cmd.v info Term.(ret (const members_run $ Common.logging_term))
278
-
279
-
(* verse fork - fork a package *)
280
-
let fork_man =
281
-
[
282
-
`S Manpage.s_description;
283
-
`P
284
-
"Fork a package from a verse member's opam repository into your \
285
-
workspace.";
286
-
`S "WHAT IT DOES";
287
-
`I ("1.", "Looks up the package in the member's opam-repo");
288
-
`I ("2.", "Finds all packages from the same git repository");
289
-
`I ("3.", "Creates entries in your opam-repo with your fork URL");
290
-
`S Manpage.s_examples;
291
-
`P "Fork a package:";
292
-
`Pre
293
-
"monopam verse fork cohttp --from avsm.bsky.social --url \
294
-
git@github.com:me/cohttp.git";
295
-
`P "Preview what would be forked:";
296
-
`Pre
297
-
"monopam verse fork cohttp --from avsm.bsky.social --url \
298
-
git@github.com:me/cohttp.git --dry-run";
299
-
]
300
-
301
-
let handle_fork_success ~fs ~config ~dry_run result =
302
-
if dry_run then begin
303
-
Fmt.pr "Would fork %d package(s) from %s:@."
304
-
(List.length result.Monopam.Verse.packages_forked)
305
-
result.source_handle;
306
-
List.iter (fun p -> Fmt.pr " %s@." p) result.packages_forked
307
-
end
308
-
else begin
309
-
let mono_path = Monopam.Verse_config.mono_path config in
310
-
let sources_path = Fpath.(mono_path / "sources.toml") in
311
-
let sources =
312
-
match
313
-
Monopam.Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path
314
-
with
315
-
| Ok s -> s
316
-
| Error _ -> Monopam.Sources_registry.empty
317
-
in
318
-
let entry =
319
-
Monopam.Sources_registry.
320
-
{
321
-
source = result.Monopam.Verse.fork_url;
322
-
upstream = Some result.upstream_url;
323
-
branch = None;
324
-
reason = Some (Fmt.str "Forked from %s" result.source_handle);
325
-
origin = Some Join;
326
-
ref_ = None;
327
-
path = None;
328
-
}
329
-
in
330
-
let sources =
331
-
Monopam.Sources_registry.add sources ~subtree:result.subtree_name entry
332
-
in
333
-
(match
334
-
Monopam.Sources_registry.save
335
-
~fs:(fs :> _ Eio.Path.t)
336
-
sources_path sources
337
-
with
338
-
| Ok () ->
339
-
Fmt.pr "Updated sources.toml with fork entry for %s@."
340
-
result.subtree_name
341
-
| Error msg -> Fmt.epr "Warning: Failed to update sources.toml: %s@." msg);
342
-
Fmt.pr "Forked %d package(s): %a@."
343
-
(List.length result.packages_forked)
344
-
Fmt.(list ~sep:(any ", ") string)
345
-
result.packages_forked;
346
-
Fmt.pr "@.Next steps:@.";
347
-
Fmt.pr " 1. cd opam-repo && git add -A && git commit@.";
348
-
Fmt.pr " 2. monopam pull@."
349
-
end
350
-
351
-
let fork_inner ~sw ~proc ~fs ~config ~handle ~package ~fork_url ~dry_run =
352
-
match
353
-
Monopam.Verse.fork ~sw ~proc ~fs ~config ~handle ~package ~fork_url ~dry_run
354
-
()
355
-
with
356
-
| Ok result ->
357
-
handle_fork_success ~fs ~config ~dry_run result;
358
-
`Ok ()
359
-
| Error e ->
360
-
let msg = Fmt.str "%a" Monopam.Verse.pp_error_with_hint e in
361
-
Common.fail_ctx (Monopam.Ctx.err msg)
362
-
363
-
let fork_run package handle fork_url dry_run () =
364
-
Eio_main.run @@ fun env ->
365
-
Common.with_verse_config env @@ fun config ->
366
-
let fs = Eio.Stdenv.fs env in
367
-
let proc = Eio.Stdenv.process_mgr env in
368
-
Eio.Switch.run @@ fun sw ->
369
-
fork_inner ~sw ~proc ~fs ~config ~handle ~package ~fork_url ~dry_run
370
-
371
-
let fork_cmd =
372
-
let doc = "Fork a package from a verse member" in
373
-
let info = Cmd.info "fork" ~doc ~man:fork_man in
374
-
let package_arg =
375
-
let doc = "Package name to fork" in
376
-
Arg.(required & pos 0 (some string) None & info [] ~docv:"PACKAGE" ~doc)
377
-
in
378
-
let from_arg =
379
-
let doc = "Verse member handle to fork from" in
380
-
Arg.(
381
-
required & opt (some string) None & info [ "from" ] ~docv:"HANDLE" ~doc)
382
-
in
383
-
let url_arg =
384
-
let doc = "Git URL of your fork" in
385
-
Arg.(required & opt (some string) None & info [ "url" ] ~docv:"URL" ~doc)
386
-
in
387
-
let dry_run_arg =
388
-
let doc = "Show what would be forked without making changes" in
389
-
Arg.(value & flag & info [ "dry-run"; "n" ] ~doc)
390
-
in
391
-
Cmd.v info
392
-
Term.(
393
-
ret
394
-
(const fork_run $ package_arg $ from_arg $ url_arg $ dry_run_arg
395
-
$ Common.logging_term))
396
-
397
-
(* Main verse command group *)
398
3
let cmd =
399
4
let doc = "Collaborate with verse community members" in
400
5
let man =
···
413
18
in
414
19
let info = Cmd.info "verse" ~doc ~man in
415
20
Cmd.group info
416
-
[ pull_cmd; diff_cmd; cherrypick_cmd; status_cmd; members_cmd; fork_cmd ]
21
+
[
22
+
Cmd_verse_pull.cmd;
23
+
Cmd_verse_diff.cmd;
24
+
Cmd_verse_cherrypick.cmd;
25
+
Cmd_verse_status.cmd;
26
+
Cmd_verse_members.cmd;
27
+
Cmd_verse_fork.cmd;
28
+
]
+45
bin/cmd_verse_cherrypick.ml
+45
bin/cmd_verse_cherrypick.ml
···
1
+
open Cmdliner
2
+
3
+
let inner ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh =
4
+
match
5
+
Monopam.cherrypick ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh ()
6
+
with
7
+
| Ok result ->
8
+
Fmt.pr "%a" Monopam.pp_cherrypick_result result;
9
+
Fmt.pr "Run $(b,monopam push) to publish this change.@.";
10
+
`Ok ()
11
+
| Error e -> Common.fail_ctx e
12
+
13
+
let run sha refresh () =
14
+
Common.with_eio_verse (fun ~sw ~proc ~fs ~config ~verse_config ->
15
+
inner ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh)
16
+
17
+
let cmd =
18
+
let doc = "Cherry-pick a specific commit from a verse member" in
19
+
let man =
20
+
[
21
+
`S Manpage.s_description;
22
+
`P
23
+
"Applies a specific commit from a verse member's fork to your local \
24
+
checkout.";
25
+
`S "WORKFLOW";
26
+
`I ("1.", "$(b,monopam verse diff) - See available commits");
27
+
`I ("2.", "$(b,monopam verse diff <sha>) - View the patch");
28
+
`I ("3.", "$(b,monopam verse cherry-pick <sha>) - Apply that commit");
29
+
`I ("4.", "$(b,monopam push) - Push changes upstream");
30
+
`S Manpage.s_examples;
31
+
`P "Cherry-pick a commit:";
32
+
`Pre "monopam verse cherry-pick abc1234";
33
+
]
34
+
in
35
+
let info = Cmd.info "cherry-pick" ~doc ~man in
36
+
let sha_arg =
37
+
let doc = "The commit SHA (or prefix) to cherry-pick (at least 7 chars)." in
38
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"SHA" ~doc)
39
+
in
40
+
let refresh_arg =
41
+
let doc = "Force fresh fetches from all remotes." in
42
+
Arg.(value & flag & info [ "refresh"; "r" ] ~doc)
43
+
in
44
+
Cmd.v info
45
+
Term.(ret (const run $ sha_arg $ refresh_arg $ Common.logging_term))
+80
bin/cmd_verse_diff.ml
+80
bin/cmd_verse_diff.ml
···
1
+
open Cmdliner
2
+
3
+
let man =
4
+
[
5
+
`S Manpage.s_description;
6
+
`P
7
+
"Shows commit diffs from verse members for repositories where they have \
8
+
commits you don't have.";
9
+
`S "OUTPUT";
10
+
`P "For each repository where a verse member is ahead:";
11
+
`I ("+N", "They have N commits you don't have");
12
+
`I ("+N/-M", "Diverged: they have N new commits, you have M new commits");
13
+
`S Manpage.s_examples;
14
+
`P "Show diffs for all repos:";
15
+
`Pre "monopam verse diff";
16
+
`P "Show diff for a specific repository:";
17
+
`Pre "monopam verse diff eio";
18
+
`P "Show patch for a specific commit:";
19
+
`Pre "monopam verse diff abc1234";
20
+
]
21
+
22
+
let arg =
23
+
let doc =
24
+
"Repository name or commit SHA. If a 7+ character hex string, shows the \
25
+
patch for that commit."
26
+
in
27
+
Arg.(value & pos 0 (some string) None & info [] ~docv:"REPO|SHA" ~doc)
28
+
29
+
let refresh_arg =
30
+
let doc = "Force fresh fetches from all remotes." in
31
+
Arg.(value & flag & info [ "refresh"; "r" ] ~doc)
32
+
33
+
let patch_arg =
34
+
let doc = "Show full patch content for each commit." in
35
+
Arg.(value & flag & info [ "patch"; "p" ] ~doc)
36
+
37
+
let show_commit_info (info : Monopam.commit_info) =
38
+
let short_hash =
39
+
String.sub info.commit_hash 0 (min 7 (String.length info.commit_hash))
40
+
in
41
+
Fmt.pr "%a %s (%s/%s)@.@.%s@."
42
+
Fmt.(styled `Yellow string)
43
+
short_hash info.commit_subject info.commit_repo info.commit_handle
44
+
info.commit_patch;
45
+
`Ok ()
46
+
47
+
let handle_sha ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh =
48
+
match
49
+
Monopam.diff_show_commit ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh
50
+
()
51
+
with
52
+
| Some info -> show_commit_info info
53
+
| None ->
54
+
Fmt.epr "Commit %s not found in any verse diff@." sha;
55
+
`Error (false, "commit not found")
56
+
57
+
let inner ~sw ~proc ~fs ~config ~verse_config ~arg ~refresh ~patch =
58
+
match arg with
59
+
| Some sha when Monopam.is_commit_sha sha ->
60
+
handle_sha ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh
61
+
| repo ->
62
+
let result =
63
+
Monopam.diff ~sw ~proc ~fs ~config ~verse_config ?repo ~refresh ~patch
64
+
()
65
+
in
66
+
Fmt.pr "%a" (Monopam.pp_diff_result ~show_patch:patch) result;
67
+
`Ok ()
68
+
69
+
let run arg ~refresh ~patch () =
70
+
Common.with_eio_verse (fun ~sw ~proc ~fs ~config ~verse_config ->
71
+
inner ~sw ~proc ~fs ~config ~verse_config ~arg ~refresh ~patch)
72
+
73
+
let cmd =
74
+
let doc = "Show diffs from verse members" in
75
+
let info = Cmd.info "diff" ~doc ~man in
76
+
Cmd.v info
77
+
Term.(
78
+
ret
79
+
(const (fun arg refresh patch () -> run arg ~refresh ~patch ())
80
+
$ arg $ refresh_arg $ patch_arg $ Common.logging_term))
+116
bin/cmd_verse_fork.ml
+116
bin/cmd_verse_fork.ml
···
1
+
open Cmdliner
2
+
3
+
let man =
4
+
[
5
+
`S Manpage.s_description;
6
+
`P
7
+
"Fork a package from a verse member's opam repository into your \
8
+
workspace.";
9
+
`S "WHAT IT DOES";
10
+
`I ("1.", "Looks up the package in the member's opam-repo");
11
+
`I ("2.", "Finds all packages from the same git repository");
12
+
`I ("3.", "Creates entries in your opam-repo with your fork URL");
13
+
`S Manpage.s_examples;
14
+
`P "Fork a package:";
15
+
`Pre
16
+
"monopam verse fork cohttp --from avsm.bsky.social --url \
17
+
git@github.com:me/cohttp.git";
18
+
`P "Preview what would be forked:";
19
+
`Pre
20
+
"monopam verse fork cohttp --from avsm.bsky.social --url \
21
+
git@github.com:me/cohttp.git --dry-run";
22
+
]
23
+
24
+
let handle_fork_success ~fs ~config ~dry_run result =
25
+
if dry_run then (
26
+
Fmt.pr "Would fork %d package(s) from %s:@."
27
+
(List.length result.Monopam.Verse.packages_forked)
28
+
result.source_handle;
29
+
List.iter (fun p -> Fmt.pr " %s@." p) result.packages_forked)
30
+
else
31
+
let mono_path = Monopam.Verse_config.mono_path config in
32
+
let sources_path = Fpath.(mono_path / "sources.toml") in
33
+
let sources =
34
+
match
35
+
Monopam.Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path
36
+
with
37
+
| Ok s -> s
38
+
| Error _ -> Monopam.Sources_registry.empty
39
+
in
40
+
let entry =
41
+
Monopam.Sources_registry.
42
+
{
43
+
source = result.Monopam.Verse.fork_url;
44
+
upstream = Some result.upstream_url;
45
+
branch = None;
46
+
reason = Some (Fmt.str "Forked from %s" result.source_handle);
47
+
origin = Some Join;
48
+
ref_ = None;
49
+
path = None;
50
+
}
51
+
in
52
+
let sources =
53
+
Monopam.Sources_registry.add sources ~subtree:result.subtree_name entry
54
+
in
55
+
(match
56
+
Monopam.Sources_registry.save
57
+
~fs:(fs :> _ Eio.Path.t)
58
+
sources_path sources
59
+
with
60
+
| Ok () ->
61
+
Fmt.pr "Updated sources.toml with fork entry for %s@."
62
+
result.subtree_name
63
+
| Error msg -> Fmt.epr "Warning: Failed to update sources.toml: %s@." msg);
64
+
Fmt.pr "Forked %d package(s): %a@."
65
+
(List.length result.packages_forked)
66
+
Fmt.(list ~sep:(any ", ") string)
67
+
result.packages_forked;
68
+
Fmt.pr "@.Next steps:@.";
69
+
Fmt.pr " 1. cd opam-repo && git add -A && git commit@.";
70
+
Fmt.pr " 2. monopam pull@."
71
+
72
+
let inner ~sw ~proc ~fs ~config ~handle ~package ~fork_url ~dry_run =
73
+
match
74
+
Monopam.Verse.fork ~sw ~proc ~fs ~config ~handle ~package ~fork_url ~dry_run
75
+
()
76
+
with
77
+
| Ok result ->
78
+
handle_fork_success ~fs ~config ~dry_run result;
79
+
`Ok ()
80
+
| Error e ->
81
+
let msg = Fmt.str "%a" Monopam.Verse.pp_error_with_hint e in
82
+
Common.fail_ctx (Monopam.Ctx.err msg)
83
+
84
+
let run package handle fork_url dry_run () =
85
+
Eio_main.run @@ fun env ->
86
+
Common.with_verse_config env @@ fun config ->
87
+
let fs = Eio.Stdenv.fs env in
88
+
let proc = Eio.Stdenv.process_mgr env in
89
+
Eio.Switch.run @@ fun sw ->
90
+
inner ~sw ~proc ~fs ~config ~handle ~package ~fork_url ~dry_run
91
+
92
+
let cmd =
93
+
let doc = "Fork a package from a verse member" in
94
+
let info = Cmd.info "fork" ~doc ~man in
95
+
let package_arg =
96
+
let doc = "Package name to fork" in
97
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"PACKAGE" ~doc)
98
+
in
99
+
let from_arg =
100
+
let doc = "Verse member handle to fork from" in
101
+
Arg.(
102
+
required & opt (some string) None & info [ "from" ] ~docv:"HANDLE" ~doc)
103
+
in
104
+
let url_arg =
105
+
let doc = "Git URL of your fork" in
106
+
Arg.(required & opt (some string) None & info [ "url" ] ~docv:"URL" ~doc)
107
+
in
108
+
let dry_run_arg =
109
+
let doc = "Show what would be forked without making changes" in
110
+
Arg.(value & flag & info [ "dry-run"; "n" ] ~doc)
111
+
in
112
+
Cmd.v info
113
+
Term.(
114
+
ret
115
+
(const run $ package_arg $ from_arg $ url_arg $ dry_run_arg
116
+
$ Common.logging_term))
+33
bin/cmd_verse_members.ml
+33
bin/cmd_verse_members.ml
···
1
+
open Cmdliner
2
+
3
+
let inner ~sw ~proc ~fs ~config =
4
+
match Monopam.Verse.members ~sw ~proc ~fs ~config () with
5
+
| Ok members ->
6
+
Fmt.pr "@[<v>%a@]@."
7
+
Fmt.(list ~sep:cut Monopam.Verse_registry.pp_member)
8
+
members;
9
+
`Ok ()
10
+
| Error e ->
11
+
let msg = Fmt.str "%a" Monopam.Verse.pp_error_with_hint e in
12
+
Common.fail_ctx (Monopam.Ctx.err msg)
13
+
14
+
let run () =
15
+
Eio_main.run @@ fun env ->
16
+
Common.with_verse_config env @@ fun config ->
17
+
let fs = Eio.Stdenv.fs env in
18
+
let proc = Eio.Stdenv.process_mgr env in
19
+
Eio.Switch.run @@ fun sw -> inner ~sw ~proc ~fs ~config
20
+
21
+
let cmd =
22
+
let doc = "List registry members" in
23
+
let man =
24
+
[
25
+
`S Manpage.s_description;
26
+
`P "Lists all members registered in the verse community registry.";
27
+
`S Manpage.s_examples;
28
+
`P "List all community members:";
29
+
`Pre "monopam verse members";
30
+
]
31
+
in
32
+
let info = Cmd.info "members" ~doc ~man in
33
+
Cmd.v info Term.(ret (const run $ Common.logging_term))
+60
bin/cmd_verse_pull.ml
+60
bin/cmd_verse_pull.ml
···
1
+
open Cmdliner
2
+
3
+
let man =
4
+
[
5
+
`S Manpage.s_description;
6
+
`P
7
+
"Pulls commits from a verse member's forks into your local checkouts. \
8
+
This merges their changes into your checkout branches.";
9
+
`S "WORKFLOW";
10
+
`P "The typical workflow for incorporating changes from collaborators:";
11
+
`I ("1.", "$(b,monopam verse diff) - See what changes are available");
12
+
`I ("2.", "$(b,monopam verse pull <handle>) - Pull their changes");
13
+
`I ("3.", "$(b,monopam push) - Push merged changes upstream");
14
+
`S Manpage.s_examples;
15
+
`P "Pull all changes from a verse member:";
16
+
`Pre "monopam verse pull avsm.bsky.social";
17
+
`P "Pull changes for a specific repository:";
18
+
`Pre "monopam verse pull avsm.bsky.social eio";
19
+
]
20
+
21
+
let handle_arg =
22
+
let doc = "The verse member handle to pull from (e.g., avsm.bsky.social)." in
23
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"HANDLE" ~doc)
24
+
25
+
let repo_arg =
26
+
let doc = "Optional repository to pull from." in
27
+
Arg.(value & pos 1 (some string) None & info [] ~docv:"REPO" ~doc)
28
+
29
+
let refresh_arg =
30
+
let doc = "Force fresh fetches from all remotes." in
31
+
Arg.(value & flag & info [ "refresh"; "r" ] ~doc)
32
+
33
+
let handle_pull_result (result : Monopam.handle_pull_result) handle =
34
+
Fmt.pr "%a" Monopam.pp_handle_pull_result result;
35
+
if result.repos_failed <> [] then `Error (false, "some repos failed to pull")
36
+
else if result.repos_pulled = [] then (
37
+
Fmt.pr "Nothing to pull from %s@." handle;
38
+
`Ok ())
39
+
else (
40
+
Fmt.pr "@.Run $(b,monopam push) to publish merged changes.@.";
41
+
`Ok ())
42
+
43
+
let inner ~sw ~proc ~fs ~config ~verse_config ~handle ~repo ~refresh =
44
+
match
45
+
Monopam.pull_from_handle ~sw ~proc ~fs ~config ~verse_config ~handle ?repo
46
+
~refresh ()
47
+
with
48
+
| Ok result -> handle_pull_result result handle
49
+
| Error e -> Common.fail_ctx e
50
+
51
+
let run handle repo refresh () =
52
+
Common.with_eio_verse (fun ~sw ~proc ~fs ~config ~verse_config ->
53
+
inner ~sw ~proc ~fs ~config ~verse_config ~handle ~repo ~refresh)
54
+
55
+
let cmd =
56
+
let doc = "Pull commits from a verse member's forks" in
57
+
let info = Cmd.info "pull" ~doc ~man in
58
+
Cmd.v info
59
+
Term.(
60
+
ret (const run $ handle_arg $ repo_arg $ refresh_arg $ Common.logging_term))
+47
bin/cmd_verse_status.ml
+47
bin/cmd_verse_status.ml
···
1
+
open Cmdliner
2
+
3
+
let inner ~sw ~proc ~fs ~config ~show_all =
4
+
match Monopam.Verse_config.load ~fs () with
5
+
| Error _ ->
6
+
Fmt.epr "No verse configuration found. Run: monopam init@.";
7
+
`Error (false, "no verse config")
8
+
| Ok verse_config ->
9
+
let forks =
10
+
Monopam.Forks.compute ~sw ~proc ~fs ~verse_config ~monopam_config:config
11
+
()
12
+
in
13
+
if forks.repos <> [] then
14
+
Fmt.pr "%a" (Monopam.Forks.pp_summary' ~show_all) forks;
15
+
`Ok ()
16
+
17
+
let run show_all () =
18
+
Eio_main.run @@ fun env ->
19
+
Common.with_config env @@ fun config ->
20
+
let fs = Eio.Stdenv.fs env in
21
+
let proc = Eio.Stdenv.process_mgr env in
22
+
Eio.Switch.run @@ fun sw -> inner ~sw ~proc ~fs ~config ~show_all
23
+
24
+
let cmd =
25
+
let doc = "Show status of verse members" in
26
+
let man =
27
+
[
28
+
`S Manpage.s_description;
29
+
`P "Shows the sync status between you and verse members.";
30
+
`S "STATUS INDICATORS";
31
+
`I ("+N", "They have N commits you don't have");
32
+
`I ("-N", "You have N commits they don't have");
33
+
`I ("=", "Same commit");
34
+
`I ("~", "Not in your workspace");
35
+
`S Manpage.s_examples;
36
+
`P "Show verse status:";
37
+
`Pre "monopam verse status";
38
+
`P "Show all repos including those not in workspace:";
39
+
`Pre "monopam verse status --all";
40
+
]
41
+
in
42
+
let info = Cmd.info "status" ~doc ~man in
43
+
let all_arg =
44
+
let doc = "Show all repos including those not in your workspace." in
45
+
Arg.(value & flag & info [ "all"; "a" ] ~doc)
46
+
in
47
+
Cmd.v info Term.(ret (const run $ all_arg $ Common.logging_term))