├── .gitignore
├── .meta
└── example.gif
├── .ocamlformat
├── CHANGES.md
├── LICENSE
├── Makefile
├── README.md
├── docs
├── fonts
│ ├── JetBrainsMono-Regular.ttf
│ ├── JetBrainsMono-Regular.woff
│ ├── JetBrainsMono-Regular.woff2
│ ├── lato-v17-latin-700.woff2
│ ├── lato-v17-latin-italic.woff2
│ └── lato-v17-latin-regular.woff2
└── odoc.css
├── dune
├── dune-project
├── examples
├── bar_styles.ml
├── bar_styles.mli
├── cargo.ml
├── cargo.mli
├── download.ml
├── download.mli
├── dune
├── interject.ml
├── interject.mli
├── main.ml
├── main.mli
├── readme.ml
├── readme.mli
├── spinners.ml
├── spinners.mli
├── utils.ml
├── utils.mli
├── yarn.ml
└── yarn.mli
├── progress.opam
├── src
├── progress
│ ├── dune
│ ├── engine
│ │ ├── config.ml
│ │ ├── dune
│ │ ├── duration.ml
│ │ ├── duration.mli
│ │ ├── flow_meter.ml
│ │ ├── flow_meter.mli
│ │ ├── import.ml
│ │ ├── integer.ml
│ │ ├── line.ml
│ │ ├── line.mli
│ │ ├── line_buffer.ml
│ │ ├── line_buffer.mli
│ │ ├── line_intf.ml
│ │ ├── line_primitives.ml
│ │ ├── line_primitives.mli
│ │ ├── line_primitives_intf.ml
│ │ ├── multi.ml
│ │ ├── multi.mli
│ │ ├── multi_intf.ml
│ │ ├── platform.ml
│ │ ├── printer.ml
│ │ ├── printer.mli
│ │ ├── progress_engine.ml
│ │ ├── progress_engine.mli
│ │ ├── progress_engine_intf.ml
│ │ ├── renderer.ml
│ │ ├── renderer.mli
│ │ ├── renderer_intf.ml
│ │ ├── stdlib_ext.ml
│ │ ├── units.ml
│ │ └── units.mli
│ ├── progress.ml
│ ├── progress.mli
│ ├── terminal_width.ml
│ └── tests
│ │ ├── common.ml
│ │ ├── dune
│ │ ├── test.ml
│ │ ├── test.mli
│ │ ├── test_flow_meter.ml
│ │ ├── test_flow_meter.mli
│ │ ├── test_printers.ml
│ │ ├── test_printers.mli
│ │ ├── test_units.ml
│ │ └── test_units.mli
└── terminal
│ ├── ansi
│ ├── ansi.ml
│ ├── color.ml
│ ├── dune
│ ├── import.ml
│ ├── style.ml
│ ├── terminal_ansi.ml
│ └── terminal_ansi.mli
│ ├── dune
│ ├── terminal.ml
│ ├── terminal.mli
│ ├── terminal_stubs.c
│ └── tests
│ ├── common.ml
│ ├── dune
│ ├── test.ml
│ ├── test_colours.ml
│ ├── test_colours.mli
│ ├── test_width.ml
│ └── test_width.mli
└── terminal.opam
/.gitignore:
--------------------------------------------------------------------------------
1 | _build/
2 | _opam
3 | *~
4 | \.\#*
5 | \#*#
6 | *.install
7 | .merlin
8 |
--------------------------------------------------------------------------------
/.meta/example.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/craigfe/progress/d59f6eccd2317ff959a06afc6d53644eeecadf1e/.meta/example.gif
--------------------------------------------------------------------------------
/.ocamlformat:
--------------------------------------------------------------------------------
1 | version = 0.27.0
2 | profile = conventional
3 |
4 | parse-docstrings
5 | module-item-spacing = compact
6 | dock-collection-brackets = false
7 | break-infix = fit-or-vertical
8 | break-separators = before
9 |
--------------------------------------------------------------------------------
/CHANGES.md:
--------------------------------------------------------------------------------
1 | ### 0.4.0 (2024-20-05)
2 |
3 | - Revert the `terminal` API and keep an "happy" path to get size of a tty
4 | and be compatible with MirageOS (@art-w, @msprotz, #42, #43)
5 | - Use a `float` instead of a `int` in `flow_meter per-second` (@mbarbin, #23, #27)
6 |
7 | ### 0.3.0 (2024-04-13)
8 |
9 | - Be compatible with MirageOS and remove `ocaml_terminal_get_sigwinch` (@art-w, #38)
10 | - Clear all lines in `interject_with` (@Gbury, #30)
11 | - Add `Display.remove_line` (@mbarbin, #26)
12 | - Fix compilation for OCaml 5.2 (reported by @Gbury, fixed by @dinosaure, #40)
13 | - Add `Display.{pause,resume}` (@Gbury, #37)
14 |
15 | ### 0.2.2 (2023-05-26)
16 |
17 | - Fix lower bounds on UTF-8 libraries (@craigfe, 42759d5)
18 | - Fix removed functions in `mtime.2.0.0` (@patricoferris, #31)
19 | - Use actual printer width for elapsed segment (@lsdch, #28)
20 |
21 | ### 0.2.1 (2021-06-29)
22 |
23 | - Fix the count segment of `Progress.counter` (when `pp` is passed) to show the
24 | running total rather than the latest reported value. (#19; @CraigFe, report
25 | by @Ngoguey42)
26 | - Fix `Terminal` stubs on MacOS. (#13; @CraigFe, report by @Ngoguey42)
27 | - Fix package tests on Windows. `Progress` does not yet support the Windows and
28 | Cygwin terminals; this is tracked by #16. (#15; @emillon)
29 |
30 | ### 0.2.0 (2021-06-26)
31 |
32 | Major update of the API, including a number of new features:
33 |
34 | - Rename the `Segment` module to `Line`, and improve the set of primitives for
35 | progress bar construction significantly. This includes time-sensitive segments
36 | (e.g `bytes_per_sec`, `eta`) and padding segments (`lpad` and `rpad`).
37 | - Add `Progress.interject_with` for interleaving logging with rendering, and
38 | functions for using `Progress` with `Logs` reporters.
39 | - Add support for adding lines to an ongoing rendering process via `Display`.
40 | - Improve the behaviour of the rendering core: handle terminal width changes /
41 | respond to user input etc. more cleanly.
42 | - Add many more examples and general improvements to the documentation.
43 | - Extract terminal-specific utilities to a new `Terminal` package.
44 |
45 | Also contains a number of smaller fixes:
46 |
47 | - Fix the display of minutes and seconds of `Progress.Units.seconds` and
48 | `Progress_unix.counter`. (#6, @Ngoguey42)
49 | - Raise an exception when attempting to run separate render processes
50 | simultaneously. (#8, @CraigFe)
51 |
52 | ### 0.1.1 (2020-10-13)
53 |
54 | - Rename `Progress.with_display` to `Progress.with_reporters`. (#3, @CraigFe)
55 | - Change the default display mode of progress bars to `ASCII` rather than
56 | `UTF8`. (#2, @CraigFe)
57 | - Change `Segment.box_dynamic` to take a function rather than a reference. (#1,
58 | @CraigFe)
59 | - Fix a bug causing multi-line layouts to occasionally not adapt to terminal
60 | size changes. (#1, @CraigFe)
61 |
62 | ### 0.1.0 (2020-10-12)
63 |
64 | Initial release.
65 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | The MIT License
2 |
3 | Copyright (c) 2020 Craig Ferguson
4 |
5 | Permission is hereby granted, free of charge, to any person obtaining a copy
6 | of this software and associated documentation files (the "Software"), to deal
7 | in the Software without restriction, including without limitation the rights
8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9 | copies of the Software, and to permit persons to whom the Software is
10 | furnished to do so, subject to the following conditions:
11 |
12 | The above copyright notice and this permission notice shall be included in
13 | all copies or substantial portions of the Software.
14 |
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
21 | THE SOFTWARE.
22 |
--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
1 | screenshot:
2 | asciinema rec -c "dune exec examples/main.exe -- Stack" --overwrite /tmp/screenshot.json
3 | asciicast2gif -h 4 /tmp/screenshot.json .meta/example.gif
4 |
5 | .PHONY: docs
6 | docs:
7 | dune build @doc
8 | cp -fr docs/{odoc.css,fonts} _build/default/_doc/_html
9 |
10 | .PHONY: example
11 | example:
12 | @dune exec examples/main.exe -- $(name)
13 |
14 | .PHONY: examples
15 | examples:
16 | @for example in $(shell dune exec -- examples/main.exe --list); do \
17 | echo "*** $$example"; \
18 | dune exec -- examples/main.exe $$example; \
19 | done
20 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | Progress
2 | User-definable progress bars for OCaml
3 |
4 |
5 | 
6 |
7 |
8 | **Features**:
9 |
10 | - allows user-defined progress bar layouts;
11 | - supports rendering multiple progress bars simultaneously;
12 | - dynamically responds to changes in terminal size;
13 | - supports interleaving logging with progress bar rendering.
14 |
15 | The documentation is available [online][docs].
16 |
17 | [docs]: https://craigfe.github.io/progress/progress/index.html
18 |
19 |
20 |
21 | ### Installation
22 |
23 | `Progress` can be installed with `opam`:
24 |
25 | ```
26 | opam install progress
27 | ```
28 |
--------------------------------------------------------------------------------
/docs/fonts/JetBrainsMono-Regular.ttf:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/craigfe/progress/d59f6eccd2317ff959a06afc6d53644eeecadf1e/docs/fonts/JetBrainsMono-Regular.ttf
--------------------------------------------------------------------------------
/docs/fonts/JetBrainsMono-Regular.woff:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/craigfe/progress/d59f6eccd2317ff959a06afc6d53644eeecadf1e/docs/fonts/JetBrainsMono-Regular.woff
--------------------------------------------------------------------------------
/docs/fonts/JetBrainsMono-Regular.woff2:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/craigfe/progress/d59f6eccd2317ff959a06afc6d53644eeecadf1e/docs/fonts/JetBrainsMono-Regular.woff2
--------------------------------------------------------------------------------
/docs/fonts/lato-v17-latin-700.woff2:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/craigfe/progress/d59f6eccd2317ff959a06afc6d53644eeecadf1e/docs/fonts/lato-v17-latin-700.woff2
--------------------------------------------------------------------------------
/docs/fonts/lato-v17-latin-italic.woff2:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/craigfe/progress/d59f6eccd2317ff959a06afc6d53644eeecadf1e/docs/fonts/lato-v17-latin-italic.woff2
--------------------------------------------------------------------------------
/docs/fonts/lato-v17-latin-regular.woff2:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/craigfe/progress/d59f6eccd2317ff959a06afc6d53644eeecadf1e/docs/fonts/lato-v17-latin-regular.woff2
--------------------------------------------------------------------------------
/docs/odoc.css:
--------------------------------------------------------------------------------
1 | @charset "UTF-8";
2 | /* Copyright (c) 2016 The odoc contributors. All rights reserved.
3 | Distributed under the ISC license, see terms at the end of the file.
4 | %%NAME%% %%VERSION%% */
5 |
6 | /* Fonts */
7 |
8 | @font-face {
9 | font-family: "JetBrainsMono";
10 | src: url("./fonts/JetBrainsMono-Regular.woff2") format("woff2"),
11 | url("./fonts/JetBrainsMono-Regular.woff") format("woff");
12 |
13 | font-weight: normal;
14 | font-style: normal;
15 | }
16 |
17 | @import url("https://rsms.me/inter/inter.css");
18 |
19 | @font-face {
20 | font-family: "Lato";
21 | font-style: normal;
22 | font-weight: 400;
23 | src: url("./fonts/lato-v17-latin-regular.woff2") format("woff2");
24 | }
25 |
26 | @font-face {
27 | font-family: "Lato";
28 | font-style: normal;
29 | font-weight: 700;
30 | src: url("./fonts/lato-v17-latin-700.woff2") format("woff2");
31 | }
32 |
33 | @font-face {
34 | font-family: "Lato";
35 | font-style: italic;
36 | font-weight: 400;
37 | src: url("./fonts/lato-v17-latin-italic.woff2") format("woff2");
38 | }
39 |
40 | @import url("https://fonts.googleapis.com/css?family=Noticia+Text:400,400i,700");
41 | @import url("https://fonts.googleapis.com/css?family=Fira+Sans:400,400i,500,500i,600,600i,700,700i");
42 |
43 | :root {
44 | --font-code: JetBrainsMono, courier;
45 | --font: Lato, -apple-system, BlinkMacSystemFont, Segoe UI, Roboto, Oxygen,
46 | Ubuntu, Cantarell, Open Sans, Helvetica Neue, Helvetica, Arial, sans-serif;
47 |
48 | --font-heading: Inter, -apple-system, BlinkMacSystemFont, Segoe UI, Roboto,
49 | Oxygen, Ubuntu, Cantarell, Open Sans, Helvetica Neue, Helvetica, Arial,
50 | sans-serif;
51 |
52 | --link-color: #3d8fd1;
53 | --anchor-hover: #555;
54 | --anchor-color: #d5d5d5;
55 | --xref-shadow: #cc6666;
56 | --header-shadow: #ddd;
57 | --by-name-version-color: #aaa;
58 | --by-name-nav-link-color: #222;
59 | --target-background: rgba(187, 239, 253, 0.3);
60 | --target-shadow: rgba(187, 239, 253, 0.8);
61 | --pre-border-color: #eee;
62 | --code-background: #f6f8fa;
63 | --spec-summary-border-color: #5c9cf5;
64 | --spec-summary-background: var(--code-background);
65 | --spec-summary-hover-background: #ebeff2;
66 | --spec-details-after-background: rgba(0, 4, 15, 0.05);
67 | --spec-details-after-shadow: rgba(204, 204, 204, 0.53);
68 | }
69 |
70 | /* Reset a few things. */
71 |
72 | html,
73 | body,
74 | div,
75 | span,
76 | applet,
77 | object,
78 | iframe,
79 | h1,
80 | h2,
81 | h3,
82 | h4,
83 | h5,
84 | h6,
85 | p,
86 | blockquote,
87 | pre,
88 | a,
89 | abbr,
90 | acronym,
91 | address,
92 | big,
93 | cite,
94 | code,
95 | del,
96 | dfn,
97 | em,
98 | img,
99 | ins,
100 | kbd,
101 | q,
102 | s,
103 | samp,
104 | small,
105 | strike,
106 | strong,
107 | sub,
108 | sup,
109 | tt,
110 | var,
111 | b,
112 | u,
113 | i,
114 | center,
115 | dl,
116 | dt,
117 | dd,
118 | ol,
119 | ul,
120 | li,
121 | fieldset,
122 | form,
123 | label,
124 | legend,
125 | table,
126 | caption,
127 | tbody,
128 | tfoot,
129 | thead,
130 | tr,
131 | th,
132 | td,
133 | article,
134 | aside,
135 | canvas,
136 | details,
137 | embed,
138 | figure,
139 | figcaption,
140 | footer,
141 | header,
142 | hgroup,
143 | menu,
144 | nav,
145 | output,
146 | ruby,
147 | section,
148 | summary,
149 | time,
150 | mark,
151 | audio,
152 | video {
153 | margin: 0;
154 | padding: 0;
155 | border: 0;
156 | font: inherit;
157 | vertical-align: baseline;
158 | }
159 |
160 | table {
161 | border-collapse: collapse;
162 | border-spacing: 0;
163 | }
164 |
165 | *,
166 | *:before,
167 | *:after {
168 | box-sizing: border-box;
169 | }
170 |
171 | html {
172 | font-size: 15px;
173 | }
174 |
175 | body {
176 | text-align: left;
177 | background: #ffffff;
178 | color: var(--color);
179 | background-color: var(--main-background);
180 | }
181 |
182 | body {
183 | max-width: 90ex;
184 | margin-left: calc(10vw + 20ex);
185 | margin-right: 4ex;
186 | margin-top: 20px;
187 | margin-bottom: 50px;
188 | font-family: var(--font);
189 | line-height: 1.5;
190 | }
191 |
192 | header {
193 | margin-bottom: 30px;
194 | }
195 |
196 | nav {
197 | font-family: var(--font);
198 | }
199 |
200 | /* Basic markup elements */
201 |
202 | b,
203 | strong {
204 | font-weight: bold;
205 | }
206 |
207 | i {
208 | font-style: italic;
209 | }
210 |
211 | em,
212 | i em.odd {
213 | font-style: italic;
214 | }
215 |
216 | em.odd,
217 | i em {
218 | font-style: normal;
219 | }
220 |
221 | sup {
222 | vertical-align: super;
223 | }
224 |
225 | sub {
226 | vertical-align: sub;
227 | }
228 |
229 | sup,
230 | sub {
231 | font-size: 12px;
232 | line-height: 0;
233 | margin-left: 0.2ex;
234 | }
235 |
236 | pre {
237 | margin-top: 0.8em;
238 | margin-bottom: 1.2em;
239 | }
240 |
241 | p,
242 | ul,
243 | ol {
244 | margin-top: 0.5em;
245 | margin-bottom: 1em;
246 | }
247 | ul,
248 | ol {
249 | list-style-position: outside;
250 | }
251 |
252 | ul > li {
253 | margin-left: 22px;
254 | }
255 |
256 | ol > li {
257 | margin-left: 27.2px;
258 | }
259 |
260 | li > *:first-child {
261 | margin-top: 0;
262 | }
263 |
264 | /* Text alignements, this should be forbidden. */
265 |
266 | .left {
267 | text-align: left;
268 | }
269 |
270 | .right {
271 | text-align: right;
272 | }
273 |
274 | .center {
275 | text-align: center;
276 | }
277 |
278 | /* Links and anchors */
279 |
280 | a {
281 | text-decoration: none;
282 | color: #2c5cbd;
283 | color: var(--link-color);
284 | }
285 |
286 | a:hover {
287 | box-shadow: 0 1px 0 0 #2c5cbd;
288 | box-shadow: 0 1px 0 0 var(--link-color);
289 | }
290 |
291 | /* Linked highlight */
292 | *:target {
293 | background-color: rgba(187, 239, 253, 0.3) !important;
294 | box-shadow: 0 0px 0 1px rgba(187, 239, 253, 0.8) !important;
295 | background-color: var(--target-background) !important;
296 | box-shadow: 0 0px 0 1px var(--target-shadow) !important;
297 | border-radius: 1px;
298 | }
299 |
300 | *:hover > a.anchor {
301 | visibility: visible;
302 | }
303 |
304 | a.anchor:before {
305 | content: "#";
306 | }
307 |
308 | a.anchor:hover {
309 | box-shadow: none;
310 | text-decoration: none;
311 | color: #555;
312 | color: var(--anchor-hover);
313 | }
314 |
315 | a.anchor {
316 | visibility: hidden;
317 | position: absolute;
318 | /* top: 0px; */
319 | /* margin-left: -3ex; */
320 | margin-left: -1.3em;
321 | font-weight: normal;
322 | font-style: normal;
323 | padding-right: 0.4em;
324 | padding-left: 0.4em;
325 | /* To remain selectable */
326 | color: #d5d5d5;
327 | color: var(--anchor-color);
328 | }
329 |
330 | .spec > a.anchor {
331 | margin-left: -2.3em;
332 | padding-right: 0.9em;
333 | }
334 |
335 | .xref-unresolved {
336 | color: #2c94bd;
337 | }
338 | .xref-unresolved:hover {
339 | box-shadow: 0 1px 0 0 #cc6666;
340 | box-shadow: 0 1px 0 0 var(--xref-shadow);
341 | }
342 |
343 | /* Section and document divisions.
344 | Until at least 4.03 many of the modules of the stdlib start at .h7,
345 | we restart the sequence there like h2 */
346 |
347 | h1,
348 | h2,
349 | h3,
350 | h4,
351 | h5,
352 | h6,
353 | .h7,
354 | .h8,
355 | .h9,
356 | .h10 {
357 | font-family: var(--font-heading);
358 | font-weight: 500;
359 | margin: 0.5em 0 0.5em 0;
360 | padding-top: 0.1em;
361 | line-height: 1.2;
362 | overflow-wrap: break-word;
363 | }
364 |
365 | h1,
366 | h2,
367 | h3,
368 | h4,
369 | h5,
370 | h6,
371 | .spec {
372 | scroll-margin-top: 50px;
373 | }
374 |
375 | h1 {
376 | font-weight: 500;
377 | font-size: 2.441em;
378 | margin-top: 1.214em;
379 | }
380 |
381 | h1 {
382 | font-weight: 500;
383 | font-size: 1.953em;
384 | box-shadow: 0 1px 0 0 #ddd;
385 | box-shadow: 0 1px 0 0 var(--header-shadow);
386 | }
387 |
388 | h2 {
389 | text-transform: uppercase;
390 | font-weight: 600;
391 | font-size: 1.263em;
392 | margin-top: 1.7em;
393 | margin-left: 0.5em;
394 | margin-bottom: 1em;
395 | }
396 |
397 | h3 {
398 | margin-top: 1.4em;
399 | font-size: 1.25em;
400 | }
401 |
402 | h4 {
403 | margin-top: 1em;
404 | margin-bottom: 0.7em;
405 | }
406 |
407 | small,
408 | .font_small {
409 | font-size: 0.8em;
410 | }
411 |
412 | h1 code,
413 | h1 tt {
414 | font-size: 95%;
415 | font-weight: inherit;
416 | }
417 |
418 | h2 code,
419 | h2 tt {
420 | font-size: 95%;
421 | font-weight: inherit;
422 | }
423 |
424 | h3 code,
425 | h3 tt {
426 | font-size: 95%;
427 | font-weight: inherit;
428 | }
429 |
430 | h4 {
431 | font-size: 1.12em;
432 | }
433 |
434 | .spec-doc {
435 | margin-bottom: 2em;
436 | }
437 |
438 | /* Comment delimiters, hidden but accessible to screen readers and
439 | selected for copy/pasting */
440 |
441 | /* Taken from bootstrap */
442 | /* See also https://stackoverflow.com/a/27769435/4220738 */
443 | .comment-delim {
444 | position: absolute;
445 | width: 1px;
446 | height: 1px;
447 | padding: 0;
448 | margin: -1px;
449 | overflow: hidden;
450 | clip: rect(0, 0, 0, 0);
451 | white-space: nowrap;
452 | border: 0;
453 | }
454 |
455 | /* Preformatted and code */
456 |
457 | tt,
458 | code,
459 | pre {
460 | font-family: var(--font-code);
461 | font-weight: 400;
462 | }
463 |
464 | pre {
465 | padding: 0.1em;
466 | border: 1px solid #eee;
467 | border: 1px solid var(--pre-border-color);
468 | border-radius: 5px;
469 | overflow-x: auto;
470 | }
471 |
472 | p code,
473 | li code {
474 | background-color: #f6f8fa;
475 | color: #0d2b3e;
476 | background-color: var(--li-code-background);
477 | color: var(--li-code-color);
478 | border-radius: 3px;
479 | padding: 0 0.3ex;
480 | }
481 |
482 | p a > code {
483 | color: #2c5cbd;
484 | color: var(--link-color);
485 | }
486 |
487 | /* Code blocks (e.g. Examples) */
488 |
489 | code {
490 | font-size: 0.893rem;
491 | }
492 |
493 | :not(pre):not(h1) > code {
494 | background: var(--code-background);
495 | border-radius: 2px;
496 | padding: 2px 4px;
497 | }
498 |
499 | /* Code lexemes */
500 |
501 | .keyword {
502 | font-weight: 500;
503 | }
504 |
505 | .arrow {
506 | white-space: nowrap;
507 | }
508 |
509 | /* Module member specification */
510 |
511 | .spec {
512 | background-color: var(--spec-summary-background);
513 | border-radius: 3px;
514 | border-left: 4px solid var(--spec-summary-border-color);
515 | border-right: 5px solid transparent;
516 | padding: 0.35em 0.5em;
517 | }
518 |
519 | div.spec,
520 | .def-doc {
521 | margin-bottom: 15px;
522 | }
523 |
524 | .spec.type .variant {
525 | margin-left: 2ch;
526 | }
527 | .spec.type .variant p {
528 | margin: 0;
529 | font-style: italic;
530 | }
531 | .spec.type .record {
532 | margin-left: 2ch;
533 | }
534 | .spec.type .record p {
535 | margin: 0;
536 | font-style: italic;
537 | }
538 |
539 | div.def {
540 | margin-top: 0;
541 | text-indent: -2ex;
542 | padding-left: 2ex;
543 | }
544 |
545 | div.def + div.def-doc {
546 | margin-left: 1ex;
547 | margin-top: 2.5px;
548 | }
549 |
550 | div.def-doc > *:first-child {
551 | margin-top: 0;
552 | }
553 |
554 | /* Collapsible inlined include and module */
555 |
556 | .odoc-include details {
557 | position: relative;
558 | }
559 |
560 | .odoc-include details:after {
561 | z-index: -100;
562 | display: block;
563 | content: " ";
564 | position: absolute;
565 | border-radius: 0 1ex 1ex 0;
566 | right: -20px;
567 | top: 1px;
568 | bottom: 1px;
569 | width: 15px;
570 | background: rgba(0, 4, 15, 0.05);
571 | box-shadow: 0 0px 0 1px rgba(204, 204, 204, 0.53);
572 | background: var(--spec-details-after-background);
573 | box-shadow: 0 0px 0 1px var(--spec-details-after-shadow);
574 | }
575 |
576 | .odoc-include summary {
577 | position: relative;
578 | margin-bottom: 20px;
579 | cursor: pointer;
580 | outline: none;
581 | }
582 |
583 | .odoc-include summary:hover {
584 | background-color: var(--spec-summary-hover-background);
585 | }
586 |
587 | /* FIXME: Does not work in Firefox. */
588 | .odoc-include summary::-webkit-details-marker {
589 | color: #888;
590 | transform: scaleX(-1);
591 | position: absolute;
592 | top: calc(50% - 5px);
593 | height: 11px;
594 | right: -29px;
595 | }
596 |
597 | /* Records and variants FIXME */
598 |
599 | div.def table {
600 | text-indent: 0em;
601 | padding: 0;
602 | margin-left: -2ex;
603 | }
604 |
605 | td.def {
606 | padding-left: 2ex;
607 | }
608 |
609 | td.def-doc *:first-child {
610 | margin-top: 0em;
611 | }
612 |
613 | /* Lists of @tags */
614 |
615 | .at-tags {
616 | list-style-type: none;
617 | margin-left: -3ex;
618 | }
619 | .at-tags li {
620 | padding-left: 3ex;
621 | text-indent: -3ex;
622 | }
623 | .at-tags .at-tag {
624 | text-transform: capitalize;
625 | }
626 |
627 | /* Lists of modules */
628 |
629 | .modules {
630 | list-style-type: none;
631 | margin-left: -3ex;
632 | }
633 | .modules li {
634 | padding-left: 3ex;
635 | text-indent: -3ex;
636 | margin-top: 5px;
637 | }
638 | .modules .synopsis {
639 | padding-left: 1ch;
640 | }
641 |
642 | /* Odig package index */
643 |
644 | .packages {
645 | list-style-type: none;
646 | margin-left: -3ex;
647 | }
648 | .packages li {
649 | padding-left: 3ex;
650 | text-indent: -3ex;
651 | }
652 | .packages li a.anchor {
653 | padding-right: 0.5ch;
654 | padding-left: 3ch;
655 | }
656 | .packages .version {
657 | font-size: 10px;
658 | color: var(--by-name-version-color);
659 | }
660 | .packages .synopsis {
661 | padding-left: 1ch;
662 | }
663 |
664 | .by-name nav a {
665 | text-transform: uppercase;
666 | font-size: 18px;
667 | margin-right: 1ex;
668 | color: #222;
669 | color: var(--by-name-nav-link-color);
670 | display: inline-block;
671 | }
672 |
673 | .by-tag nav a {
674 | margin-right: 1ex;
675 | color: #222;
676 | color: var(--by-name-nav-link-color);
677 | display: inline-block;
678 | }
679 |
680 | .by-tag ol {
681 | list-style-type: none;
682 | }
683 | .by-tag ol.tags li {
684 | margin-left: 1ch;
685 | display: inline-block;
686 | }
687 | .by-tag td:first-child {
688 | text-transform: uppercase;
689 | }
690 |
691 | /* Odig package page */
692 |
693 | .package nav {
694 | display: inline;
695 | font-size: 14px;
696 | font-weight: normal;
697 | }
698 |
699 | .package .version {
700 | font-size: 14px;
701 | }
702 |
703 | .package.info {
704 | margin: 0;
705 | }
706 |
707 | .package.info td:first-child {
708 | font-style: italic;
709 | padding-right: 2ex;
710 | }
711 |
712 | .package.info ul {
713 | list-style-type: none;
714 | display: inline;
715 | margin: 0;
716 | }
717 |
718 | .package.info li {
719 | display: inline-block;
720 | margin: 0;
721 | margin-right: 1ex;
722 | }
723 |
724 | #info-authors li,
725 | #info-maintainers li {
726 | display: block;
727 | }
728 |
729 | /* Sidebar and TOC */
730 |
731 | .odoc-toc:before {
732 | display: block;
733 | content: "Contents";
734 | text-transform: uppercase;
735 | font-size: 1.1em;
736 | margin: 1.414em 0 0.5em;
737 | font-weight: 800;
738 | color: #777;
739 | color: var(--toc-before-color);
740 | line-height: 1.2;
741 | }
742 |
743 | .odoc-toc {
744 | position: fixed;
745 | top: 0px;
746 | bottom: 0px;
747 | left: 0px;
748 | max-width: 30ex;
749 | min-width: 26ex;
750 | width: 20%;
751 | background: #f6f8fa;
752 | background: var(--toc-background);
753 | overflow: auto;
754 | color: #1f2d3d;
755 | color: var(--toc-color);
756 | padding-left: 2ex;
757 | padding-right: 2ex;
758 | }
759 |
760 | .odoc-toc ul li a {
761 | font-family: "Fira Sans", sans-serif;
762 | font-size: 0.95em;
763 | color: #333;
764 | color: var(--color);
765 | font-weight: 400;
766 | line-height: 1.6em;
767 | display: block;
768 | }
769 |
770 | .odoc-toc ul li a:hover {
771 | box-shadow: none;
772 | text-decoration: underline;
773 | }
774 |
775 | /* First level titles */
776 |
777 | .odoc-toc > ul > li > a {
778 | font-weight: 500;
779 | }
780 |
781 | .odoc-toc li ul {
782 | margin: 0px;
783 | }
784 |
785 | .odoc-toc ul {
786 | list-style-type: none;
787 | }
788 |
789 | .odoc-toc ul li {
790 | margin: 0;
791 | }
792 | .odoc-toc > ul > li {
793 | margin-bottom: 0.3em;
794 | }
795 |
796 | .odoc-toc ul li li {
797 | border-left: 1px solid #ccc;
798 | border-left: 1px solid var(--toc-list-border);
799 | margin-left: 5px;
800 | padding-left: 12px;
801 | }
802 |
803 | /* Mobile adjustements. */
804 |
805 | @media only screen and (max-width: 95ex) {
806 | body {
807 | margin-left: 4ex;
808 | }
809 | .odoc-content {
810 | margin: auto;
811 | padding: 2em;
812 | }
813 | .odoc-toc {
814 | position: static;
815 | width: auto;
816 | min-width: unset;
817 | max-width: unset;
818 | border: none;
819 | padding: 0.2em 1em;
820 | border-radius: 5px;
821 | }
822 | }
823 |
824 | /* Print adjustements. */
825 |
826 | @media print {
827 | body {
828 | color: black;
829 | background: white;
830 | }
831 | body nav:first-child {
832 | visibility: hidden;
833 | }
834 | }
835 |
836 | /* Syntax highlighting (based on github-gist) */
837 |
838 | .hljs {
839 | display: block;
840 | background: white;
841 | background: var(--code-background);
842 | padding: 0.5em;
843 | color: #333333;
844 | color: var(--color);
845 | overflow-x: auto;
846 | }
847 |
848 | .hljs-comment,
849 | .hljs-meta {
850 | color: #969896;
851 | }
852 |
853 | .hljs-string,
854 | .hljs-variable,
855 | .hljs-template-variable,
856 | .hljs-strong,
857 | .hljs-emphasis,
858 | .hljs-quote {
859 | color: #df5000;
860 | }
861 |
862 | .hljs-keyword,
863 | .hljs-selector-tag {
864 | color: #a71d5d;
865 | }
866 |
867 | .hljs-type,
868 | .hljs-class .hljs-title {
869 | color: #458;
870 | font-weight: 500;
871 | }
872 |
873 | .hljs-literal,
874 | .hljs-symbol,
875 | .hljs-bullet,
876 | .hljs-attribute {
877 | color: #0086b3;
878 | }
879 |
880 | .hljs-section,
881 | .hljs-name {
882 | color: #63a35c;
883 | }
884 |
885 | .hljs-tag {
886 | color: #333333;
887 | }
888 |
889 | .hljs-attr,
890 | .hljs-selector-id,
891 | .hljs-selector-class,
892 | .hljs-selector-attr,
893 | .hljs-selector-pseudo {
894 | color: #795da3;
895 | }
896 |
897 | .hljs-addition {
898 | color: #55a532;
899 | background-color: #eaffea;
900 | }
901 |
902 | .hljs-deletion {
903 | color: #bd2c00;
904 | background-color: #ffecec;
905 | }
906 |
907 | .hljs-link {
908 | text-decoration: underline;
909 | }
910 |
911 | /*---------------------------------------------------------------------------
912 | Copyright (c) 2016 The odoc contributors
913 |
914 | Permission to use, copy, modify, and/or distribute this software for any
915 | purpose with or without fee is hereby granted, provided that the above
916 | copyright notice and this permission notice appear in all copies.
917 |
918 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
919 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
920 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
921 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
922 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
923 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
924 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
925 | ---------------------------------------------------------------------------*/
926 |
--------------------------------------------------------------------------------
/dune:
--------------------------------------------------------------------------------
1 | (rule
2 | (alias docs)
3 | (deps
4 | (universe)
5 | (alias_rec doc)
6 | (source_tree docs))
7 | (action
8 | (bash "cp -fr docs/{odoc.css,fonts} _doc/_html")))
9 |
--------------------------------------------------------------------------------
/dune-project:
--------------------------------------------------------------------------------
1 | (lang dune 2.7)
2 | (name progress)
3 | (implicit_transitive_deps false)
4 |
5 | (generate_opam_files true)
6 | (source (github CraigFe/progress))
7 | (license MIT)
8 | (maintainers "Craig Ferguson ")
9 | (authors "Craig Ferguson ")
10 |
11 | (package
12 | (name progress)
13 | (synopsis "User-definable progress bars")
14 | (description "\
15 | A progress bar library for OCaml, featuring a DSL for declaratively specifying
16 | progress bar formats. Supports rendering multiple progress bars simultaneously.\
17 | ")
18 | (documentation https://CraigFe.github.io/progress/)
19 | (depends
20 | (ocaml (>= 4.08.0))
21 | (terminal (= :version))
22 | (fmt (>= 0.8.5))
23 | (logs (>= 0.7.0))
24 | (mtime (>= 2.0.0))
25 | (uucp (>= 2.0.0))
26 | (uutf (>= 1.0.0))
27 | vector
28 | (optint (>= 0.1.0))
29 | (alcotest (and :with-test (>= 1.4.0)))
30 | (astring :with-test)))
31 |
32 | (package
33 | (name terminal)
34 | (synopsis "Basic utilities for interacting with terminals")
35 | (description "Basic utilities for interacting with terminals")
36 | (documentation https://CraigFe.github.io/progress/)
37 | (depends
38 | (ocaml (>= 4.03.0))
39 | (uucp (>= 2.0.0))
40 | (uutf (>= 1.0.0))
41 | stdlib-shims
42 | (alcotest (and :with-test (>= 1.4.0)))
43 | (fmt :with-test)
44 | (astring :with-test)
45 | (mtime (and :with-test (>= 2.0.0)))))
46 |
--------------------------------------------------------------------------------
/examples/bar_styles.ml:
--------------------------------------------------------------------------------
1 | let[@ocamlformat "disable"] bar_styles =
2 | let open Progress.Line.Bar_style in
3 | let open Progress.Color in
4 | let brackets = ("[", "]") in
5 | let bars = ("│", "│") in
6 | [ ("ASCII" , ascii |> with_color (ansi `cyan) |> with_empty_color (ansi `blue))
7 | ; ("arrow" , v ~delims:brackets ~color:(ansi `red) [ "="; ">"; " " ])
8 | ; ("dots" , v ~delims:brackets ~color:(ansi `magenta) [ "." ])
9 | ; ("digits1" , v ~delims:brackets (List.init 10 @@ fun i -> string_of_int (9 - i)))
10 | ; ("digits2" , v ~delims:brackets (List.concat @@
11 | List.init 10 @@ fun i ->
12 | List.init 10 @@ fun j ->
13 | Printf.sprintf "«%d%d»" (9 - i) (9 - j)))
14 | ; ("UTF8" , utf8 |> with_color (ansi `green))
15 | ; ("rough bar", v ~delims:bars ~color:(hex "#DC2F02") [ "█"; " " ])
16 | ; ("fine bar" , v ~delims:bars ~color:(hex "#E85D04") [ "█"; "▉"; "▊"; "▋"; "▌"; "▍"; "▎"; "▏"; " " ] )
17 | ; ("vertical" , v ~delims:bars ~color:(hex "#F48C06") [ "█"; "▇"; "▆"; "▅"; "▄"; "▃"; "▂"; "▁"; " " ] )
18 | ; ("blocky" , v ~delims:bars ~color:(hex "#FAA307") [ "█"; "▛"; "▌"; "▖"; " " ])
19 | ; ("fade in" , v ~delims:bars ~color:(hex "#FFBA08") [ "█"; "▓"; "▒"; "░"; " " ])
20 | ]
21 |
22 | let layout =
23 | let pick_colour = Utils.colour_picker () in
24 | let open Progress.Line in
25 | let bars =
26 | ListLabels.map bar_styles ~f:(fun (name, style) ->
27 | lpad 17 (constf "%s : " name)
28 | ++ bar ~style:(`Custom style) ~color:(pick_colour ()) 1000)
29 | in
30 | Progress.Multi.(blank ++ lines bars ++ blank)
31 |
32 | let run () =
33 | Progress.with_reporters ~config:(Progress.Config.v ~max_width:(Some 51) ())
34 | layout (fun reporters ->
35 | for _ = 0 to 1000 do
36 | List.iter (fun f -> f 1) reporters;
37 | Unix.sleepf 0.006
38 | done)
39 |
--------------------------------------------------------------------------------
/examples/bar_styles.mli:
--------------------------------------------------------------------------------
1 | val run : unit -> unit
2 |
--------------------------------------------------------------------------------
/examples/cargo.ml:
--------------------------------------------------------------------------------
1 | let packages =
2 | [ ("0install-solver", "2.17")
3 | ; ("afl-persistent", "1.3")
4 | ; ("alcotest", "1.4.0")
5 | ; ("astring", "0.8.5")
6 | ; ("base", "v0.14.0")
7 | ; ("bechamel", "0.1.0")
8 | ; ("bos", "0.2.0")
9 | ; ("cmdliner", "1.0.4")
10 | ; ("cohttp", "4.0.0")
11 | ; ("core", "v0.14.1")
12 | ; ("ctypes", "0.17.1")
13 | ; ("dune", "2.8.4")
14 | ; ("either", "1.0.0")
15 | ; ("fmt", "0.8.9")
16 | ; ("fpath", "0.7.2")
17 | ; ("logs", "0.7.0")
18 | ; ("lru", "0.3.0")
19 | ; ("lwt", "5.4.0")
20 | ; ("memtrace", "0.1.2")
21 | ; ("mirage", "3.10.1")
22 | ; ("mirage-clock", "3.1.0")
23 | ; ("mirage-clock-unix", "3.1.0")
24 | ; ("mirage-crypto", "0.10.1")
25 | ; ("optint", "0.1.0")
26 | ; ("ppx_repr", "0.3.0")
27 | ; ("repr", "0.3.0")
28 | ; ("stdio", "v0.14.0")
29 | ; ("uucp", "13.0.0")
30 | ; ("uutf", "1.0.2")
31 | ; ("yojson", "1.7.0")
32 | ; ("zarith", "1.9.1")
33 | ]
34 | |> Vector.of_list ~dummy:("", "")
35 |
36 | let setup_logs () =
37 | let reporter = Progress.logs_reporter () in
38 | Fmt_tty.setup_std_outputs ();
39 | Logs_threaded.enable ();
40 | Logs.set_reporter reporter
41 |
42 | let bar =
43 | let open Progress.Line in
44 | let total = Vector.length packages in
45 | list
46 | [ constf " %a" Fmt.(styled `Cyan string) "Building"
47 | ; using fst
48 | (brackets
49 | (bar
50 | ~style:(`Custom (Bar_style.v [ "="; ">"; " " ]))
51 | ~width:(`Fixed 40) total))
52 | ; ticker_to total
53 | ; using snd string
54 | ]
55 |
56 | let rec package_worker (active_packages, reporter) =
57 | match Vector.pop packages with
58 | | exception Vector.Empty -> ()
59 | | package, version ->
60 | active_packages := package :: !active_packages;
61 | Logs.app (fun f ->
62 | f " %a %s %s" Fmt.(styled `Green string) "Compiling" package version);
63 | Unix.sleepf (Random.float 1.);
64 | active_packages := List.filter (( <> ) package) !active_packages;
65 | reporter ();
66 | package_worker (active_packages, reporter)
67 |
68 | let run () =
69 | setup_logs ();
70 | Random.self_init ();
71 | let cpus = 4 in
72 | let run_duration = Mtime_clock.counter () in
73 | let active_packages = ref [] in
74 | Progress.with_reporter ~config:(Progress.Config.v ~persistent:false ()) bar
75 | (fun reporter ->
76 | let reporter () =
77 | let package_list =
78 | !active_packages |> List.sort String.compare |> String.concat ", "
79 | in
80 | reporter (1, package_list)
81 | in
82 | let threads =
83 | List.init cpus (fun _ ->
84 | Thread.create package_worker (active_packages, reporter))
85 | in
86 | List.iter Thread.join threads);
87 | Logs.app (fun f ->
88 | f " %a in %a"
89 | Fmt.(styled `Green string)
90 | "Finished" Mtime.Span.pp
91 | (Mtime_clock.count run_duration))
92 |
--------------------------------------------------------------------------------
/examples/cargo.mli:
--------------------------------------------------------------------------------
1 | val run : unit -> unit
2 |
--------------------------------------------------------------------------------
/examples/download.ml:
--------------------------------------------------------------------------------
1 | open Progress
2 |
3 | let pick_colour = Utils.colour_picker ()
4 |
5 | let bar ~total =
6 | let open Line in
7 | let spinner = spinner ~color:(Color.ansi `green) () in
8 | let bar = bar ~color:(pick_colour ()) ~style:`ASCII total in
9 | list
10 | [ spinner
11 | ; brackets (elapsed ())
12 | ; bar
13 | ; bytes
14 | ; parens (const "eta: " ++ eta total)
15 | ]
16 |
17 | (* Simple mock for a worker performing a download action. *)
18 | module Worker = struct
19 | type t =
20 | { mutable todo : int
21 | ; mutable download_rate : int
22 | ; mutable reporter : int Reporter.t option
23 | }
24 |
25 | let empty () = { todo = 0; reporter = None; download_rate = 100_000 }
26 |
27 | let make_progress t =
28 | let progress = min t.todo t.download_rate in
29 | t.download_rate <- max 0 (t.download_rate + (Random.int 50_001 - 25_000));
30 | t.todo <- t.todo - progress;
31 | Reporter.report (Option.get t.reporter) progress
32 | end
33 |
34 | type t = { mutable active_workers : Worker.t list; mutable files : int list }
35 |
36 | let run () =
37 | let remove_lines =
38 | (* Run with [REMOVE_LINES=true] to see bars being removed from the
39 | display after the download is done. *)
40 | match Sys.getenv_opt "REMOVE_LINES" with
41 | | None | Some "false" -> false
42 | | Some _ -> true
43 | in
44 | let total_files = 18 in
45 | let files = List.init total_files (fun _ -> Random.int 100_000_000) in
46 |
47 | let bottom_line =
48 | Line.(
49 | spacer 4
50 | ++ ticker_to ~sep:(const " / ") total_files
51 | ++ const " files downloaded, elapsed: "
52 | ++ elapsed ())
53 | in
54 | let display =
55 | Display.start Multi.(blank ++ blank ++ line bottom_line ++ blank)
56 | in
57 | let [ completed ] = Display.reporters display in
58 | let nb_workers = 5 in
59 | let finish_item (worker : Worker.t) =
60 | Reporter.finalise (Option.get worker.reporter);
61 | completed ();
62 | if remove_lines then
63 | Display.remove_line display (Option.get worker.reporter)
64 | in
65 | let pick_item t (worker : Worker.t) =
66 | match t.files with
67 | | [] -> false
68 | | x :: xs ->
69 | let new_reporter = Display.add_line ~above:3 display (bar ~total:x) in
70 | worker.reporter <- Some new_reporter;
71 | worker.todo <- x;
72 | t.files <- xs;
73 | true
74 | in
75 | let t =
76 | { files; active_workers = List.init nb_workers (fun _ -> Worker.empty ()) }
77 | in
78 |
79 | (* Give everyone something to do *)
80 | ListLabels.iter t.active_workers ~f:(fun x ->
81 | let item_available = pick_item t x in
82 | assert item_available);
83 |
84 | (* Keep going until all files are downloaded *)
85 | while List.length t.active_workers > 0 do
86 | let active_workers =
87 | ListLabels.filter t.active_workers ~f:(fun (worker : Worker.t) ->
88 | Worker.make_progress worker;
89 | if worker.todo > 0 then true (* Not done yet; keep going. *)
90 | else (
91 | finish_item worker;
92 | pick_item t worker))
93 | in
94 |
95 | t.active_workers <- active_workers;
96 | Unix.sleepf 0.01
97 | done;
98 | Display.finalise display
99 |
--------------------------------------------------------------------------------
/examples/download.mli:
--------------------------------------------------------------------------------
1 | val run : unit -> unit
2 |
--------------------------------------------------------------------------------
/examples/dune:
--------------------------------------------------------------------------------
1 | (library
2 | (name examples)
3 | (modules
4 | (:standard \ main))
5 | (libraries progress unix logs logs.fmt logs.threaded fmt fmt.tty mtime
6 | mtime.clock.os vector threads.posix))
7 |
8 | (executable
9 | (name main)
10 | (modules main)
11 | (libraries examples fmt))
12 |
--------------------------------------------------------------------------------
/examples/interject.ml:
--------------------------------------------------------------------------------
1 | let bar ~total =
2 | let open Progress.Line in
3 | list
4 | [ spinner ~color:(Progress.Color.ansi `green) ()
5 | ; bar total
6 | ; count_to total
7 | ]
8 |
9 | let run () =
10 | let total = 100 in
11 | Progress.with_reporter (bar ~total) (fun f ->
12 | for i = 1 to total do
13 | f 1;
14 | if i mod 10 = 0 then
15 | Progress.interject_with (fun () ->
16 | print_endline (":: Finished " ^ string_of_int i));
17 | Unix.sleepf 0.025
18 | done)
19 |
--------------------------------------------------------------------------------
/examples/interject.mli:
--------------------------------------------------------------------------------
1 | val run : unit -> unit
2 |
--------------------------------------------------------------------------------
/examples/main.ml:
--------------------------------------------------------------------------------
1 | let examples =
2 | Examples.
3 | [ ( "bar_styles"
4 | , "Demo of possible progress bar configurations"
5 | , Bar_styles.run )
6 | ; ("cargo", "Port of the Cargo install progress bar", Cargo.run)
7 | ; ("download", "Rainbow-coloured download sequence", Download.run)
8 | ; ("interject", "Logging while displaying a progress bar", Interject.run)
9 | ; ("readme", "Demonstration included in the README", Readme.run)
10 | ; ("spinners", "Demo of possible spinner configurations", Spinners.run)
11 | ; ("yarn", "Yarn-like download and install sequence", Yarn.run)
12 | ]
13 |
14 | let available_examples () =
15 | Format.eprintf "Available examples: @.";
16 | ListLabels.iter examples ~f:(fun (name, desc, _) ->
17 | Format.eprintf "- %-12s %a@." name
18 | Fmt.(styled `Faint (parens string))
19 | desc)
20 |
21 | let usage () =
22 | Format.eprintf "@.";
23 | available_examples ();
24 | Format.eprintf "\n%a: dune exec %s%s%s.exe -- [--help] @."
25 | Fmt.(styled `Green string)
26 | "usage" Filename.current_dir_name Filename.dir_sep
27 | (Filename.chop_extension __FILE__)
28 |
29 | let () =
30 | Random.self_init ();
31 | Fmt.set_style_renderer Fmt.stderr `Ansi_tty;
32 | match Sys.argv with
33 | | [| _ |] | [| _; "-h" | "-help" | "--help" |] -> usage ()
34 | | [| _; "--list" |] ->
35 | ListLabels.iter ~f:(fun (name, _, _) -> print_endline name) examples
36 | | [| _; name |] -> (
37 | match
38 | List.find_opt
39 | (fun (n, _, _) -> n = String.lowercase_ascii name)
40 | examples
41 | with
42 | | None ->
43 | Format.eprintf "%a: unrecognised example name `%a`.@.@."
44 | Fmt.(styled `Bold @@ styled `Red string)
45 | "Error"
46 | Fmt.(styled `Cyan string)
47 | name;
48 | available_examples ();
49 | exit 1
50 | | Some (_, _, f) -> f ())
51 | | _ ->
52 | usage ();
53 | exit 1
54 |
--------------------------------------------------------------------------------
/examples/main.mli:
--------------------------------------------------------------------------------
1 | (* Intentionally empty *)
2 |
--------------------------------------------------------------------------------
/examples/readme.ml:
--------------------------------------------------------------------------------
1 | open Progress
2 |
3 | let bar color message =
4 | let total = 1_000_000_000L in
5 | let open Line.Using_int64 in
6 | list
7 | [ rpad 16 (constf " %s" message)
8 | ; bytes
9 | ; bytes_per_sec
10 | ; bar ~color ~style:`UTF8 total
11 | ; percentage_of total ++ const " "
12 | ]
13 | |> Multi.line
14 |
15 | let main () =
16 | let layout =
17 | let open Multi in
18 | bar (Color.hex "#90e0ef") "index.html"
19 | ++ bar (Color.hex "#48cae4") "sitemap.xml"
20 | ++ bar (Color.hex "#00b4d8") "img/kittens.jpg"
21 | ++ bar (Color.hex "#0096c7") "img/puppies.jpg"
22 | in
23 | with_reporters layout @@ fun a b c d ->
24 | let pick_random () =
25 | match Random.int 100 with
26 | | n when n < 19 -> a
27 | | n when n < 58 -> b
28 | | n when n < 74 -> c
29 | | _ -> d
30 | in
31 | let random_progress () = Random.int64 1_000_000L in
32 | for i = 1 to 13_000 do
33 | if i mod 100 = 0 then Logs.info (fun f -> f "Iterations reached: %d" i);
34 | (pick_random ()) (random_progress ());
35 | Unix.sleepf 0.001
36 | done
37 |
38 | let run () =
39 | let () =
40 | (* Run with [VERBOSE=true] to see log entries being interleaved with
41 | progress bar rendering. *)
42 | match Sys.getenv_opt "VERBOSE" with
43 | | None | Some "false" -> ()
44 | | Some _ ->
45 | (* Configure a [Logs] reporter that behaves properly with concurrent
46 | progress bar rendering. *)
47 | Logs.set_reporter (Progress.logs_reporter ());
48 | Logs.set_level (Some Info)
49 | in
50 | main ()
51 |
--------------------------------------------------------------------------------
/examples/readme.mli:
--------------------------------------------------------------------------------
1 | val run : unit -> unit
2 |
--------------------------------------------------------------------------------
/examples/spinners.ml:
--------------------------------------------------------------------------------
1 | open Progress
2 | module Ansi = Terminal.Style
3 |
4 | let apply_color color s = Ansi.(code color) ^ s ^ Ansi.(code none)
5 |
6 | let pick_colour =
7 | let i = ref 0 in
8 | let colours = [| `magenta; `blue; `cyan; `green; `yellow; `red |] in
9 | fun () ->
10 | i := (!i + 1) mod Array.length colours;
11 | Color.ansi colours.(!i)
12 |
13 | (** Examples taken from: https://github.com/sindresorhus/cli-spinners/ *)
14 |
15 | include struct
16 | let spin frames min_interval = Line.spinner ~color:(pick_colour ()) ~frames ~min_interval ()
17 |
18 | let dots1 = spin [ "⠋"; "⠙"; "⠹"; "⠸"; "⠼"; "⠴"; "⠦"; "⠧"; "⠇"; "⠏" ]
19 | let dots2 = spin [ "⣾"; "⣽"; "⣻"; "⢿"; "⡿"; "⣟"; "⣯"; "⣷" ]
20 | let dots3 = spin [ "⠋"; "⠙"; "⠚"; "⠞"; "⠖"; "⠦"; "⠴"; "⠲"; "⠳"; "⠓" ]
21 | let dots4 = spin [ "⠄"; "⠆"; "⠇"; "⠋"; "⠙"; "⠸"; "⠰"; "⠠"; "⠰"; "⠸"; "⠙"; "⠋"; "⠇"; "⠆" ]
22 | let dots5 = spin [ "⠋"; "⠙"; "⠚"; "⠒"; "⠂"; "⠂"; "⠒"; "⠲"; "⠴"; "⠦"; "⠖"; "⠒"; "⠐"; "⠐"; "⠒"; "⠓"; "⠋" ]
23 | let dots6 = spin [ "⠁"; "⠉"; "⠙"; "⠚"; "⠒"; "⠂"; "⠂"; "⠒"; "⠲"; "⠴"; "⠤"; "⠄"; "⠄"; "⠤"; "⠴"; "⠲"; "⠒"; "⠂"; "⠂"; "⠒"; "⠚"; "⠙"; "⠉"; "⠁" ]
24 | let dots7 = spin [ "⠈"; "⠉"; "⠋"; "⠓"; "⠒"; "⠐"; "⠐"; "⠒"; "⠖"; "⠦"; "⠤"; "⠠"; "⠠"; "⠤"; "⠦"; "⠖"; "⠒"; "⠐"; "⠐"; "⠒"; "⠓"; "⠋"; "⠉"; "⠈" ]
25 | let dots8 = spin [ "⢹"; "⢺"; "⢼"; "⣸"; "⣇"; "⡧"; "⡗"; "⡏" ]
26 | let dots9 = spin [ "⠁"; "⠂"; "⠄"; "⡀"; "⢀"; "⠠"; "⠐"; "⠈" ]
27 | let pointer = spin [ "←"; "↖"; "↑"; "↗"; "→"; "↘"; "↓"; "↙" ]
28 | let chevron = spin [ "▹▹▹▹▹"; "▸▹▹▹▹"; "▹▸▹▹▹"; "▹▹▸▹▹"; "▹▹▹▸▹"; "▹▹▹▹▸" ]
29 | let hamburger = spin [ "☱"; "☲"; "☴" ]
30 | let grow_vert = spin [ " "; "▁"; "▂"; "▃"; "▄"; "▅"; "▆"; "▇"; "█"; "▇"; "▆"; "▅"; "▄"; "▃"; "▂"; "▁" ]
31 | let grow_hori = spin [ "▏"; "▎"; "▍"; "▌"; "▋"; "▊"; "▉"; "▊"; "▋"; "▌"; "▍"; "▎" ]
32 | let moon = spin [ "🌑"; "🌒"; "🌓"; "🌔"; "🌕"; "🌖"; "🌗"; "🌘"; "🌑"; "🌒"; "🌓"; "🌔"; "🌕"; "🌖"; "🌗"; "🌘" ]
33 | let earth = spin [ "🌍 "; "🌎 "; "🌏 " ]
34 | let clock = spin [ "🕛"; "🕚"; "🕙"; "🕘"; "🕗"; "🕖"; "🕕"; "🕔"; "🕓"; "🕒"; "🕑"; "🕐"]
35 | let toggle = spin [ "⊶"; "⊷" ]
36 | let triangle = spin [ "◢"; "◣"; "◤"; "◥" ]
37 |
38 | let bouncing_bar =
39 | spin
40 | [ "[ ]"
41 | ; "[= ]"
42 | ; "[== ]"
43 | ; "[=== ]"
44 | ; "[ ===]"
45 | ; "[ ==]"
46 | ; "[ =]"
47 | ; "[ ]"
48 | ; "[ =]"
49 | ; "[ ==]"
50 | ; "[ ===]"
51 | ; "[====]"
52 | ; "[=== ]"
53 | ; "[== ]"
54 | ; "[= ]"
55 | ]
56 | end
57 | [@@ocamlformat "disable"]
58 |
59 | let unlimited_bar min_interval =
60 | let frames =
61 | let width = 6 in
62 | List.init width (fun i ->
63 | String.concat ""
64 | (List.init width (fun x ->
65 | if x = i then apply_color (Ansi.fg @@ Color.ansi `cyan) ">"
66 | else apply_color Ansi.faint "-")))
67 | in
68 | let spin = Line.spinner ~min_interval ~frames () in
69 | Line.(const "[" ++ spin ++ spin ++ spin ++ spin ++ spin ++ const "]")
70 |
71 | let run () =
72 | let spinners =
73 | [ ("dots1", dots1, 80)
74 | ; ("dots2", dots2, 80)
75 | ; ("dots3", dots3, 80)
76 | ; ("dots4", dots4, 80)
77 | ; ("dots5", dots5, 80)
78 | ; ("dots6", dots6, 80)
79 | ; ("dots7", dots7, 80)
80 | ; ("dots8", dots8, 80)
81 | ; ("dots9", dots9, 80)
82 | ; ("pointer", pointer, 80)
83 | ; ("chevron", chevron, 80)
84 | ; ("hamburger", hamburger, 100)
85 | ; ("grow vertical", grow_vert, 80)
86 | ; ("grow horizontal", grow_hori, 120)
87 | ; ("earth", earth, 180)
88 | ; ("moon", moon, 100)
89 | ; ("clock", clock, 80)
90 | ; ("bouncing bar", bouncing_bar, 80)
91 | ; ("toggle", toggle, 250)
92 | ; ("triangle", triangle, 50)
93 | ; ("unlimited bar", unlimited_bar, 80)
94 | ]
95 | |> List.map (fun (name, elt, interval) ->
96 | let open Line in
97 | lpad 25 (constf "%s : " name)
98 | ++ elt (Some (Duration.of_int_ms interval)))
99 | in
100 | with_reporters
101 | Multi.(blank ++ lines spinners ++ line (Line.noop ()))
102 | (fun reporters _ ->
103 | let timer = Mtime_clock.counter () in
104 | let render_time = Duration.of_sec 20. in
105 | while Duration.(Mtime_clock.count timer < render_time) do
106 | List.iter (fun f -> f ()) reporters
107 | done)
108 |
--------------------------------------------------------------------------------
/examples/spinners.mli:
--------------------------------------------------------------------------------
1 | val run : unit -> unit
2 |
--------------------------------------------------------------------------------
/examples/utils.ml:
--------------------------------------------------------------------------------
1 | let ( .%() ) v i = Vector.get v i
2 | let ( .%()<- ) v i x = Vector.set v i x
3 |
4 | let shuffle_vector =
5 | let shuffle_subvector rand_int v i j =
6 | for k = j - 1 downto i + 1 do
7 | let l = rand_int (k + 1) in
8 | let tmp = v.%(l) in
9 | v.%(l) <- v.%(k);
10 | v.%(k) <- tmp
11 | done
12 | in
13 | fun v -> shuffle_subvector Random.int v 0 (Vector.length v)
14 |
15 | let colors =
16 | (* import matplotlib.cm
17 | for i in matplotlib.cm.rainbow(numpy.linspace(0.2, 1, 20)):
18 | print(matplotlib.colors.rgb2hex(i))
19 | *)
20 | Array.map Progress.Color.hex
21 | [| "#1996f3"; "#06aeed"; "#10c6e6"; "#27dade"; "#3dead5"
22 | ; "#52f5cb"; "#66fcc2"; "#7dffb6"; "#92fda9"; "#a8f79c"
23 | ; "#bced8f"; "#d2de81"; "#e8cb72"; "#feb562"; "#ff9b52"
24 | ; "#ff8143"; "#ff6232"; "#ff4121"
25 | |]
26 | [@@ocamlformat "disable"]
27 |
28 | let colour_picker () =
29 | let count = ref (-1) in
30 | fun () ->
31 | count := succ !count mod Array.length colors;
32 | colors.(!count)
33 |
--------------------------------------------------------------------------------
/examples/utils.mli:
--------------------------------------------------------------------------------
1 | val shuffle_vector : _ Vector.t -> unit
2 | val colour_picker : unit -> unit -> Progress.Color.t
3 |
--------------------------------------------------------------------------------
/examples/yarn.ml:
--------------------------------------------------------------------------------
1 | (* This example ports the following example from Indicatif (Rust progress bar
2 | library) to use Progress instead:
3 | https://github.com/mitsuhiko/indicatif/blob/556db194b5ffeb4596275f1ce1d477f300bb4626/examples/yarnish.rs *)
4 |
5 | let line_prefix ~stages =
6 | let count = ref 0 in
7 | fun ppf ->
8 | incr count;
9 | Fmt.(styled `Bold (styled `Faint string))
10 | ppf
11 | (Fmt.str "[%d/%d]" !count stages)
12 |
13 | let config = Progress.Config.v ~persistent:false ()
14 |
15 | let with_plain_bar ~total f =
16 | Progress.(
17 | with_reporter ~config
18 | Line.(list [ elapsed (); bar total; percentage_of total ])
19 | f)
20 |
21 | let with_bars f =
22 | let bar_names = [ "alcotest"; "ctypes"; "irmin"; "fmt"; "logs" ] in
23 | let bars =
24 | ListLabels.map bar_names ~f:(fun name ->
25 | let open Progress.Line in
26 | spinner ~color:(Progress.Color.ansi `green) ()
27 | ++ constf " %s: " name
28 | ++ string)
29 | |> Progress.Multi.lines
30 | in
31 | let display = Progress.Display.start ~config bars in
32 | let [ reporters ] = Progress.Display.reporters display in
33 | let a = f display reporters in
34 | Progress.Display.finalise display;
35 | a
36 |
37 | let pick_random l =
38 | let len = List.length l in
39 | fun () -> List.nth l (Random.int len)
40 |
41 | let random_action =
42 | pick_random
43 | [ "cmake ."
44 | ; "make"
45 | ; "make clean"
46 | ; "gcc foo.c -o foo"
47 | ; "gcc bar.c -o bar"
48 | ; "./helper.sh rebuild-cache"
49 | ; "make all-clean"
50 | ; "make test"
51 | ]
52 |
53 | let run () =
54 | Fmt.set_style_renderer Fmt.stdout `Ansi_tty;
55 | let line_prefix = line_prefix ~stages:4 in
56 | let deps = 1234 in
57 | let started = Mtime_clock.counter () in
58 | Fmt.pr "%t 🔍 Resolving packages ... @." line_prefix;
59 | Fmt.pr "%t 🚚 Fetching packages ... @." line_prefix;
60 | Fmt.pr "%t 🔗 Linking %d dependencies ... @." line_prefix deps;
61 | with_plain_bar ~total:deps (fun f ->
62 | for _ = 1 to deps do
63 | f 1;
64 | Unix.sleepf 0.001
65 | done);
66 | Fmt.pr "%t 📃 Building fresh packages ... @." line_prefix;
67 | with_bars (fun display reporters ->
68 | (* Give everyone something to do *)
69 | List.iter (fun f -> f (random_action ())) reporters;
70 |
71 | (* Finish a task every so often *)
72 | let random_reporter = pick_random reporters in
73 | for _ = 1 to 50 do
74 | random_reporter () (random_action ());
75 |
76 | (* Advance the spinners while we wait *)
77 | for _ = 1 to 5 do
78 | Progress.Display.tick display;
79 | Unix.sleepf 0.05
80 | done
81 | done);
82 | Fmt.pr "✨ Done in %a@." Mtime.Span.pp (Mtime_clock.count started)
83 |
--------------------------------------------------------------------------------
/examples/yarn.mli:
--------------------------------------------------------------------------------
1 | val run : unit -> unit
2 |
--------------------------------------------------------------------------------
/progress.opam:
--------------------------------------------------------------------------------
1 | # This file is generated by dune, edit dune-project instead
2 | opam-version: "2.0"
3 | synopsis: "User-definable progress bars"
4 | description: """
5 | A progress bar library for OCaml, featuring a DSL for declaratively specifying
6 | progress bar formats. Supports rendering multiple progress bars simultaneously."""
7 | maintainer: ["Craig Ferguson "]
8 | authors: ["Craig Ferguson "]
9 | license: "MIT"
10 | homepage: "https://github.com/CraigFe/progress"
11 | doc: "https://CraigFe.github.io/progress/"
12 | bug-reports: "https://github.com/CraigFe/progress/issues"
13 | depends: [
14 | "dune" {>= "2.7"}
15 | "ocaml" {>= "4.08.0"}
16 | "terminal" {= version}
17 | "fmt" {>= "0.8.5"}
18 | "logs" {>= "0.7.0"}
19 | "mtime" {>= "2.0.0"}
20 | "uucp" {>= "2.0.0"}
21 | "uutf" {>= "1.0.0"}
22 | "vector"
23 | "optint" {>= "0.1.0"}
24 | "alcotest" {with-test & >= "1.4.0"}
25 | "astring" {with-test}
26 | "odoc" {with-doc}
27 | ]
28 | build: [
29 | ["dune" "subst"] {dev}
30 | [
31 | "dune"
32 | "build"
33 | "-p"
34 | name
35 | "-j"
36 | jobs
37 | "@install"
38 | "@runtest" {with-test}
39 | "@doc" {with-doc}
40 | ]
41 | ]
42 | dev-repo: "git+https://github.com/CraigFe/progress.git"
43 |
--------------------------------------------------------------------------------
/src/progress/dune:
--------------------------------------------------------------------------------
1 | (library
2 | (name progress)
3 | (public_name progress)
4 | (libraries
5 | (re_export progress.engine)
6 | (re_export terminal)
7 | mtime.clock.os
8 | fmt
9 | unix))
10 |
--------------------------------------------------------------------------------
/src/progress/engine/config.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | type user_supplied =
7 | { ppf : Format.formatter option
8 | ; hide_cursor : bool option
9 | ; persistent : bool option
10 | ; max_width : int option option
11 | ; min_interval : Duration.t option option
12 | }
13 |
14 | module Default = struct
15 | (* NOTE: changes here should be reflected in the doc-strings. *)
16 |
17 | let ppf =
18 | (* We avoid using [Format.err_formatter] directly since [Fmt] uses
19 | physical equality to share configuration options. *)
20 | let ppf = Format.formatter_of_out_channel stderr in
21 | Fmt.set_style_renderer ppf `Ansi_tty;
22 | Fmt.set_utf_8 ppf true;
23 | ppf
24 |
25 | let hide_cursor = true
26 | let persistent = true
27 | let max_width = None
28 | let min_interval = Some (Duration.of_sec (1. /. 60.))
29 | end
30 |
31 | (* Boilerplate from here onwards. Someday I'll write a PPX for this... *)
32 |
33 | let v ?ppf ?hide_cursor ?persistent ?max_width ?min_interval () =
34 | { ppf; hide_cursor; persistent; max_width; min_interval }
35 |
36 | (* Merge two ['a option]s with a left [Some] taking priority *)
37 | let merge_on ~f a b = match (f a, f b) with Some a, _ -> Some a | None, b -> b
38 |
39 | let ( || ) a b =
40 | { ppf = merge_on a b ~f:(fun x -> x.ppf)
41 | ; hide_cursor = merge_on a b ~f:(fun x -> x.hide_cursor)
42 | ; persistent = merge_on a b ~f:(fun x -> x.persistent)
43 | ; max_width = merge_on a b ~f:(fun x -> x.max_width)
44 | ; min_interval = merge_on a b ~f:(fun x -> x.min_interval)
45 | }
46 |
47 | type t =
48 | { ppf : Format.formatter
49 | ; hide_cursor : bool
50 | ; persistent : bool
51 | ; max_width : int option
52 | ; min_interval : Duration.t option
53 | }
54 |
55 | let apply_defaults : user_supplied -> t =
56 | fun { ppf; hide_cursor; persistent; max_width; min_interval } ->
57 | { ppf = Option.value ppf ~default:Default.ppf
58 | ; hide_cursor = Option.value hide_cursor ~default:Default.hide_cursor
59 | ; persistent = Option.value persistent ~default:Default.persistent
60 | ; max_width = Option.value max_width ~default:Default.max_width
61 | ; min_interval = Option.value min_interval ~default:Default.min_interval
62 | }
63 |
64 | (*————————————————————————————————————————————————————————————————————————————
65 | Copyright (c) 2020–2021 Craig Ferguson
66 |
67 | Permission to use, copy, modify, and/or distribute this software for any
68 | purpose with or without fee is hereby granted, provided that the above
69 | copyright notice and this permission notice appear in all copies.
70 |
71 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
72 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
73 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
74 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
75 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
76 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
77 | DEALINGS IN THE SOFTWARE.
78 | ————————————————————————————————————————————————————————————————————————————*)
79 |
--------------------------------------------------------------------------------
/src/progress/engine/dune:
--------------------------------------------------------------------------------
1 | (library
2 | (name progress_engine)
3 | (public_name progress.engine)
4 | (libraries
5 | (re_export mtime)
6 | (re_export optint)
7 | fmt
8 | logs
9 | logs.fmt
10 | terminal_ansi
11 | vector))
12 |
--------------------------------------------------------------------------------
/src/progress/engine/duration.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | open Mtime.Span
7 |
8 | let ( ** ) = Int64.mul
9 |
10 | type nonrec t = t
11 |
12 | let equal = Mtime.Span.equal
13 | let compare = Mtime.Span.compare
14 | let compare_zero (f : int -> int -> _) a b = f (compare a b) 0
15 | let ( + ) = Mtime.Span.add
16 | let ( < ) = compare_zero ( < )
17 | let ( <= ) = compare_zero ( <= )
18 | let ( = ) = compare_zero ( = )
19 | let ( >= ) = compare_zero ( >= )
20 | let ( > ) = compare_zero ( > )
21 | let v = of_uint64_ns
22 | let zero = v 0L
23 | let nanosecond = v 1L
24 | let microsecond = v 1_000L
25 | let millisecond = v 1_000_000L
26 | let second = v 1_000_000_000L
27 | let minute = v (60L ** 1_000_000_000L)
28 | let hour = v (60L ** 60L ** 1_000_000_000_000L)
29 | let day = v (24L ** 60L ** 60L ** 1_000_000_000_000L)
30 | let of_ns x = v (Int64.of_float x)
31 | let of_us x = v (Int64.of_float (x *. 1e3))
32 | let of_ms x = v (Int64.of_float (x *. 1e6))
33 | let of_sec x = v (Int64.of_float (x *. 1e9))
34 | let of_int64_ms x = v (x ** 1_000_000L)
35 | let of_int_ms x = of_int64_ms (Int64.of_int x)
36 | let of_int64_sec x = v (x ** 1_000_000_000L)
37 | let of_int_sec x = of_int64_sec (Int64.of_int x)
38 |
39 | let of_min =
40 | let f = 60. *. 1e9 in
41 | fun x -> v (Int64.of_float (x *. f))
42 |
43 | let of_int64_min =
44 | let f = 60L ** 1_000_000_000L in
45 | fun x -> v (x ** f)
46 |
47 | let of_int_min x = of_int64_min (Int64.of_int x)
48 |
49 | let of_hour =
50 | let f = 60. *. 60. *. 1e9 in
51 | fun x -> v (Int64.of_float (x *. f))
52 |
53 | let of_int64_hour =
54 | let f = 60L ** 60L ** 1_000_000_000L in
55 | fun x -> v (x ** f)
56 |
57 | let of_int_hour x = of_int64_hour (Int64.of_int x)
58 |
59 | let of_day =
60 | let f = 24. *. 60. *. 60. *. 1e9 in
61 | fun x -> v (Int64.of_float (x *. f))
62 |
63 | module Of_int = struct
64 | let ms = of_int_ms
65 | let sec = of_int_sec
66 | let min = of_int_min
67 | let hour = of_int_hour
68 | let ( + ) = ( + )
69 | end
70 |
71 | (*————————————————————————————————————————————————————————————————————————————
72 | Copyright (c) 2020–2021 Craig Ferguson
73 |
74 | Permission to use, copy, modify, and/or distribute this software for any
75 | purpose with or without fee is hereby granted, provided that the above
76 | copyright notice and this permission notice appear in all copies.
77 |
78 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
79 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
80 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
81 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
82 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
83 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
84 | DEALINGS IN THE SOFTWARE.
85 | ————————————————————————————————————————————————————————————————————————————*)
86 |
--------------------------------------------------------------------------------
/src/progress/engine/duration.mli:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | type t = Mtime.Span.t
7 | (** The type of time durations. This module is just a convenience wrapper around
8 | {!Mtime.Span}.*)
9 |
10 | val equal : t -> t -> bool
11 | val compare : t -> t -> int
12 |
13 | (** {1 Round values} *)
14 |
15 | val zero : t
16 | val nanosecond : t
17 | val microsecond : t
18 | val millisecond : t
19 | val second : t
20 | val minute : t
21 | val hour : t
22 | val day : t
23 |
24 | (** {1 Convertors} *)
25 |
26 | val of_ns : float -> t
27 | val of_us : float -> t
28 | val of_ms : float -> t
29 | val of_sec : float -> t
30 | val of_min : float -> t
31 | val of_hour : float -> t
32 | val of_day : float -> t
33 |
34 | (** {2 From integers} *)
35 |
36 | val of_int_ms : int -> t
37 | val of_int_sec : int -> t
38 | val of_int_min : int -> t
39 | val of_int_hour : int -> t
40 | val of_int64_ms : int64 -> t
41 | val of_int64_sec : int64 -> t
42 |
43 | module Of_int : sig
44 | val ms : int -> t
45 | val sec : int -> t
46 | val min : int -> t
47 | val hour : int -> t
48 | val ( + ) : t -> t -> t
49 | end
50 |
51 | (** {2 Infix operators} *)
52 |
53 | val ( + ) : t -> t -> t
54 | val ( < ) : t -> t -> bool
55 | val ( <= ) : t -> t -> bool
56 | val ( = ) : t -> t -> bool
57 | val ( >= ) : t -> t -> bool
58 | val ( > ) : t -> t -> bool
59 |
60 | (*————————————————————————————————————————————————————————————————————————————
61 | Copyright (c) 2020–2021 Craig Ferguson
62 |
63 | Permission to use, copy, modify, and/or distribute this software for any
64 | purpose with or without fee is hereby granted, provided that the above
65 | copyright notice and this permission notice appear in all copies.
66 |
67 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
68 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
69 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
70 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
71 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
72 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
73 | DEALINGS IN THE SOFTWARE.
74 | ————————————————————————————————————————————————————————————————————————————*)
75 |
--------------------------------------------------------------------------------
/src/progress/engine/flow_meter.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 | open! Import
6 |
7 | type 'a t =
8 | { data : 'a array
9 | ; timestamps : Mtime.t array
10 | ; max_length : int
11 | ; mutable most_recently_added : int
12 | ; mutable length : int
13 | ; get_time : unit -> Mtime.t
14 | ; elt : (module Integer.S with type t = 'a)
15 | }
16 |
17 | let create (type a) ~clock:get_time ~size ~elt : a t =
18 | if size <= 0 then
19 | Fmt.invalid_arg "Flow_meter.create: non-positive size %d" size;
20 | (* We need [n + 1] timestamp samples to integrate over [n] values. *)
21 | let max_length = size + 1 in
22 | let start_time = get_time () in
23 | { get_time
24 | ; data = Array.make max_length (Obj.magic None)
25 | ; timestamps = Array.make max_length start_time
26 | ; max_length
27 | ; most_recently_added = -1
28 | ; length = 0
29 | ; elt
30 | }
31 |
32 | let is_empty t = t.most_recently_added = -1
33 |
34 | let push t ~key ~data =
35 | t.data.(key) <- data;
36 | t.timestamps.(key) <- t.get_time ()
37 |
38 | let record t data =
39 | if t.length = t.max_length then (
40 | (* Buffer is full. Overwrite the oldest value. *)
41 | let next = (t.most_recently_added + 1) mod t.length in
42 | push t ~key:next ~data;
43 | t.most_recently_added <- next)
44 | else (
45 | (* Increase the buffer size *)
46 | push t ~key:t.length ~data;
47 | t.most_recently_added <- t.length;
48 | t.length <- succ t.length)
49 |
50 | let oldest_index t =
51 | if t.length = t.max_length then (t.most_recently_added + 1) mod t.length
52 | else 0
53 |
54 | let fold =
55 | let rec aux data f acc = function
56 | | -1 -> acc
57 | | n -> aux data f (f acc data.(n)) (n - 1)
58 | in
59 | fun t ~f ~init -> aux t.data f init (t.length - 1)
60 |
61 | let per_second : type a. a t -> float =
62 | fun t ->
63 | let (module Integer) = t.elt in
64 | if is_empty t then Float.zero
65 | else
66 | (* Sum all values in the window {i except the first one} and divide by the
67 | time interval. We can think of the first value as representing work done
68 | just {i before} the time interval starts, so using a half-open sample
69 | correctly avoids over-reporting the flow-rate. *)
70 | let oldest_index = oldest_index t in
71 | let sum =
72 | Integer.sub
73 | (fold t ~f:Integer.add ~init:Integer.zero)
74 | t.data.(oldest_index)
75 | in
76 | let interval =
77 | let start_time = t.timestamps.(oldest_index) in
78 | let end_time = t.timestamps.(t.most_recently_added) in
79 | Mtime.span_to_s (Mtime.span start_time end_time)
80 | in
81 | if Float.compare interval Float.epsilon < 0 then Float.zero
82 | else Integer.to_float sum /. interval
83 |
84 | (*————————————————————————————————————————————————————————————————————————————
85 | Copyright (c) 2020–2021 Craig Ferguson
86 |
87 | Permission to use, copy, modify, and/or distribute this software for any
88 | purpose with or without fee is hereby granted, provided that the above
89 | copyright notice and this permission notice appear in all copies.
90 |
91 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
92 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
93 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
94 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
95 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
96 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
97 | DEALINGS IN THE SOFTWARE.
98 | ————————————————————————————————————————————————————————————————————————————*)
99 |
--------------------------------------------------------------------------------
/src/progress/engine/flow_meter.mli:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | type 'a t
7 | (** The type of {i flow meters} for some metric: values that compute an online
8 | windowed integral of a discrete sequence of [(value, time)] samples. This is
9 | useful for e.g. estimating the download rate of a process given a sequence
10 | of progress updates. *)
11 |
12 | val create :
13 | clock:(unit -> Mtime.t)
14 | -> size:int
15 | -> elt:(module Integer.S with type t = 'a)
16 | -> 'a t
17 | (** [create ~clock ~size ~elt] is a flow meter for values of type [elt], using a
18 | window size of [size] and the [clock] function for collecting timestamps for
19 | recorded values. *)
20 |
21 | val record : 'a t -> 'a -> unit
22 | (** Add a value to the ring buffer. *)
23 |
24 | val per_second : 'a t -> float
25 | (** Estimate the rate of change of recorded values per second. *)
26 |
27 | (*————————————————————————————————————————————————————————————————————————————
28 | Copyright (c) 2020–2021 Craig Ferguson
29 |
30 | Permission to use, copy, modify, and/or distribute this software for any
31 | purpose with or without fee is hereby granted, provided that the above
32 | copyright notice and this permission notice appear in all copies.
33 |
34 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
35 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
36 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
37 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
38 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
39 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
40 | DEALINGS IN THE SOFTWARE.
41 | ————————————————————————————————————————————————————————————————————————————*)
42 |
--------------------------------------------------------------------------------
/src/progress/engine/import.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | include Stdlib_ext
7 | module Terminal = Terminal_ansi
8 |
9 | module Mtime = struct
10 | include Mtime
11 |
12 | let span_to_s span = Mtime.Span.to_float_ns span *. 1e-9
13 | end
14 |
15 | module Vector = struct
16 | include Vector
17 |
18 | let iter ~f t = iter f t
19 |
20 | let iteri_from ~f i t =
21 | for i = i to length t - 1 do
22 | f i (unsafe_get t i)
23 | done
24 |
25 | let rec find_map_from i t ~f =
26 | if i >= length t then None
27 | else
28 | let a = unsafe_get t i in
29 | match f a with
30 | | Some _ as some -> some
31 | | None -> find_map_from (i + 1) t ~f
32 |
33 | let find_map t ~f = find_map_from 0 t ~f
34 |
35 | let insert t k v =
36 | Vector.push t v (* Dummy insertion to expand *);
37 | for i = Vector.length t - 1 downto k + 1 do
38 | Vector.set t i (Vector.get t (pred i))
39 | done;
40 | Vector.set t k v
41 |
42 | let remove (type a) (t : a t) k =
43 | for i = k to Vector.length t - 2 do
44 | Vector.set t i (Vector.get t (succ i))
45 | done;
46 | ignore (Vector.pop t : a)
47 |
48 | let get_exn = get
49 | let get = `shadowed
50 | end
51 | (*————————————————————————————————————————————————————————————————————————————
52 | Copyright (c) 2020–2021 Craig Ferguson
53 |
54 | Permission to use, copy, modify, and/or distribute this software for any
55 | purpose with or without fee is hereby granted, provided that the above
56 | copyright notice and this permission notice appear in all copies.
57 |
58 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
59 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
60 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
61 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
62 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
63 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
64 | DEALINGS IN THE SOFTWARE.
65 | ————————————————————————————————————————————————————————————————————————————*)
66 |
--------------------------------------------------------------------------------
/src/progress/engine/integer.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | open! Import
7 |
8 | module type S = sig
9 | type t
10 |
11 | val zero : t
12 | val one : t
13 | val add : t -> t -> t
14 | val sub : t -> t -> t
15 | val equal : t -> t -> bool
16 | val to_string : t -> string
17 | val to_float : t -> float
18 | val of_float : float -> t
19 | end
20 |
21 | module Int : S with type t = int = Int
22 | module Int32 : S with type t = int32 = Int32
23 | module Int64 : S with type t = int64 = Int64
24 | module Int63 : S with type t = int63 = Int63
25 | module Float : S with type t = float = Float
26 |
27 | (*————————————————————————————————————————————————————————————————————————————
28 | Copyright (c) 2020–2021 Craig Ferguson
29 |
30 | Permission to use, copy, modify, and/or distribute this software for any
31 | purpose with or without fee is hereby granted, provided that the above
32 | copyright notice and this permission notice appear in all copies.
33 |
34 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
35 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
36 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
37 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
38 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
39 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
40 | DEALINGS IN THE SOFTWARE.
41 | ————————————————————————————————————————————————————————————————————————————*)
42 |
--------------------------------------------------------------------------------
/src/progress/engine/line.mli:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | include Line_intf.Line
7 | (** @inline *)
8 |
9 | (*————————————————————————————————————————————————————————————————————————————
10 | Copyright (c) 2020–2021 Craig Ferguson
11 |
12 | Permission to use, copy, modify, and/or distribute this software for any
13 | purpose with or without fee is hereby granted, provided that the above
14 | copyright notice and this permission notice appear in all copies.
15 |
16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
19 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
21 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
22 | DEALINGS IN THE SOFTWARE.
23 | ————————————————————————————————————————————————————————————————————————————*)
24 |
--------------------------------------------------------------------------------
/src/progress/engine/line_buffer.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | open! Import
7 |
8 | external unsafe_blit_string : string -> int -> bytes -> int -> int -> unit
9 | = "caml_blit_string"
10 | [@@noalloc]
11 | (** Polyfill for pre-4.09.0 *)
12 |
13 | type t =
14 | { mutable buffer : bytes
15 | ; mutable position : int
16 | ; mutable length : int
17 | ; mutable last : string
18 | (** Cache latest delivered contents to avoid unnecessary re-rendering *)
19 | ; mutable last_len : int (** Avoids some string comparisons on [last] *)
20 | ; ppf : Format.formatter Lazy.t
21 | }
22 | (** Invariants:
23 |
24 | - [0 <= position <= length]
25 | - [length = Bytes.length buffer] *)
26 |
27 | let resize t more =
28 | let old_pos = t.position and old_len = t.length in
29 | let new_len =
30 | let res = ref old_len in
31 | while old_pos + more > !res do
32 | res := 2 * !res
33 | done;
34 | !res
35 | in
36 | let new_buffer = Bytes.create new_len in
37 | Bytes.blit ~src:t.buffer ~src_pos:0 ~dst:new_buffer ~dst_pos:0 ~len:t.position;
38 | t.buffer <- new_buffer;
39 | t.length <- new_len
40 |
41 | let advance t len =
42 | let new_position = t.position + len in
43 | if new_position > t.length then resize t len;
44 | (* Fmt.pr "[%d -> %d]" t.position new_position; *)
45 | t.position <- new_position
46 |
47 | let lift_write ~len ~write =
48 | Staged.inj (fun t x ->
49 | let position = t.position in
50 | advance t len;
51 | write x ~into:t.buffer ~pos:position)
52 |
53 | let add_char b c =
54 | let pos = b.position in
55 | if pos >= b.length then resize b 1;
56 | Bytes.unsafe_set b.buffer pos c;
57 | b.position <- pos + 1
58 |
59 | let add_substring t s ~off ~len =
60 | if off < 0 || len < 0 || off > String.length s - len then
61 | invalid_arg "Line_buffer.add_substring";
62 | let position = t.position in
63 | advance t len;
64 | unsafe_blit_string s off t.buffer position len
65 |
66 | let add_string b s =
67 | let len = String.length s in
68 | let new_position = b.position + len in
69 | if new_position > b.length then resize b len;
70 | unsafe_blit_string s 0 b.buffer b.position len;
71 | b.position <- new_position
72 |
73 | let add_line_buffer ~dst ~src =
74 | let position = dst.position in
75 | let len = src.position in
76 | advance dst len;
77 | Bytes.unsafe_blit ~src:src.buffer ~src_pos:0 ~dst:dst.buffer ~dst_pos:position
78 | ~len
79 |
80 | let create ~size =
81 | let buffer = Bytes.create size in
82 | let rec ppf =
83 | lazy
84 | (let ppf =
85 | Format.make_formatter
86 | (fun s off len -> add_substring t s ~off ~len)
87 | (fun () -> ())
88 | in
89 | Fmt.set_style_renderer ppf `Ansi_tty;
90 | ppf)
91 | and t =
92 | { buffer; position = 0; length = size; ppf; last = ""; last_len = 0 }
93 | in
94 | t
95 |
96 | let with_ppf t f =
97 | let ppf = Lazy.force t.ppf in
98 | let a = f ppf in
99 | Format.pp_print_flush ppf ();
100 | a
101 |
102 | let reset t = t.position <- 0
103 |
104 | let contents t =
105 | let last = t.last in
106 | let last_len = t.last_len in
107 | let current_len = t.position in
108 | (* NOTE: Without an efficient substring equality function, we have no choice
109 | but to copy here even if the buffer is clean... *)
110 | let current = Bytes.sub_string t.buffer ~pos:0 ~len:current_len in
111 | reset t;
112 |
113 | match Int.equal last_len current_len && String.equal last current with
114 | | true -> `Clean t.last
115 | | false ->
116 | t.last <- current;
117 | t.last_len <- current_len;
118 | `Dirty current
119 |
120 | type mark = int
121 |
122 | let current_position t = t.position
123 |
124 | module Span = struct
125 | type t = { pos : int; len : int }
126 |
127 | let pp ppf t = Fmt.pf ppf "{ pos = %d; len = %d }" t.pos t.len
128 | let empty = { pos = 0; len = 0 }
129 | let between_marks a b = { pos = a; len = b - a }
130 | end
131 |
132 | let skip t (span : Span.t) =
133 | (* XXX: this can cause spurious failures when zooming the terminal, so for the
134 | moment we don't validate positions whatsoever. *)
135 | (* if t.position <> span.pos then
136 | * Fmt.failwith "Misaligned span %a inside line buffer at position %d" Span.pp
137 | * span t.position; *)
138 | advance t span.len
139 |
140 | (*————————————————————————————————————————————————————————————————————————————
141 | Copyright (c) 2020–2021 Craig Ferguson
142 |
143 | Permission to use, copy, modify, and/or distribute this software for any
144 | purpose with or without fee is hereby granted, provided that the above
145 | copyright notice and this permission notice appear in all copies.
146 |
147 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
148 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
149 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
150 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
151 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
152 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
153 | DEALINGS IN THE SOFTWARE.
154 | ————————————————————————————————————————————————————————————————————————————*)
155 |
--------------------------------------------------------------------------------
/src/progress/engine/line_buffer.mli:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | open! Import
7 |
8 | type t
9 | (** A line buffer is a variant of [Stdlib.Buffer] that supports {i skipping}
10 | some section of the underlying bytestring when doing a write pass. *)
11 |
12 | val create : size:int -> t
13 | (** Create a line buffer with the given initial size. *)
14 |
15 | val with_ppf : t -> (Format.formatter -> 'a) -> 'a
16 | (** [with_ppf buf f] gives a view of [buf] as a formatter to [f] (and then
17 | flushes the formatter to [buf]). *)
18 |
19 | val add_char : t -> char -> unit
20 | val add_string : t -> string -> unit
21 | val add_substring : t -> string -> off:int -> len:int -> unit
22 | val add_line_buffer : dst:t -> src:t -> unit
23 |
24 | val lift_write :
25 | len:int
26 | -> write:('a -> into:bytes -> pos:int -> unit)
27 | -> (t -> 'a -> unit) Staged.t
28 |
29 | val contents : t -> [ `Clean of string | `Dirty of string ]
30 | (** Reset the write head to the start of the buffer and return a copy of the
31 | intervening contents. *)
32 |
33 | val reset : t -> unit
34 |
35 | type mark
36 |
37 | val current_position : t -> mark
38 | (** Get a mark of the current write head in the buffer. *)
39 |
40 | module Span : sig
41 | type t
42 |
43 | val empty : t
44 | val between_marks : mark -> mark -> t
45 | val pp : Format.formatter -> t -> unit
46 | end
47 |
48 | val skip : t -> Span.t -> unit
49 | (** Advance over a given span in the buffer. *)
50 |
51 | (*————————————————————————————————————————————————————————————————————————————
52 | Copyright (c) 2020–2021 Craig Ferguson
53 |
54 | Permission to use, copy, modify, and/or distribute this software for any
55 | purpose with or without fee is hereby granted, provided that the above
56 | copyright notice and this permission notice appear in all copies.
57 |
58 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
59 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
60 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
61 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
62 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
63 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
64 | DEALINGS IN THE SOFTWARE.
65 | ————————————————————————————————————————————————————————————————————————————*)
66 |
--------------------------------------------------------------------------------
/src/progress/engine/line_intf.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | open! Import
7 |
8 | (** These values are documented as part of {!DSL}.*)
9 | module type Integer_dependent = sig
10 | type integer
11 | type color
12 | type duration
13 | type 'a printer
14 | type bar_style
15 |
16 | (**)
17 | type 'a t
18 |
19 | val sum : ?pp:integer printer -> width:int -> unit -> integer t
20 | val count_to : ?pp:integer printer -> ?sep:unit t -> integer -> integer t
21 | val bytes : integer t
22 | val bytes_per_sec : integer t
23 | val percentage_of : integer -> integer t
24 | val rate : float printer -> integer t
25 | val eta : ?pp:duration printer -> integer -> integer t
26 |
27 | type bar_style := [ `ASCII | `UTF8 | `Custom of bar_style ]
28 |
29 | val bar :
30 | ?style:bar_style
31 | -> ?color:color
32 | -> ?width:[ `Fixed of int | `Expand ]
33 | -> ?data:[ `Sum | `Latest ]
34 | -> integer
35 | -> integer t
36 | end
37 |
38 | (** The 'main' set of combinators, specialised to a particular integer type. *)
39 | module type DSL = sig
40 | type integer
41 | type color
42 | type duration
43 | type 'a printer
44 |
45 | type 'a t
46 | (** The type of progress lines for reported values of type ['a]. This module
47 | provides a selection of {{!basic} individual line segments} that can be
48 | {{!combinators} combined} to produce more interesting layouts. You may
49 | wish to look over the {{!examples} examples} for inspiration. *)
50 |
51 | (** {1:basic Basic line segments} *)
52 |
53 | val const : string -> _ t
54 | (** [const s] is the segment that always displays [s]. *)
55 |
56 | val constf : ('a, Format.formatter, unit, _ t) format4 -> 'a
57 | (** Like {!const}, but takes a format string and corresponding arguments.
58 | [constf "..." a b c ...] is equivalent to
59 | [const (Format.asprintf "..." a b c ...)], except that colours added with
60 | [Fmt.styled] are not discarded. *)
61 |
62 | val string : string t
63 | (** A line segment that displays a dynamically-sized string message. Use
64 | {!lpad} and {!rpad} to pad the message up to a given length. *)
65 |
66 | val lpad : int -> 'a t -> 'a t
67 | (** [lpad n t] left-pads the segment [t] to size [n] by adding blank space at
68 | the start. *)
69 |
70 | val rpad : int -> 'a t -> 'a t
71 | (** [rpad n t] right-pads the segment [t] to size [n] by adding blank space at
72 | the end. *)
73 |
74 | val of_printer : ?init:'a -> 'a printer -> 'a t
75 | (** [of_printer p] is a segment that renders the {i latest} reported value
76 | using printer [p]. See {!sum} for a variant that reports accumulated
77 | values instead. *)
78 |
79 | (** {2:counting Counting segments}
80 |
81 | These segments all consume integer values and display the accumulated
82 | total of reported values in some way. The top-level [Line] segments are
83 | specialised to [int] values; see "{!integers}" for variants supporting
84 | [int32], [int64] etc. *)
85 |
86 | val count_to : ?pp:integer printer -> ?sep:unit t -> integer -> integer t
87 | (** [count_to target] renders both the current running total of reported
88 | values and the fixed value [target], separated by the the given separator,
89 | i.e. [42/100]. [sep] defaults to [const "/"]. *)
90 |
91 | val bytes : integer t
92 | (** Prints the running total as a number of bytes, using ISO/IEC binary
93 | prefixes (e.g. [10.4 MiB]). See also {!bytes_per_sec}. *)
94 |
95 | val percentage_of : integer -> integer t
96 | (** [percentage_of target] renders the running total as a percentage of
97 | [target], i.e. [42%]. Values outside the range [[0, 100]] will be clamped
98 | to either [0] or [100]. *)
99 |
100 | val sum : ?pp:integer printer -> width:int -> unit -> integer t
101 | (** [sum ~width ()] displays a running total of reported values using
102 | [width]-many terminal columns. If passed, [pp] overrides the printer used
103 | for rendering the count. *)
104 |
105 | (** {2:graphical Graphical segments} *)
106 |
107 | module Bar_style : sig
108 | type t
109 | (** The type of progress bar style specifications. *)
110 |
111 | val ascii : t
112 | (** The style used by [bar ~style:`ASCII] (which is the default). Generates
113 | bars of the form [[######---]]. *)
114 |
115 | val utf8 : t
116 | (** {!utf8} is the style used by [bar ~style:`UTF8]. Uses the UTF-8 block
117 | element characters ([U+2588]–[U+258F]) for progress stages, and a
118 | box-drawing character ([U+2502]) for delimiters. *)
119 |
120 | (** {1 Custom styles} *)
121 |
122 | val v :
123 | ?delims:string * string
124 | -> ?color:color
125 | -> ?color_empty:color
126 | -> string list
127 | -> t
128 |
129 | (** [v stages] is a bar that uses the given string {i stages} to render
130 | progress. The first stage is interpreted as a "full" segment, with
131 | subsequent stages denoting progressively {i less}-full segments until a
132 | final "empty" stage (which is implicitly a space if only one stage is
133 | provided).
134 |
135 | The optional parameters are as follows:
136 |
137 | - [?delims]: a pair of left and right delimiters used to wrap the body
138 | of the progress bar;
139 | - [?color]: the color of non-empty segments (including the in-progress
140 | one);
141 | - [?color_empty]: the color of empty segments.
142 |
143 | {2 Examples}
144 |
145 | - [v [ "#" ]] renders like "[####### ]";
146 | - [v [ "="; ">"; " " ]] renders like "[======> ]";
147 | - [v [ "4"; "3"; "2"; "1"; "0" ]] renders like "[444444410000]";
148 | - ... see [examples/bar_styles.ml] in the source repository for more.
149 |
150 | {2 Specifics}
151 |
152 | Each segment of a rendering progress bar is in one of three states:
153 | full, empty or in-progress. At any given time, either the bar is
154 | entirely full or or there is exactly one in-progress segment. Given the
155 | style [v [s1; s2; ... sN]], these states are rendered as follows:
156 |
157 | - {b full}: rendered as [s1];
158 | - {b empty}: rendered as [sN] if [N >= 1], otherwise [' '];
159 | - {b in-progress}: if [N <= 1], then equivalent to the empty state.
160 | Otherwise, the intermediate stages [s2], [s3], ... [s{N-1}] denote
161 | decreasing progress. For example, if there are four intermediate
162 | stages ([N = 6]) then [s2] is used for progress in the range
163 | [\[0, 25%)], [s3] for [\[25%, 50%)] etc.
164 |
165 | For the progress bar to render within a fixed size, the user must ensure
166 | that each of the [stages] must have the same rendered width. *)
167 |
168 | (** {1 Setters} *)
169 |
170 | val with_color : color -> t -> t
171 | val with_empty_color : color -> t -> t
172 | val with_delims : (string * string) option -> t -> t
173 | val with_stages : string list -> t -> t
174 | end
175 |
176 | val bar :
177 | ?style:[ `ASCII | `UTF8 | `Custom of Bar_style.t ]
178 | -> ?color:color
179 | -> ?width:[ `Fixed of int | `Expand ]
180 | -> ?data:[ `Sum | `Latest ]
181 | -> integer
182 | -> integer t
183 | (** [bar total] is a progress bar of the form:
184 | [[#################...............]]
185 |
186 | The proportion of the bar that is filled is given by
187 | [ / total]. Optional parameters are as follows:
188 |
189 | - [?style] specifies whether to use a UTF-8 or an ASCII encoding for the
190 | progress bar. The UTF-8 encoding shows a higher resolution of progress,
191 | but may not be supported in all terminals. The default is [`ASCII].
192 |
193 | - [?color] causes the filled portion of the bar to be rendered with the
194 | given colour. (Equivalent to setting the colour with
195 | {!Bar_style.with_color}.)
196 |
197 | - [?width] is the width of the bar in columns. Defaults to [`Expand],
198 | which causes the bar to occupy the remaining rendering space after
199 | accounting for other line segments on the same line.
200 |
201 | - [?data] changes the metric that is indicated by the progress bar. [`Sum]
202 | (the default) causes the progress bar to correspond to the
203 | {i running total} of values reported so far. [`Latest] causes each
204 | reported value to overwrite the previous one instead. *)
205 |
206 | val spinner :
207 | ?frames:string list
208 | -> ?color:color
209 | -> ?min_interval:duration option
210 | -> unit
211 | -> _ t
212 | (** [spinner ()] is a small segment that cycles over a fixed number of frames
213 | each time a value is reported. e.g.
214 |
215 | {[
216 | ⠋ → ⠙ → ⠹ → ⠸ → ⠼ → ⠴ → ⠦ → ⠧ → ⠇ → ⠏ → ...
217 | ]}
218 |
219 | Optional prameters are as follows:
220 |
221 | - [?frames] alters the sequence of frames rendered by the spinner;
222 | - [?color] causes each frame to be rendered with the given colour;
223 | - [?min_interval] is the minimum time interval between frame transitions
224 | of the spinner (i.e. a debounce threshold). The default is [Some 80ms].
225 | *)
226 |
227 | (** {2:time Time-sensitive segments} *)
228 |
229 | val bytes_per_sec : integer t
230 | (** [bytes_per_sec] renders the rate of change of the running total as a
231 | number of bytes per second, using ISO/IEC binary prefixes (e.g.
232 | [10.4 MiB/s]). *)
233 |
234 | val elapsed : ?pp:duration printer -> unit -> _ t
235 | (** Displays the time for which the bar has been rendering in [MM:SS] form. *)
236 |
237 | val eta : ?pp:duration printer -> integer -> integer t
238 | (** Displays an estimate of the remaining time until [total] is accumulated by
239 | the reporters, in [MM:SS] form. *)
240 |
241 | val rate : float printer -> integer t
242 | (** [rate pp] is an integer segment that uses [pp] to print the {i rate} of
243 | reported values per second. (For instance, [bytes_per_sec] is
244 | [rate Units.Bytes.of_float].)*)
245 |
246 | (** {1:combinators Combining segments} *)
247 |
248 | val ( ++ ) : 'a t -> 'a t -> 'a t
249 | (** Horizontally join two segments of the same reported value type. *)
250 |
251 | val list : ?sep:'a t -> 'a t list -> 'a t
252 | (** Horizontally join a list of segments, with a given separator. [sep]
253 | defaults to [const " "]. *)
254 |
255 | val pair : ?sep:unit t -> 'a t -> 'b t -> ('a * 'b) t
256 | (** Horizontally join a pair of segments consuming different reported values
257 | into a single segment that consumes a pair. *)
258 |
259 | val using : ('a -> 'b) -> 'b t -> 'a t
260 | (** [using f s] is a segment that first applies [f] to the reported value and
261 | then behaves as segment [s]. *)
262 |
263 | (** {1 Utilities}
264 |
265 | The following line segments are definable in terms of the others, but
266 | provided for convenience: *)
267 |
268 | val parens : 'a t -> 'a t
269 | (** [parens t] is [const "(" ++ t ++ const ")"]. *)
270 |
271 | val brackets : 'a t -> 'a t
272 | (** [brackets t] is [const "[" ++ t ++ const "]"]. *)
273 |
274 | val braces : 'a t -> 'a t
275 | (** [braces t] is [const "{" ++ t ++ const "}"]. *)
276 |
277 | val noop : unit -> _ t
278 | (** A zero-width line segment that does nothing. This segment will not be
279 | surrounded with separators when used in a {!list}, making it a useful
280 | "off" state for conditionally-enabled segments. *)
281 |
282 | val spacer : int -> _ t
283 | (** [spacer n] is [const (String.make n ' ')]. *)
284 |
285 | val ticker_to : ?sep:unit t -> integer -> _ t
286 | (** [ticker_to total] is [using ~f:(fun _ -> 1) (counter_to total)]. i.e. it
287 | renders the total {i number} of reported values of some arbitrary type. *)
288 | end
289 |
290 | module Assert_subtype (X : DSL) :
291 | Integer_dependent with type bar_style := X.Bar_style.t =
292 | X
293 |
294 | module type S = sig
295 | include DSL with type integer := int
296 | (** @inline *)
297 |
298 | (** {1:integers Alternative integer types}
299 |
300 | Many of the line segments above are specialised to [int] values for
301 | simplicity (and performance), but certain use-cases may require different
302 | types (e.g. for file transfers greater than [2 GiB] on 32-bit platforms).
303 | The following modules re-export the [Line] DSL with different integer
304 | specialisations, and are intended to be opened locally, e.g.
305 |
306 | {[
307 | let my_line =
308 | let open Progress.Line.Using_int64 in
309 | list [ const "Downloading large file"; bar total; bytes ]
310 | ]} *)
311 |
312 | module Integer_dependent : sig
313 | (** {!S} contains just the line segments that can be specialised to an
314 | underlying integer implementation. *)
315 | module type S =
316 | Integer_dependent
317 | with type 'a t := 'a t
318 | and type color := color
319 | and type duration := duration
320 | and type 'a printer := 'a printer
321 | and type bar_style := Bar_style.t
322 |
323 | module Make (Integer : Integer.S) : S with type integer := Integer.t
324 |
325 | (** {!Ext} is {!S} extended with non-integer-dependent segments as well. *)
326 | module type Ext =
327 | DSL
328 | with type 'a t := 'a t
329 | and type color := color
330 | and type duration := duration
331 | and type 'a printer := 'a printer
332 | and type Bar_style.t := Bar_style.t
333 | end
334 |
335 | module Using_int32 : Integer_dependent.Ext with type integer := int32
336 | module Using_int63 : Integer_dependent.Ext with type integer := int63
337 | module Using_int64 : Integer_dependent.Ext with type integer := int64
338 | module Using_float : Integer_dependent.Ext with type integer := float
339 |
340 | (** {1:examples Examples}
341 |
342 | {[
343 | (* Renders: "[######---------------------------------------] 14/100" *)
344 | bar 100 ++ const " " ++ count_to 100
345 | ]}
346 | {[
347 | (* Renders: "⠏ [01:04] [####-----------------] 293.9 MiB (eta: 07:12)" *)
348 | list
349 | [ spinner ()
350 | ; brackets (elapsed ())
351 | ; bar total
352 | ; bytes
353 | ; parens (const "eta: " ++ eta total)
354 | ]
355 | ]}
356 | {[
357 | (* Renders: " a.txt │██████████████████████████▋ │ 91.4 MiB/s 92%" *)
358 | list
359 | [ lpad 7 (const file_name)
360 | ; bar ~style:`UTF8 total
361 | ; bytes_per_sec
362 | ; percentage_of total
363 | ]
364 | ]}
365 |
366 | See the [examples/] directory of the source repository for more. *)
367 |
368 | (** {1 Library internals} *)
369 |
370 | module Internals : sig
371 | (** Exposes the underlying implementation of line segments for testing. This
372 | API is unstable, unsafe and mostly undocumented; here be dragons etc. *)
373 |
374 | type 'a line
375 |
376 | module Line_buffer = Line_buffer
377 |
378 | include Line_primitives.S with type 'a t = 'a Line_primitives.t
379 | (** @inline *)
380 |
381 | val box_winsize : ?max:int -> ?fallback:int -> 'a t -> 'a t
382 | (** A box that takes on the current size of the terminal (or [fallback] if
383 | stdout is not attached to a terminal).
384 |
385 | @param fallback defaults to [80].
386 | @param max defaults to no limit. *)
387 |
388 | val to_line : 'a t -> 'a line
389 | end
390 | with type 'a line := 'a t
391 | end
392 |
393 | module type Line = sig
394 | module type S = S
395 |
396 | type 'a t
397 |
398 | module Make (_ : Platform.S) : sig
399 | include
400 | S
401 | with type 'a t := 'a t
402 | and type color := Terminal.Color.t
403 | and type duration := Duration.t
404 | and type 'a printer := 'a Printer.t
405 |
406 | val to_primitive : Config.t -> 'a t -> 'a Internals.t
407 | end
408 | end
409 |
410 | (*————————————————————————————————————————————————————————————————————————————
411 | Copyright (c) 2020–2021 Craig Ferguson
412 |
413 | Permission to use, copy, modify, and/or distribute this software for any
414 | purpose with or without fee is hereby granted, provided that the above
415 | copyright notice and this permission notice appear in all copies.
416 |
417 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
418 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
419 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
420 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
421 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
422 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
423 | DEALINGS IN THE SOFTWARE.
424 | ————————————————————————————————————————————————————————————————————————————*)
425 |
--------------------------------------------------------------------------------
/src/progress/engine/line_primitives.mli:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | include Line_primitives_intf.Line_primitives
7 | (** @inline *)
8 |
9 | (*————————————————————————————————————————————————————————————————————————————
10 | Copyright (c) 2020–2021 Craig Ferguson
11 |
12 | Permission to use, copy, modify, and/or distribute this software for any
13 | purpose with or without fee is hereby granted, provided that the above
14 | copyright notice and this permission notice appear in all copies.
15 |
16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
19 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
21 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
22 | DEALINGS IN THE SOFTWARE.
23 | ————————————————————————————————————————————————————————————————————————————*)
24 |
--------------------------------------------------------------------------------
/src/progress/engine/line_primitives_intf.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | open! Import
7 |
8 | module type Counter = sig
9 | type t
10 |
11 | val counter : unit -> t
12 | val count : t -> Mtime.span
13 | end
14 |
15 | module Types = struct
16 | type event =
17 | [ `report (* User has supplied a reported value. *)
18 | | `rerender (* Renderer wants a re-display. *)
19 | | `tick (* User has requested a "tick" (e.g. to update spinners). *)
20 | | `finish (* The bar or display has been finalised. *) ]
21 | end
22 |
23 | (** The DSL of progress bar segments. *)
24 | module type S = sig
25 | type 'a t
26 | (** The type of segments of progress bars that display reported values of type
27 | ['a]. *)
28 |
29 | include module type of Types
30 |
31 | type theta := Line_buffer.t -> event -> unit
32 | type 'a alpha := Line_buffer.t -> event -> 'a -> unit
33 |
34 | val noop : unit -> _ t
35 | val theta : width:int -> theta -> _ t
36 |
37 | val alpha :
38 | width:int
39 | -> initial:[ `Theta of Line_buffer.t -> unit | `Val of 'a ]
40 | -> 'a alpha
41 | -> 'a t
42 |
43 | val alpha_unsized :
44 | initial:
45 | [ `Theta of width:(unit -> int) -> Line_buffer.t -> int | `Val of 'a ]
46 | -> (width:(unit -> int) -> Line_buffer.t -> event -> 'a -> int)
47 | -> 'a t
48 |
49 | val array : 'a t array -> 'a t
50 | val pair : ?sep:unit t -> 'a t -> 'b t -> ('a * 'b) t
51 | val contramap : f:('a -> 'b) -> 'b t -> 'a t
52 | val on_finalise : 'a -> 'a t -> 'a t
53 |
54 | val of_pp :
55 | width:int -> initial:'a -> (Format.formatter -> event -> 'a -> unit) -> 'a t
56 | (** [of_pp ~width pp] is a segment that uses the supplied fixed-width
57 | pretty-printer to render the value. The pretty-printer must never emit
58 | newline characters. *)
59 |
60 | val conditional : ('a -> bool) -> 'a t -> 'a t
61 | (** [conditional pred s] has the same output format as [s], but is only passes
62 | reported values down to [s] when they satisfy [pred]. *)
63 |
64 | (** {2:stateful Stateful segments} *)
65 |
66 | val periodic : int -> 'a t -> 'a t
67 | (** [periodic n s] has the same output format as [s], but only passes reported
68 | values down to [s] on every [n]-th call. This is useful when progress is
69 | being reported from a hot-loop, where the cost of rendering is
70 | non-negligible. *)
71 |
72 | val accumulator : ('a -> 'a -> 'a) -> 'a -> 'a t -> 'a t
73 | (** [accumulator combine zero s] has the same output format [s]. *)
74 |
75 | val stateful : (unit -> 'a t) -> 'a t
76 | (** [stateful f] is a segment that behaves as [f ()] for any given render,
77 | allowing [f] to initialise any display state at the start of the rendering
78 | process. *)
79 |
80 | (** {2:boxes Dynamically-sized segments} *)
81 |
82 | (** Certain segments can have their size determined dynamically by being
83 | wrapped inside one of the following boxes: *)
84 |
85 | val box_dynamic :
86 | ?pad:[ `left | `right | `none ] -> (unit -> int) -> 'a t -> 'a t
87 | (** [box w] is a box that wraps a dynamically-sized segment and sets it to
88 | have size [w ()] on each tick. *)
89 |
90 | val box_fixed : ?pad:[ `left | `right | `none ] -> int -> 'a t -> 'a t
91 | (** [box-fixed n s] fixes the size of the dynamic segment [s] to be [n]. *)
92 | end
93 |
94 | module type Line_primitives = sig
95 | module type S = S
96 |
97 | include S
98 |
99 | module Compiled : sig
100 | type 'a t
101 |
102 | val pp_dump : Format.formatter -> 'a t -> unit
103 | end
104 |
105 | val compile : 'a t -> 'a Compiled.t
106 |
107 | val update :
108 | 'a Compiled.t -> (unconditional:bool -> Line_buffer.t -> int) Staged.t
109 |
110 | val report : 'a Compiled.t -> (Line_buffer.t -> 'a -> int) Staged.t
111 | val tick : 'a Compiled.t -> (Line_buffer.t -> int) Staged.t
112 | val finalise : 'a Compiled.t -> (Line_buffer.t -> int) Staged.t
113 | end
114 |
115 | (*————————————————————————————————————————————————————————————————————————————
116 | Copyright (c) 2020–2021 Craig Ferguson
117 |
118 | Permission to use, copy, modify, and/or distribute this software for any
119 | purpose with or without fee is hereby granted, provided that the above
120 | copyright notice and this permission notice appear in all copies.
121 |
122 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
123 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
124 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
125 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
126 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
127 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
128 | DEALINGS IN THE SOFTWARE.
129 | ————————————————————————————————————————————————————————————————————————————*)
130 |
--------------------------------------------------------------------------------
/src/progress/engine/multi.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | include Multi_intf
7 | open! Import
8 |
9 | (* This module deals with extending the [Line] DSL to multiple-line layouts.
10 | We want to allow such layouts to have ['a Line.t] values with _different_
11 | choices of ['a], so have to bite the bullet and use heterogeneous lists. *)
12 |
13 | include Hlist (Line)
14 |
15 | let blank = Zero
16 | let line l = One l
17 | let lines ls = Many ls
18 |
19 | (*————————————————————————————————————————————————————————————————————————————
20 | Copyright (c) 2020–2021 Craig Ferguson
21 |
22 | Permission to use, copy, modify, and/or distribute this software for any
23 | purpose with or without fee is hereby granted, provided that the above
24 | copyright notice and this permission notice appear in all copies.
25 |
26 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
27 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
28 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
29 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
30 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
31 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
32 | DEALINGS IN THE SOFTWARE.
33 | ————————————————————————————————————————————————————————————————————————————*)
34 |
--------------------------------------------------------------------------------
/src/progress/engine/multi.mli:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | include Multi_intf.Multi
7 | (** @inline *)
8 |
9 | (*————————————————————————————————————————————————————————————————————————————
10 | Copyright (c) 2020–2021 Craig Ferguson
11 |
12 | Permission to use, copy, modify, and/or distribute this software for any
13 | purpose with or without fee is hereby granted, provided that the above
14 | copyright notice and this permission notice appear in all copies.
15 |
16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
19 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
21 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
22 | DEALINGS IN THE SOFTWARE.
23 | ————————————————————————————————————————————————————————————————————————————*)
24 |
--------------------------------------------------------------------------------
/src/progress/engine/multi_intf.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | open! Import
7 |
8 | type 'a reporter = 'a -> unit
9 |
10 | module type S = sig
11 | type 'a line
12 | type 'a reporter
13 |
14 | type ('a, 'b) t
15 | (** The type of vertical {i sequences} of progress bars. The parameter ['a]
16 | stores a list of the reporting functions associated with each bar,
17 | terminating with ['b]. For example:
18 |
19 | {[
20 | (* Single progress bar, taking a [float] value. *)
21 | (float reporter -> 'b, 'b) t
22 |
23 | (* A two-bar layout, where the top bar takes [int64]s and the bottom one
24 | takes [string * float] pairs. *)
25 | (int64 reporter -> (string * float) reporter -> 'b, 'b) t
26 | ]}
27 |
28 | These reporting functions are supplied when beginning the
29 | {{!rendering} rendering} process. *)
30 |
31 | val line : 'a line -> ('a reporter -> 'b, 'b) t
32 | (** Construct a multiple-line layout from a single progress bar line. *)
33 |
34 | val lines : 'a line list -> ('a reporter list -> 'b, 'b) t
35 | (** Construct a multiple-line layout from a sequence of lines that all have
36 | the same type of reported values. *)
37 |
38 | val ( ++ ) : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t
39 | (** Stack progress bars vertically. [a ++ b] is a set with [a] stacked on top
40 | of [b]. The two sections have separate reporting functions, passed
41 | consecutively to the {!with_reporters} continuation when rendering. *)
42 |
43 | val blank : ('a, 'a) t
44 | (** A blank line, for adding spacing between progress lines. *)
45 | end
46 |
47 | module Hlist (Elt : sig
48 | type 'a t
49 | end) =
50 | struct
51 | type (_, _) t =
52 | | Zero : ('a, 'a) t
53 | | One : 'a Elt.t -> ('a reporter -> 'b, 'b) t
54 | | Many : 'a Elt.t list -> ('a reporter list -> 'b, 'b) t
55 | | Plus : (('a, 'b) t * ('b, 'c) t) -> ('a, 'c) t
56 |
57 | type 'b mapper = { f : 'a. int -> 'a Elt.t option -> 'b }
58 |
59 | let mapi =
60 | let rec aux : type a b c. (a, b) t -> int -> f:c mapper -> int * c list =
61 | fun t i ~f ->
62 | match t with
63 | | Zero -> (succ i, [ f.f i None ])
64 | | One b -> (succ i, [ f.f i (Some b) ])
65 | | Many bs ->
66 | ( i + List.length bs
67 | , List.mapi bs ~f:(fun i' x -> f.f (i + i') (Some x)) )
68 | | Plus (xs, ys) ->
69 | let i, xs = aux xs ~f i in
70 | let i, ys = aux ys ~f i in
71 | (i, xs @ ys)
72 | in
73 | fun t ~f -> snd (aux t 0 ~f)
74 |
75 | let rec length : type a b. (a, b) t -> int = function
76 | | Zero -> 1
77 | | One _ -> 1
78 | | Many xs -> List.length xs
79 | | Plus (a, b) -> length a + length b
80 |
81 | let ( ++ ) xs ys = Plus (xs, ys)
82 | end
83 |
84 | module type Multi = sig
85 | module type S = S
86 |
87 | module Hlist = Hlist
88 |
89 | include
90 | S
91 | with type 'a line := 'a Line.t
92 | and type 'a reporter := 'a -> unit
93 | and type ('a, 'b) t = ('a, 'b) Hlist(Line).t
94 | end
95 | (*————————————————————————————————————————————————————————————————————————————
96 | Copyright (c) 2020–2021 Craig Ferguson
97 |
98 | Permission to use, copy, modify, and/or distribute this software for any
99 | purpose with or without fee is hereby granted, provided that the above
100 | copyright notice and this permission notice appear in all copies.
101 |
102 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
103 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
104 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
105 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
106 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
107 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
108 | DEALINGS IN THE SOFTWARE.
109 | ————————————————————————————————————————————————————————————————————————————*)
110 |
--------------------------------------------------------------------------------
/src/progress/engine/platform.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | (** A platform provides a time source and access to the terminal width. *)
7 | module type S = sig
8 | (** Signature of a monotonic clock. See [Mtime] for various implementations on
9 | different plaforms. *)
10 | module Clock : sig
11 | val elapsed : unit -> Mtime.span
12 | val now : unit -> Mtime.t
13 |
14 | type counter
15 |
16 | val counter : unit -> counter
17 | val count : counter -> Mtime.span
18 | end
19 |
20 | (** Functions for polling (and subscribing to) the terminal width. *)
21 | module Terminal_width : sig
22 | val get : unit -> int option
23 | val set_changed_callback : (int option -> unit) -> unit
24 | end
25 | end
26 |
27 | (*————————————————————————————————————————————————————————————————————————————
28 | Copyright (c) 2020–2021 Craig Ferguson
29 |
30 | Permission to use, copy, modify, and/or distribute this software for any
31 | purpose with or without fee is hereby granted, provided that the above
32 | copyright notice and this permission notice appear in all copies.
33 |
34 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
35 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
36 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
37 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
38 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
39 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
40 | DEALINGS IN THE SOFTWARE.
41 | ————————————————————————————————————————————————————————————————————————————*)
42 |
--------------------------------------------------------------------------------
/src/progress/engine/printer.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | open! Import
7 |
8 | external unsafe_blit_string : string -> int -> bytes -> int -> int -> unit
9 | = "caml_blit_string"
10 | [@@noalloc]
11 | (** Polyfill for pre-4.09.0 *)
12 |
13 | type 'a t =
14 | { write : 'a -> into:bytes -> pos:int -> unit
15 | ; write_len : int
16 | ; width : int
17 | ; to_string : 'a -> string
18 | ; pp : 'a pp
19 | }
20 |
21 | let create ?width ?pp ~to_string ~string_len () =
22 | let write x ~into ~pos =
23 | unsafe_blit_string (to_string x) 0 into pos string_len
24 | in
25 | let width = match width with None -> string_len | Some width -> width in
26 | let pp = match pp with None -> Fmt.of_to_string to_string | Some pp -> pp in
27 | { write; write_len = string_len; width; to_string; pp }
28 |
29 | let integer (type a) ~width (module Integer : Integer.S with type t = a) : a t =
30 | let to_string x =
31 | let x = Integer.to_string x in
32 | let x_len = String.length x in
33 | let padding = width - x_len in
34 | if padding < 0 then
35 | Fmt.invalid_arg
36 | "Progress.Printer.int: can't print integer %s within a width of %d" x
37 | width;
38 | if padding = 0 then x
39 | else
40 | let buf = Bytes.make width ' ' in
41 | unsafe_blit_string x 0 buf padding x_len;
42 | Bytes.unsafe_to_string buf
43 | in
44 | create ~string_len:width ~to_string ()
45 |
46 | let int ~width = integer ~width (module Integer.Int)
47 |
48 | let string ~width =
49 | if width < 0 then failwith "Printer.string: negative print length";
50 | let ellipsis_length = min 3 width in
51 | let ellipsis = String.make ellipsis_length '.' in
52 | let to_string s =
53 | let printed_len = Terminal.guess_printed_width s in
54 | let padding = width - printed_len in
55 | if padding = 0 then s
56 | else if padding > 0 then (
57 | let len = String.length s in
58 | let buf = Bytes.make (len + padding) ' ' in
59 | unsafe_blit_string s 0 buf 0 len;
60 | Bytes.unsafe_to_string buf)
61 | else
62 | let s = Terminal.truncate_to_width (width - ellipsis_length) s in
63 | s ^ ellipsis
64 | in
65 | create ~string_len:width ~to_string ()
66 |
67 | let to_pp { pp; _ } = pp
68 |
69 | let using ~f { write; write_len; to_string; pp; width } =
70 | let write x ~into ~pos = write (f x) ~into ~pos in
71 | let pp = Fmt.using f pp in
72 | let to_string x = to_string (f x) in
73 | { write; write_len; to_string; pp; width }
74 |
75 | let to_line_printer { write; write_len; _ } =
76 | Line_buffer.lift_write ~len:write_len ~write
77 |
78 | let to_to_string { to_string; _ } = to_string
79 | let print_width { width; _ } = width
80 |
81 | module Internals = struct
82 | let integer = integer
83 | let to_line_printer = to_line_printer
84 | end
85 |
86 | (*————————————————————————————————————————————————————————————————————————————
87 | Copyright (c) 2020–2021 Craig Ferguson
88 |
89 | Permission to use, copy, modify, and/or distribute this software for any
90 | purpose with or without fee is hereby granted, provided that the above
91 | copyright notice and this permission notice appear in all copies.
92 |
93 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
94 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
95 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
96 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
97 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
98 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
99 | DEALINGS IN THE SOFTWARE.
100 | ————————————————————————————————————————————————————————————————————————————*)
101 |
--------------------------------------------------------------------------------
/src/progress/engine/printer.mli:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | open! Import
7 |
8 | type -'a t
9 | (** The type of {i fixed-width} pretty-printers for values of type ['a].
10 | Specifically, these pretty-printers aim to emit strings that have the same
11 | {i rendered} length in terminals (i.e. after accounting for UTF-8 encoding
12 | and ANSI escapes).
13 |
14 | {b Most users don't need this module, and can use the pre-provided {!Line}
15 | segments and {!Units} printers directly.} *)
16 |
17 | (** {1 Constructing printers} *)
18 |
19 | val int : width:int -> int t
20 | (** [int ~width] pretty-prints integers using [width] characters, adding left
21 | padding if necessary. The printer will raise [Invalid_argument] if the
22 | integer to be printed can't be displayed in the given width. *)
23 |
24 | val string : width:int -> string t
25 | (** [string ~width] is a pretty-printer for UTF8-encoded strings using [width]
26 | characters, adding right padding or truncating with ellipses as necessary.
27 |
28 | For example, [string ~width:8] processes values as follows:
29 |
30 | {[
31 | "" ↦ " "
32 | "hello" ↦ "hello "
33 | "hello world" ↦ "hello..."
34 | ]}
35 |
36 | {b Note:}
37 | {i this printer uses a heuristic function ({!Uucp.tty_width_hint}) to guess
38 | the rendered length of supplied strings. This function is not guaranteed
39 | to be correct on all UTF-8 codepoints, and so certain "unusual" string
40 | inputs can cause progress bar rendering to go awry.} *)
41 |
42 | val using : f:('b -> 'a) -> 'a t -> 'b t
43 | (** [using ~f t] prints values [v] by passing [f v] to the printer [t]. *)
44 |
45 | val create :
46 | ?width:int
47 | -> ?pp:'a pp
48 | -> to_string:('a -> string)
49 | -> string_len:int
50 | -> unit
51 | -> 'a t
52 | (** [create ~to_string ~string_len ()] is a printer that uses [to_string] to
53 | render values in [string_len]-many bytes.
54 |
55 | The rendered width of the output (when displayed in a terminal) is assumed
56 | to also be [string_len] (i.e. the output string is assumed to be ASCII), but
57 | this can be assumption can be overridden by passing an explicit [~width]
58 | (e.g. if the printer emits non-ASCII UTF-8 characters or ANSI escape
59 | sequences). *)
60 |
61 | (** {1 Consuming printers} *)
62 |
63 | val to_pp : 'a t -> Format.formatter -> 'a -> unit
64 | (** Convert a pretty-printer to a [Format]-compatible pretty-printer. *)
65 |
66 | val to_to_string : 'a t -> 'a -> string
67 | (** Convert a pretty-printer to a [to_string] function. *)
68 |
69 | val print_width : _ t -> int
70 | (** [print_width t] is the number of terminal columns occupied by the output of
71 | [t]. *)
72 |
73 | (** {1 Internals} *)
74 |
75 | module Internals : sig
76 | val integer : width:int -> (module Integer.S with type t = 'a) -> 'a t
77 | val to_line_printer : 'a t -> (Line_buffer.t -> 'a -> unit) Staged.t
78 | end
79 |
80 | (*————————————————————————————————————————————————————————————————————————————
81 | Copyright (c) 2020–2021 Craig Ferguson
82 |
83 | Permission to use, copy, modify, and/or distribute this software for any
84 | purpose with or without fee is hereby granted, provided that the above
85 | copyright notice and this permission notice appear in all copies.
86 |
87 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
88 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
89 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
90 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
91 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
92 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
93 | DEALINGS IN THE SOFTWARE.
94 | ————————————————————————————————————————————————————————————————————————————*)
95 |
--------------------------------------------------------------------------------
/src/progress/engine/progress_engine.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | open! Import
7 | include Progress_engine_intf
8 |
9 | module type Platform = Platform.S
10 |
11 | module Make (Platform : Platform) = struct
12 | module Color = Terminal.Color
13 | module Duration = Duration
14 | module Multi = Multi
15 | module Printer = Printer
16 | module Units = Units
17 |
18 | module Internals = struct
19 | module Ansi = Terminal.Style
20 | end
21 |
22 | module Config = struct
23 | include Config
24 |
25 | type t = user_supplied
26 | end
27 |
28 | module Renderer = struct
29 | include Renderer.Make (Platform)
30 | include Renderer
31 | end
32 |
33 | module Line = struct
34 | include Line.Make (Platform)
35 | include Line
36 | end
37 |
38 | module Display = Renderer.Display
39 | module Reporter = Renderer.Reporter
40 |
41 | let counter ?(style = `ASCII) ?message ?pp total =
42 | let map_option ~f x = Option.fold ~none:(Line.noop ()) ~some:f x in
43 | let open Line.Using_int64 in
44 | list
45 | [ map_option message ~f:const
46 | ; map_option pp ~f:(fun pp -> sum ~pp ~width:(Printer.print_width pp) ())
47 | ; elapsed ()
48 | ; bar ~style total
49 | ; percentage_of total
50 | ]
51 |
52 | let interject_with = Renderer.interject_with
53 | let instrument_logs_reporter = Renderer.instrument_logs_reporter
54 | let logs_reporter = Renderer.logs_reporter
55 | let with_reporters = Renderer.with_reporters
56 | let with_reporter ?config b f = with_reporters ?config (Multi.line b) f
57 | end
58 |
59 | module Integer = Integer
60 |
61 | module Exposed_for_testing = struct
62 | module Flow_meter = Flow_meter
63 | end
64 |
65 | (*————————————————————————————————————————————————————————————————————————————
66 | Copyright (c) 2020–2021 Craig Ferguson
67 |
68 | Permission to use, copy, modify, and/or distribute this software for any
69 | purpose with or without fee is hereby granted, provided that the above
70 | copyright notice and this permission notice appear in all copies.
71 |
72 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
73 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
74 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
75 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
76 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
77 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
78 | DEALINGS IN THE SOFTWARE.
79 | ————————————————————————————————————————————————————————————————————————————*)
80 |
--------------------------------------------------------------------------------
/src/progress/engine/progress_engine.mli:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | (** [Progress_engine] provides a platform-independent progress bar renderer.
7 | Most users should use the {!Progress} module, which instantiates this core
8 | with a Unix platform implementation. *)
9 |
10 | include Progress_engine_intf.Progress_engine
11 | (** @inline *)
12 |
13 | (*————————————————————————————————————————————————————————————————————————————
14 | Copyright (c) 2020–2021 Craig Ferguson
15 |
16 | Permission to use, copy, modify, and/or distribute this software for any
17 | purpose with or without fee is hereby granted, provided that the above
18 | copyright notice and this permission notice appear in all copies.
19 |
20 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
21 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
22 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
23 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
24 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
25 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
26 | DEALINGS IN THE SOFTWARE.
27 | ————————————————————————————————————————————————————————————————————————————*)
28 |
--------------------------------------------------------------------------------
/src/progress/engine/progress_engine_intf.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | module type S = sig
7 | (* We go to some effort here to avoid having types directly refer to those in
8 | [Progress_engine] rather than going via the aliases. *)
9 |
10 | (** *)
11 |
12 | (** {1 Preliminaries}
13 |
14 | Some basic types used throughout the rest of the library: *)
15 |
16 | module Color = Terminal_ansi.Color
17 | module Duration = Duration
18 | module Printer = Printer
19 | module Units = Units
20 |
21 | (** {1 Description}
22 |
23 | Describing a progress line is done via the {!Line} DSL. Individual lines
24 | can be stacked vertically via {!Multi}. *)
25 |
26 | module Line : sig
27 | (** @inline *)
28 | include
29 | Line.S
30 | with type 'a t = 'a Line.t
31 | and type color := Color.t
32 | and type duration := Duration.t
33 | and type 'a printer := 'a Printer.t
34 | end
35 |
36 | module Multi : sig
37 | type 'a reporter := 'a -> unit
38 |
39 | (** @inline *)
40 | include
41 | Multi.S with type 'a line := 'a Line.t and type 'a reporter := 'a reporter
42 | end
43 |
44 | (** {2 Pre-provided lines} *)
45 |
46 | val counter :
47 | ?style:[ `ASCII | `UTF8 | `Custom of Line.Bar_style.t ]
48 | -> ?message:string
49 | -> ?pp:int64 Printer.t
50 | -> int64
51 | -> int64 Line.t
52 | (** [counter total] is a progress bar of the form:
53 |
54 | {[
55 | MM:SS [########..............................] XX%
56 | ]}
57 |
58 | where each reported value contributes cumulatively towards an eventual
59 | total of [total]. [?style] specifies the
60 | {{!Line.Bar_style.t} [Bar_style.t]} to use for rendering the bar, and
61 | [?pp] is used to pretty-print the [] segment, if passed. (For
62 | example, {!Units.Bytes.of_int64} can be used for totals measured in
63 | bytes.) *)
64 |
65 | (** {1 Rendering}
66 |
67 | Once you have a {{!description} description} of the progress bar to be
68 | rendered (either a {!Line.t} or a {!Multi.t}), begin rendering it by using
69 | {!with_reporter} or {!with_reporters} respectively. *)
70 |
71 | type 'a reporter := 'a -> unit
72 | (** A {i reporter} for values of type ['a]. In this library, each progress
73 | line has its own reporting function. *)
74 |
75 | (** Configuration for progress bar rendering. *)
76 | module Config : sig
77 | type t
78 |
79 | val v :
80 | ?ppf:Format.formatter
81 | -> ?hide_cursor:bool
82 | -> ?persistent:bool
83 | -> ?max_width:int option
84 | -> ?min_interval:Duration.t option
85 | -> unit
86 | -> t
87 | (** - [ppf]: the formatter to use for rendering. Defaults to
88 | [Format.err_formatter].
89 |
90 | - [hide_cursor]: whether or not to hide the terminal cursor (using the
91 | {{:https://en.wikipedia.org/wiki/ANSI_escape_code} [DECTCEM]} ANSI
92 | escape codes) during progress bar rendering. Defaults to [true].
93 |
94 | - [persistent]: whether or not to retain the final progress bar display
95 | in the terminal after rendering has finished. Defaults to [true].
96 |
97 | - [max_width]: an optional fixed upper bound on the size of a progress
98 | bar (in addition to the one by the terminal width). Defaults to
99 | [None].
100 |
101 | - [min_interval]: the minimum time interval between re-renders of the
102 | progress bar display (i.e. a debounce threshold). Defaults to 1/60th
103 | of a second. *)
104 |
105 | val ( || ) : t -> t -> t
106 | (** Merge two config values, with settings from the left taking priority.
107 | That is, [a || b] contains the configuration of [a], with unset defaults
108 | taken from [b]. *)
109 |
110 | (** Provides the default values of each of the config parameters. *)
111 | module Default : sig
112 | val ppf : Format.formatter
113 | (** [ppf] is [Format.err_formatter]. *)
114 |
115 | val hide_cursor : bool
116 | (** [hide_cursor] is [true]. *)
117 |
118 | val persistent : bool
119 | (** [persistent] is [true]. *)
120 |
121 | val max_width : int option
122 | (** [max_width] is [None]. *)
123 |
124 | val min_interval : Duration.t option
125 | (** [min_interval] is 1/60th of a second. *)
126 | end
127 | end
128 |
129 | (** @inline *)
130 | include
131 | Renderer.S
132 | with type 'a reporter := 'a reporter
133 | and type 'a line := 'a Line.t
134 | and type ('a, 'b) multi := ('a, 'b) Multi.t
135 | and type config := Config.t
136 | end
137 |
138 | module type Progress_engine = sig
139 | module type S = S
140 | module type Platform = Platform.S
141 |
142 | module Make (_ : Platform) : S
143 | module Integer = Integer
144 |
145 | module Exposed_for_testing : sig
146 | module Flow_meter = Flow_meter
147 | end
148 | end
149 |
150 | (*————————————————————————————————————————————————————————————————————————————
151 | Copyright (c) 2020–2021 Craig Ferguson
152 |
153 | Permission to use, copy, modify, and/or distribute this software for any
154 | purpose with or without fee is hereby granted, provided that the above
155 | copyright notice and this permission notice appear in all copies.
156 |
157 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
158 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
159 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
160 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
161 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
162 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
163 | DEALINGS IN THE SOFTWARE.
164 | ————————————————————————————————————————————————————————————————————————————*)
165 |
--------------------------------------------------------------------------------
/src/progress/engine/renderer.mli:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | include Renderer_intf.Renderer
7 | (** @inline *)
8 |
9 | (*————————————————————————————————————————————————————————————————————————————
10 | Copyright (c) 2020–2021 Craig Ferguson
11 |
12 | Permission to use, copy, modify, and/or distribute this software for any
13 | purpose with or without fee is hereby granted, provided that the above
14 | copyright notice and this permission notice appear in all copies.
15 |
16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
19 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
21 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
22 | DEALINGS IN THE SOFTWARE.
23 | ————————————————————————————————————————————————————————————————————————————*)
24 |
--------------------------------------------------------------------------------
/src/progress/engine/renderer_intf.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | open! Import
7 |
8 | type 'a reporter = 'a -> unit
9 |
10 | module type S = sig
11 | type 'a reporter
12 | type 'a line
13 | type ('a, 'b) multi
14 | type config
15 |
16 | val with_reporter : ?config:config -> 'a line -> ('a reporter -> 'b) -> 'b
17 | (** [with_reporters line f] begins rendering [line] and calls [f] with the
18 | reporting function. Once [f] returns, the display is finalised. {b Note:}
19 | attempting to use the reporting function after [f] has returned will raise
20 | a [Finalised] exception. *)
21 |
22 | val with_reporters : ?config:config -> ('a, 'b) multi -> 'a -> 'b
23 | (** [with_reporters bars f] begins rendering [bars] and passes the
24 | corresponding reporting functions to [f]. Once [f] returns, the display is
25 | finalised. *)
26 |
27 | (** {2 Examples}
28 |
29 | - Reading a file into memory and displaying a single progress bar:
30 |
31 | {[
32 | let read_file path buffer =
33 | let total = file_size path and in_channel = open_in path in
34 | try
35 | with_reporter (counter ~total ()) @@ fun report ->
36 | let rec aux offset =
37 | let bytes_read = really_read buffer offset in
38 | report bytes_read;
39 | aux (offset + bytes_read)
40 | in
41 | aux 0
42 | with End_of_file -> close_in in_channel
43 | ]}
44 | - Sending data to multiple clients, with one progress bar each:
45 |
46 | {[
47 | let multi_bar_rendering () =
48 | with_reporters
49 | Multi.(line bar_a ++ line bar_b ++ line bar_c)
50 | (fun report_a report_b report_c ->
51 | for i = 1 to 1000 do
52 | report_a (transfer_bytes client_a);
53 | report_b (transfer_bytes client_b);
54 | report_c (transfer_bytes client_c)
55 | done)
56 | ]} *)
57 |
58 | (** {2 Logging during rendering} *)
59 |
60 | val interject_with : (unit -> 'a) -> 'a
61 | (** [interject_with f] executes the function [f] while temporarily suspending
62 | the rendering of any active progress bar display. This can be useful when
63 | printing to [stdout] / [stderr], to avoid any interference from the
64 | rendering of progress bars. If using the [Logs] library, consider using
65 | {!reporter} and {!instrument_reporter} instead.
66 |
67 | {b Note}:
68 | {i the caller must ensure that the terminal cursor is left in an
69 | appropriate position to resume rendering. In practice, this means that
70 | any printing to the terminal should be terminated with a newline
71 | character and flushed.} *)
72 |
73 | (** Extensions to the {{:https://erratique.ch/software/logs} [Logs]} library
74 | designed to cooperate with progress bar rendering: *)
75 |
76 | val logs_reporter :
77 | ?pp_header:(Logs.level * string option) Fmt.t
78 | -> ?app:Format.formatter
79 | -> ?dst:Format.formatter
80 | -> unit
81 | -> Logs.reporter
82 | (** [reporter] is like [Logs_fmt.reporter] but produces a reporter that
83 | {{!Progress.interject_with} suspends} any ongoing progress bar rendering
84 | while displaying log entries, ensuring that log entries in the terminal
85 | are never overwritten by the renderer. *)
86 |
87 | val instrument_logs_reporter : Logs.reporter -> Logs.reporter
88 | (** [instrument_reporter r] wraps the synchronous reporter [r] to ensure that
89 | any progress bar rendering is suspended while messages are being
90 | constructed for [r].
91 |
92 | {b Note}:
93 | {i to ensure that log entries are not overwritten by the [Progress]
94 | renderer, [r] must flush any log entries to the terminal synchronously:
95 | as soon as they are reported. This is true of the [Logs] reporters
96 | built by {!Logs.format_reporter} and {!Logs_fmt.reporter}. An
97 | asynchronous reporter should use {!interject_with} to delimit its
98 | flushing action instead.} *)
99 |
100 | (** {2 Manual lifecycle management}
101 |
102 | Functions for explicitly starting and stopping the process of rendering a
103 | bar; useful when the code doing the progress reporting cannot be
104 | conveniently delimited inside {!with_reporter}. All {!Display}s must be
105 | properly {{!Display.finalise} finalised}, and it is not possible to
106 | interleave rendering of displays. *)
107 |
108 | module Reporter : sig
109 | type -'a t
110 | (** The (abstract) type of reporter functions used by the manual lifecycle
111 | management functions in {!Display}. An ['a t] is conceptually an
112 | ['a -> unit] function, but can be explicitly {!finalise}d. *)
113 |
114 | val report : 'a t -> 'a -> unit
115 |
116 | val finalise : _ t -> unit
117 | (** [finalise t] terminates rendering of the line associated with reporter
118 | [t]. Attempting to {!report} to a finalised reporter will raise an
119 | exception. *)
120 |
121 | (** A heterogeneous list type, used by {!Display} for returning a list of
122 | reporters corresponding to multi-line progress displays. *)
123 | type (_, _) list =
124 | | [] : ('a, 'a) list
125 | | ( :: ) : 'a * ('b, 'c) list -> ('a -> 'b, 'c) list
126 | end
127 |
128 | module Display : sig
129 | type ('a, 'b) t
130 | (** The type of active progress bar displays. The type parameters ['a] and
131 | ['b] track the types of the reporting functions supplied by {!reporters}
132 | (see {!Multi.t} for details).*)
133 |
134 | val start : ?config:config -> ('a, 'b) multi -> ('a, 'b) t
135 | (** Initiate rendering of a progress bar display. Raises [Failure] if there
136 | is already an active progress bar display. *)
137 |
138 | val reporters : ('a, unit) t -> ('a, unit) Reporter.list
139 | (** [reporters d] is the list of initial reporting functions belonging to
140 | display [d].
141 |
142 | {b Note}
143 | {i this list does not include any reporters added {i during} progress
144 | bar rendering via {!add_line}.} *)
145 |
146 | val tick : _ t -> unit
147 | (** [tick d] re-renders the contents of display [d] without reporting any
148 | specific values. This function can be used to update spinners,
149 | durations, etc. when there is no actual progress to report. *)
150 |
151 | val add_line : ?above:int -> (_, _) t -> 'a line -> 'a Reporter.t
152 | (** Add a line to an ongoing display, and get its reporting function. By
153 | default, the line is added to the {i bottom} of the display
154 | ([above = 0]); the [~above] argument can be passed to add the line above
155 | some number of existing lines. *)
156 |
157 | val remove_line : (_, _) t -> _ Reporter.t -> unit
158 | (** Remove a line from an ongoing display, identified by the reporting
159 | function that was returned by [add_line]. Lines may be removed either
160 | before they are finalised (for example if some task has been cancelled)
161 | or after being finalised. In both cases, the line will be removed from
162 | the display, thus retrieving some space in the terminal. Attempting to
163 | remove a line that has already been removed from the display will raise
164 | [Failure]. Also raises [Failure] if the display has already been
165 | finalised. *)
166 |
167 | val pause : (_, _) t -> unit
168 | (** Suspends the rendering of any active progress bar display. It can be
169 | useful to compose with the [Logs] library and avoid interference when
170 | printing to [stdout] / [stderr] from the rendering of progress bars. *)
171 |
172 | val resume : (_, _) t -> unit
173 | (** Resume the rendering of progress bar display. *)
174 |
175 | val finalise : (_, _) t -> unit
176 | (** Terminate the given progress bar display. Raises [Failure] if the
177 | display has already been finalised. *)
178 | end
179 | end
180 |
181 | module type Renderer = sig
182 | module type S = S
183 |
184 | module Make (_ : Platform.S) :
185 | S
186 | with type 'a reporter := 'a reporter
187 | and type 'a line := 'a Line.t
188 | and type ('a, 'b) multi := ('a, 'b) Multi.t
189 | and type config := Config.user_supplied
190 | end
191 |
192 | (*————————————————————————————————————————————————————————————————————————————
193 | Copyright (c) 2020–2021 Craig Ferguson
194 |
195 | Permission to use, copy, modify, and/or distribute this software for any
196 | purpose with or without fee is hereby granted, provided that the above
197 | copyright notice and this permission notice appear in all copies.
198 |
199 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
200 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
201 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
202 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
203 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
204 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
205 | DEALINGS IN THE SOFTWARE.
206 | ————————————————————————————————————————————————————————————————————————————*)
207 |
--------------------------------------------------------------------------------
/src/progress/engine/stdlib_ext.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | type 'a pp = Format.formatter -> 'a -> unit
7 |
8 | let ( >> ) f g x = g (f x)
9 |
10 | let tap f x =
11 | f x;
12 | x
13 |
14 | let trace fmt x =
15 | Fmt.epr fmt x;
16 | x
17 |
18 | module type Eq = sig
19 | type t
20 |
21 | val equal : t -> t -> bool
22 | end
23 |
24 | module type Comparable_infix = sig
25 | type t
26 |
27 | val ( = ) : t -> t -> bool
28 | val ( <= ) : t -> t -> bool
29 | val ( >= ) : t -> t -> bool
30 | val ( < ) : t -> t -> bool
31 | val ( > ) : t -> t -> bool
32 | end
33 |
34 | module Poly = struct
35 | let ( = ) = Stdlib.( = )
36 | let ( <= ) = Stdlib.( <= )
37 | let ( >= ) = Stdlib.( >= )
38 | let ( < ) = Stdlib.( < )
39 | let ( > ) = Stdlib.( > )
40 | end
41 |
42 | include Stdlib.StdLabels
43 | include Stdlib.MoreLabels
44 |
45 | (** Shadow polymorphic operators in the Stdlib. *)
46 | include struct
47 | let min : int -> int -> int = min
48 | let max : int -> int -> int = max
49 | let compare : int -> int -> int = compare
50 |
51 | include (Poly : Comparable_infix with type t := int)
52 | end
53 |
54 | module Int = struct
55 | include Int
56 | include (Poly : Comparable_infix with type t := t)
57 |
58 | let float_div a b = to_float a /. to_float b
59 | end
60 |
61 | module Int32 = struct
62 | include Int32
63 | include (Poly : Comparable_infix with type t := t)
64 |
65 | let float_div a b = to_float a /. to_float b
66 | end
67 |
68 | module Int63 = struct
69 | include Optint.Int63
70 | include (Poly : Comparable_infix with type t := t)
71 |
72 | let float_div a b = to_float a /. to_float b
73 | end
74 |
75 | type int63 = Int63.t
76 |
77 | module Int64 = struct
78 | include Int64
79 | include (Poly : Comparable_infix with type t := t)
80 |
81 | let float_div a b = to_float a /. to_float b
82 | end
83 |
84 | module Float = struct
85 | include Float
86 | include (Poly : Comparable_infix with type t := t)
87 |
88 | let float_div = ( /. )
89 | let to_float x = x
90 | let of_float x = x
91 | end
92 |
93 | module Option = struct
94 | include Option
95 |
96 | let ( || ) a b = match a with Some _ -> a | None -> b
97 | end
98 |
99 | module Result = struct
100 | let get_or_invalid_arg = function
101 | | Ok x -> x
102 | | Error (`Msg s) -> invalid_arg s
103 |
104 | let errorf fmt = Format.kasprintf (fun s -> Error (`Msg s)) fmt
105 | end
106 |
107 | module List = struct
108 | include List
109 |
110 | let rec intersperse ~sep = function
111 | | ([] | [ _ ]) as l -> l
112 | | h1 :: (_ :: _ as tl) -> h1 :: sep :: intersperse ~sep tl
113 | end
114 |
115 | module Staged : sig
116 | type 'a t
117 | type ('a, 'b) endo := 'a t -> 'b t
118 |
119 | external map : f:('a -> 'b) -> ('a, 'b) endo = "%identity"
120 | external inj : 'a -> 'a t = "%identity"
121 | external prj : 'a t -> 'a = "%identity"
122 |
123 | module Syntax : sig
124 | val ( let$ ) : 'a t -> ('a -> 'b) -> 'b t
125 | val ( and$ ) : 'a t -> 'b t -> ('a * 'b) t
126 | end
127 | end = struct
128 | type 'a t = 'a
129 | type ('a, 'b) endo = 'a t -> 'b t
130 |
131 | external map : f:('a -> 'b) -> ('a, 'b) endo = "%identity"
132 | external inj : 'a -> 'a t = "%identity"
133 | external prj : 'a t -> 'a = "%identity"
134 |
135 | module Syntax = struct
136 | let ( let$ ) x f = f x
137 | let ( and$ ) a b = (a, b)
138 | end
139 | end
140 |
141 | module Unique_id () : sig
142 | type t
143 |
144 | val create : unit -> t
145 | val equal : t -> t -> bool
146 | val pp : t pp
147 | end = struct
148 | let allocated = ref 0
149 |
150 | type t = int
151 |
152 | let create () =
153 | let v = !allocated in
154 | incr allocated;
155 | v
156 |
157 | let equal = Int.equal
158 | let pp = Fmt.int
159 | end
160 |
161 | module Sta_dyn : sig
162 | type 'a t = Static of 'a | Dynamic of (unit -> 'a)
163 |
164 | val get : 'a t -> 'a
165 | val lift : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
166 | val pp : 'a pp -> 'a t pp
167 | end = struct
168 | type 'a t = Static of 'a | Dynamic of (unit -> 'a)
169 |
170 | let get = function Static x -> x | Dynamic f -> f ()
171 |
172 | let lift add x y =
173 | let ( ++ ) = add in
174 | match (x, y) with
175 | | Static x, Static y -> Static (x ++ y)
176 | | Dynamic f, Static x | Static x, Dynamic f -> Dynamic (fun () -> x ++ f ())
177 | | Dynamic f, Dynamic g -> Dynamic (fun () -> f () ++ g ())
178 |
179 | let pp pp_elt ppf = function
180 | | Static x -> Fmt.pf ppf "Static %a" pp_elt x
181 | | Dynamic f -> Fmt.pf ppf "Dynamic %a" pp_elt (f ())
182 | end
183 |
184 | (*————————————————————————————————————————————————————————————————————————————
185 | Copyright (c) 2020–2021 Craig Ferguson
186 |
187 | Permission to use, copy, modify, and/or distribute this software for any
188 | purpose with or without fee is hereby granted, provided that the above
189 | copyright notice and this permission notice appear in all copies.
190 |
191 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
192 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
193 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
194 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
195 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
196 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
197 | DEALINGS IN THE SOFTWARE.
198 | ————————————————————————————————————————————————————————————————————————————*)
199 |
--------------------------------------------------------------------------------
/src/progress/engine/units.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | open! Import
7 |
8 | module Percentage = struct
9 | let clamp (lower, upper) = min upper >> max lower
10 |
11 | let of_float =
12 | let percentage x = clamp (0, 100) (Float.to_int (x *. 100.)) in
13 | let pp ppf x = Format.fprintf ppf "%3.0d%%" (percentage x) in
14 | let to_string x = Format.asprintf "%3.0d%%" (percentage x) in
15 | Printer.create ~string_len:4 ~to_string ~pp ()
16 | end
17 |
18 | module Bytes = struct
19 | let rec power = function 1 -> 1024L | n -> Int64.mul 1024L (power (n - 1))
20 | let conv exp = Int64.(of_int >> mul (power exp))
21 | let kib = conv 1
22 | let mib = conv 2
23 | let gib = conv 3
24 | let tib = conv 4
25 | let pib = conv 5
26 |
27 | (** Pretty-printer for byte counts *)
28 | let generic (type a) (module Integer : Integer.S with type t = a) =
29 | let process_components x k =
30 | let mantissa, unit, rpad =
31 | match[@ocamlformat "disable"] Integer.to_float x with
32 | | n when Float.(n < 1024. ) -> (n , "B", " ")
33 | | n when Float.(n < 1024. ** 2.) -> (n /. 1024. , "KiB", "")
34 | | n when Float.(n < 1024. ** 3.) -> (n /. (1024. ** 2.), "MiB", "")
35 | | n when Float.(n < 1024. ** 4.) -> (n /. (1024. ** 3.), "GiB", "")
36 | | n when Float.(n < 1024. ** 5.) -> (n /. (1024. ** 4.), "TiB", "")
37 | | n when Float.(n < 1024. ** 6.) -> (n /. (1024. ** 5.), "PiB", "")
38 | | n -> (n /. (1024. ** 6.), "EiB", "")
39 | in
40 | (* Round down to the nearest 0.1 *)
41 | let mantissa = Float.trunc (mantissa *. 10.) /. 10. in
42 | let lpad =
43 | match mantissa with
44 | | n when Float.(n < 10.) -> " "
45 | | n when Float.(n < 100.) -> " "
46 | | n when Float.(n < 1000.) -> " "
47 | | _ -> ""
48 | in
49 | k ~mantissa ~unit ~rpad ~lpad
50 | in
51 | let pp ppf x =
52 | process_components x (fun ~mantissa ~unit ~rpad:_ ~lpad:_ ->
53 | Fmt.pf ppf "%.1f %s" mantissa unit)
54 | in
55 | let to_string x =
56 | process_components x (fun ~mantissa ~unit ~rpad ~lpad ->
57 | Printf.sprintf "%s%.1f %s%s" lpad mantissa unit rpad)
58 | in
59 | let string_len = 10 in
60 | Printer.create ~to_string ~string_len ~pp ()
61 |
62 | let of_int = generic (module Integer.Int)
63 | let of_int63 = generic (module Integer.Int63)
64 | let of_int64 = generic (module Integer.Int64)
65 | let of_float = generic (module Integer.Float)
66 | let pp_int63 = Printer.to_pp of_int63
67 | end
68 |
69 | module Duration = struct
70 | let mm_ss =
71 | let to_string span =
72 | let span_s = Mtime.span_to_s span in
73 | let minutes = Float.div span_s 60. |> Float.floor in
74 | let seconds = Float.rem span_s 60. |> Float.floor in
75 | (* Reasonable values correctly, but Mtime.Span.max_span must
76 | print to "--:--" as {!Line.eta} relies on it. *)
77 | if Float.compare span_s 0. < 0 || Float.compare minutes 1e4 > 0 then
78 | "--:--"
79 | else Printf.sprintf "%02.0f:%02.0f" minutes seconds
80 | in
81 | Printer.create ~string_len:5 ~to_string ()
82 |
83 | let hh_mm_ss =
84 | let to_string span =
85 | let seconds = Mtime.span_to_s span in
86 | if Float.compare seconds 0. < 0 then "--:--:--"
87 | else
88 | Printf.sprintf "%02.0f:%02.0f:%02.0f"
89 | (Float.div seconds 3600. |> Float.floor)
90 | (Float.(rem (div seconds 60.) 60.) |> Float.floor)
91 | (Float.rem seconds 60. |> Float.floor)
92 | in
93 | Printer.create ~string_len:8 ~to_string ()
94 | end
95 |
96 | (*————————————————————————————————————————————————————————————————————————————
97 | Copyright (c) 2020–2021 Craig Ferguson
98 |
99 | Permission to use, copy, modify, and/or distribute this software for any
100 | purpose with or without fee is hereby granted, provided that the above
101 | copyright notice and this permission notice appear in all copies.
102 |
103 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
104 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
105 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
106 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
107 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
108 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
109 | DEALINGS IN THE SOFTWARE.
110 | ————————————————————————————————————————————————————————————————————————————*)
111 |
--------------------------------------------------------------------------------
/src/progress/engine/units.mli:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | open! Import
7 |
8 | (** Pretty-printing utilities for common units used in progress bars. *)
9 |
10 | (** Printers for time durations (e.g. [MM:SS], [HH:MM:SS]). *)
11 | module Duration : sig
12 | val mm_ss : Duration.t Printer.t
13 | (** Prints a time span in fixed-width [MM:SS] form. *)
14 |
15 | val hh_mm_ss : Duration.t Printer.t
16 | (** Prints a time span in fixed-width [HH:MM:SS] form. *)
17 | end
18 |
19 | (** Prints a proportion as a percentage (e.g. [42%]).
20 |
21 | {[
22 | 0. ↦ " 0%"
23 | 0.42 ↦ " 42%"
24 | 0.9999 ↦ " 99%"
25 | 1. ↦ "100%"
26 | ]}
27 |
28 | {b Note:} values will be clamped into the range [[0., 1.]]. *)
29 | module Percentage : sig
30 | val of_float : float Printer.t
31 | end
32 |
33 | (** Prints a numeric value as as a byte count.
34 |
35 | {[
36 | 0 ↦ " 0.0 B "
37 | 999 ↦ " 999.0 B "
38 | 1024 ↦ " 1.0 KiB"
39 | 1024 * 1023 ↦ "1023.0 KiB"
40 | 1024 * 1024 - 1 ↦ "1023.9 KiB"
41 | ]}*)
42 | module Bytes : sig
43 | val generic : (module Integer.S with type t = 't) -> 't Printer.t
44 | val of_int : int Printer.t
45 | val of_float : float Printer.t
46 | val of_int64 : int64 Printer.t
47 |
48 | (** Quick builders for base-2 byte counts *)
49 |
50 | val kib : int -> int64
51 | (** [kib n] is [n] kibibytes. *)
52 |
53 | val mib : int -> int64
54 | (** [mib n] is [n] mebibytes. *)
55 |
56 | val gib : int -> int64
57 | (** [gib n] is [n] gibibytes. *)
58 |
59 | val tib : int -> int64
60 | (** [tib n] is [n] tebibytes. *)
61 |
62 | val pib : int -> int64
63 | (** [pib n] is [n] pebibytes. *)
64 |
65 | val pp_int63 : int63 Fmt.t
66 | end
67 |
68 | (*————————————————————————————————————————————————————————————————————————————
69 | Copyright (c) 2020–2021 Craig Ferguson
70 |
71 | Permission to use, copy, modify, and/or distribute this software for any
72 | purpose with or without fee is hereby granted, provided that the above
73 | copyright notice and this permission notice appear in all copies.
74 |
75 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
76 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
77 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
78 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
79 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
80 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
81 | DEALINGS IN THE SOFTWARE.
82 | ————————————————————————————————————————————————————————————————————————————*)
83 |
--------------------------------------------------------------------------------
/src/progress/progress.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | module Platform = struct
7 | module Clock = Mtime_clock
8 | module Terminal_width = Terminal_width
9 | end
10 |
11 | include Progress_engine.Make (Platform)
12 |
13 | module Config = struct
14 | include Config
15 |
16 | let stderr_if_tty =
17 | if Unix.(isatty stderr) then Default.ppf
18 | else Format.make_formatter (fun _ _ _ -> ()) (fun () -> ())
19 |
20 | let v ?(ppf = stderr_if_tty) ?hide_cursor ?persistent ?max_width ?min_interval
21 | () : t =
22 | v ~ppf ?hide_cursor ?persistent ?max_width ?min_interval ()
23 | end
24 |
25 | (*————————————————————————————————————————————————————————————————————————————
26 | Copyright (c) 2020–2021 Craig Ferguson
27 |
28 | Permission to use, copy, modify, and/or distribute this software for any
29 | purpose with or without fee is hereby granted, provided that the above
30 | copyright notice and this permission notice appear in all copies.
31 |
32 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
33 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
34 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
35 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
36 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
37 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
38 | DEALINGS IN THE SOFTWARE.
39 | ————————————————————————————————————————————————————————————————————————————*)
40 |
--------------------------------------------------------------------------------
/src/progress/progress.mli:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | (** A library for displaying progress bars, including support for rendering
7 | multiple bars at once. Start by {{!description} describing} of a sequence of
8 | progress bars, then begin {{!rendering} rendering} them.
9 |
10 | {[
11 | (** Description: "⠼️ [###########--------------------] 37/100" *)
12 | let bar ~total =
13 | let open Progress.Line in
14 | list [ spinner (); bar total; count_to total ]
15 |
16 | (** Rendering: get access to a function [f] for reporting progress. *)
17 | let run () =
18 | Progress.with_reporter (bar ~total:100) (fun f ->
19 | for i = 1 to 100 do
20 | (* ... do some work ... *)
21 | f 1 (* report some progress *)
22 | done)
23 | ]}
24 |
25 | See {!Progress_engine} for an equivalent API that is portable to non-Unix
26 | platforms. *)
27 |
28 | include Progress_engine.S
29 | (** @inline *)
30 |
31 | (*————————————————————————————————————————————————————————————————————————————
32 | Copyright (c) 2020–2021 Craig Ferguson
33 |
34 | Permission to use, copy, modify, and/or distribute this software for any
35 | purpose with or without fee is hereby granted, provided that the above
36 | copyright notice and this permission notice appear in all copies.
37 |
38 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
39 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
40 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
41 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
42 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
43 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
44 | DEALINGS IN THE SOFTWARE.
45 | ————————————————————————————————————————————————————————————————————————————*)
46 |
--------------------------------------------------------------------------------
/src/progress/terminal_width.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | let latest_width = ref None
7 | let refresh () = latest_width := Terminal.Size.get_columns ()
8 | let initialize = lazy (refresh ())
9 |
10 | let get () =
11 | Lazy.force initialize;
12 | !latest_width
13 |
14 | let set_changed_callback on_change =
15 | Terminal.Size.set_changed_callback (fun () ->
16 | refresh ();
17 | on_change !latest_width)
18 |
19 | (*————————————————————————————————————————————————————————————————————————————
20 | Copyright (c) 2020–2021 Craig Ferguson
21 |
22 | Permission to use, copy, modify, and/or distribute this software for any
23 | purpose with or without fee is hereby granted, provided that the above
24 | copyright notice and this permission notice appear in all copies.
25 |
26 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
27 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
28 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
29 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
30 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
31 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
32 | DEALINGS IN THE SOFTWARE.
33 | ————————————————————————————————————————————————————————————————————————————*)
34 |
--------------------------------------------------------------------------------
/src/progress/tests/common.ml:
--------------------------------------------------------------------------------
1 | let check_invalid ~__POS__:pos f =
2 | match f () with
3 | | _ ->
4 | Alcotest.fail ~pos
5 | "Expected [Invalid_argument], but no exception was raised."
6 | | exception Invalid_argument _ -> ()
7 |
--------------------------------------------------------------------------------
/src/progress/tests/dune:
--------------------------------------------------------------------------------
1 | (test
2 | (name test)
3 | (package progress)
4 | (libraries progress alcotest astring fmt mtime))
5 |
--------------------------------------------------------------------------------
/src/progress/tests/test.ml:
--------------------------------------------------------------------------------
1 | open Astring
2 |
3 | let ( -- ), ( // ) = Int64.(sub, div)
4 | let almost f = f -. Float.epsilon
5 | let ( let@ ) f x = f x
6 |
7 | let config =
8 | Progress.Config.v ~ppf:Format.str_formatter ~hide_cursor:false
9 | ~persistent:true ~max_width:(Some 50) ~min_interval:None ()
10 |
11 | let read_bar () =
12 | Format.flush_str_formatter ()
13 | |> String.trim ~drop:(function '\r' | '\n' -> true | _ -> false)
14 |
15 | let check_bar ~__POS__:pos expected =
16 | Alcotest.check ~pos
17 | Alcotest.(testable Fmt.Dump.string String.equal)
18 | ("Expected state: " ^ expected)
19 | expected (read_bar ())
20 |
21 | let clear_test_state () = ignore (Format.flush_str_formatter () : string)
22 |
23 | let test_pair () =
24 | let bar =
25 | Progress.(
26 | Line.(
27 | pair ~sep:(const ", ")
28 | (of_printer ~init:0 (Printer.int ~width:1))
29 | (of_printer ~init:"foo" (Printer.string ~width:3))))
30 | in
31 | let () =
32 | let@ report = Progress.with_reporter ~config bar in
33 | check_bar ~__POS__ "0, foo";
34 | report (1, "bar");
35 | check_bar ~__POS__ "1, bar"
36 | in
37 | check_bar ~__POS__ "1, bar"
38 |
39 | let test_unicode_bar () =
40 | let () =
41 | let@ report =
42 | Progress.Line.Using_float.bar ~data:`Latest ~style:`UTF8 ~width:(`Fixed 3)
43 | 1.
44 | |> Progress.with_reporter ~config
45 | in
46 | let expect ~__POS__:pos s f =
47 | report f;
48 | check_bar ~__POS__:pos s
49 | in
50 | check_bar ~__POS__ "│ │";
51 | expect ~__POS__ "" 0.;
52 | expect ~__POS__ "" (almost (1. /. 8.));
53 | expect ~__POS__ "│▏│" (1. /. 8.);
54 | expect ~__POS__ "" (almost (2. /. 8.));
55 | expect ~__POS__ "│▎│" (2. /. 8.);
56 | expect ~__POS__ "" (almost (3. /. 8.));
57 | expect ~__POS__ "│▍│" (3. /. 8.);
58 | expect ~__POS__ "" (almost (4. /. 8.));
59 | expect ~__POS__ "│▌│" (4. /. 8.);
60 | expect ~__POS__ "" (almost (5. /. 8.));
61 | expect ~__POS__ "│▋│" (5. /. 8.);
62 | expect ~__POS__ "" (almost (6. /. 8.));
63 | expect ~__POS__ "│▊│" (6. /. 8.);
64 | expect ~__POS__ "" (almost (7. /. 8.));
65 | expect ~__POS__ "│▉│" (7. /. 8.);
66 | expect ~__POS__ "" (almost 1.);
67 | expect ~__POS__ "│█│" 1.;
68 | expect ~__POS__ "" (1. +. Float.epsilon);
69 | expect ~__POS__ "" (1. +. (1. /. 8.));
70 | expect ~__POS__ "" (almost 2.)
71 | in
72 | clear_test_state ();
73 | let () =
74 | let@ report =
75 | Progress.Line.Using_float.bar ~data:`Latest ~style:`UTF8 ~width:(`Fixed 5)
76 | 1.
77 | |> Progress.with_reporter ~config
78 | in
79 | let expect s f =
80 | report f;
81 | check_bar s
82 | in
83 | check_bar ~__POS__ "│ │";
84 | expect ~__POS__ "" 0.;
85 | expect ~__POS__ "│█▌ │" 0.5;
86 | expect ~__POS__ "│██▉│" (almost 1.);
87 | expect ~__POS__ "│███│" 1.
88 | in
89 | ()
90 |
91 | let test_progress_bar_lifecycle () =
92 | let open Progress.Units.Bytes in
93 | let@ report =
94 | let open Progress.Line.Using_int64 in
95 | let total = gib 1 in
96 | list
97 | [ const ""
98 | ; bytes
99 | ; bar ~style:`ASCII ~width:(`Fixed 29) total
100 | ++ const " "
101 | ++ percentage_of total
102 | ]
103 | |> Progress.with_reporter ~config
104 | in
105 | check_bar ~__POS__ " 0.0 B [---------------------------] 0%";
106 | report (kib 1 -- 1L);
107 | check_bar ~__POS__ " 1023.0 B [---------------------------] 0%";
108 | report 1L;
109 | check_bar ~__POS__ " 1.0 KiB [---------------------------] 0%";
110 | report (mib 1 -- kib 1 -- 1L);
111 | (* Should always round downwards. *)
112 | check_bar ~__POS__ " 1023.9 KiB [---------------------------] 0%";
113 | report 1L;
114 | check_bar ~__POS__ " 1.0 MiB [---------------------------] 0%";
115 | report (mib 49);
116 | check_bar ~__POS__ " 50.0 MiB [#--------------------------] 4%";
117 | report (mib 450);
118 | check_bar ~__POS__ " 500.0 MiB [#############--------------] 48%";
119 | report (gib 1 -- mib 500 -- 1L);
120 | (* 1 byte from completion. Should show 99% and not a full 1024 MiB. *)
121 | check_bar ~__POS__ " 1023.9 MiB [##########################-] 99%";
122 | report 1L;
123 | (* Now exactly complete *)
124 | check_bar ~__POS__ " 1.0 GiB [###########################] 100%";
125 | (* Subsequent reports don't overflow the bar *)
126 | report (gib 1 // 2L);
127 | check_bar ~__POS__ " 1.5 GiB [###########################] 100%";
128 | ()
129 |
130 | let test_progress_bar_width () =
131 | let check_width width =
132 | clear_test_state ();
133 | let@ _report =
134 | let open Progress.Line.Using_int64 in
135 | Progress.with_reporter ~config
136 | (bar ~style:`ASCII ~width:(`Fixed width) 1L)
137 | in
138 | let s = read_bar () in
139 | String.length s
140 | |> Alcotest.(check int) (Fmt.str "Expected width of %d: `%S`" width s) width
141 | in
142 | check_width 80;
143 | check_width 40;
144 | Alcotest.check_raises "Overly small progress bar"
145 | (Failure "Not enough space for a progress bar") (fun () -> check_width 2)
146 |
147 | let test_preprovided_counter () =
148 | let pp = Progress.Printer.(using ~f:Int64.to_int (int ~width:3)) in
149 | let@ report = Progress.counter ~pp 999L |> Progress.with_reporter ~config in
150 | check_bar ~__POS__ " 0 00:00 [---------------------------------] 0%";
151 | report 1L;
152 | check_bar ~__POS__ " 1 00:00 [---------------------------------] 0%";
153 | report 1L;
154 | check_bar ~__POS__ " 2 00:00 [---------------------------------] 0%";
155 | report 10L;
156 | check_bar ~__POS__ " 12 00:00 [---------------------------------] 1%";
157 | report 100L;
158 | check_bar ~__POS__ "112 00:00 [###------------------------------] 11%";
159 | report 886L;
160 | check_bar ~__POS__ "998 00:00 [################################-] 99%";
161 | report 1L;
162 | check_bar ~__POS__ "999 00:00 [#################################] 100%"
163 |
164 | module Boxes = struct
165 | let unsized =
166 | Progress.Line.Internals.alpha_unsized ~initial:(`Val ())
167 | (fun ~width:_ _ _ _ -> 0)
168 |
169 | let test_unsized_not_in_box () =
170 | Alcotest.check_raises "Unsized element not contained in a box"
171 | (Invalid_argument
172 | "Encountered an expanding element that is not contained in a box")
173 | @@ fun () ->
174 | Progress.(with_reporter Line.Internals.(to_line unsized) Fun.id ())
175 |
176 | let test_two_unsized_in_box () =
177 | Alcotest.check_raises "Two unsized elements in a box"
178 | (Invalid_argument
179 | "Multiple expansion points encountered. Cannot pack two unsized \
180 | segments in a single box.")
181 | @@ fun () ->
182 | Progress.(
183 | with_reporter
184 | Line.Internals.(to_line @@ box_fixed 10 (array [| unsized; unsized |]))
185 | Fun.id ())
186 | end
187 |
188 | let () =
189 | let open Alcotest in
190 | run __FILE__
191 | [ ( "main"
192 | , [ test_case "Pair" `Quick test_pair
193 | ; test_case "Unicode bar" `Quick test_unicode_bar
194 | ; test_case "Progress bar lifecycle" `Quick test_progress_bar_lifecycle
195 | ; test_case "Progress bar width" `Quick test_progress_bar_width
196 | ; test_case "Pre-provided counter" `Quick test_preprovided_counter
197 | ] )
198 | ; ( "boxes"
199 | , [ test_case "Unsized element not in box" `Quick
200 | Boxes.test_unsized_not_in_box
201 | ; test_case "Two unsized elements in box" `Quick
202 | Boxes.test_two_unsized_in_box
203 | ] )
204 | ; ("units", Test_units.tests)
205 | ; ("printers", Test_printers.tests)
206 | ; ("flow_meter", Test_flow_meter.tests)
207 | ]
208 |
--------------------------------------------------------------------------------
/src/progress/tests/test.mli:
--------------------------------------------------------------------------------
1 | (* intentionally empty *)
2 |
--------------------------------------------------------------------------------
/src/progress/tests/test_flow_meter.ml:
--------------------------------------------------------------------------------
1 | open struct
2 | module Flow_meter = Progress_engine.Exposed_for_testing.Flow_meter
3 | module Duration = Progress.Duration
4 | end
5 |
6 | let gen_test_state () =
7 | let now = ref (Mtime.of_uint64_ns 0L) in
8 | let clock () = !now in
9 | let flow_meter = Flow_meter.create ~clock ~size:3 ~elt:(module Int) in
10 | let record ~interval x =
11 | now := Option.get (Mtime.add_span !now interval);
12 | Flow_meter.record flow_meter x
13 | in
14 | let check pos v =
15 | Alcotest.(check ~pos int)
16 | "Expected flow rate" v
17 | (Flow_meter.per_second flow_meter |> Int.of_float)
18 | in
19 | (record, check)
20 |
21 | (* Tests of flow rate in which samples are all 1ms apart. *)
22 | let test_linear () =
23 | let record, check = gen_test_state () in
24 | let record = record ~interval:Duration.millisecond in
25 | (* Initial flow is 0 *)
26 | check __POS__ 0;
27 | check __POS__ 0;
28 | (* Flow rate is 0 until we have at least 2 samples *)
29 | record 1;
30 | check __POS__ 0;
31 | record 1;
32 | check __POS__ 1000 (* 1 in 1 ms *);
33 | record 0;
34 | check __POS__ 500 (* (1 + 0) in 2 ms *);
35 | record 1;
36 | check __POS__ 666 (* (1 + 0 + 1) in 3 ms *);
37 | record 1;
38 | check __POS__ 666 (* (0 + 1 + 1) in 3 ms *);
39 | record 1;
40 | check __POS__ 1000 (* (1 + 1 + 1) in 3 ms *);
41 | record (-1);
42 | check __POS__ 333 (* (1 + 1 + -1) in 3 ms *);
43 | record (-1);
44 | check __POS__ (-333) (* (1 + -1 + -1) in 3 ms *);
45 | record 2;
46 | check __POS__ 0 (* (-1 + -1 + 2) in 3 ms *);
47 | ()
48 |
49 | let test_non_linear () =
50 | let record, check = gen_test_state () in
51 | (* Initial flow is 0 *)
52 | check __POS__ 0;
53 | check __POS__ 0;
54 | (* Flow rate is 0 until we have at least 2 samples *)
55 | record ~interval:Duration.zero 1;
56 | record ~interval:Duration.zero 1;
57 | record ~interval:Duration.zero 1;
58 | check __POS__ 0 (* 3 in 0 ms *);
59 | record ~interval:Duration.millisecond 0;
60 | check __POS__ 2000 (* (1 + 1 + 0) in 1 ms *);
61 | record ~interval:Duration.zero 0;
62 | check __POS__ 1000 (* (1 + 0 + 0) in 1 ms *);
63 | record ~interval:Duration.zero 0;
64 | check __POS__ 0 (* (0 + 0 + 0) in 1 ms *);
65 | record ~interval:Duration.zero 3;
66 | check __POS__ 0 (* (0 + 0 + 3) in 0 ms *);
67 | ()
68 |
69 | let tests =
70 | [ ("linear", `Quick, test_linear); ("non-linear", `Quick, test_non_linear) ]
71 |
--------------------------------------------------------------------------------
/src/progress/tests/test_flow_meter.mli:
--------------------------------------------------------------------------------
1 | val tests : unit Alcotest.test_case list
2 |
--------------------------------------------------------------------------------
/src/progress/tests/test_printers.ml:
--------------------------------------------------------------------------------
1 | open Common
2 |
3 | open struct
4 | module Printer = Progress.Printer
5 | module Color = Progress.Color
6 |
7 | let check_print print ~__POS__:pos str x =
8 | Alcotest.(check ~pos (testable Fmt.Dump.string String.equal))
9 | "" str (print x)
10 | end
11 |
12 | let test_int () =
13 | let print = Printer.(to_to_string (int ~width:5)) in
14 | let check = check_print print in
15 | check ~__POS__ "12345" 12345;
16 | check ~__POS__ "-2345" (-2345);
17 | check ~__POS__ " 1" 1;
18 | check ~__POS__ " -1" (-1);
19 | check_invalid ~__POS__ (fun () -> print 123456);
20 | check_invalid ~__POS__ (fun () -> print (-23456));
21 | ()
22 |
23 | let test_string () =
24 | let check ?(width = 8) = check_print Printer.(to_to_string (string ~width)) in
25 |
26 | (* ASCII strings *)
27 | check ~__POS__ " " "";
28 | check ~__POS__ "hello " "hello";
29 | check ~__POS__ " hello " " hello";
30 | check ~__POS__ "hello me" "hello me";
31 | check ~__POS__ "hello..." "hello world";
32 |
33 | (* Short ASCII strings (within maximum ellipsis size) *)
34 | check ~__POS__ ~width:3 "abc" "abc";
35 | check ~__POS__ ~width:3 "..." "abcd";
36 | check ~__POS__ ~width:2 "ab" "ab";
37 | check ~__POS__ ~width:2 ".." "abc";
38 | check ~__POS__ ~width:1 "a" "a";
39 | check ~__POS__ ~width:1 "." "ab";
40 | check ~__POS__ ~width:0 "" "";
41 | check ~__POS__ ~width:0 "" "a";
42 |
43 | (* Non-ASCII UTF8 strings *)
44 | check ~__POS__ "————————" "————————";
45 | check ~__POS__ "—————..." "—————————";
46 | check ~__POS__ ~width:3 "———" "———";
47 | check ~__POS__ ~width:3 "..." "————";
48 | check ~__POS__ ~width:2 ".." "———";
49 | check ~__POS__ ~width:1 "." "——";
50 |
51 | (* Strings containing ANSI colour escapes *)
52 | let () =
53 | let col c s =
54 | Terminal.Style.(code (fg (Color.ansi c))) ^ s ^ Terminal.Style.(code none)
55 | in
56 | (* Build up a coloured "hello world" string, retaining prefixes *)
57 | let h = col `red "h" in
58 | let he = h ^ col `blue "e" in
59 | let hel = he ^ col `green "l" in
60 | let hell = hel ^ "l" in
61 | let hello = hell ^ col `red "o" in
62 | let hello_world = hello ^ col `magenta " " ^ col `yellow "w" ^ "orld" in
63 |
64 | (* Check that ppadding is applied correctly *)
65 | check ~width:13 ~__POS__ (hello_world ^ " ") hello_world;
66 | check ~width:12 ~__POS__ (hello_world ^ " ") hello_world;
67 | check ~width:11 ~__POS__ hello_world hello_world;
68 |
69 | (* Check that it truncates correctly at each point *)
70 | check ~width:8 ~__POS__ (hello ^ "...") hello_world;
71 | check ~width:7 ~__POS__ (hell ^ "...") hello_world;
72 | check ~width:6 ~__POS__ (hel ^ "...") hello_world;
73 | check ~width:5 ~__POS__ (he ^ "...") hello_world;
74 | check ~width:4 ~__POS__ (h ^ "...") hello_world;
75 | check ~width:3 ~__POS__ "..." hello_world;
76 | check ~width:2 ~__POS__ ".." hello_world;
77 | check ~width:1 ~__POS__ "." hello_world;
78 | check ~width:0 ~__POS__ "" hello_world
79 | in
80 |
81 | ()
82 |
83 | let tests =
84 | Alcotest.
85 | [ test_case "int" `Quick test_int; test_case "string" `Quick test_string ]
86 |
--------------------------------------------------------------------------------
/src/progress/tests/test_printers.mli:
--------------------------------------------------------------------------------
1 | val tests : unit Alcotest.test_case list
2 |
--------------------------------------------------------------------------------
/src/progress/tests/test_units.ml:
--------------------------------------------------------------------------------
1 | let almost f = f -. Float.epsilon
2 | let ( - ) = Int64.sub
3 |
4 | let expect_pp_fixed ?relaxed_length ~pp:pp_fixed s f =
5 | let result = Progress.Printer.to_to_string pp_fixed f in
6 | Alcotest.(check string) (Fmt.str "Expected rendering of %s" s) s result;
7 | match relaxed_length with
8 | | Some () -> ()
9 | | None ->
10 | Alcotest.(check int)
11 | "Expected length"
12 | (Progress.Printer.print_width pp_fixed)
13 | (String.length result)
14 |
15 | let test_percentage () =
16 | let expect = expect_pp_fixed ~pp:Progress.Units.Percentage.of_float in
17 | expect " 0%" (-0.1);
18 | expect " 0%" (almost 0.01);
19 | expect " 1%" 0.01;
20 | expect " 1%" (0.01 +. Float.epsilon);
21 | expect " 10%" 0.1;
22 | expect " 50%" 0.5;
23 | expect " 99%" (almost 1.);
24 | expect "100%" 1.;
25 | expect "100%" (1. +. Float.epsilon);
26 | expect "100%" 1.1;
27 | ()
28 |
29 | let test_bytes () =
30 | let expect = expect_pp_fixed ~pp:Progress.Units.Bytes.of_int64 in
31 | let open Progress.Units.Bytes in
32 | expect " 0.0 B " 0L;
33 | expect " 999.0 B " 999L;
34 | expect " 1.0 KiB" (kib 1);
35 | expect "1023.0 KiB" (mib 1 - kib 1);
36 | expect "1023.9 KiB" (mib 1 - 1L);
37 | expect " 1.0 MiB" (mib 1);
38 | expect " 1.0 TiB" (tib 1);
39 | expect " 1.0 PiB" (pib 1);
40 | expect " 1.0 EiB" (pib 1024);
41 | ()
42 |
43 | let test_duration () =
44 | let module D = Progress.Duration.Of_int in
45 | let () =
46 | let expect = expect_pp_fixed ~pp:Progress.Units.Duration.mm_ss in
47 | expect "00:00" D.(sec 0);
48 | expect "00:29" D.(sec 29);
49 | expect "00:30" D.(sec 30);
50 | expect "00:30" D.(ms 30_400);
51 | expect "00:59" D.(ms 59_600);
52 | expect "01:00" D.(min 1);
53 | expect "01:00" D.(min 1 + ms 400);
54 | expect "99:00" D.(min 99);
55 | expect "99:59" D.(min 99 + sec 59);
56 | (* [eta] relies on this: *)
57 | expect "--:--" Mtime.Span.max_span;
58 | (* Fail gracefully: *)
59 | expect ~relaxed_length:() "100:00" D.(min 100)
60 | in
61 |
62 | let () =
63 | let expect = expect_pp_fixed ~pp:Progress.Units.Duration.hh_mm_ss in
64 | expect "00:00:00" D.(sec 0);
65 | expect "00:00:59" D.(ms 59_600);
66 | expect "00:01:00" D.(min 1);
67 | expect "00:01:00" D.(min 1 + ms 400);
68 | expect "00:59:59" D.(min 59 + sec 59 + ms 999);
69 | expect "01:00:00" D.(hour 1);
70 | expect "01:00:00" D.(hour 1 + ms 1);
71 | expect "99:59:59" D.(hour 99 + min 59 + sec 59 + ms 999);
72 | (* Fail gracefully: *)
73 | expect ~relaxed_length:() "100:00:00" D.(hour 100)
74 | in
75 |
76 | ()
77 |
78 | let tests =
79 | Alcotest.
80 | [ test_case "percentage" `Quick test_percentage
81 | ; test_case "bytes" `Quick test_bytes
82 | ; test_case "duration" `Quick test_duration
83 | ]
84 |
--------------------------------------------------------------------------------
/src/progress/tests/test_units.mli:
--------------------------------------------------------------------------------
1 | val tests : unit Alcotest.test_case list
2 |
--------------------------------------------------------------------------------
/src/terminal/ansi/ansi.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | open! Import
7 |
8 | let malformed_string s =
9 | Format.kasprintf invalid_arg "Terminal.Ansi: malformed UTF-8 string: %S" s
10 |
11 | module Length_counter = struct
12 | (* Counting length of UTF-8 strings while skipping ANSI escape sequences. See
13 | https://en.wikipedia.org/wiki/ANSI_escape_code#Fe_Escape_sequences for
14 | details. *)
15 | type t =
16 | { mutable acc : int
17 | ; mutable state :
18 | [ `Normal
19 | | `Parsing_ansi_sequence (* Read '\x1b', but not the subsequent byte. *)
20 | | `Ansi_parameter_bytes (* Inside a CSI parameter sequence *) ]
21 | }
22 |
23 | let empty () = { acc = 0; state = `Normal }
24 | let is_initial_ansi_byte c = Char.equal c '\x1b'
25 |
26 | let is_final_ansi_byte c =
27 | let c = Char.code c in
28 | c >= 0x40 && c <= 0x7e
29 |
30 | let guess_printed_char_length c =
31 | match Uucp.Break.tty_width_hint c with
32 | | -1 -> 1 (* Assume width of 1 if [Uucp] can't guess *)
33 | | n -> n
34 |
35 | let add t c =
36 | match Uchar.is_char c with
37 | | false -> t.acc <- t.acc + guess_printed_char_length c
38 | | true -> (
39 | let c = Uchar.to_char c in
40 | match t.state with
41 | | `Normal ->
42 | if is_initial_ansi_byte c then t.state <- `Parsing_ansi_sequence
43 | else t.acc <- t.acc + 1
44 | | `Parsing_ansi_sequence ->
45 | if Char.equal c '[' (* Control sequence introducer *) then
46 | t.state <- `Ansi_parameter_bytes
47 | else t.state <- `Normal
48 | | `Ansi_parameter_bytes ->
49 | if is_final_ansi_byte c then t.state <- `Normal)
50 |
51 | let count t = t.acc
52 | end
53 |
54 | let guess_printed_width s =
55 | let count = Length_counter.empty () in
56 | Uutf.String.fold_utf_8
57 | (fun () _ -> function
58 | | `Malformed _ -> malformed_string s
59 | | `Uchar c -> Length_counter.add count c)
60 | () s;
61 | Length_counter.count count
62 |
63 | let uchar_size u =
64 | match Uchar.to_int u with
65 | | u when u < 0 -> assert false
66 | | u when u <= 0x007F -> 1
67 | | u when u <= 0x07FF -> 2
68 | | u when u <= 0xFFFF -> 3
69 | | u when u <= 0x10FFFF -> 4
70 | | _ -> assert false
71 |
72 | exception Exit of int
73 |
74 | let string_equal : string -> string -> bool = ( = )
75 |
76 | let truncate_to_width width s =
77 | if width < 0 then
78 | Format.kasprintf invalid_arg
79 | "Terminal.truncate_to_width: negative width %d requested" width;
80 | let count = Length_counter.empty () in
81 | try
82 | Uutf.String.fold_utf_8
83 | (fun () i -> function
84 | | `Malformed _ -> malformed_string s
85 | | `Uchar c ->
86 | if Length_counter.count count = width then
87 | (* Check for display reset, and add it if it's there; truncating
88 | this would cause the open colour to leak. *)
89 | let display_reset = "\027[0m" in
90 | if
91 | i + 4 <= String.length s
92 | && string_equal (String.sub s ~pos:i ~len:4) display_reset
93 | then raise (Exit (i + 4))
94 | else raise (Exit i)
95 | else (
96 | Length_counter.add count c;
97 | let count = Length_counter.count count in
98 | if count <= width then () else raise (Exit i)))
99 | () s;
100 | s
101 | with Exit len -> String.sub s ~pos:0 ~len
102 |
103 | let show_cursor = "\x1b[?25h"
104 | let hide_cursor = "\x1b[?25l"
105 | let erase_display_suffix = "\x1b[J"
106 | let erase_line = "\x1b[K"
107 | let move_up ppf = function 0 -> () | n -> Format.fprintf ppf "\x1b[%dA" n
108 | let move_down ppf = function 0 -> () | n -> Format.fprintf ppf "\x1b[%dB" n
109 |
110 | (*————————————————————————————————————————————————————————————————————————————
111 | Copyright (c) 2020–2021 Craig Ferguson
112 |
113 | Permission to use, copy, modify, and/or distribute this software for any
114 | purpose with or without fee is hereby granted, provided that the above
115 | copyright notice and this permission notice appear in all copies.
116 |
117 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
118 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
119 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
120 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
121 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
122 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
123 | DEALINGS IN THE SOFTWARE.
124 | ————————————————————————————————————————————————————————————————————————————*)
125 |
--------------------------------------------------------------------------------
/src/terminal/ansi/color.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | type plain =
7 | [ `black | `blue | `cyan | `green | `magenta | `red | `white | `yellow ]
8 |
9 | type t = Ansi of [ plain | `bright of plain ] | Rgb of int * int * int
10 |
11 | let pp_plain ppf x =
12 | Format.fprintf ppf
13 | (match x with
14 | | `black -> "black"
15 | | `blue -> "blue"
16 | | `cyan -> "cyan"
17 | | `green -> "green"
18 | | `magenta -> "magenta"
19 | | `red -> "red"
20 | | `white -> "white"
21 | | `yellow -> "yellow")
22 |
23 | let pp_dump ppf = function
24 | | Rgb (r, g, b) -> Format.fprintf ppf "RGB (%d, %d, %d)" r g b
25 | | Ansi (#plain as x) -> Format.fprintf ppf "ANSI (%a)" pp_plain x
26 | | Ansi (`bright x) -> Format.fprintf ppf "ANSI (bright %a)" pp_plain x
27 |
28 | let ansi x = Ansi x
29 |
30 | let rgb =
31 | let invalid_component typ n =
32 | Format.kasprintf invalid_arg "Color.rgb: invalid %s component %d" typ n
33 | in
34 | fun r g b ->
35 | if r < 0 || r > 255 then invalid_component "red" r;
36 | if g < 0 || g > 255 then invalid_component "green" g;
37 | if b < 0 || b > 255 then invalid_component "blue" b;
38 | Rgb (r, g, b)
39 |
40 | let hex =
41 | let invalid_length =
42 | Format.kasprintf invalid_arg "Color.hex: invalid hexstring length %d"
43 | in
44 | let hex c =
45 | if c >= '0' && c <= '9' then Char.code c - Char.code '0'
46 | else if c >= 'a' && c <= 'f' then Char.code c - Char.code 'a' + 10
47 | else if c >= 'A' && c <= 'F' then Char.code c - Char.code 'A' + 10
48 | else
49 | Format.kasprintf invalid_arg "Color.hex: invalid hexstring character %c" c
50 | in
51 | fun s ->
52 | let len = String.length s in
53 | if len = 0 then invalid_length len;
54 | if s.[0] <> '#' then invalid_arg "Color.hex: hexstrings must start with '#'";
55 | let r1, r0, g1, g0, b1, b0 =
56 | match len with
57 | | 7 -> (hex s.[1], hex s.[2], hex s.[3], hex s.[4], hex s.[5], hex s.[6])
58 | | 4 ->
59 | (* Short hexstrings of the form #ABC alias longer ones of the form #AABBCC *)
60 | let r, g, b = (hex s.[1], hex s.[2], hex s.[3]) in
61 | (r, r, g, g, b, b)
62 | | _ -> invalid_length len
63 | in
64 | rgb ((16 * r1) + r0) ((16 * g1) + g0) ((16 * b1) + b0)
65 |
66 | (*————————————————————————————————————————————————————————————————————————————
67 | Copyright (c) 2020–2021 Craig Ferguson
68 |
69 | Permission to use, copy, modify, and/or distribute this software for any
70 | purpose with or without fee is hereby granted, provided that the above
71 | copyright notice and this permission notice appear in all copies.
72 |
73 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
74 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
75 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
76 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
77 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
78 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
79 | DEALINGS IN THE SOFTWARE.
80 | ————————————————————————————————————————————————————————————————————————————*)
81 |
--------------------------------------------------------------------------------
/src/terminal/ansi/dune:
--------------------------------------------------------------------------------
1 | (library
2 | (name terminal_ansi)
3 | (public_name terminal.ansi)
4 | (libraries stdlib-shims uutf uucp))
5 |
--------------------------------------------------------------------------------
/src/terminal/ansi/import.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | include Stdlib.StdLabels
7 | include Stdlib.MoreLabels
8 |
9 | (*————————————————————————————————————————————————————————————————————————————
10 | Copyright (c) 2020–2021 Craig Ferguson
11 |
12 | Permission to use, copy, modify, and/or distribute this software for any
13 | purpose with or without fee is hereby granted, provided that the above
14 | copyright notice and this permission notice appear in all copies.
15 |
16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
19 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
21 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
22 | DEALINGS IN THE SOFTWARE.
23 | ————————————————————————————————————————————————————————————————————————————*)
24 |
--------------------------------------------------------------------------------
/src/terminal/ansi/style.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | type t =
7 | | None
8 | | Bold
9 | | Faint
10 | | Italic
11 | | Underline
12 | | Reverse
13 | | Fg of Color.t
14 | | Bg of Color.t
15 |
16 | let none = None
17 | let bold = Bold
18 | let faint = Faint
19 | let italic = Italic
20 | let underline = Underline
21 | let reverse = Reverse
22 | let fg x = Fg x
23 | let bg x = Bg x
24 |
25 | let code : t -> string = function
26 | | None -> "\x1b[0m"
27 | | Bold -> "\x1b[1m"
28 | | Faint -> "\x1b[2m"
29 | | Italic -> "\x1b[3m"
30 | | Underline -> "\x1b[4m"
31 | | Reverse -> "\x1b[7m"
32 | | Fg (Ansi `black) -> "\x1b[30m"
33 | | Fg (Ansi `red) -> "\x1b[31m"
34 | | Fg (Ansi `green) -> "\x1b[32m"
35 | | Fg (Ansi `yellow) -> "\x1b[33m"
36 | | Fg (Ansi `blue) -> "\x1b[34m"
37 | | Fg (Ansi `magenta) -> "\x1b[35m"
38 | | Fg (Ansi `cyan) -> "\x1b[36m"
39 | | Fg (Ansi `white) -> "\x1b[37m"
40 | | Bg (Ansi `black) -> "\x1b[40m"
41 | | Bg (Ansi `red) -> "\x1b[41m"
42 | | Bg (Ansi `green) -> "\x1b[42m"
43 | | Bg (Ansi `yellow) -> "\x1b[43m"
44 | | Bg (Ansi `blue) -> "\x1b[44m"
45 | | Bg (Ansi `magenta) -> "\x1b[45m"
46 | | Bg (Ansi `cyan) -> "\x1b[46m"
47 | | Bg (Ansi `white) -> "\x1b[47m"
48 | | Fg (Ansi (`bright `black)) -> "\x1b[90m"
49 | | Fg (Ansi (`bright `red)) -> "\x1b[91m"
50 | | Fg (Ansi (`bright `green)) -> "\x1b[92m"
51 | | Fg (Ansi (`bright `yellow)) -> "\x1b[93m"
52 | | Fg (Ansi (`bright `blue)) -> "\x1b[94m"
53 | | Fg (Ansi (`bright `magenta)) -> "\x1b[95m"
54 | | Fg (Ansi (`bright `cyan)) -> "\x1b[96m"
55 | | Fg (Ansi (`bright `white)) -> "\x1b[97m"
56 | | Bg (Ansi (`bright `black)) -> "\x1b[100m"
57 | | Bg (Ansi (`bright `red)) -> "\x1b[101m"
58 | | Bg (Ansi (`bright `green)) -> "\x1b[102m"
59 | | Bg (Ansi (`bright `yellow)) -> "\x1b[103m"
60 | | Bg (Ansi (`bright `blue)) -> "\x1b[104m"
61 | | Bg (Ansi (`bright `magenta)) -> "\x1b[105m"
62 | | Bg (Ansi (`bright `cyan)) -> "\x1b[106m"
63 | | Bg (Ansi (`bright `white)) -> "\x1b[107m"
64 | | Fg (Rgb (r, g, b)) -> Printf.sprintf "\x1b[38;2;%d;%d;%dm" r g b
65 | | Bg (Rgb (r, g, b)) -> Printf.sprintf "\x1b[48;2;%d;%d;%dm" r g b
66 |
67 | (*————————————————————————————————————————————————————————————————————————————
68 | Copyright (c) 2020–2021 Craig Ferguson
69 |
70 | Permission to use, copy, modify, and/or distribute this software for any
71 | purpose with or without fee is hereby granted, provided that the above
72 | copyright notice and this permission notice appear in all copies.
73 |
74 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
75 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
76 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
77 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
78 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
79 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
80 | DEALINGS IN THE SOFTWARE.
81 | ————————————————————————————————————————————————————————————————————————————*)
82 |
--------------------------------------------------------------------------------
/src/terminal/ansi/terminal_ansi.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | module Color = Color
7 | module Style = Style
8 | module Ansi = Ansi
9 |
10 | let guess_printed_width, truncate_to_width =
11 | Ansi.(guess_printed_width, truncate_to_width)
12 |
13 | (*————————————————————————————————————————————————————————————————————————————
14 | Copyright (c) 2020–2021 Craig Ferguson
15 |
16 | Permission to use, copy, modify, and/or distribute this software for any
17 | purpose with or without fee is hereby granted, provided that the above
18 | copyright notice and this permission notice appear in all copies.
19 |
20 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
21 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
22 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
23 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
24 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
25 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
26 | DEALINGS IN THE SOFTWARE.
27 | ————————————————————————————————————————————————————————————————————————————*)
28 |
--------------------------------------------------------------------------------
/src/terminal/ansi/terminal_ansi.mli:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | (** This library provides a small set of standard utility functions for
7 | interacting with terminals.
8 |
9 | Note that this module does not depend on the [unix] library. There is
10 | therefore a way to use [Terminal_ansi] and [progress.engine] in a context
11 | other than a POSIX system (such as a unikernel). To do this, you need to
12 | compose [Terminal_ansi] with a library that looks like [terminal.unix]
13 | (which should allow you to obtain the size of a TTY). It would then be
14 | sufficient to compose the latter (just as the [terminal] library does) to
15 | then be able to use [Progess_engine.Make] with the result of this
16 | composition. *)
17 |
18 | module Color : sig
19 | type t
20 | (** The type of colours that can be rendered to a terminal. *)
21 |
22 | (** {1 4-bit ANSI colours}
23 |
24 | Colours built using {!ansi} will be rendered using the standard
25 | {{:https://en.wikipedia.org/wiki/ANSI_escape_code#3-bit_and_4-bit} 4-bit
26 | ANSI escape codes} for terminals. The actual colours displayed to the
27 | user depend on their terminal configuration / theme, ensuring that they
28 | look natural in context. *)
29 |
30 | type plain =
31 | [ `black | `blue | `cyan | `green | `magenta | `red | `white | `yellow ]
32 |
33 | val ansi : [ plain | `bright of plain ] -> t
34 |
35 | (** {1 24-bit RGB colours}
36 |
37 | Most modern terminals offer support for full 24-bit RGB colour (called
38 | "{{:https://en.wikipedia.org/wiki/ANSI_escape_code#24-bit} true colour}")
39 | in addition to the 16 original ANSI colours. These colours are rendered
40 | exactly as requested, offering greater flexibility at the risk of clashing
41 | with the user's theming. *)
42 |
43 | val rgb : int -> int -> int -> t
44 | (** [rgb r g b] is the RGB24 colour with the given red, green and blue colour
45 | components respectively. Raises [Invalid_argument] if any of the
46 | components are outside the range [[0, 255]]. *)
47 |
48 | val hex : string -> t
49 | (** [hex s] is the RGB24 colour given by the
50 | {{:https://en.wikipedia.org/wiki/Web_colors#Hex_triplet} hex triplet} [s],
51 | which must start with [#]. Examples:
52 |
53 | - [hex "#FF8C00"] = [rgb 0xFF 0x8C 0x00]
54 | - [hex "#fa0"] = [rgb 0xFF 0xAA 0x00]
55 |
56 | Raises [Invalid_argument] if the given string is not a [#]-prefixed hex
57 | triplet. *)
58 |
59 | val pp_dump : Format.formatter -> t -> unit
60 | (** Pretty-print a colour with an unspecified format. *)
61 | end
62 |
63 | module Style : sig
64 | type t
65 | (** The type of terminal {i styles}: values that can be printed to a terminal
66 | in order to change the way that it renders text. *)
67 |
68 | val code : t -> string
69 | (** Get the ANSI escape code for the given style. *)
70 |
71 | (** Constructing ANSI styles: *)
72 |
73 | val none : t
74 | val bold : t
75 | val faint : t
76 | val italic : t
77 | val underline : t
78 | val reverse : t
79 | val fg : Color.t -> t
80 | val bg : Color.t -> t
81 | end
82 |
83 | module Ansi : sig
84 | val show_cursor : string
85 | val hide_cursor : string
86 | val move_up : Format.formatter -> int -> unit
87 | val move_down : Format.formatter -> int -> unit
88 | val erase_line : string
89 | val erase_display_suffix : string
90 | end
91 |
92 | val guess_printed_width : string -> int
93 | (** [guess_printed_width s] returns an estimate of the number of terminal
94 | columns that the UTF-8 encoded string [s] would occupy if displayed in a
95 | terminal, after stripping any ANSI escape codes in the string.
96 |
97 | {b Note:}
98 | {i this function uses a heuristic ({!Uucp.tty_width_hint}) to guess the
99 | rendered length of supplied strings. This function is not guaranteed to
100 | be correct on all UTF-8 codepoints. See the [Uucp] documentation for
101 | details.} *)
102 |
103 | val truncate_to_width : int -> string -> string
104 | (** [truncate_to_width n s] is the longest prefix of UTF-8 encoded string [s]
105 | that will fit within [n] columns when displayed in a terminal (without
106 | including unbalanced ANSI control sequences after the [n]-th column).
107 |
108 | As with {!guess_printed_width}, the implementation relies on heuristics and
109 | so may not be accurate for all inputs (or for all terminal implementations).*)
110 |
111 | (*————————————————————————————————————————————————————————————————————————————
112 | Copyright (c) 2020–2021 Craig Ferguson
113 |
114 | Permission to use, copy, modify, and/or distribute this software for any
115 | purpose with or without fee is hereby granted, provided that the above
116 | copyright notice and this permission notice appear in all copies.
117 |
118 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
119 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
120 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
121 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
122 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
123 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
124 | DEALINGS IN THE SOFTWARE.
125 | ————————————————————————————————————————————————————————————————————————————*)
126 |
--------------------------------------------------------------------------------
/src/terminal/dune:
--------------------------------------------------------------------------------
1 | (library
2 | (public_name terminal)
3 | (name terminal)
4 | (foreign_stubs
5 | (language c)
6 | (names terminal_stubs))
7 | (libraries
8 | (re_export terminal_ansi)
9 | unix))
10 |
--------------------------------------------------------------------------------
/src/terminal/terminal.ml:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | include Terminal_ansi
7 |
8 | module Size = struct
9 | external sigwinch : unit -> int option = "ocaml_terminal_get_sigwinch"
10 | (** The number of the signal used to indicate terminal size changes. [None] on
11 | Windows. *)
12 |
13 | type dimensions = { rows : int; columns : int }
14 |
15 | external get_dimensions : unit -> dimensions option
16 | = "ocaml_terminal_get_terminal_dimensions"
17 |
18 | let get_columns () =
19 | match get_dimensions () with
20 | | Some { columns; _ } -> Some columns
21 | | None -> None
22 |
23 | let get_rows () =
24 | match get_dimensions () with Some { rows; _ } -> Some rows | None -> None
25 |
26 | let on_change = ref (fun _ -> ())
27 |
28 | let initialise =
29 | let handle_signal _ = !on_change () in
30 | lazy
31 | (match sigwinch () with
32 | | None -> ()
33 | | Some n -> Sys.set_signal n (Signal_handle handle_signal))
34 |
35 | let set_changed_callback f =
36 | Lazy.force initialise;
37 | on_change := f
38 | end
39 |
40 | (*————————————————————————————————————————————————————————————————————————————
41 | Copyright (c) 2020–2021 Craig Ferguson
42 |
43 | Permission to use, copy, modify, and/or distribute this software for any
44 | purpose with or without fee is hereby granted, provided that the above
45 | copyright notice and this permission notice appear in all copies.
46 |
47 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
48 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
49 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
50 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
51 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
52 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
53 | DEALINGS IN THE SOFTWARE.
54 | ————————————————————————————————————————————————————————————————————————————*)
55 |
--------------------------------------------------------------------------------
/src/terminal/terminal.mli:
--------------------------------------------------------------------------------
1 | (*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*)
5 |
6 | (** @inline *)
7 | include
8 | module type of Terminal_ansi
9 | with type Color.t = Terminal_ansi.Color.t
10 | and type Style.t = Terminal_ansi.Style.t
11 |
12 | module Size : sig
13 | (** Functions for getting the size of the terminal to which [stdout] is
14 | attached (provided [stdout] is a TTY). *)
15 |
16 | type dimensions = { rows : int; columns : int }
17 |
18 | val get_dimensions : unit -> dimensions option
19 | val get_columns : unit -> int option
20 | val get_rows : unit -> int option
21 | val set_changed_callback : (unit -> unit) -> unit
22 | end
23 |
24 | (*————————————————————————————————————————————————————————————————————————————
25 | Copyright (c) 2020–2021 Craig Ferguson
26 |
27 | Permission to use, copy, modify, and/or distribute this software for any
28 | purpose with or without fee is hereby granted, provided that the above
29 | copyright notice and this permission notice appear in all copies.
30 |
31 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
32 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
33 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
34 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
35 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
36 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
37 | DEALINGS IN THE SOFTWARE.
38 | ————————————————————————————————————————————————————————————————————————————*)
39 |
--------------------------------------------------------------------------------
/src/terminal/terminal_stubs.c:
--------------------------------------------------------------------------------
1 | /*————————————————————————————————————————————————————————————————————————————
2 | Copyright (c) 2020–2021 Craig Ferguson
3 | Distributed under the MIT license. See terms at the end of this file.
4 | ————————————————————————————————————————————————————————————————————————————*/
5 |
6 | #include
7 | #include
8 | #include
9 | #include
10 |
11 | // Detect platform
12 | #if defined(_WIN32) || defined (_WIN64)
13 | #define OCAML_TERMINAL_WINDOWS
14 | #elif defined(__unix__) || defined(__unix) || (defined(__APPLE__) && defined(__MACH__))
15 | #include
16 | #if defined(_POSIX_VERSION)
17 | #define OCAML_TERMINAL_POSIX
18 | #endif
19 | #endif
20 |
21 | // Windows support
22 | #if defined(OCAML_TERMINAL_WINDOWS)
23 | #define WIN32_LEAN_AND_MEAN
24 | #define VC_EXTRALEAN
25 | #include
26 |
27 |
28 | CAMLprim value ocaml_terminal_get_sigwinch()
29 | {
30 | return Val_int(0);
31 | }
32 |
33 | CAMLprim value ocaml_terminal_get_terminal_dimensions(value unit)
34 | {
35 | CAMLparam1(unit);
36 | CAMLlocal2(result, pair);
37 |
38 | CONSOLE_SCREEN_BUFFER_INFO csbi;
39 | int success = GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), &csbi);
40 | if (success)
41 | {
42 | result = caml_alloc(1, 0);
43 | pair = caml_alloc(2, 0);
44 | Store_field(result, 0, pair);
45 | Store_field(pair, 0, Val_int((int)(csbi.dwSize.Y)));
46 | Store_field(pair, 1, Val_int((int)(csbi.dwSize.X)));
47 | }
48 | else
49 | {
50 | result = Val_int(0);
51 | }
52 |
53 | CAMLreturn(result);
54 | }
55 |
56 | // POSIX support
57 | #elif defined(OCAML_TERMINAL_POSIX)
58 | #include
59 |
60 | CAMLprim value ocaml_terminal_get_sigwinch (value unit)
61 | {
62 | CAMLparam1(unit);
63 | CAMLlocal1(result);
64 | result = caml_alloc(1, 0);
65 | Store_field(result, 0, Val_int (SIGWINCH));
66 | CAMLreturn(result);
67 | }
68 |
69 | CAMLprim value ocaml_terminal_get_terminal_dimensions(value unit)
70 | {
71 | CAMLparam1(unit);
72 | CAMLlocal2(result, pair);
73 | struct winsize ws;
74 | int z = ioctl(STDOUT_FILENO, TIOCGWINSZ, &ws);
75 | if (z == 0)
76 | {
77 | result = caml_alloc(1, 0);
78 | pair = caml_alloc(2, 0);
79 | Store_field(result, 0, pair);
80 | Store_field(pair, 0, Val_int(ws.ws_row));
81 | Store_field(pair, 1, Val_int(ws.ws_col));
82 | }
83 | else
84 | {
85 | result = Val_int(0);
86 | }
87 |
88 | CAMLreturn(result);
89 | }
90 |
91 | // Unsupported platform
92 | #else
93 |
94 | CAMLprim value ocaml_terminal_get_sigwinch()
95 | {
96 | return Val_int(0);
97 | }
98 |
99 | CAMLprim value ocaml_terminal_get_terminal_dimensions(value unit)
100 | {
101 | CAMLparam1(unit);
102 | CAMLlocal2(result, pair);
103 |
104 | result = Val_int(0);
105 | CAMLreturn(result);
106 | }
107 |
108 | #endif
109 |
110 | /*————————————————————————————————————————————————————————————————————————————
111 | Copyright (c) 2020–2021 Craig Ferguson
112 |
113 | Permission to use, copy, modify, and/or distribute this software for any
114 | purpose with or without fee is hereby granted, provided that the above
115 | copyright notice and this permission notice appear in all copies.
116 |
117 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
118 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
119 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
120 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
121 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
122 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
123 | DEALINGS IN THE SOFTWARE.
124 | ————————————————————————————————————————————————————————————————————————————*/
125 |
--------------------------------------------------------------------------------
/src/terminal/tests/common.ml:
--------------------------------------------------------------------------------
1 | let check_invalid pos f =
2 | match f () with
3 | | _ ->
4 | Alcotest.fail ~pos
5 | "Expected [Invalid_argument], but no exception was raised."
6 | | exception Invalid_argument _ -> ()
7 |
--------------------------------------------------------------------------------
/src/terminal/tests/dune:
--------------------------------------------------------------------------------
1 | (test
2 | (name test)
3 | (package terminal)
4 | (libraries terminal alcotest fmt))
5 |
--------------------------------------------------------------------------------
/src/terminal/tests/test.ml:
--------------------------------------------------------------------------------
1 | let () =
2 | let open Alcotest in
3 | run __FILE__ [ ("colours", Test_colours.tests); ("width", Test_width.tests) ]
4 |
--------------------------------------------------------------------------------
/src/terminal/tests/test_colours.ml:
--------------------------------------------------------------------------------
1 | open Terminal
2 | open Common
3 |
4 | let check_string pos = Alcotest.(check ~pos (testable Fmt.Dump.string ( = ))) ""
5 |
6 | let check_color pos (r, g, b) x =
7 | Alcotest.(check ~pos string)
8 | ""
9 | (Fmt.str "RGB (%d, %d, %d)" r g b)
10 | (Fmt.to_to_string Color.pp_dump x)
11 |
12 | let test_rgb () =
13 | check_invalid __POS__ (fun () -> Color.rgb (-1) 0 0);
14 | check_invalid __POS__ (fun () -> Color.rgb 0 256 0);
15 | check_string __POS__ "\027[38;2;41;42;43m"
16 | (Color.rgb 41 42 43 |> Style.fg |> Style.code);
17 | ()
18 |
19 | let test_hex () =
20 | (* Invalid *)
21 | check_invalid __POS__ (fun () -> Color.hex "FFFFFF");
22 | check_invalid __POS__ (fun () -> Color.hex "#");
23 | check_invalid __POS__ (fun () -> Color.hex "#F");
24 | check_invalid __POS__ (fun () -> Color.hex "#00000-");
25 | check_invalid __POS__ (fun () -> Color.hex "#00-");
26 |
27 | (* Valid *)
28 | check_color __POS__ (0x12, 0x34, 0x56) (Color.hex "#123456");
29 | check_color __POS__ (0xab, 0xcd, 0xef) (Color.hex "#aBCdEf");
30 |
31 | (* Short aliases *)
32 | check_color __POS__ (0, 0, 0) (Color.hex "#000");
33 | check_color __POS__ (17, 34, 51) (Color.hex "#123");
34 | check_color __POS__ (255, 255, 255) (Color.hex "#fff");
35 |
36 | ()
37 |
38 | let tests =
39 | Alcotest.[ test_case "rgb" `Quick test_rgb; test_case "hex" `Quick test_hex ]
40 |
--------------------------------------------------------------------------------
/src/terminal/tests/test_colours.mli:
--------------------------------------------------------------------------------
1 | val tests : unit Alcotest.test_case list
2 |
--------------------------------------------------------------------------------
/src/terminal/tests/test_width.ml:
--------------------------------------------------------------------------------
1 | open Terminal
2 | open Common
3 |
4 | let pp_sty = Fmt.of_to_string Style.code
5 | let col x = Style.fg (Color.ansi x)
6 |
7 | let test_guess_width () =
8 | let check pos ~expected:n fmt =
9 | Fmt.kstr
10 | (fun x -> Alcotest.(check ~pos int) "" n (guess_printed_width x))
11 | fmt
12 | in
13 | check __POS__ ~expected:0 "";
14 | check __POS__ ~expected:1 "a";
15 | check __POS__ ~expected:5 " a ";
16 | check __POS__ ~expected:3 "▷▷▷";
17 |
18 | check __POS__ ~expected:0 "%a" pp_sty (col `red);
19 | check __POS__ ~expected:3 "%a<->%a" pp_sty (col `red) pp_sty (col `green);
20 | ()
21 |
22 | let test_truncate () =
23 | let trunc n fmt = Fmt.kstr (truncate_to_width n) fmt in
24 | let check pos ~expected s =
25 | Alcotest.(check ~pos (testable Fmt.Dump.string ( = ))) "" expected s
26 | in
27 | check __POS__ ~expected:"" (trunc 0 "");
28 | check __POS__ ~expected:"" (trunc 5 "");
29 | check __POS__ ~expected:"▷" (trunc 1 "▷▷▷");
30 | check __POS__ ~expected:"▷▷" (trunc 2 "▷▷▷");
31 | check __POS__ ~expected:"▷▷▷" (trunc 3 "▷▷▷");
32 |
33 | check __POS__ ~expected:"" (trunc 0 "%a" pp_sty (col `red));
34 | check __POS__ ~expected:"\027[31m" (trunc 1 "%a" pp_sty (col `red));
35 | check __POS__ ~expected:"▷\027[31m" (trunc 2 "▷%a" pp_sty (col `red));
36 |
37 | (* Trailing colour is trimmed: *)
38 | check __POS__ ~expected:"▷" (trunc 1 "▷%a" pp_sty (col `red));
39 |
40 | (* Trailing reset is not trimmed: *)
41 | check __POS__ ~expected:"▷\027[0m" (trunc 1 "▷%a" pp_sty Style.none);
42 |
43 | (* Trailing bytes look like a reset, but aren't: *)
44 | check __POS__ ~expected:"▷" (trunc 1 "▷\027[0");
45 |
46 | check_invalid __POS__ (fun () -> trunc (-1) "");
47 | ()
48 |
49 | let tests =
50 | Alcotest.
51 | [ test_case "guess_width" `Quick test_guess_width
52 | ; test_case "truncate" `Quick test_truncate
53 | ]
54 |
--------------------------------------------------------------------------------
/src/terminal/tests/test_width.mli:
--------------------------------------------------------------------------------
1 | val tests : unit Alcotest.test_case list
2 |
--------------------------------------------------------------------------------
/terminal.opam:
--------------------------------------------------------------------------------
1 | # This file is generated by dune, edit dune-project instead
2 | opam-version: "2.0"
3 | synopsis: "Basic utilities for interacting with terminals"
4 | description: "Basic utilities for interacting with terminals"
5 | maintainer: ["Craig Ferguson "]
6 | authors: ["Craig Ferguson "]
7 | license: "MIT"
8 | homepage: "https://github.com/CraigFe/progress"
9 | doc: "https://CraigFe.github.io/progress/"
10 | bug-reports: "https://github.com/CraigFe/progress/issues"
11 | depends: [
12 | "dune" {>= "2.7"}
13 | "ocaml" {>= "4.03.0"}
14 | "uucp" {>= "2.0.0"}
15 | "uutf" {>= "1.0.0"}
16 | "stdlib-shims"
17 | "alcotest" {with-test & >= "1.4.0"}
18 | "fmt" {with-test}
19 | "astring" {with-test}
20 | "mtime" {with-test & >= "2.0.0"}
21 | "odoc" {with-doc}
22 | ]
23 | build: [
24 | ["dune" "subst"] {dev}
25 | [
26 | "dune"
27 | "build"
28 | "-p"
29 | name
30 | "-j"
31 | jobs
32 | "@install"
33 | "@runtest" {with-test}
34 | "@doc" {with-doc}
35 | ]
36 | ]
37 | dev-repo: "git+https://github.com/CraigFe/progress.git"
38 |
--------------------------------------------------------------------------------