My aggregated monorepo of OCaml code, automaintained
Distinguish local vs remote sync in monopam status
Status now shows:
- local:-N (blue): subtree behind checkout by N commits (fix with sync)
- local:+N (blue): subtree ahead of checkout by N commits (fix with sync)
- remote:+N/-M (cyan/red): checkout ahead/behind upstream (needs network)
This helps users understand which issues can be fixed locally with
`monopam sync` vs those requiring network access.
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
+126
-20
+106
-20
monopam/lib/status.ml
+106
-20
monopam/lib/status.ml
···
6
6
7
7
type subtree_status = Not_added | Present
8
8
9
+
(** Sync state between monorepo subtree and local checkout *)
10
+
type subtree_sync =
11
+
| In_sync (** Subtree matches checkout HEAD *)
12
+
| Subtree_behind of int (** Subtree needs pull from checkout (checkout has new commits) *)
13
+
| Subtree_ahead of int (** Subtree has commits not in checkout (need push to checkout) *)
14
+
| Unknown (** Can't determine (subtree not added or checkout missing) *)
15
+
9
16
type t = {
10
17
package : Package.t;
11
18
checkout : checkout_status;
12
19
subtree : subtree_status;
20
+
subtree_sync : subtree_sync; (** Sync state between monorepo and checkout *)
13
21
}
14
22
15
23
let fs_typed (fs : _ Eio.Path.t) : Eio.Fs.dir_ty Eio.Path.t =
···
42
50
if Git.Subtree.exists ~fs:fs_t ~repo:monorepo ~prefix then Present
43
51
else Not_added
44
52
in
45
-
{ package = pkg; checkout; subtree }
53
+
(* Compute subtree sync state: compare subtree's last upstream commit with checkout HEAD *)
54
+
let subtree_sync =
55
+
match (checkout, subtree) with
56
+
| (Missing | Not_a_repo | Dirty), _ -> Unknown
57
+
| _, Not_added -> Unknown
58
+
| Clean _, Present ->
59
+
(* Get the last upstream commit the subtree was synced from *)
60
+
let subtree_commit =
61
+
Git.subtree_last_upstream_commit ~proc ~fs:fs_t ~repo:monorepo ~prefix ()
62
+
in
63
+
(* Get the checkout's current HEAD *)
64
+
let checkout_head = Git.head_commit ~proc ~fs:fs_t checkout_dir in
65
+
match (subtree_commit, checkout_head) with
66
+
| None, _ -> Unknown (* Can't determine subtree's upstream commit *)
67
+
| _, Error _ -> Unknown (* Can't get checkout HEAD *)
68
+
| Some subtree_sha, Ok checkout_sha ->
69
+
(* Normalize to short hashes for comparison *)
70
+
let subtree_short = String.sub subtree_sha 0 (min 7 (String.length subtree_sha)) in
71
+
let checkout_short = String.sub checkout_sha 0 (min 7 (String.length checkout_sha)) in
72
+
if subtree_short = checkout_short then In_sync
73
+
else
74
+
(* Check if subtree commit is ancestor of checkout (subtree behind) *)
75
+
if Git.is_ancestor ~proc ~fs:fs_t ~repo:checkout_dir
76
+
~commit1:subtree_sha ~commit2:checkout_sha () then
77
+
(* Subtree is behind checkout - checkout has newer commits *)
78
+
let count = Git.count_commits_between ~proc ~fs:fs_t ~repo:checkout_dir
79
+
~base:subtree_sha ~head:checkout_sha () in
80
+
Subtree_behind count
81
+
else if Git.is_ancestor ~proc ~fs:fs_t ~repo:checkout_dir
82
+
~commit1:checkout_sha ~commit2:subtree_sha () then
83
+
(* Checkout is behind subtree - subtree has commits not pushed *)
84
+
let count = Git.count_commits_between ~proc ~fs:fs_t ~repo:checkout_dir
85
+
~base:checkout_sha ~head:subtree_sha () in
86
+
Subtree_ahead count
87
+
else
88
+
(* Diverged - treat as unknown for now *)
89
+
Unknown
90
+
in
91
+
{ package = pkg; checkout; subtree; subtree_sync }
46
92
47
93
let compute_all ~proc ~fs ~config packages =
48
94
List.map (compute ~proc ~fs ~config) packages
···
55
101
56
102
let needs_push t = match t.checkout with Clean ab -> ab.ahead > 0 | _ -> false
57
103
104
+
(** Needs local sync: monorepo subtree out of sync with checkout *)
105
+
let needs_local_sync t =
106
+
match t.subtree_sync with
107
+
| Subtree_behind _ | Subtree_ahead _ -> true
108
+
| In_sync | Unknown -> false
109
+
110
+
(** Needs remote action: checkout ahead/behind of upstream *)
111
+
let needs_remote_action t =
112
+
match t.checkout with
113
+
| Clean ab -> ab.ahead > 0 || ab.behind > 0
114
+
| _ -> false
115
+
58
116
let is_fully_synced t =
59
-
match (t.checkout, t.subtree) with
60
-
| Clean ab, Present -> ab.ahead = 0 && ab.behind = 0
117
+
match (t.checkout, t.subtree, t.subtree_sync) with
118
+
| Clean ab, Present, In_sync -> ab.ahead = 0 && ab.behind = 0
61
119
| _ -> false
62
120
63
121
let filter_actionable statuses =
···
65
123
(fun t ->
66
124
match t.checkout with
67
125
| Missing | Not_a_repo | Dirty -> true
68
-
| Clean ab -> ab.ahead > 0 || ab.behind > 0 || t.subtree = Not_added)
126
+
| Clean ab ->
127
+
ab.ahead > 0 || ab.behind > 0 ||
128
+
t.subtree = Not_added ||
129
+
needs_local_sync t)
69
130
statuses
70
131
71
132
let pp_checkout_status ppf = function
···
87
148
(** Compact status for actionable items with colors *)
88
149
let pp_compact ppf t =
89
150
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 ->
151
+
(* First check for local sync issues (monorepo <-> checkout) *)
152
+
let local_sync_info =
153
+
match t.subtree_sync with
154
+
| Subtree_behind n -> Some (Fmt.(styled `Blue (fun ppf n -> pf ppf "local:-%d" n)), n)
155
+
| Subtree_ahead n -> Some (Fmt.(styled `Blue (fun ppf n -> pf ppf "local:+%d" n)), n)
156
+
| In_sync | Unknown -> None
157
+
in
158
+
(* Then check for remote sync issues (checkout <-> upstream) *)
159
+
match (t.checkout, t.subtree, local_sync_info) with
160
+
(* Local sync issues take precedence when present *)
161
+
| Clean ab, Present, Some (fmt, n) when ab.ahead > 0 || ab.behind > 0 ->
162
+
(* Both local and remote sync needed *)
163
+
Fmt.pf ppf "%-22s %a %a" name fmt n
164
+
Fmt.(styled `Yellow (fun ppf (a, b) -> pf ppf "remote:+%d/-%d" a b)) (ab.ahead, ab.behind)
165
+
| Clean _, Present, Some (fmt, n) ->
166
+
(* Only local sync needed *)
167
+
Fmt.pf ppf "%-22s %a" name fmt n
168
+
(* Remote sync issues *)
169
+
| Clean ab, Present, None when ab.ahead > 0 && ab.behind > 0 ->
170
+
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Yellow (fun ppf (a,b) -> pf ppf "remote:+%d/-%d" a b)) (ab.ahead, ab.behind)
171
+
| Clean ab, Present, None when ab.ahead > 0 ->
172
+
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Cyan (fun ppf n -> pf ppf "remote:+%d" n)) ab.ahead
173
+
| Clean ab, Present, None when ab.behind > 0 ->
174
+
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red (fun ppf n -> pf ppf "remote:-%d" n)) ab.behind
175
+
(* Other issues *)
176
+
| Clean _, Not_added, _ ->
98
177
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Magenta string) "(no subtree)"
99
-
| Missing, _ ->
178
+
| Missing, _, _ ->
100
179
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(no checkout)"
101
-
| Not_a_repo, _ ->
180
+
| Not_a_repo, _, _ ->
102
181
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(not a repo)"
103
-
| Dirty, _ ->
182
+
| Dirty, _, _ ->
104
183
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Yellow string) "(dirty)"
105
-
| Clean _, Present ->
184
+
| Clean _, Present, None ->
106
185
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Green string) "ok"
107
186
108
187
let pp_summary ppf statuses =
···
110
189
let actionable = filter_actionable statuses in
111
190
let synced = List.filter is_fully_synced statuses |> List.length in
112
191
let dirty = List.filter has_local_changes statuses |> List.length in
192
+
let local_sync_needed = List.filter needs_local_sync statuses |> List.length in
193
+
let remote_needed = List.filter needs_remote_action statuses |> List.length in
113
194
let action_count = List.length actionable in
114
195
(* Header line with colors *)
115
196
if dirty > 0 then
···
117
198
Fmt.(styled `Bold string) "Packages:" total
118
199
Fmt.(styled `Green int) synced
119
200
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"
201
+
else if action_count > 0 then begin
202
+
Fmt.pf ppf "%a %d total, %a synced"
122
203
Fmt.(styled `Bold string) "Packages:" total
123
-
Fmt.(styled `Green int) synced
124
-
Fmt.(styled `Cyan int) action_count
204
+
Fmt.(styled `Green int) synced;
205
+
if local_sync_needed > 0 then
206
+
Fmt.pf ppf ", %a local sync" Fmt.(styled `Blue int) local_sync_needed;
207
+
if remote_needed > 0 then
208
+
Fmt.pf ppf ", %a remote" Fmt.(styled `Cyan int) remote_needed;
209
+
Fmt.pf ppf "\n"
210
+
end
125
211
else
126
212
Fmt.pf ppf "%a %d total, %a\n"
127
213
Fmt.(styled `Bold string) "Packages:" total
+20
monopam/lib/status.mli
+20
monopam/lib/status.mli
···
18
18
| Not_added (** Subtree has not been added to monorepo *)
19
19
| Present (** Subtree exists in monorepo *)
20
20
21
+
(** Sync state between monorepo subtree and local checkout.
22
+
This distinguishes issues fixable with [monopam sync] from those
23
+
requiring network access. *)
24
+
type subtree_sync =
25
+
| In_sync (** Subtree matches checkout HEAD *)
26
+
| Subtree_behind of int
27
+
(** Subtree needs pull from checkout (checkout has n new commits) *)
28
+
| Subtree_ahead of int
29
+
(** Subtree has n commits not in checkout (need push to checkout) *)
30
+
| Unknown (** Can't determine (subtree not added or checkout missing) *)
31
+
21
32
type t = {
22
33
package : Package.t;
23
34
checkout : checkout_status;
24
35
subtree : subtree_status;
36
+
subtree_sync : subtree_sync; (** Sync state between monorepo and checkout *)
25
37
}
26
38
(** Combined status for a package. *)
27
39
···
69
81
70
82
val needs_push : t -> bool
71
83
(** [needs_push t] returns true if the checkout is ahead of the remote. *)
84
+
85
+
val needs_local_sync : t -> bool
86
+
(** [needs_local_sync t] returns true if the monorepo subtree is out of sync
87
+
with the local checkout. This can be fixed with [monopam sync]. *)
88
+
89
+
val needs_remote_action : t -> bool
90
+
(** [needs_remote_action t] returns true if the checkout is ahead of or behind
91
+
the remote. This requires network access to fix. *)
72
92
73
93
val is_fully_synced : t -> bool
74
94
(** [is_fully_synced t] returns true if the package is fully in sync across all