forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
progress: modernize API with functional core and improved rendering
ocaml-tty:
- Add functional API (state, config, render) for pure state management
- Smooth gradient bar using partial block characters (▏▎▍▌▋▊▉█)
- ANSI color support (cyan spinner, green bar, dim counter)
- Add phase support for multi-step operations
- Add reset function to reuse progress bars across phases
- Make total required (no more indeterminate spinner mode)
monopam:
- Consolidate push into single progress bar for both phases
- Remove interleaved status messages (all printed at end)
- Use update() for cleaner progress loop
+51
-61
+51
-61
lib/monopam.ml
+51
-61
lib/monopam.ml
···
1101
1101
else begin
1102
1102
let repos = unique_repos pkgs in
1103
1103
Log.info (fun m -> m "Pushing %d unique repos" (List.length repos));
1104
-
let total = List.length repos in
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
1105
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
1114
+
in
1115
+
(* Phase 1: Subtree pushes (sequential due to git constraints) *)
1106
1116
let rec loop pushed_repos = function
1107
1117
| [] -> Ok (List.rev pushed_repos)
1108
1118
| pkg :: rest -> (
1109
1119
let name = Package.subtree_prefix pkg in
1110
-
Tty.Progress.message progress
1111
-
(Fmt.str "Push: %s (%d/%d)" name
1112
-
(List.length pushed_repos + 1)
1113
-
total);
1120
+
update_progress "Export" name;
1114
1121
Log.info (fun m -> m "Subtree push %s" name);
1115
1122
match push_one ~proc ~fs ~config ~clean pkg with
1116
-
| Ok () ->
1117
-
Tty.Progress.tick progress;
1118
-
loop (pkg :: pushed_repos) rest
1123
+
| Ok () -> loop (pkg :: pushed_repos) rest
1119
1124
| Error e ->
1120
1125
Tty.Progress.clear progress;
1121
1126
Error e)
1122
1127
in
1123
1128
match loop [] repos with
1124
1129
| Error e -> Error e
1125
-
| Ok pushed_repos ->
1126
-
Tty.Progress.clear progress;
1127
-
List.iter
1128
-
(fun pkg ->
1129
-
Log.app (fun m -> m " ✓ %s" (Package.subtree_prefix pkg)))
1130
-
pushed_repos;
1131
-
if upstream && pushed_repos <> [] then begin
1132
-
Log.info (fun m ->
1133
-
m "Pushing %d repos to upstream (parallel)"
1134
-
(List.length pushed_repos));
1135
-
let checkouts_root = Config.Paths.checkouts config in
1136
-
let remote_total = List.length pushed_repos in
1137
-
let remote_progress =
1138
-
Tty.Progress.create ~total:remote_total "Push remote"
1139
-
in
1140
-
let completed = Atomic.make 0 in
1141
-
(* Push to remotes in parallel, limited to 2 concurrent pushes *)
1142
-
let push_results =
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
1143
1138
Eio.Fiber.List.map ~max_fibers:2
1144
1139
(fun pkg ->
1145
1140
let checkout_dir =
1146
1141
Package.checkout_dir ~checkouts_root pkg
1147
1142
in
1143
+
let name = Package.repo_name pkg in
1144
+
update_progress "Push" name;
1148
1145
let branch = branch ~config pkg in
1149
1146
let push_url = url_to_push_url (Package.dev_repo pkg) in
1150
-
let n = Atomic.fetch_and_add completed 1 + 1 in
1151
-
Tty.Progress.message remote_progress
1152
-
(Fmt.str "Push: %s (%d/%d)" (Package.repo_name pkg) n
1153
-
remote_total);
1154
-
Log.info (fun m ->
1155
-
m "Pushing %s to %s" (Package.repo_name pkg) push_url);
1156
-
(* Set the push URL for origin *)
1147
+
Log.info (fun m -> m "Pushing %s to %s" name push_url);
1157
1148
let repo =
1158
1149
Git.Repository.open_repo ~fs:fs_t checkout_dir
1159
1150
in
···
1164
1155
| Ok () -> ()
1165
1156
| Error (`Msg msg) ->
1166
1157
Log.warn (fun m -> m "Failed to set push URL: %s" msg));
1167
-
let result =
1158
+
match
1168
1159
Git_cli.push_remote ~proc ~fs:fs_t ~branch ~force
1169
1160
checkout_dir
1170
-
in
1171
-
Tty.Progress.tick remote_progress;
1172
-
match result with
1173
-
| Ok () -> Ok (Package.repo_name pkg)
1174
-
| Error e -> Error (Package.repo_name pkg, Git_error e))
1161
+
with
1162
+
| Ok () -> Ok name
1163
+
| Error e -> Error (name, Git_error e))
1175
1164
pushed_repos
1176
-
in
1177
-
Tty.Progress.clear remote_progress;
1178
-
let successes, failures =
1179
-
List.partition_map
1180
-
(function
1181
-
| Ok name -> Left name | Error (name, _) -> Right name)
1182
-
push_results
1183
-
in
1184
-
List.iter
1185
-
(fun name -> Log.app (fun m -> m " ✓ %s" name))
1186
-
successes;
1187
-
List.iter
1188
-
(fun name -> Log.app (fun m -> m " ✗ %s" name))
1189
-
failures;
1190
-
(* Return first error if any *)
1191
-
match List.find_opt Result.is_error push_results with
1192
-
| Some (Error (_, e)) -> Error e
1193
-
| _ ->
1194
-
(* Also push mono and opam-repo if they have remotes *)
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
1195
1187
push_workspace_repos ~proc ~fs:fs_t ~config ~force;
1196
-
Ok ()
1197
-
end
1198
-
else Ok ()
1188
+
Ok ())
1199
1189
end
1200
1190
end
1201
1191