forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
tty: fix progress bar rendering on narrow terminals
Root cause: terminal_width() returned 80 (fallback) instead of the
actual width because tput/COLUMNS were unreliable. An 80-char progress
line on a 71-column terminal wraps, and \r only returns to the start
of the wrapped portion — each update appears on a new line.
Fix: use ioctl TIOCGWINSZ via C stub for reliable width detection.
Also: all progress output now goes through Format.pp (no split between
Format and output_string stdout), matching CraigFe's progress library
pattern. Tests use Format.str_formatter + flush_str_formatter.
Additional fixes:
- Progress.suspend: clear bar, run function, redraw (for interleaving)
- Progress.logs_reporter: wraps Logs reporter to auto-suspend progress
- Vlog wires up logs_reporter so Log.app doesn't break the progress bar
- Progress.message/set_phase no longer render (batch until next tick)
+123
-118
+6
-8
lib/opam_sync.ml
+6
-8
lib/opam_sync.ml
···
151
151
let total = List.length pkgs in
152
152
let progress = Tty.Progress.v ~total label in
153
153
let sync_results =
154
-
List.mapi
155
-
(fun i pkg ->
156
-
Tty.Progress.message progress (Pkg.name pkg);
157
-
Tty.Progress.set progress (i + 1);
154
+
List.map
155
+
(fun pkg ->
156
+
Tty.Progress.update progress ~phase:"" ~msg:(Pkg.name pkg);
158
157
sync_package ~sw ~fs ~opam_repo pkg)
159
158
pkgs
160
159
in
···
435
434
let total = List.length pkgs in
436
435
let progress = Tty.Progress.v ~total "Export" in
437
436
let sync_results =
438
-
List.mapi
439
-
(fun i pkg ->
440
-
Tty.Progress.message progress (Pkg.name pkg);
441
-
Tty.Progress.set progress (i + 1);
437
+
List.map
438
+
(fun pkg ->
439
+
Tty.Progress.update progress ~phase:"" ~msg:(Pkg.name pkg);
442
440
sync_package_to ~sw ~fs ~opam_repo:target ~dry_run pkg)
443
441
pkgs
444
442
in
+6
-8
lib/progress.ml
+6
-8
lib/progress.ml
···
12
12
phase_name : string;
13
13
}
14
14
15
-
let v ~total phase_name =
15
+
let v ?ppf ?enabled ~total phase_name =
16
16
let msg = Fmt.str "%s (0/%d)" phase_name total in
17
-
let progress = Tty.Progress.v ~total msg in
17
+
let progress = Tty.Progress.v ?ppf ?enabled ~total msg in
18
18
{ progress; completed = Atomic.make 0; total; phase_name }
19
19
20
20
let tick t name =
21
-
let n = Atomic.fetch_and_add t.completed 1 + 1 in
22
-
let msg = Fmt.str "%s: %s (%d/%d)" t.phase_name name n t.total in
23
-
Tty.Progress.message t.progress msg;
24
-
Tty.Progress.set t.progress n
21
+
let _n = Atomic.fetch_and_add t.completed 1 + 1 in
22
+
Tty.Progress.update t.progress ~phase:t.phase_name ~msg:name
25
23
26
24
let clear t = Tty.Progress.clear t.progress
27
25
let finish t = Tty.Progress.finish t.progress
···
30
28
module type S = sig
31
29
type t
32
30
33
-
val v : total:int -> string -> t
31
+
val v : ?ppf:Format.formatter -> ?enabled:bool -> total:int -> string -> t
34
32
val tick : t -> string -> unit
35
33
val clear : t -> unit
36
34
val finish : t -> unit
···
50
48
module Disabled : S with type t = unit = struct
51
49
type t = unit
52
50
53
-
let v ~total:_ _ = ()
51
+
let v ?ppf:_ ?enabled:_ ~total:_ _ = ()
54
52
let tick () _ = ()
55
53
let clear () = ()
56
54
let finish () = ()
+4
-3
lib/progress.mli
+4
-3
lib/progress.mli
···
31
31
type t
32
32
(** Progress state for a sync phase. *)
33
33
34
-
val v : total:int -> string -> t
34
+
val v : ?ppf:Format.formatter -> ?enabled:bool -> total:int -> string -> t
35
35
(** [v ~total phase_name] creates progress for a phase with [total] items. Shows
36
-
as "[phase_name] (0/[total])" initially. *)
36
+
as "[phase_name] (0/[total])" initially. Pass [~ppf] and [~enabled:true] to
37
+
redirect output to a buffer for testing. *)
37
38
38
39
val tick : t -> string -> unit
39
40
(** [tick t name] increments progress and updates message to show [name]. *)
···
51
52
module type S = sig
52
53
type t
53
54
54
-
val v : total:int -> string -> t
55
+
val v : ?ppf:Format.formatter -> ?enabled:bool -> total:int -> string -> t
55
56
(** Create progress for a phase with the given total item count. *)
56
57
57
58
val tick : t -> string -> unit
+4
-15
lib/pull.ml
+4
-15
lib/pull.ml
···
217
217
Ok (List.rev acc)
218
218
| pkg :: rest -> (
219
219
let repo_name = Package.repo_name pkg in
220
-
Tty.Progress.message progress
221
-
(Fmt.str "Fetch: %s (%d/%d)" repo_name (List.length acc + 1) total);
222
220
Log.info (fun m -> m "Fetching repo %s" repo_name);
223
221
let existed = Ctx.checkout_exists ~fs ~config pkg in
224
-
(* Snapshot HEAD before ensure_checkout runs fetch+merge_ff. The
225
-
previous approach called [Ctx.behind] here, which reads the
226
-
local [origin/<branch>] tracking ref — stale on the first pull
227
-
after a push because [push] doesn't update that ref. Counting
228
-
after-vs-before HEADs always reflects what pull actually did. *)
229
222
let head_before =
230
223
if existed then checkout_head ~sw ~fs ~config pkg else None
231
224
in
···
234
227
Tty.Progress.clear progress;
235
228
Error (Ctx.Git_error e)
236
229
| Ok () ->
237
-
Tty.Progress.tick progress;
230
+
Tty.Progress.update progress ~phase:"Fetch" ~msg:repo_name;
238
231
let commits_pulled =
239
232
match (head_before, checkout_head ~sw ~fs ~config pkg) with
240
233
| Some before, Some after when not (Git.Hash.equal before after)
···
268
261
Ok (List.rev results_acc)
269
262
| pkg :: rest_repos, cr :: rest_cr -> (
270
263
let name = Package.subtree_prefix pkg in
271
-
Tty.Progress.message progress
272
-
(Fmt.str "Subtree: %s (%d/%d)" name
273
-
(List.length results_acc + 1)
274
-
total);
275
264
Log.info (fun m -> m "Subtree %s" name);
276
265
match subtree ~sw ~proc ~fs ~config ?sources pkg with
277
266
| Ok Skipped ->
278
-
Tty.Progress.tick progress;
267
+
Tty.Progress.update progress ~phase:"Subtree" ~msg:name;
279
268
loop (cr :: results_acc) rest_repos rest_cr
280
269
| Ok Merged ->
281
-
Tty.Progress.tick progress;
270
+
Tty.Progress.update progress ~phase:"Subtree" ~msg:name;
282
271
let result = { cr with conflicts = [] } in
283
272
loop (result :: results_acc) rest_repos rest_cr
284
273
| Ok (Conflict conflicts) ->
285
-
Tty.Progress.tick progress;
274
+
Tty.Progress.update progress ~phase:"Subtree" ~msg:name;
286
275
let result = { cr with conflicts } in
287
276
loop (result :: results_acc) rest_repos rest_cr
288
277
| Error e ->
+7
-9
lib/sync_progress.ml
+7
-9
lib/sync_progress.ml
···
12
12
phase_name : string;
13
13
}
14
14
15
-
let v ~total phase_name =
15
+
let v ?ppf ?enabled ~total phase_name =
16
16
let msg = Fmt.str "%s (0/%d)" phase_name total in
17
-
let progress = Tty.Progress.v ~total msg in
17
+
let progress = Tty.Progress.v ?ppf ?enabled ~total msg in
18
18
{ progress; completed = Atomic.make 0; total; phase_name }
19
19
20
20
let tick t name =
21
-
let n = Atomic.fetch_and_add t.completed 1 + 1 in
22
-
let msg = Fmt.str "%s: %s (%d/%d)" t.phase_name name n t.total in
23
-
Tty.Progress.message t.progress msg;
24
-
Tty.Progress.set t.progress n
21
+
let _n = Atomic.fetch_and_add t.completed 1 + 1 in
22
+
Tty.Progress.update t.progress ~phase:t.phase_name ~msg:name
25
23
26
24
let clear t = Tty.Progress.clear t.progress
27
25
let finish t = Tty.Progress.finish t.progress
···
30
28
module type S = sig
31
29
type t
32
30
33
-
val create : total:int -> string -> t
31
+
val v : ?ppf:Format.formatter -> ?enabled:bool -> total:int -> string -> t
34
32
val tick : t -> string -> unit
35
33
val clear : t -> unit
36
34
val finish : t -> unit
···
40
38
module Active : S with type t = t = struct
41
39
type nonrec t = t
42
40
43
-
let create = v
41
+
let v = v
44
42
let tick = tick
45
43
let clear = clear
46
44
let finish = finish
···
50
48
module Disabled : S with type t = unit = struct
51
49
type t = unit
52
50
53
-
let create ~total:_ _ = ()
51
+
let v ?ppf:_ ?enabled:_ ~total:_ _ = ()
54
52
let tick () _ = ()
55
53
let clear () = ()
56
54
let finish () = ()
+4
-5
lib/sync_progress.mli
+4
-5
lib/sync_progress.mli
···
23
23
(val if show_progress then (module Sync_progress.Active)
24
24
else (module Sync_progress.Disabled) : Sync_progress.S)
25
25
in
26
-
let p = P.create ~total "Fetching" in
26
+
let p = P.v ~total "Fetching" in
27
27
...;
28
28
P.finish p
29
29
]} *)
···
31
31
type t
32
32
(** Progress state for a sync phase. *)
33
33
34
-
val v : total:int -> string -> t
35
-
(** [v ~total phase_name] creates progress for a phase with [total] items. Shows
36
-
as "[phase_name] (0/[total])" initially. *)
34
+
val v : ?ppf:Format.formatter -> ?enabled:bool -> total:int -> string -> t
35
+
(** [v ~total phase_name] creates progress for a phase with [total] items. *)
37
36
38
37
val tick : t -> string -> unit
39
38
(** [tick t name] increments progress and updates message to show [name]. *)
···
51
50
module type S = sig
52
51
type t
53
52
54
-
val create : total:int -> string -> t
53
+
val v : ?ppf:Format.formatter -> ?enabled:bool -> total:int -> string -> t
55
54
(** Create progress for a phase with the given total item count. *)
56
55
57
56
val tick : t -> string -> unit
+6
-1
test/dune
+6
-1
test/dune
+27
test/progress_output.t/run.t
+27
test/progress_output.t/run.t
···
1
+
Progress bar stays on one line (no interleaved output):
2
+
3
+
$ ../test_progress_stdout.exe clean
4
+
1 visible lines:
5
+
[100%] 5/5 Export: repo-5
6
+
7
+
Interleaving stdout writes without suspend breaks the display:
8
+
9
+
$ ../test_progress_stdout.exe broken
10
+
6 visible lines:
11
+
[ 20%] 1/5 Export: repo-1
12
+
[ 40%] 2/5 Export: repo-2
13
+
[ 60%] 3/5 Export: repo-3
14
+
[ 80%] 4/5 Export: repo-4
15
+
[100%] 5/5 Export: repo-5
16
+
[100%] 5/5 Export: repo-5
17
+
18
+
With suspend, log messages appear above and progress stays on the last line:
19
+
20
+
$ ../test_progress_stdout.exe fixed
21
+
6 visible lines:
22
+
* repo-1 (glob)
23
+
* repo-2 (glob)
24
+
* repo-3 (glob)
25
+
* repo-4 (glob)
26
+
* repo-5 (glob)
27
+
[100%] 5/5 Export: repo-5
+23
-39
test/test_progress.ml
+23
-39
test/test_progress.ml
···
1
-
(* Tests for progress module *)
2
-
3
-
(* Monopam.Progress = Sync_progress, whose S type uses `create` *)
1
+
(* Monopam.Progress = Sync_progress *)
4
2
module P = Monopam.Progress
5
3
6
-
(* {1 Disabled module tests} *)
4
+
let read_bar () = Format.flush_str_formatter () |> String.trim
7
5
8
-
let test_disabled_create () =
9
-
let p = P.Disabled.create ~total:10 "Test" in
10
-
ignore p
6
+
let contains s line =
7
+
String.length line > 0 && Re.(execp (compile (str s)) line)
11
8
12
-
let test_disabled_tick () =
13
-
let p = P.Disabled.create ~total:10 "Test" in
9
+
let test_disabled () =
10
+
let p = P.Disabled.v ~total:10 "Test" in
14
11
P.Disabled.tick p "item1";
15
-
P.Disabled.tick p "item2"
16
-
17
-
let test_disabled_clear () =
18
-
let p = P.Disabled.create ~total:10 "Test" in
19
-
P.Disabled.clear p
20
-
21
-
let test_disabled_finish () =
22
-
let p = P.Disabled.create ~total:10 "Test" in
12
+
P.Disabled.tick p "item2";
23
13
P.Disabled.finish p
24
14
25
-
(* {1 Active module basic tests} *)
26
-
27
-
let test_active_lifecycle () =
28
-
let p = P.Active.create ~total:3 "Testing" in
29
-
P.Active.tick p "step1";
30
-
P.Active.tick p "step2";
31
-
P.Active.clear p;
32
-
P.Active.finish p
33
-
34
-
(* {1 Top-level functions} *)
35
-
36
-
let test_v_and_finish () =
37
-
let p = P.v ~total:2 "TopLevel" in
38
-
P.tick p "a";
39
-
P.tick p "b";
40
-
P.finish p
15
+
let test_lifecycle () =
16
+
let p = P.v ~ppf:Format.str_formatter ~enabled:true ~total:3 "Phase" in
17
+
ignore (read_bar ());
18
+
P.tick p "first";
19
+
let output = read_bar () in
20
+
Alcotest.(check bool) "contains first" true (contains "first" output);
21
+
P.tick p "second";
22
+
let output = read_bar () in
23
+
Alcotest.(check bool) "contains second" true (contains "second" output);
24
+
P.tick p "third";
25
+
let output = read_bar () in
26
+
Alcotest.(check bool) "contains third" true (contains "third" output);
27
+
P.finish p;
28
+
ignore (read_bar ())
41
29
42
30
let suite =
43
31
( "progress",
44
32
[
45
-
Alcotest.test_case "disabled create" `Quick test_disabled_create;
46
-
Alcotest.test_case "disabled tick" `Quick test_disabled_tick;
47
-
Alcotest.test_case "disabled clear" `Quick test_disabled_clear;
48
-
Alcotest.test_case "disabled finish" `Quick test_disabled_finish;
49
-
Alcotest.test_case "active lifecycle" `Quick test_active_lifecycle;
50
-
Alcotest.test_case "v and finish" `Quick test_v_and_finish;
33
+
Alcotest.test_case "disabled" `Quick test_disabled;
34
+
Alcotest.test_case "lifecycle" `Quick test_lifecycle;
51
35
] )
+23
test/test_progress_stdout.ml
+23
test/test_progress_stdout.ml
···
1
+
(* Test progress + interleaved stdout writes. *)
2
+
3
+
let read_bar () = Format.flush_str_formatter () |> String.trim
4
+
5
+
let () =
6
+
let mode = if Array.length Sys.argv > 1 then Sys.argv.(1) else "clean" in
7
+
let bar =
8
+
Tty.Progress.v ~ppf:Format.str_formatter ~width:50 ~enabled:true
9
+
~style:`Plain ~total:5 "Push"
10
+
in
11
+
ignore (read_bar ());
12
+
for i = 1 to 5 do
13
+
Tty.Progress.update bar ~phase:"Export" ~msg:(Printf.sprintf "repo-%d" i);
14
+
ignore (read_bar ());
15
+
if mode = "broken" then
16
+
Format.fprintf Format.str_formatter " ✓ repo-%d\n%!" i
17
+
else if mode = "fixed" then
18
+
Tty.Progress.suspend (fun () ->
19
+
Format.fprintf Format.str_formatter " ✓ repo-%d\n%!" i)
20
+
done;
21
+
Tty.Progress.finish bar;
22
+
let final = read_bar () in
23
+
Printf.printf "final: %s\n" final
+13
-30
test/test_sync_progress.ml
+13
-30
test/test_sync_progress.ml
···
1
-
(* Tests for sync_progress module *)
2
-
3
1
(* Monopam.Progress = Sync_progress *)
4
2
module SP = Monopam.Progress
5
3
6
-
(* {1 Disabled module tests} *)
4
+
let read_bar () = Format.flush_str_formatter () |> String.trim
7
5
8
6
let test_disabled_lifecycle () =
9
-
let p = SP.Disabled.create ~total:5 "Syncing" in
7
+
let p = SP.Disabled.v ~total:5 "Syncing" in
10
8
SP.Disabled.tick p "repo1";
11
9
SP.Disabled.tick p "repo2";
12
10
SP.Disabled.clear p;
13
11
SP.Disabled.finish p
14
12
15
-
(* {1 Active module tests} *)
16
-
17
-
let test_active_zero_total () =
18
-
let p = SP.Active.create ~total:0 "Empty" in
19
-
SP.Active.finish p
20
-
21
-
let test_active_single_tick () =
22
-
let p = SP.Active.create ~total:1 "Single" in
23
-
SP.Active.tick p "only-item";
24
-
SP.Active.finish p
25
-
26
-
let test_active_multiple_ticks () =
27
-
let p = SP.Active.create ~total:3 "Multi" in
13
+
let test_active_lifecycle () =
14
+
let p =
15
+
SP.Active.v ~ppf:Format.str_formatter ~enabled:true ~total:3 "Multi"
16
+
in
17
+
ignore (read_bar ());
28
18
SP.Active.tick p "a";
19
+
ignore (read_bar ());
29
20
SP.Active.tick p "b";
21
+
ignore (read_bar ());
30
22
SP.Active.tick p "c";
31
-
SP.Active.finish p
32
-
33
-
let test_active_clear_then_finish () =
34
-
let p = SP.Active.create ~total:2 "ClearTest" in
35
-
SP.Active.tick p "item";
36
-
SP.Active.clear p;
37
-
SP.Active.finish p
23
+
ignore (read_bar ());
24
+
SP.Active.finish p;
25
+
ignore (read_bar ())
38
26
39
27
let suite =
40
28
( "sync_progress",
41
29
[
42
30
Alcotest.test_case "disabled lifecycle" `Quick test_disabled_lifecycle;
43
-
Alcotest.test_case "active zero total" `Quick test_active_zero_total;
44
-
Alcotest.test_case "active single tick" `Quick test_active_single_tick;
45
-
Alcotest.test_case "active multiple ticks" `Quick
46
-
test_active_multiple_ticks;
47
-
Alcotest.test_case "active clear+finish" `Quick
48
-
test_active_clear_then_finish;
31
+
Alcotest.test_case "active lifecycle" `Quick test_active_lifecycle;
49
32
] )