1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
open! Import
external unsafe_blit_string : string -> int -> bytes -> int -> int -> unit
= "caml_blit_string"
[@@noalloc]
(** Polyfill for pre-4.09.0 *)
type 'a t =
{ write : 'a -> into:bytes -> pos:int -> unit
; write_len : int
; width : int
; to_string : 'a -> string
; pp : 'a pp
}
let create ?width ?pp ~to_string ~string_len () =
let write x ~into ~pos =
unsafe_blit_string (to_string x) 0 into pos string_len
in
let width = match width with None -> string_len | Some width -> width in
let pp = match pp with None -> Fmt.of_to_string to_string | Some pp -> pp in
{ write; write_len = string_len; width; to_string; pp }
let integer (type a) ~width (module Integer : Integer.S with type t = a) : a t =
let to_string x =
let x = Integer.to_string x in
let x_len = String.length x in
let padding = width - x_len in
if padding < 0 then
Fmt.invalid_arg
"Progress.Printer.int: can't print integer %s within a width of %d" x
width;
if padding = 0 then x
else
let buf = Bytes.make width ' ' in
unsafe_blit_string x 0 buf padding x_len;
Bytes.unsafe_to_string buf
in
create ~string_len:width ~to_string ()
let int ~width = integer ~width (module Integer.Int)
let string ~width =
if width < 0 then failwith "Printer.string: negative print length";
let ellipsis_length = min 3 width in
let ellipsis = String.make ellipsis_length '.' in
let to_string s =
let printed_len = Terminal.guess_printed_width s in
let padding = width - printed_len in
if padding = 0 then s
else if padding > 0 then (
let len = String.length s in
let buf = Bytes.make (len + padding) ' ' in
unsafe_blit_string s 0 buf 0 len;
Bytes.unsafe_to_string buf)
else
let s = Terminal.truncate_to_width (width - ellipsis_length) s in
s ^ ellipsis
in
create ~string_len:width ~to_string ()
let to_pp { pp; _ } = pp
let using ~f { write; write_len; to_string; pp; width } =
let write x ~into ~pos = write (f x) ~into ~pos in
let pp = Fmt.using f pp in
let to_string x = to_string (f x) in
{ write; write_len; to_string; pp; width }
let to_line_printer { write; write_len; _ } =
Line_buffer.lift_write ~len:write_len ~write
let to_to_string { to_string; _ } = to_string
let print_width { width; _ } = width
module Internals = struct
let integer = integer
let to_line_printer = to_line_printer
end