anil.recoil.org
My aggregated monorepo of OCaml code, automaintained
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 = Option.bind sources (fun s -> Sources_registry.find s ~subtree) in
207 (* Helper to print remote sync info *)
208 let pp_remote ab =
209 if ab.Git.ahead > 0 && ab.behind > 0 then
210 Fmt.pf ppf " %a"
211 Fmt.(styled `Yellow (fun ppf (a, b) -> pf ppf "remote:+%d/-%d" a b))
212 (ab.ahead, ab.behind)
213 else if ab.ahead > 0 then
214 Fmt.pf ppf " %a"
215 Fmt.(styled `Cyan (fun ppf n -> pf ppf "remote:+%d" n))
216 ab.ahead
217 else if ab.behind > 0 then
218 Fmt.pf ppf " %a"
219 Fmt.(styled `Red (fun ppf n -> pf ppf "remote:-%d" n))
220 ab.behind
221 in
222 match (t.checkout, t.subtree, t.subtree_sync) with
223 (* Local sync issues with count *)
224 | Clean ab, Present, Subtree_behind n ->
225 Fmt.pf ppf "%-22s %a" name
226 Fmt.(styled `Blue (fun ppf n -> pf ppf "local:-%d" n))
227 n;
228 pp_remote ab;
229 pp_origin_indicator ppf entry
230 | Clean ab, Present, Subtree_ahead n ->
231 Fmt.pf ppf "%-22s %a" name
232 Fmt.(styled `Blue (fun ppf n -> pf ppf "local:+%d" n))
233 n;
234 pp_remote ab;
235 pp_origin_indicator ppf entry
236 (* Trees differ but can't determine count *)
237 | Clean ab, Present, Trees_differ ->
238 Fmt.pf ppf "%-22s %a" name Fmt.(styled `Blue string) "local:sync";
239 pp_remote ab;
240 pp_origin_indicator ppf entry
241 (* Remote sync issues only *)
242 | Clean ab, Present, (In_sync | Unknown) when ab.ahead > 0 && ab.behind > 0 ->
243 Fmt.pf ppf "%-22s %a" name
244 Fmt.(styled `Yellow (fun ppf (a, b) -> pf ppf "remote:+%d/-%d" a b))
245 (ab.ahead, ab.behind);
246 pp_origin_indicator ppf entry
247 | Clean ab, Present, (In_sync | Unknown) when ab.ahead > 0 ->
248 Fmt.pf ppf "%-22s %a" name
249 Fmt.(styled `Cyan (fun ppf n -> pf ppf "remote:+%d" n))
250 ab.ahead;
251 pp_origin_indicator ppf entry
252 | Clean ab, Present, (In_sync | Unknown) when ab.behind > 0 ->
253 Fmt.pf ppf "%-22s %a" name
254 Fmt.(styled `Red (fun ppf n -> pf ppf "remote:-%d" n))
255 ab.behind;
256 pp_origin_indicator ppf entry
257 (* Other issues *)
258 | Clean _, Not_added, _ ->
259 Fmt.pf ppf "%-22s %a" name Fmt.(styled `Magenta string) "(no subtree)";
260 pp_origin_indicator ppf entry
261 | Missing, _, _ ->
262 Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(no checkout)";
263 pp_origin_indicator ppf entry
264 | Not_a_repo, _, _ ->
265 Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(not a repo)";
266 pp_origin_indicator ppf entry
267 | Dirty, _, _ ->
268 Fmt.pf ppf "%-22s %a" name Fmt.(styled `Yellow string) "(dirty)";
269 pp_origin_indicator ppf entry
270 | Clean _, Present, (In_sync | Unknown) ->
271 Fmt.pf ppf "%-22s %a" name Fmt.(styled `Green string) "ok";
272 pp_origin_indicator ppf entry
273
274let pp_summary ?sources ppf statuses =
275 let total = List.length statuses in
276 let actionable = filter_actionable statuses in
277 let synced = List.filter is_fully_synced statuses |> List.length in
278 let dirty = List.filter has_local_changes statuses |> List.length in
279 let local_sync_needed =
280 List.filter needs_local_sync statuses |> List.length
281 in
282 let remote_needed = List.filter needs_remote_action statuses |> List.length in
283 let action_count = List.length actionable in
284 (* Header line with colors *)
285 if dirty > 0 then
286 Fmt.pf ppf "%a %d total, %a synced, %a dirty\n"
287 Fmt.(styled `Bold string)
288 "Packages:" total
289 Fmt.(styled `Green int)
290 synced
291 Fmt.(styled `Yellow int)
292 dirty
293 else if action_count > 0 then begin
294 Fmt.pf ppf "%a %d total, %a synced"
295 Fmt.(styled `Bold string)
296 "Packages:" total
297 Fmt.(styled `Green int)
298 synced;
299 if local_sync_needed > 0 then
300 Fmt.pf ppf ", %a local sync" Fmt.(styled `Blue int) local_sync_needed;
301 if remote_needed > 0 then
302 Fmt.pf ppf ", %a remote" Fmt.(styled `Cyan int) remote_needed;
303 Fmt.pf ppf "\n"
304 end
305 else
306 Fmt.pf ppf "%a %d total, %a\n"
307 Fmt.(styled `Bold string)
308 "Packages:" total
309 Fmt.(styled `Green string)
310 "all synced";
311 (* Only show actionable items *)
312 if actionable <> [] then
313 List.iter (fun t -> Fmt.pf ppf " %a\n" (pp_compact ?sources) t) actionable