jon.recoil.org
forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
1type checkout_status =
2 | Missing
3 | Not_a_repo
4 | Dirty
5 | Clean of Git.ahead_behind
6
7type subtree_status = Not_added | Present
8
9(** Sync state between monorepo subtree and local checkout *)
10type subtree_sync =
11 | In_sync (** Subtree matches checkout HEAD *)
12 | Subtree_behind of int
13 (** Subtree needs pull from checkout (checkout has new commits) *)
14 | Subtree_ahead of int
15 (** Subtree has commits not in checkout (need push to checkout) *)
16 | Trees_differ (** Trees differ but can't determine direction/count *)
17 | Unknown (** Can't determine (subtree not added or checkout missing) *)
18
19type t = {
20 package : Package.t;
21 checkout : checkout_status;
22 subtree : subtree_status;
23 subtree_sync : subtree_sync; (** Sync state between monorepo and checkout *)
24}
25
26let fs_typed (fs : _ Eio.Path.t) : Eio.Fs.dir_ty Eio.Path.t =
27 let dir, _ = fs in
28 (dir, "")
29
30let compute ~proc ~fs ~config pkg =
31 let checkouts_root = Config.Paths.checkouts config in
32 let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
33 let monorepo = Config.Paths.monorepo config in
34 let prefix = Package.subtree_prefix pkg in
35 let fs_t = fs_typed fs in
36 let fs_dir =
37 let dir, _ = fs in
38 (dir, Fpath.to_string checkout_dir)
39 in
40 let checkout =
41 match Eio.Path.kind ~follow:true fs_dir with
42 | exception Eio.Io _ -> Missing
43 | `Directory -> (
44 if not (Git.is_repo ~proc ~fs:fs_t checkout_dir) then Not_a_repo
45 else if Git.is_dirty ~proc ~fs:fs_t checkout_dir then Dirty
46 else
47 match Git.ahead_behind ~proc ~fs:fs_t checkout_dir with
48 | Ok ab -> Clean ab
49 | Error _ -> Clean { ahead = 0; behind = 0 })
50 | _ -> Missing
51 in
52 let subtree =
53 if Git.Subtree.exists ~fs:fs_t ~repo:monorepo ~prefix then Present
54 else Not_added
55 in
56 (* Compute subtree sync state: compare tree content between monorepo subtree and checkout.
57 This is more accurate than commit ancestry because it handles both push and pull directions.
58 If the trees match, the content is in sync regardless of how it got there. *)
59 let subtree_sync =
60 match (checkout, subtree) with
61 | (Missing | Not_a_repo | Dirty), _ -> Unknown
62 | _, Not_added -> Unknown
63 | Clean _, Present -> (
64 (* Get tree hash of subtree directory in monorepo *)
65 let subtree_tree =
66 Git.rev_parse ~proc ~fs:fs_t ~rev:("HEAD:" ^ prefix) monorepo
67 in
68 (* Get tree hash of checkout root *)
69 let checkout_tree =
70 Git.rev_parse ~proc ~fs:fs_t ~rev:"HEAD^{tree}" checkout_dir
71 in
72 match (subtree_tree, checkout_tree) with
73 | Ok st, Ok ct when st = ct -> In_sync
74 | Ok _, Ok _ -> (
75 (* Trees differ - check commit ancestry to determine direction *)
76 let subtree_commit =
77 Git.subtree_last_upstream_commit ~proc ~fs:fs_t ~repo:monorepo
78 ~prefix ()
79 in
80 let checkout_head = Git.head_commit ~proc ~fs:fs_t checkout_dir in
81 match (subtree_commit, checkout_head) with
82 | Some subtree_sha, Ok checkout_sha ->
83 if
84 Git.is_ancestor ~proc ~fs:fs_t ~repo:checkout_dir
85 ~commit1:subtree_sha ~commit2:checkout_sha ()
86 then
87 (* Checkout has commits not in subtree - need subtree pull *)
88 let count =
89 Git.count_commits_between ~proc ~fs:fs_t ~repo:checkout_dir
90 ~base:subtree_sha ~head:checkout_sha ()
91 in
92 if count > 0 then Subtree_behind count else Trees_differ
93 (* Same commit but trees differ - monorepo has changes *)
94 else if
95 Git.is_ancestor ~proc ~fs:fs_t ~repo:checkout_dir
96 ~commit1:checkout_sha ~commit2:subtree_sha ()
97 then
98 (* Subtree has content not in checkout - need push *)
99 let count =
100 Git.count_commits_between ~proc ~fs:fs_t ~repo:checkout_dir
101 ~base:checkout_sha ~head:subtree_sha ()
102 in
103 if count > 0 then Subtree_ahead count else Trees_differ
104 else Trees_differ (* Diverged *)
105 | _ -> Trees_differ
106 (* Trees differ but can't determine ancestry *))
107 | _ -> Unknown)
108 in
109 { package = pkg; checkout; subtree; subtree_sync }
110
111let compute_all ~proc ~fs ~config packages =
112 List.map (compute ~proc ~fs ~config) packages
113
114let is_checkout_clean t = match t.checkout with Clean _ -> true | _ -> false
115let has_local_changes t = match t.checkout with Dirty -> true | _ -> false
116
117let needs_pull t =
118 match t.checkout with Clean ab -> ab.behind > 0 | _ -> false
119
120let needs_push t = match t.checkout with Clean ab -> ab.ahead > 0 | _ -> false
121
122(** Needs local sync: monorepo subtree out of sync with checkout *)
123let needs_local_sync t =
124 match t.subtree_sync with
125 | Subtree_behind _ | Subtree_ahead _ | Trees_differ -> true
126 | In_sync | Unknown -> false
127
128(** Needs remote action: checkout ahead/behind of upstream *)
129let needs_remote_action t =
130 match t.checkout with Clean ab -> ab.ahead > 0 || ab.behind > 0 | _ -> false
131
132let is_fully_synced t =
133 match (t.checkout, t.subtree, t.subtree_sync) with
134 | Clean ab, Present, In_sync -> ab.ahead = 0 && ab.behind = 0
135 | _ -> false
136
137let filter_actionable statuses =
138 List.filter
139 (fun t ->
140 match t.checkout with
141 | Missing | Not_a_repo | Dirty -> true
142 | Clean ab ->
143 ab.ahead > 0 || ab.behind > 0 || t.subtree = Not_added
144 || needs_local_sync t)
145 statuses
146
147let pp_checkout_status ppf = function
148 | Missing -> Fmt.string ppf "missing"
149 | Not_a_repo -> Fmt.string ppf "not a repo"
150 | Dirty -> Fmt.string ppf "dirty"
151 | Clean ab ->
152 if ab.ahead = 0 && ab.behind = 0 then Fmt.string ppf "clean"
153 else Fmt.pf ppf "ahead %d, behind %d" ab.ahead ab.behind
154
155let pp_subtree_status ppf = function
156 | Not_added -> Fmt.string ppf "not added"
157 | Present -> Fmt.string ppf "present"
158
159let pp ppf t =
160 Fmt.pf ppf "@[<h>%-20s checkout: %a subtree: %a@]" (Package.name t.package)
161 pp_checkout_status t.checkout pp_subtree_status t.subtree
162
163(** Extract handle from a tangled.org URL like "git+https://tangled.org/handle/repo" *)
164let extract_handle_from_url url =
165 let url = if String.starts_with ~prefix:"git+" url then
166 String.sub url 4 (String.length url - 4)
167 else url in
168 let uri = Uri.of_string url in
169 match Uri.host uri with
170 | Some "tangled.org" ->
171 let path = Uri.path uri in
172 (* Path is like "/handle/repo" - extract first component *)
173 let path = if String.length path > 0 && path.[0] = '/' then
174 String.sub path 1 (String.length path - 1)
175 else path in
176 (match String.index_opt path '/' with
177 | Some i -> Some (String.sub path 0 i)
178 | None -> Some path)
179 | _ -> None
180
181(** Format origin indicator from sources registry entry *)
182let pp_origin_indicator ppf entry =
183 match entry with
184 | None -> ()
185 | Some Sources_registry.{ origin = Some Sources_registry.Fork; _ } ->
186 Fmt.pf ppf " %a" Fmt.(styled `Magenta string) "^"
187 | Some Sources_registry.{ origin = Some Sources_registry.Join; upstream = Some url; _ } ->
188 (match extract_handle_from_url url with
189 | Some handle ->
190 (* Abbreviate handle - take first part before dot, max 8 chars *)
191 let abbrev = match String.index_opt handle '.' with
192 | Some i -> String.sub handle 0 i
193 | None -> handle
194 in
195 let abbrev = if String.length abbrev > 8 then String.sub abbrev 0 8 else abbrev in
196 Fmt.pf ppf " %a" Fmt.(styled `Cyan (fun ppf s -> pf ppf "v:%s" s)) abbrev
197 | None -> Fmt.pf ppf " %a" Fmt.(styled `Cyan string) "v:")
198 | Some Sources_registry.{ origin = Some Sources_registry.Join; _ } ->
199 Fmt.pf ppf " %a" Fmt.(styled `Cyan string) "v:"
200 | Some _ -> ()
201
202(** Compact status for actionable items with colors *)
203let pp_compact ?sources ppf t =
204 let name = Package.name t.package in
205 let subtree = Package.subtree_prefix t.package in
206 let entry = match sources with
207 | Some s -> Sources_registry.find s ~subtree
208 | None -> None
209 in
210 (* Helper to print remote sync info *)
211 let pp_remote ab =
212 if ab.Git.ahead > 0 && ab.behind > 0 then
213 Fmt.pf ppf " %a"
214 Fmt.(styled `Yellow (fun ppf (a, b) -> pf ppf "remote:+%d/-%d" a b))
215 (ab.ahead, ab.behind)
216 else if ab.ahead > 0 then
217 Fmt.pf ppf " %a"
218 Fmt.(styled `Cyan (fun ppf n -> pf ppf "remote:+%d" n))
219 ab.ahead
220 else if ab.behind > 0 then
221 Fmt.pf ppf " %a"
222 Fmt.(styled `Red (fun ppf n -> pf ppf "remote:-%d" n))
223 ab.behind
224 in
225 match (t.checkout, t.subtree, t.subtree_sync) with
226 (* Local sync issues with count *)
227 | Clean ab, Present, Subtree_behind n ->
228 Fmt.pf ppf "%-22s %a" name
229 Fmt.(styled `Blue (fun ppf n -> pf ppf "local:-%d" n))
230 n;
231 pp_remote ab;
232 pp_origin_indicator ppf entry
233 | Clean ab, Present, Subtree_ahead n ->
234 Fmt.pf ppf "%-22s %a" name
235 Fmt.(styled `Blue (fun ppf n -> pf ppf "local:+%d" n))
236 n;
237 pp_remote ab;
238 pp_origin_indicator ppf entry
239 (* Trees differ but can't determine count *)
240 | Clean ab, Present, Trees_differ ->
241 Fmt.pf ppf "%-22s %a" name Fmt.(styled `Blue string) "local:sync";
242 pp_remote ab;
243 pp_origin_indicator ppf entry
244 (* Remote sync issues only *)
245 | Clean ab, Present, (In_sync | Unknown) when ab.ahead > 0 && ab.behind > 0 ->
246 Fmt.pf ppf "%-22s %a" name
247 Fmt.(styled `Yellow (fun ppf (a, b) -> pf ppf "remote:+%d/-%d" a b))
248 (ab.ahead, ab.behind);
249 pp_origin_indicator ppf entry
250 | Clean ab, Present, (In_sync | Unknown) when ab.ahead > 0 ->
251 Fmt.pf ppf "%-22s %a" name
252 Fmt.(styled `Cyan (fun ppf n -> pf ppf "remote:+%d" n))
253 ab.ahead;
254 pp_origin_indicator ppf entry
255 | Clean ab, Present, (In_sync | Unknown) when ab.behind > 0 ->
256 Fmt.pf ppf "%-22s %a" name
257 Fmt.(styled `Red (fun ppf n -> pf ppf "remote:-%d" n))
258 ab.behind;
259 pp_origin_indicator ppf entry
260 (* Other issues *)
261 | Clean _, Not_added, _ ->
262 Fmt.pf ppf "%-22s %a" name Fmt.(styled `Magenta string) "(no subtree)";
263 pp_origin_indicator ppf entry
264 | Missing, _, _ ->
265 Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(no checkout)";
266 pp_origin_indicator ppf entry
267 | Not_a_repo, _, _ ->
268 Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(not a repo)";
269 pp_origin_indicator ppf entry
270 | Dirty, _, _ ->
271 Fmt.pf ppf "%-22s %a" name Fmt.(styled `Yellow string) "(dirty)";
272 pp_origin_indicator ppf entry
273 | Clean _, Present, (In_sync | Unknown) ->
274 Fmt.pf ppf "%-22s %a" name Fmt.(styled `Green string) "ok";
275 pp_origin_indicator ppf entry
276
277let pp_summary ?sources ppf statuses =
278 let total = List.length statuses in
279 let actionable = filter_actionable statuses in
280 let synced = List.filter is_fully_synced statuses |> List.length in
281 let dirty = List.filter has_local_changes statuses |> List.length in
282 let local_sync_needed =
283 List.filter needs_local_sync statuses |> List.length
284 in
285 let remote_needed = List.filter needs_remote_action statuses |> List.length in
286 let action_count = List.length actionable in
287 (* Header line with colors *)
288 if dirty > 0 then
289 Fmt.pf ppf "%a %d total, %a synced, %a dirty\n"
290 Fmt.(styled `Bold string)
291 "Packages:" total
292 Fmt.(styled `Green int)
293 synced
294 Fmt.(styled `Yellow int)
295 dirty
296 else if action_count > 0 then begin
297 Fmt.pf ppf "%a %d total, %a synced"
298 Fmt.(styled `Bold string)
299 "Packages:" total
300 Fmt.(styled `Green int)
301 synced;
302 if local_sync_needed > 0 then
303 Fmt.pf ppf ", %a local sync" Fmt.(styled `Blue int) local_sync_needed;
304 if remote_needed > 0 then
305 Fmt.pf ppf ", %a remote" Fmt.(styled `Cyan int) remote_needed;
306 Fmt.pf ppf "\n"
307 end
308 else
309 Fmt.pf ppf "%a %d total, %a\n"
310 Fmt.(styled `Bold string)
311 "Packages:" total
312 Fmt.(styled `Green string)
313 "all synced";
314 (* Only show actionable items *)
315 if actionable <> [] then
316 List.iter (fun t -> Fmt.pf ppf " %a\n" (pp_compact ?sources) t) actionable