forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
tty/monopam: improve progress bar and optimize push
Progress bar improvements:
- Fix terminal width detection to reject invalid values (COLUMNS=0)
- Add cursor hiding during updates for cleaner display
- Use time-based spinner (10 fps) instead of update-based
- Add \027[K (clear to end of line) for clean overwrites
- Add Plain style for testing without colors/spinner
- Add debug mode via TTY_PROGRESS_DEBUG env var
Monopam push optimizations:
- Skip repos that are already in sync (uses status info)
- Increase remote push parallelism from 2 to 8 fibers
- Early exit when nothing to push
+107
-85
+107
-85
lib/monopam.ml
+107
-85
lib/monopam.ml
···
1099
1099
in
1100
1100
if dirty <> [] then Error (Dirty_state dirty)
1101
1101
else begin
1102
-
let repos = unique_repos pkgs in
1103
-
Log.info (fun m -> m "Pushing %d unique repos" (List.length repos));
1104
-
let n_repos = List.length repos in
1105
-
(* Calculate total steps: subtree pushes + remote pushes (if upstream) *)
1106
-
let total = if upstream then n_repos * 2 else n_repos in
1107
-
let progress = Tty.Progress.create ~total "Push" in
1108
-
let completed = Atomic.make 0 in
1109
-
let update_progress phase name =
1110
-
let n = Atomic.fetch_and_add completed 1 + 1 in
1111
-
Tty.Progress.message progress
1112
-
(Fmt.str "%s: %s (%d/%d)" phase name n total);
1113
-
Tty.Progress.set progress n
1102
+
(* Build status lookup to check which repos need pushing *)
1103
+
let status_by_prefix =
1104
+
List.fold_left
1105
+
(fun acc s ->
1106
+
let prefix = Package.subtree_prefix s.Status.package in
1107
+
(prefix, s) :: acc)
1108
+
[] statuses
1114
1109
in
1115
-
(* Phase 1: Subtree pushes (sequential due to git constraints) *)
1116
-
let rec loop pushed_repos = function
1117
-
| [] -> Ok (List.rev pushed_repos)
1118
-
| pkg :: rest -> (
1119
-
let name = Package.subtree_prefix pkg in
1120
-
update_progress "Export" name;
1121
-
Log.info (fun m -> m "Subtree push %s" name);
1122
-
match push_one ~proc ~fs ~config ~clean pkg with
1123
-
| Ok () -> loop (pkg :: pushed_repos) rest
1124
-
| Error e ->
1125
-
Tty.Progress.clear progress;
1126
-
Error e)
1110
+
let needs_export pkg =
1111
+
let prefix = Package.subtree_prefix pkg in
1112
+
match List.assoc_opt prefix status_by_prefix with
1113
+
| Some s -> not (Status.is_fully_synced s)
1114
+
| None -> true (* conservative: push if no status *)
1127
1115
in
1128
-
match loop [] repos with
1129
-
| Error e -> Error e
1130
-
| Ok pushed_repos -> (
1131
-
(* Phase 2: Remote pushes (parallel) *)
1132
-
let push_results =
1133
-
if upstream && pushed_repos <> [] then begin
1134
-
Log.info (fun m ->
1135
-
m "Pushing %d repos to upstream (parallel)"
1136
-
(List.length pushed_repos));
1137
-
let checkouts_root = Config.Paths.checkouts config in
1138
-
Eio.Fiber.List.map ~max_fibers:2
1139
-
(fun pkg ->
1140
-
let checkout_dir =
1141
-
Package.checkout_dir ~checkouts_root pkg
1142
-
in
1143
-
let name = Package.repo_name pkg in
1144
-
update_progress "Push" name;
1145
-
let branch = branch ~config pkg in
1146
-
let push_url = url_to_push_url (Package.dev_repo pkg) in
1147
-
Log.info (fun m -> m "Pushing %s to %s" name push_url);
1148
-
let repo =
1149
-
Git.Repository.open_repo ~fs:fs_t checkout_dir
1150
-
in
1151
-
(match
1152
-
Git.Repository.set_push_url repo ~name:"origin"
1153
-
~url:push_url
1154
-
with
1155
-
| Ok () -> ()
1156
-
| Error (`Msg msg) ->
1157
-
Log.warn (fun m -> m "Failed to set push URL: %s" msg));
1158
-
match
1159
-
Git_cli.push_remote ~proc ~fs:fs_t ~branch ~force
1160
-
checkout_dir
1161
-
with
1162
-
| Ok () -> Ok name
1163
-
| Error e -> Error (name, Git_error e))
1164
-
pushed_repos
1165
-
end
1166
-
else List.map (fun p -> Ok (Package.repo_name p)) pushed_repos
1167
-
in
1168
-
Tty.Progress.clear progress;
1169
-
(* Print all results at the end *)
1170
-
let successes, failures =
1171
-
List.partition_map
1172
-
(function
1173
-
| Ok name -> Left name | Error (name, _) -> Right name)
1174
-
push_results
1175
-
in
1176
-
List.iter
1177
-
(fun name -> Log.app (fun m -> m " ✓ %s" name))
1178
-
successes;
1179
-
List.iter
1180
-
(fun name -> Log.app (fun m -> m " ✗ %s" name))
1181
-
failures;
1182
-
(* Return first error if any *)
1183
-
match List.find_opt Result.is_error push_results with
1184
-
| Some (Error (_, e)) -> Error e
1185
-
| _ ->
1186
-
if upstream then
1187
-
push_workspace_repos ~proc ~fs:fs_t ~config ~force;
1188
-
Ok ())
1116
+
let all_repos = unique_repos pkgs in
1117
+
(* Filter to only repos that need pushing *)
1118
+
let repos = List.filter needs_export all_repos in
1119
+
let skipped = List.length all_repos - List.length repos in
1120
+
if skipped > 0 then
1121
+
Log.info (fun m -> m "Skipping %d already-synced repos" skipped);
1122
+
Log.info (fun m -> m "Pushing %d unique repos" (List.length repos));
1123
+
let n_repos = List.length repos in
1124
+
if n_repos = 0 then begin
1125
+
Log.app (fun m -> m "Nothing to push (all repos in sync)");
1126
+
Ok ()
1127
+
end
1128
+
else begin
1129
+
(* Calculate total steps: subtree pushes + remote pushes (if upstream) *)
1130
+
let total = if upstream then n_repos * 2 else n_repos in
1131
+
let progress = Tty.Progress.create ~total "Push" in
1132
+
let update_progress phase name =
1133
+
Tty.Progress.update progress ~phase ~msg:name
1134
+
in
1135
+
(* Phase 1: Subtree pushes (sequential due to git constraints) *)
1136
+
let rec loop pushed_repos = function
1137
+
| [] -> Ok (List.rev pushed_repos)
1138
+
| pkg :: rest -> (
1139
+
let name = Package.subtree_prefix pkg in
1140
+
update_progress "Export" name;
1141
+
Log.debug (fun m -> m "Subtree push %s" name);
1142
+
match push_one ~proc ~fs ~config ~clean pkg with
1143
+
| Ok () -> loop (pkg :: pushed_repos) rest
1144
+
| Error e ->
1145
+
Tty.Progress.clear progress;
1146
+
Error e)
1147
+
in
1148
+
match loop [] repos with
1149
+
| Error e -> Error e
1150
+
| Ok pushed_repos -> (
1151
+
(* Phase 2: Remote pushes (parallel) *)
1152
+
let push_results =
1153
+
if upstream && pushed_repos <> [] then begin
1154
+
Log.info (fun m ->
1155
+
m "Pushing %d repos to upstream (parallel)"
1156
+
(List.length pushed_repos));
1157
+
let checkouts_root = Config.Paths.checkouts config in
1158
+
Eio.Fiber.List.map ~max_fibers:8
1159
+
(fun pkg ->
1160
+
let checkout_dir =
1161
+
Package.checkout_dir ~checkouts_root pkg
1162
+
in
1163
+
let name = Package.repo_name pkg in
1164
+
update_progress "Push" name;
1165
+
let branch = branch ~config pkg in
1166
+
let push_url = url_to_push_url (Package.dev_repo pkg) in
1167
+
Log.info (fun m -> m "Pushing %s to %s" name push_url);
1168
+
let repo =
1169
+
Git.Repository.open_repo ~fs:fs_t checkout_dir
1170
+
in
1171
+
(match
1172
+
Git.Repository.set_push_url repo ~name:"origin"
1173
+
~url:push_url
1174
+
with
1175
+
| Ok () -> ()
1176
+
| Error (`Msg msg) ->
1177
+
Log.warn (fun m ->
1178
+
m "Failed to set push URL: %s" msg));
1179
+
match
1180
+
Git_cli.push_remote ~proc ~fs:fs_t ~branch ~force
1181
+
checkout_dir
1182
+
with
1183
+
| Ok () -> Ok name
1184
+
| Error e -> Error (name, Git_error e))
1185
+
pushed_repos
1186
+
end
1187
+
else List.map (fun p -> Ok (Package.repo_name p)) pushed_repos
1188
+
in
1189
+
Tty.Progress.clear progress;
1190
+
(* Print all results at the end *)
1191
+
let successes, failures =
1192
+
List.partition_map
1193
+
(function
1194
+
| Ok name -> Left name | Error (name, _) -> Right name)
1195
+
push_results
1196
+
in
1197
+
List.iter
1198
+
(fun name -> Log.app (fun m -> m " ✓ %s" name))
1199
+
successes;
1200
+
List.iter
1201
+
(fun name -> Log.app (fun m -> m " ✗ %s" name))
1202
+
failures;
1203
+
(* Return first error if any *)
1204
+
match List.find_opt Result.is_error push_results with
1205
+
| Some (Error (_, e)) -> Error e
1206
+
| _ ->
1207
+
if upstream then
1208
+
push_workspace_repos ~proc ~fs:fs_t ~config ~force;
1209
+
Ok ())
1210
+
end
1189
1211
end
1190
1212
end
1191
1213