Monorepo management for opam overlays
Consolidate monopam status with dense colored fork analysis
- Add fork graph discovery via verse opam repos (Forks module)
- Consolidate status command into single dense view combining
package status and verse fork analysis
- Add ANSI colors with Fmt for status indicators:
- Red (+N) for repos where others have commits to pull
- Cyan (-N) for repos where I'm ahead
- Yellow (+N/-M) for diverged repos
- Green (=) for in-sync repos
- Faint (~) for repos not in workspace
- Add --all flag to show synced repos and others' repos
- Add succinct pp_summary for cross_status module
- Fetch verse opam repos before scanning for dev-repo URLs
- Add DEBUG logging for git commands at -vv level
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
+796
-45
+37
-38
bin/main.ml
+37
-38
bin/main.ml
···
49
49
[
50
50
`S Manpage.s_description;
51
51
`P
52
-
"Displays the status of each package discovered in the opam overlay. \
53
-
For each package, shows whether the checkout is clean or has local \
54
-
changes, and whether the subtree is present in the monorepo.";
55
-
`P "Status indicators:";
56
-
`I ("clean", "Checkout matches remote, no local changes");
57
-
`I
58
-
( "ahead N, behind M",
59
-
"Checkout has N unpushed commits and is M commits behind remote" );
60
-
`I ("present", "Subtree exists in monorepo");
61
-
`I ("missing", "Subtree not yet added to monorepo");
62
-
`S "CROSS-USER COMPARISON";
63
-
`P
64
-
"When verse members are tracked, also shows how your subtrees compare \
65
-
to theirs. Use --no-verse to skip this comparison.";
52
+
"Displays package status and verse fork analysis in a dense format.";
53
+
`S "FORK SYMBOLS";
54
+
`I ("+N", "They have N commits you don't (consider pulling)");
55
+
`I ("-N", "You have N commits they don't");
56
+
`I ("+N/-M", "Diverged: they +N, you +M");
57
+
`I ("=", "In sync (same URL or same commit)");
58
+
`I ("~", "Not in your workspace (use --all to list)");
66
59
]
67
60
in
68
61
let info = Cmd.info "status" ~doc ~man in
69
-
let no_verse_arg =
70
-
let doc = "Skip cross-user comparison with verse members." in
71
-
Arg.(value & flag & info [ "no-verse" ] ~doc)
62
+
let all_arg =
63
+
let doc = "Show all repos including those not in your workspace." in
64
+
Arg.(value & flag & info [ "all"; "a" ] ~doc)
72
65
in
73
-
let run no_verse () =
66
+
let run show_all () =
74
67
Eio_main.run @@ fun env ->
75
68
with_config env @@ fun config ->
76
69
let fs = Eio.Stdenv.fs env in
77
70
let proc = Eio.Stdenv.process_mgr env in
78
71
match Monopam.status ~proc ~fs ~config () with
79
72
| Ok statuses ->
80
-
Fmt.pr "%a@." Monopam.Status.pp_summary statuses;
73
+
Fmt.pr "%a" Monopam.Status.pp_summary statuses;
81
74
(* Check for unregistered opam files *)
82
75
(match Monopam.discover_packages ~fs ~config () with
83
76
| Ok pkgs ->
84
77
let unregistered = Monopam.find_unregistered_opam_files ~fs ~config pkgs in
85
78
if unregistered <> [] then begin
86
-
Fmt.pr "@.";
87
-
Fmt.pr "@[<v>Warning: Found opam files not in overlay:@,";
88
-
List.iter (fun (repo, pkg) ->
89
-
Fmt.pr " %s/%s.opam@," repo pkg) unregistered;
90
-
Fmt.pr "Consider adding these packages to the opam overlay.@]@."
79
+
(* Get local handle abbreviation *)
80
+
let handle_abbrev = match Monopam.Verse_config.load ~fs () with
81
+
| Ok vc ->
82
+
let h = Monopam.Verse_config.handle vc in
83
+
(match String.split_on_char '.' h with
84
+
| first :: _ -> if String.length first <= 4 then first else String.sub first 0 3
85
+
| [] -> h)
86
+
| Error _ -> "local"
87
+
in
88
+
Fmt.pr "%a %a\n"
89
+
Fmt.(styled `Bold string) "Unregistered:"
90
+
Fmt.(styled `Faint int) (List.length unregistered);
91
+
List.iter (fun (_r, p) ->
92
+
Fmt.pr " %-22s %a\n" p Fmt.(styled `Faint (fun ppf s -> pf ppf "%s~" s)) handle_abbrev)
93
+
unregistered
91
94
end
92
95
| Error _ -> ());
93
-
(* Cross-user comparison if verse config is available *)
94
-
if not no_verse then begin
95
-
match Monopam.Verse_config.load ~fs () with
96
-
| Error _ -> () (* No verse config, skip silently *)
97
-
| Ok verse_config ->
98
-
let cross_status =
99
-
Monopam.Cross_status.compute ~proc ~fs ~verse_config ~monopam_config:config ()
100
-
in
101
-
if cross_status.my_repos <> [] || cross_status.other_repos <> [] then begin
102
-
Fmt.pr "@.";
103
-
Fmt.pr "%a@." Monopam.Cross_status.pp cross_status
104
-
end
105
-
end;
96
+
(* Fork analysis *)
97
+
(match Monopam.Verse_config.load ~fs () with
98
+
| Error _ -> ()
99
+
| Ok verse_config ->
100
+
let forks =
101
+
Monopam.Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ()
102
+
in
103
+
if forks.repos <> [] then
104
+
Fmt.pr "%a" (Monopam.Forks.pp_summary' ~show_all) forks);
106
105
`Ok ()
107
106
| Error e ->
108
107
Fmt.epr "Error: %a@." Monopam.pp_error e;
109
108
`Error (false, "status failed")
110
109
in
111
-
Cmd.v info Term.(ret (const run $ no_verse_arg $ logging_term))
110
+
Cmd.v info Term.(ret (const run $ all_arg $ logging_term))
112
111
113
112
(* Pull command *)
114
113
+57
lib/cross_status.ml
+57
lib/cross_status.ml
···
58
58
comp.others;
59
59
Fmt.pf ppf "@]"
60
60
61
+
(** Verbose output with commit SHAs *)
61
62
let pp ppf t =
62
63
if t.my_repos <> [] then begin
63
64
Fmt.pf ppf "@[<v>Cross-user comparison:@,";
···
71
72
Fmt.pf ppf " %-19s %s@," repo (String.concat ", " handles))
72
73
t.other_repos;
73
74
Fmt.pf ppf "@]"
75
+
end
76
+
77
+
(** Check if a relationship represents "others have commits I don't" *)
78
+
let is_actionable = function
79
+
| I_am_behind _ -> true
80
+
| Diverged _ -> true
81
+
| _ -> false
82
+
83
+
(** Succinct relationship display *)
84
+
let pp_rel_short ppf = function
85
+
| Same -> Fmt.string ppf "="
86
+
| I_am_ahead n -> Fmt.pf ppf "-%d" n
87
+
| I_am_behind n -> Fmt.pf ppf "+%d" n
88
+
| Diverged { my_ahead; their_ahead } ->
89
+
Fmt.pf ppf "+%d/-%d" their_ahead my_ahead
90
+
| Unknown -> Fmt.string ppf "?"
91
+
92
+
(** Succinct summary: one line per repo with emphasis on action needed *)
93
+
let pp_summary ppf t =
94
+
if t.my_repos = [] && t.other_repos = [] then ()
95
+
else begin
96
+
(* Separate repos into categories *)
97
+
let with_actions = ref [] in
98
+
let in_sync = ref [] in
99
+
100
+
List.iter (fun comp ->
101
+
let actionable =
102
+
List.filter (fun (_, _, rel) -> is_actionable rel) comp.others
103
+
in
104
+
if actionable <> [] then
105
+
with_actions := (comp, actionable) :: !with_actions
106
+
else
107
+
in_sync := comp :: !in_sync)
108
+
t.my_repos;
109
+
110
+
(* Print repos with actions needed first *)
111
+
if !with_actions <> [] then begin
112
+
Fmt.pf ppf "@[<v>@,Subtrees with upstream changes:@,";
113
+
List.iter (fun (comp, actionable) ->
114
+
let changes = List.map (fun (h, _, rel) ->
115
+
Fmt.str "%s:%a" h pp_rel_short rel) actionable
116
+
in
117
+
Fmt.pf ppf " %-24s %s@," comp.repo_name (String.concat " " changes))
118
+
(List.rev !with_actions);
119
+
Fmt.pf ppf "@]"
120
+
end;
121
+
122
+
(* Print in-sync repos compactly *)
123
+
if !in_sync <> [] then
124
+
Fmt.pf ppf "@,Subtrees in sync: %d repos@," (List.length !in_sync);
125
+
126
+
(* Print not-mine repos *)
127
+
if t.other_repos <> [] then begin
128
+
let names = List.map fst t.other_repos in
129
+
Fmt.pf ppf "@,Not in my monorepo: %s@," (String.concat ", " names)
130
+
end
74
131
end
75
132
76
133
(** Get subtree info for a given prefix in a monorepo. *)
+9
-1
lib/cross_status.mli
+9
-1
lib/cross_status.mli
···
48
48
(** [pp_repo_comparison] formats a single repo comparison. *)
49
49
50
50
val pp : t Fmt.t
51
-
(** [pp] formats the full cross-user status. *)
51
+
(** [pp] formats the full cross-user status with commit SHAs. *)
52
+
53
+
val pp_summary : t Fmt.t
54
+
(** [pp_summary] formats a succinct summary with emphasis on repos where
55
+
others have commits not in mine. *)
56
+
57
+
val is_actionable : relationship -> bool
58
+
(** [is_actionable rel] returns [true] if the relationship indicates
59
+
that others have commits I should consider pulling (I_am_behind or Diverged). *)
52
60
53
61
(** {1 Computation} *)
54
62
+558
lib/forks.ml
+558
lib/forks.ml
···
1
+
(** Fork graph discovery via verse opam repos.
2
+
3
+
Scans verse opam repos to discover dev-repo URLs, adds git remotes
4
+
to local checkouts, and computes fork relationships. *)
5
+
6
+
let src = Logs.Src.create "monopam.forks" ~doc:"Fork analysis"
7
+
module Log = (val Logs.src_log src : Logs.LOG)
8
+
9
+
(** A dev-repo source from a specific member *)
10
+
type repo_source = {
11
+
handle : string; (** Member handle or "me" *)
12
+
url : Uri.t; (** Normalized git URL *)
13
+
packages : string list; (** Opam packages from this repo *)
14
+
}
15
+
16
+
(** Fork relationship between two sources *)
17
+
type relationship =
18
+
| Same_url (** Same git URL *)
19
+
| Same_commit (** Different URLs but same HEAD *)
20
+
| I_am_ahead of int (** They forked from me, I'm N commits ahead *)
21
+
| I_am_behind of int (** I forked from them, they're N commits ahead *)
22
+
| Diverged of { common_ancestor : string; my_ahead : int; their_ahead : int }
23
+
| Unrelated (** No common history *)
24
+
| Not_fetched (** Remote not yet fetched *)
25
+
26
+
(** Analysis result for a single repository *)
27
+
type repo_analysis = {
28
+
repo_name : string; (** Repository basename *)
29
+
my_source : repo_source option; (** My dev-repo if I have it *)
30
+
verse_sources : (string * repo_source * relationship) list;
31
+
(** (handle, source, relationship to me) *)
32
+
}
33
+
34
+
(** Full fork analysis result *)
35
+
type t = {
36
+
repos : repo_analysis list;
37
+
}
38
+
39
+
let pp_relationship ppf = function
40
+
| Same_url -> Fmt.string ppf "same URL"
41
+
| Same_commit -> Fmt.string ppf "same commit"
42
+
| I_am_ahead n -> Fmt.pf ppf "they're %d behind" n
43
+
| I_am_behind n -> Fmt.pf ppf "they're %d ahead" n
44
+
| Diverged { common_ancestor = _; my_ahead; their_ahead } ->
45
+
Fmt.pf ppf "diverged: me +%d, them +%d" my_ahead their_ahead
46
+
| Unrelated -> Fmt.string ppf "unrelated"
47
+
| Not_fetched -> Fmt.string ppf "not fetched"
48
+
49
+
let pp_repo_source ppf src =
50
+
Fmt.pf ppf "%s" (Uri.to_string src.url)
51
+
52
+
let pp_repo_analysis ppf analysis =
53
+
Fmt.pf ppf "@[<v 2>%s:@," analysis.repo_name;
54
+
(match analysis.my_source with
55
+
| Some src -> Fmt.pf ppf "me: %a@," pp_repo_source src
56
+
| None -> Fmt.pf ppf "me: (not in my repos)@,");
57
+
List.iter
58
+
(fun (handle, src, rel) ->
59
+
Fmt.pf ppf "%-19s %a (%a)@," handle pp_repo_source src pp_relationship rel)
60
+
analysis.verse_sources;
61
+
Fmt.pf ppf "@]"
62
+
63
+
(** Verbose output with full URLs *)
64
+
let pp ppf t =
65
+
if t.repos <> [] then begin
66
+
Fmt.pf ppf "@[<v>Fork analysis:@,";
67
+
List.iter (fun r -> Fmt.pf ppf " %a@," pp_repo_analysis r) t.repos;
68
+
Fmt.pf ppf "@]"
69
+
end
70
+
71
+
(** Check if a relationship represents "others have commits I don't" *)
72
+
let is_actionable = function
73
+
| I_am_behind _ -> true
74
+
| Diverged _ -> true
75
+
| _ -> false
76
+
77
+
(** Succinct relationship display with colors *)
78
+
let pp_rel_short ppf = function
79
+
| Same_url -> Fmt.(styled `Green string) ppf "="
80
+
| Same_commit -> Fmt.(styled `Green string) ppf "="
81
+
| I_am_ahead n -> Fmt.(styled `Cyan (fun ppf -> pf ppf "-%d")) ppf n
82
+
| I_am_behind n -> Fmt.(styled `Red (fun ppf -> pf ppf "+%d")) ppf n
83
+
| Diverged { common_ancestor = _; my_ahead; their_ahead } ->
84
+
Fmt.(styled `Yellow (fun ppf (a, b) -> pf ppf "+%d/-%d" a b)) ppf (their_ahead, my_ahead)
85
+
| Unrelated -> Fmt.(styled `Magenta string) ppf "?"
86
+
| Not_fetched -> Fmt.(styled `Faint string) ppf "~"
87
+
88
+
(** Summarize a repo analysis for succinct output *)
89
+
let summarize_repo analysis =
90
+
let actionable =
91
+
List.filter (fun (_, _, rel) -> is_actionable rel) analysis.verse_sources
92
+
in
93
+
let in_sync =
94
+
List.for_all (fun (_, _, rel) ->
95
+
match rel with Same_url | Same_commit -> true | _ -> false)
96
+
analysis.verse_sources
97
+
in
98
+
let all_not_fetched =
99
+
List.for_all (fun (_, _, rel) ->
100
+
match rel with Not_fetched -> true | _ -> false)
101
+
analysis.verse_sources
102
+
in
103
+
(actionable, in_sync, all_not_fetched)
104
+
105
+
(** Compact handle display - abbreviate to first initial if possible *)
106
+
let abbrev_handle h =
107
+
(* Use first part before dot, max 3 chars *)
108
+
match String.split_on_char '.' h with
109
+
| first :: _ -> if String.length first <= 4 then first else String.sub first 0 3
110
+
| [] -> h
111
+
112
+
(** Print a list of (handle, rel) pairs with colors *)
113
+
let pp_changes ppf actionable =
114
+
let first = ref true in
115
+
List.iter (fun (h, _, rel) ->
116
+
if not !first then Fmt.pf ppf " ";
117
+
first := false;
118
+
Fmt.pf ppf "%s%a" (abbrev_handle h) pp_rel_short rel)
119
+
actionable
120
+
121
+
(** Succinct summary: dense one-line-per-repo format *)
122
+
let pp_summary' ~show_all ppf t =
123
+
if t.repos = [] then ()
124
+
else begin
125
+
(* Separate repos into categories *)
126
+
let with_actions = ref [] in
127
+
let in_sync = ref [] in
128
+
let not_mine = ref [] in
129
+
130
+
List.iter (fun r ->
131
+
let (actionable, is_in_sync, _) = summarize_repo r in
132
+
match r.my_source with
133
+
| None ->
134
+
not_mine := r :: !not_mine
135
+
| Some _ when actionable <> [] ->
136
+
with_actions := (r, actionable) :: !with_actions
137
+
| Some _ when is_in_sync ->
138
+
in_sync := r :: !in_sync
139
+
| Some _ ->
140
+
(* Has verse sources but all same URL - treat as in sync *)
141
+
in_sync := r :: !in_sync)
142
+
t.repos;
143
+
144
+
(* Print header with counts *)
145
+
let action_count = List.length !with_actions in
146
+
let sync_count = List.length !in_sync in
147
+
let other_count = List.length !not_mine in
148
+
Fmt.pf ppf "%a %a need attention, %a synced, %a others\n"
149
+
Fmt.(styled `Bold string) "Verse:"
150
+
Fmt.(styled (if action_count > 0 then `Red else `Green) int) action_count
151
+
Fmt.(styled `Green int) sync_count
152
+
Fmt.(styled `Faint int) other_count;
153
+
154
+
(* Print repos needing attention - dense format *)
155
+
if !with_actions <> [] then
156
+
List.iter (fun (r, actionable) ->
157
+
Fmt.pf ppf " %-22s %a\n" r.repo_name pp_changes actionable)
158
+
(List.rev !with_actions);
159
+
160
+
(* Print in-sync repos if show_all *)
161
+
if show_all && !in_sync <> [] then begin
162
+
let in_sync_sorted = List.sort (fun a b -> String.compare a.repo_name b.repo_name) !in_sync in
163
+
List.iter (fun r ->
164
+
Fmt.pf ppf " %-22s %a\n" r.repo_name Fmt.(styled `Green string) "=")
165
+
in_sync_sorted
166
+
end;
167
+
168
+
(* Print others *)
169
+
if !not_mine <> [] then begin
170
+
if show_all then begin
171
+
(* List each repo with ~ *)
172
+
let not_mine_sorted = List.sort (fun a b -> String.compare a.repo_name b.repo_name) !not_mine in
173
+
List.iter (fun r ->
174
+
let handles = List.map (fun (h, _, _) -> abbrev_handle h) r.verse_sources
175
+
|> List.sort_uniq String.compare in
176
+
Fmt.pf ppf " %-22s %a\n" r.repo_name
177
+
Fmt.(styled `Faint (fun ppf s -> pf ppf "%s~" s)) (String.concat "," handles))
178
+
not_mine_sorted
179
+
end else begin
180
+
(* Compact summary *)
181
+
let grouped = Hashtbl.create 16 in
182
+
List.iter (fun r ->
183
+
List.iter (fun (h, _, _) ->
184
+
let existing = try Hashtbl.find grouped h with Not_found -> [] in
185
+
Hashtbl.replace grouped h (r.repo_name :: existing))
186
+
r.verse_sources)
187
+
!not_mine;
188
+
Fmt.pf ppf " %a " Fmt.(styled (`Bold) string) "Others:";
189
+
let first = ref true in
190
+
Hashtbl.iter (fun h repos ->
191
+
if not !first then Fmt.pf ppf ", ";
192
+
first := false;
193
+
Fmt.(styled `Faint (fun ppf (h, n) -> pf ppf "%s(%d)" h n)) ppf (abbrev_handle h, List.length repos))
194
+
grouped;
195
+
Fmt.pf ppf "\n"
196
+
end
197
+
end
198
+
end
199
+
200
+
let pp_summary ppf t = pp_summary' ~show_all:false ppf t
201
+
202
+
(** Normalize a git URL for comparison.
203
+
Handles: git+https, https, git@, with/without .git suffix *)
204
+
let normalize_url url =
205
+
let s = Uri.to_string url in
206
+
(* Strip git+ prefix *)
207
+
let s = if String.starts_with ~prefix:"git+" s then
208
+
String.sub s 4 (String.length s - 4)
209
+
else s
210
+
in
211
+
(* Convert SSH to HTTPS for comparison *)
212
+
let s =
213
+
if String.starts_with ~prefix:"git@github.com:" s then
214
+
"https://github.com/" ^ String.sub s 15 (String.length s - 15)
215
+
else if String.starts_with ~prefix:"git@gitlab.com:" s then
216
+
"https://gitlab.com/" ^ String.sub s 15 (String.length s - 15)
217
+
else if String.starts_with ~prefix:"git@git.recoil.org:" s then
218
+
"https://git.recoil.org/" ^ String.sub s 19 (String.length s - 19)
219
+
else s
220
+
in
221
+
(* Strip .git suffix *)
222
+
let s = if String.ends_with ~suffix:".git" s then
223
+
String.sub s 0 (String.length s - 4)
224
+
else s
225
+
in
226
+
(* Strip trailing slash *)
227
+
let s = if String.ends_with ~suffix:"/" s then
228
+
String.sub s 0 (String.length s - 1)
229
+
else s
230
+
in
231
+
Uri.of_string s
232
+
233
+
let urls_equal url1 url2 =
234
+
let n1 = normalize_url url1 in
235
+
let n2 = normalize_url url2 in
236
+
Uri.equal n1 n2
237
+
238
+
(** Extract repo basename from a URL *)
239
+
let repo_basename url =
240
+
let path = Uri.path url in
241
+
let basename = Filename.basename path in
242
+
if Filename.check_suffix basename ".git" then
243
+
Filename.chop_suffix basename ".git"
244
+
else basename
245
+
246
+
(** Scan a verse opam repo and return (package_name, dev_repo_url) pairs *)
247
+
let scan_verse_opam_repo ~fs opam_repo_path =
248
+
let packages_dir = Fpath.(opam_repo_path / "packages") in
249
+
let eio_packages = Eio.Path.(fs / Fpath.to_string packages_dir) in
250
+
try
251
+
let package_names = Eio.Path.read_dir eio_packages in
252
+
List.filter_map
253
+
(fun pkg_name ->
254
+
let pkg_dir = Fpath.(packages_dir / pkg_name) in
255
+
let eio_pkg = Eio.Path.(fs / Fpath.to_string pkg_dir) in
256
+
try
257
+
let versions = Eio.Path.read_dir eio_pkg in
258
+
match versions with
259
+
| [] -> None
260
+
| version :: _ ->
261
+
let opam_path = Fpath.(pkg_dir / version / "opam") in
262
+
let eio_opam = Eio.Path.(fs / Fpath.to_string opam_path) in
263
+
try
264
+
let content = Eio.Path.load eio_opam in
265
+
let opamfile = OpamParser.FullPos.string content (Fpath.to_string opam_path) in
266
+
match Opam_repo.find_dev_repo opamfile.file_contents with
267
+
| None -> None
268
+
| Some url_str ->
269
+
if Opam_repo.is_git_url url_str then
270
+
Some (pkg_name, Opam_repo.normalize_git_url url_str)
271
+
else None
272
+
with _ -> None
273
+
with _ -> None)
274
+
package_names
275
+
with _ -> []
276
+
277
+
(** Fetch a verse opam repo *)
278
+
let fetch_verse_opam_repo ~proc ~fs path =
279
+
let cwd = Eio.Path.(fs / Fpath.to_string path) in
280
+
let cmd = ["git"; "fetch"; "--quiet"] in
281
+
Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp path);
282
+
Eio.Switch.run @@ fun sw ->
283
+
let child = Eio.Process.spawn proc ~sw ~cwd
284
+
~stdout:(Eio.Flow.buffer_sink (Buffer.create 16))
285
+
~stderr:(Eio.Flow.buffer_sink (Buffer.create 16))
286
+
cmd
287
+
in
288
+
match Eio.Process.await child with
289
+
| `Exited 0 -> ()
290
+
| _ -> Log.debug (fun m -> m "Failed to fetch %a" Fpath.pp path)
291
+
292
+
(** Scan all verse opam repos and build a map: repo_basename -> [(handle, url, [packages])] *)
293
+
let scan_all_verse_opam_repos ~proc ~fs ~verse_path () =
294
+
let eio_verse = Eio.Path.(fs / Fpath.to_string verse_path) in
295
+
let entries = try Eio.Path.read_dir eio_verse with _ -> [] in
296
+
(* Find opam repo directories (ending in -opam) *)
297
+
let opam_dirs = List.filter (fun name -> String.ends_with ~suffix:"-opam" name) entries in
298
+
(* Fetch each opam repo first *)
299
+
Log.info (fun m -> m "Fetching %d verse opam repos" (List.length opam_dirs));
300
+
List.iter (fun opam_dir ->
301
+
let opam_path = Fpath.(verse_path / opam_dir) in
302
+
fetch_verse_opam_repo ~proc ~fs opam_path)
303
+
opam_dirs;
304
+
(* Build map: repo_basename -> [(handle, url, [packages])] *)
305
+
let repo_map = Hashtbl.create 64 in
306
+
List.iter
307
+
(fun opam_dir ->
308
+
let handle = String.sub opam_dir 0 (String.length opam_dir - 5) in (* strip -opam *)
309
+
let opam_path = Fpath.(verse_path / opam_dir) in
310
+
let pkg_urls = scan_verse_opam_repo ~fs opam_path in
311
+
(* Group by repo basename *)
312
+
let by_repo = Hashtbl.create 16 in
313
+
List.iter
314
+
(fun (pkg_name, url) ->
315
+
let repo = repo_basename url in
316
+
let existing = try Hashtbl.find by_repo repo with Not_found -> (url, []) in
317
+
let (existing_url, pkgs) = existing in
318
+
Hashtbl.replace by_repo repo (existing_url, pkg_name :: pkgs))
319
+
pkg_urls;
320
+
(* Add to main map *)
321
+
Hashtbl.iter
322
+
(fun repo (url, pkgs) ->
323
+
let source = { handle; url; packages = pkgs } in
324
+
let existing = try Hashtbl.find repo_map repo with Not_found -> [] in
325
+
Hashtbl.replace repo_map repo (source :: existing))
326
+
by_repo)
327
+
opam_dirs;
328
+
repo_map
329
+
330
+
(** Get my dev-repo URLs from my opam repo *)
331
+
let scan_my_opam_repo ~fs ~opam_repo_path () =
332
+
let repo_map = Hashtbl.create 32 in
333
+
match Opam_repo.scan ~fs opam_repo_path with
334
+
| Error _ -> repo_map
335
+
| Ok packages ->
336
+
List.iter
337
+
(fun pkg ->
338
+
let repo = Package.repo_name pkg in
339
+
let url = Package.dev_repo pkg in
340
+
let existing = try Hashtbl.find repo_map repo with Not_found -> (url, []) in
341
+
let (_, pkgs) = existing in
342
+
Hashtbl.replace repo_map repo (url, Package.name pkg :: pkgs))
343
+
packages;
344
+
repo_map
345
+
346
+
(** Remote name for a verse member *)
347
+
let verse_remote_name handle = "verse/" ^ handle
348
+
349
+
(** Check if a remote exists *)
350
+
let remote_exists ~proc ~fs ~repo remote_name =
351
+
let cwd = Eio.Path.(fs / Fpath.to_string repo) in
352
+
let result = Eio.Switch.run @@ fun sw ->
353
+
let buf = Buffer.create 256 in
354
+
let child = Eio.Process.spawn proc ~sw ~cwd
355
+
~stdout:(Eio.Flow.buffer_sink buf)
356
+
~stderr:(Eio.Flow.buffer_sink (Buffer.create 16))
357
+
["git"; "remote"; "get-url"; remote_name]
358
+
in
359
+
match Eio.Process.await child with
360
+
| `Exited 0 -> true
361
+
| _ -> false
362
+
in
363
+
result
364
+
365
+
(** Add a git remote *)
366
+
let add_remote ~proc ~fs ~repo ~name ~url () =
367
+
let cwd = Eio.Path.(fs / Fpath.to_string repo) in
368
+
let cmd = ["git"; "remote"; "add"; name; Uri.to_string url] in
369
+
Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo);
370
+
Eio.Switch.run @@ fun sw ->
371
+
let child = Eio.Process.spawn proc ~sw ~cwd
372
+
~stdout:(Eio.Flow.buffer_sink (Buffer.create 16))
373
+
~stderr:(Eio.Flow.buffer_sink (Buffer.create 16))
374
+
cmd
375
+
in
376
+
match Eio.Process.await child with
377
+
| `Exited 0 -> Ok ()
378
+
| _ -> Error "Failed to add remote"
379
+
380
+
(** Fetch a remote *)
381
+
let fetch_remote ~proc ~fs ~repo ~remote () =
382
+
let cwd = Eio.Path.(fs / Fpath.to_string repo) in
383
+
let cmd = ["git"; "fetch"; remote] in
384
+
Log.info (fun m -> m "Fetching %s in %a" remote Fpath.pp repo);
385
+
Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo);
386
+
Eio.Switch.run @@ fun sw ->
387
+
let child = Eio.Process.spawn proc ~sw ~cwd
388
+
~stdout:(Eio.Flow.buffer_sink (Buffer.create 256))
389
+
~stderr:(Eio.Flow.buffer_sink (Buffer.create 256))
390
+
cmd
391
+
in
392
+
match Eio.Process.await child with
393
+
| `Exited 0 -> Ok ()
394
+
| _ -> Error "Failed to fetch remote"
395
+
396
+
(** Get the commit SHA for a ref *)
397
+
let get_ref_commit ~proc ~fs ~repo ref_name =
398
+
let cwd = Eio.Path.(fs / Fpath.to_string repo) in
399
+
let cmd = ["git"; "rev-parse"; ref_name] in
400
+
Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo);
401
+
Eio.Switch.run @@ fun sw ->
402
+
let buf = Buffer.create 64 in
403
+
let child = Eio.Process.spawn proc ~sw ~cwd
404
+
~stdout:(Eio.Flow.buffer_sink buf)
405
+
~stderr:(Eio.Flow.buffer_sink (Buffer.create 16))
406
+
cmd
407
+
in
408
+
match Eio.Process.await child with
409
+
| `Exited 0 -> Some (String.trim (Buffer.contents buf))
410
+
| _ -> None
411
+
412
+
(** Compare two refs and determine relationship *)
413
+
let compare_refs ~proc ~fs ~repo ~my_ref ~their_ref () =
414
+
let my_commit = get_ref_commit ~proc ~fs ~repo my_ref in
415
+
let their_commit = get_ref_commit ~proc ~fs ~repo their_ref in
416
+
match (my_commit, their_commit) with
417
+
| None, _ | _, None -> Not_fetched
418
+
| Some my_sha, Some their_sha when my_sha = their_sha -> Same_commit
419
+
| Some my_sha, Some their_sha ->
420
+
(* Check ancestry *)
421
+
let cwd = Eio.Path.(fs / Fpath.to_string repo) in
422
+
let is_ancestor commit1 commit2 =
423
+
let cmd = ["git"; "merge-base"; "--is-ancestor"; commit1; commit2] in
424
+
Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo);
425
+
Eio.Switch.run @@ fun sw ->
426
+
let child = Eio.Process.spawn proc ~sw ~cwd
427
+
~stdout:(Eio.Flow.buffer_sink (Buffer.create 16))
428
+
~stderr:(Eio.Flow.buffer_sink (Buffer.create 16))
429
+
cmd
430
+
in
431
+
match Eio.Process.await child with
432
+
| `Exited 0 -> true
433
+
| _ -> false
434
+
in
435
+
let count_commits base head =
436
+
let cmd = ["git"; "rev-list"; "--count"; base ^ ".." ^ head] in
437
+
Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo);
438
+
Eio.Switch.run @@ fun sw ->
439
+
let buf = Buffer.create 16 in
440
+
let child = Eio.Process.spawn proc ~sw ~cwd
441
+
~stdout:(Eio.Flow.buffer_sink buf)
442
+
~stderr:(Eio.Flow.buffer_sink (Buffer.create 16))
443
+
cmd
444
+
in
445
+
match Eio.Process.await child with
446
+
| `Exited 0 -> (try int_of_string (String.trim (Buffer.contents buf)) with _ -> 0)
447
+
| _ -> 0
448
+
in
449
+
let my_is_ancestor = is_ancestor my_sha their_sha in
450
+
let their_is_ancestor = is_ancestor their_sha my_sha in
451
+
match (my_is_ancestor, their_is_ancestor) with
452
+
| true, true -> Same_commit (* shouldn't happen if SHAs differ *)
453
+
| true, false ->
454
+
(* My commit is ancestor of theirs -> I'm behind *)
455
+
let behind = count_commits my_sha their_sha in
456
+
I_am_behind behind
457
+
| false, true ->
458
+
(* Their commit is ancestor of mine -> I'm ahead *)
459
+
let ahead = count_commits their_sha my_sha in
460
+
I_am_ahead ahead
461
+
| false, false ->
462
+
(* Check for common ancestor *)
463
+
let cmd = ["git"; "merge-base"; my_sha; their_sha] in
464
+
Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo);
465
+
let merge_base =
466
+
Eio.Switch.run @@ fun sw ->
467
+
let buf = Buffer.create 64 in
468
+
let child = Eio.Process.spawn proc ~sw ~cwd
469
+
~stdout:(Eio.Flow.buffer_sink buf)
470
+
~stderr:(Eio.Flow.buffer_sink (Buffer.create 16))
471
+
cmd
472
+
in
473
+
match Eio.Process.await child with
474
+
| `Exited 0 -> Some (String.trim (Buffer.contents buf))
475
+
| _ -> None
476
+
in
477
+
match merge_base with
478
+
| None -> Unrelated
479
+
| Some base ->
480
+
let my_ahead = count_commits base my_sha in
481
+
let their_ahead = count_commits base their_sha in
482
+
Diverged { common_ancestor = base; my_ahead; their_ahead }
483
+
484
+
(** Compute fork analysis for all repos *)
485
+
let compute ~proc ~fs ~verse_config ~monopam_config () =
486
+
let verse_path = Verse_config.verse_path verse_config in
487
+
let opam_repo_path = Config.Paths.opam_repo monopam_config in
488
+
let checkouts_path = Config.Paths.checkouts monopam_config in
489
+
490
+
(* Scan my opam repo *)
491
+
Log.info (fun m -> m "Scanning my opam repo");
492
+
let my_repos = scan_my_opam_repo ~fs ~opam_repo_path () in
493
+
494
+
(* Scan verse opam repos *)
495
+
Log.info (fun m -> m "Scanning verse opam repos");
496
+
let verse_repos = scan_all_verse_opam_repos ~proc ~fs ~verse_path () in
497
+
498
+
(* Build combined list of all repo names *)
499
+
let all_repos = Hashtbl.create 64 in
500
+
Hashtbl.iter (fun repo _ -> Hashtbl.replace all_repos repo ()) my_repos;
501
+
Hashtbl.iter (fun repo _ -> Hashtbl.replace all_repos repo ()) verse_repos;
502
+
503
+
(* Analyze each repo *)
504
+
let analyses =
505
+
Hashtbl.fold
506
+
(fun repo_name () acc ->
507
+
let my_source =
508
+
match Hashtbl.find_opt my_repos repo_name with
509
+
| None -> None
510
+
| Some (url, pkgs) -> Some { handle = "me"; url; packages = pkgs }
511
+
in
512
+
let verse_sources =
513
+
match Hashtbl.find_opt verse_repos repo_name with
514
+
| None -> []
515
+
| Some sources -> sources
516
+
in
517
+
(* Skip if no verse sources *)
518
+
if verse_sources = [] then acc
519
+
else begin
520
+
(* Check if we have a local checkout *)
521
+
let checkout_path = Fpath.(checkouts_path / repo_name) in
522
+
let have_checkout = Git.is_repo ~proc ~fs checkout_path in
523
+
524
+
(* Process each verse source *)
525
+
let verse_with_rel =
526
+
List.map
527
+
(fun src ->
528
+
(* Check if URL is same as mine *)
529
+
let rel =
530
+
match my_source with
531
+
| Some my when urls_equal my.url src.url -> Same_url
532
+
| _ when not have_checkout -> Not_fetched
533
+
| _ ->
534
+
let remote_name = verse_remote_name src.handle in
535
+
(* Add remote if needed *)
536
+
if not (remote_exists ~proc ~fs ~repo:checkout_path remote_name) then begin
537
+
Log.info (fun m -> m "Adding remote %s -> %a" remote_name Uri.pp src.url);
538
+
ignore (add_remote ~proc ~fs ~repo:checkout_path ~name:remote_name ~url:src.url ())
539
+
end;
540
+
(* Fetch remote *)
541
+
(match fetch_remote ~proc ~fs ~repo:checkout_path ~remote:remote_name () with
542
+
| Error _ -> Not_fetched
543
+
| Ok () ->
544
+
(* Compare refs *)
545
+
let my_ref = "origin/main" in
546
+
let their_ref = remote_name ^ "/main" in
547
+
compare_refs ~proc ~fs ~repo:checkout_path ~my_ref ~their_ref ())
548
+
in
549
+
(src.handle, src, rel))
550
+
verse_sources
551
+
in
552
+
{ repo_name; my_source; verse_sources = verse_with_rel } :: acc
553
+
end)
554
+
all_repos []
555
+
in
556
+
(* Sort by repo name *)
557
+
let repos = List.sort (fun a b -> String.compare a.repo_name b.repo_name) analyses in
558
+
{ repos }
+86
lib/forks.mli
+86
lib/forks.mli
···
1
+
(** Fork graph discovery via verse opam repos.
2
+
3
+
Scans verse opam repos to discover dev-repo URLs, adds git remotes
4
+
to local checkouts, and computes fork relationships. *)
5
+
6
+
(** {1 Types} *)
7
+
8
+
(** A dev-repo source from a specific member *)
9
+
type repo_source = {
10
+
handle : string; (** Member handle or "me" *)
11
+
url : Uri.t; (** Normalized git URL *)
12
+
packages : string list; (** Opam packages from this repo *)
13
+
}
14
+
15
+
(** Fork relationship between two sources *)
16
+
type relationship =
17
+
| Same_url (** Same git URL *)
18
+
| Same_commit (** Different URLs but same HEAD *)
19
+
| I_am_ahead of int (** They forked from me, I'm N commits ahead *)
20
+
| I_am_behind of int (** I forked from them, they're N commits ahead *)
21
+
| Diverged of { common_ancestor : string; my_ahead : int; their_ahead : int }
22
+
| Unrelated (** No common history *)
23
+
| Not_fetched (** Remote not yet fetched *)
24
+
25
+
(** Analysis result for a single repository *)
26
+
type repo_analysis = {
27
+
repo_name : string; (** Repository basename *)
28
+
my_source : repo_source option; (** My dev-repo if I have it *)
29
+
verse_sources : (string * repo_source * relationship) list;
30
+
(** (handle, source, relationship to me) *)
31
+
}
32
+
33
+
(** Full fork analysis result *)
34
+
type t = {
35
+
repos : repo_analysis list;
36
+
}
37
+
38
+
(** {1 Pretty Printing} *)
39
+
40
+
val pp_relationship : relationship Fmt.t
41
+
val pp_repo_source : repo_source Fmt.t
42
+
val pp_repo_analysis : repo_analysis Fmt.t
43
+
val pp : t Fmt.t
44
+
(** Verbose output with full URLs for each repo. *)
45
+
46
+
val pp_summary : t Fmt.t
47
+
(** Succinct summary: one line per repo with emphasis on repos where
48
+
others have commits not in mine. *)
49
+
50
+
val pp_summary' : show_all:bool -> t Fmt.t
51
+
(** [pp_summary' ~show_all] formats a succinct summary. When [show_all] is true,
52
+
lists all repos that others have but you don't. *)
53
+
54
+
val is_actionable : relationship -> bool
55
+
(** [is_actionable rel] returns [true] if the relationship indicates
56
+
that others have commits I should consider pulling (I_am_behind or Diverged). *)
57
+
58
+
(** {1 URL Utilities} *)
59
+
60
+
val normalize_url : Uri.t -> Uri.t
61
+
(** [normalize_url url] normalizes a git URL for comparison.
62
+
Converts SSH to HTTPS, strips git+ prefix and .git suffix. *)
63
+
64
+
val urls_equal : Uri.t -> Uri.t -> bool
65
+
(** [urls_equal url1 url2] checks if two URLs refer to the same repo. *)
66
+
67
+
val repo_basename : Uri.t -> string
68
+
(** [repo_basename url] extracts the repository basename from a URL. *)
69
+
70
+
(** {1 Analysis} *)
71
+
72
+
val compute :
73
+
proc:_ Eio.Process.mgr ->
74
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
75
+
verse_config:Verse_config.t ->
76
+
monopam_config:Config.t ->
77
+
unit ->
78
+
t
79
+
(** [compute ~proc ~fs ~verse_config ~monopam_config ()] performs full fork
80
+
analysis by:
81
+
1. Scanning my opam repo for dev-repo URLs
82
+
2. Scanning all verse opam repos for dev-repo URLs
83
+
3. Adding git remotes to my checkouts for each member's fork
84
+
4. Fetching remotes and comparing commit histories
85
+
86
+
This is an expensive operation as it fetches from all verse member remotes. *)
+1
lib/monopam.ml
+1
lib/monopam.ml
+1
lib/monopam.mli
+1
lib/monopam.mli
+5
lib/opam_repo.mli
+5
lib/opam_repo.mli
···
86
86
@param fs Eio filesystem capability
87
87
@param dir_path Path to the directory to scan
88
88
@return List of dependency package names *)
89
+
90
+
(** {1 Low-level Opam File Parsing} *)
91
+
92
+
val find_dev_repo : OpamParserTypes.FullPos.opamfile_item list -> string option
93
+
(** [find_dev_repo items] extracts the dev-repo field from parsed opam file items. *)
+42
-6
lib/status.ml
+42
-6
lib/status.ml
···
84
84
Fmt.pf ppf "@[<h>%-20s checkout: %a subtree: %a@]" (Package.name t.package)
85
85
pp_checkout_status t.checkout pp_subtree_status t.subtree
86
86
87
+
(** Compact status for actionable items with colors *)
88
+
let pp_compact ppf t =
89
+
let name = Package.name t.package in
90
+
match (t.checkout, t.subtree) with
91
+
| Clean ab, Present when ab.ahead > 0 && ab.behind > 0 ->
92
+
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Yellow (fun ppf (a,b) -> pf ppf "+%d/-%d" a b)) (ab.ahead, ab.behind)
93
+
| Clean ab, Present when ab.ahead > 0 ->
94
+
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Cyan (fun ppf n -> pf ppf "+%d" n)) ab.ahead
95
+
| Clean ab, Present when ab.behind > 0 ->
96
+
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red (fun ppf n -> pf ppf "-%d" n)) ab.behind
97
+
| Clean _, Not_added ->
98
+
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Magenta string) "(no subtree)"
99
+
| Missing, _ ->
100
+
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(no checkout)"
101
+
| Not_a_repo, _ ->
102
+
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(not a repo)"
103
+
| Dirty, _ ->
104
+
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Yellow string) "(dirty)"
105
+
| Clean _, Present ->
106
+
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Green string) "ok"
107
+
87
108
let pp_summary ppf statuses =
88
109
let total = List.length statuses in
89
-
let clean = List.filter is_checkout_clean statuses |> List.length in
110
+
let actionable = filter_actionable statuses in
90
111
let synced = List.filter is_fully_synced statuses |> List.length in
91
-
Fmt.pf ppf
92
-
"@[<v>Packages: %d total, %d clean checkouts, %d fully synced@,@,%a@]" total
93
-
clean synced
94
-
Fmt.(list ~sep:cut pp)
95
-
statuses
112
+
let dirty = List.filter has_local_changes statuses |> List.length in
113
+
let action_count = List.length actionable in
114
+
(* Header line with colors *)
115
+
if dirty > 0 then
116
+
Fmt.pf ppf "%a %d total, %a synced, %a dirty\n"
117
+
Fmt.(styled `Bold string) "Packages:" total
118
+
Fmt.(styled `Green int) synced
119
+
Fmt.(styled `Yellow int) dirty
120
+
else if action_count > 0 then
121
+
Fmt.pf ppf "%a %d total, %a synced, %a need attention\n"
122
+
Fmt.(styled `Bold string) "Packages:" total
123
+
Fmt.(styled `Green int) synced
124
+
Fmt.(styled `Cyan int) action_count
125
+
else
126
+
Fmt.pf ppf "%a %d total, %a\n"
127
+
Fmt.(styled `Bold string) "Packages:" total
128
+
Fmt.(styled `Green string) "all synced";
129
+
(* Only show actionable items *)
130
+
if actionable <> [] then
131
+
List.iter (fun t -> Fmt.pf ppf " %a\n" pp_compact t) actionable