brmlab/hackerbase
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Support for quieting progresses.

Browse source
This commit is contained in:
Dominik Pantůček 2023-04-11 21:22:21 +02:00
parent ee47971450
commit 990340ded9
1 changed files with 37 additions and 27 deletions
Download patch file Download diff file Expand all files Collapse all files

64
src/progress.scm
View file

@ -28,6 +28,8 @@
(module
progress
(
*progress-quiet*
run-with-progress
progress-advance
with-progress
@ -47,13 +49,17 @@
(chicken port)
util-time)
;; Suppress all output if #t
(define *progress-quiet* (make-parameter #f))
;; Parameterized current progress string
(define *current-progress* (make-parameter #f))
;; Prints current progress.
(define (print-current-progress . args)
(let ((cp (*current-progress*)))
(when cp
(when (and cp
(not (*progress-quiet*)))
(display (sprintf "\r\x1b[K~A" cp)))))
;; Adds something to current progress and refreshes the display.
@ -71,13 +77,15 @@
(print-current-progress)
(let ((result (thunk)))
(print-current-progress)
(when echo?
(when (and echo?
(not (*progress-quiet*)))
(print post-msg))
result)))
;; Allows printing output when progress is advancing.
(define (run-progress-break thunk)
(when (*current-progress*)
(when (and (*current-progress*)
(not (*progress-quiet*)))
(display "\r\x1b[K"))
(thunk)
(print-current-progress))
@ -109,29 +117,30 @@
;; Unconditionally prints the current progress.
(define (print-current-progress% . eols)
(let ((eol (if (null? eols)
""
(car eols))))
(when (and (*current-progress%*)
(*current-progress%-echo?*))
(let* ((raw-value (*current-progress%-value*))
(range (*current-progress%-range*))
(value (+ (car range)
(* raw-value
(- (cdr range) (car range)))))
(value% (* 100 value))
(ivalue% (inexact->exact (round value%)))
(bwidth (inexact->exact
(round
(* value (*progress%-width*)))))
(swidth (- (*progress%-width*) bwidth)))
(display
(sprintf "\r[~A~A] ~A% ~A~A"
(make-string bwidth #\=)
(make-string swidth #\space)
ivalue%
(*current-progress%*)
eol))))))
(when (not (*progress-quiet*))
(let ((eol (if (null? eols)
""
(car eols))))
(when (and (*current-progress%*)
(*current-progress%-echo?*))
(let* ((raw-value (*current-progress%-value*))
(range (*current-progress%-range*))
(value (+ (car range)
(* raw-value
(- (cdr range) (car range)))))
(value% (* 100 value))
(ivalue% (inexact->exact (round value%)))
(bwidth (inexact->exact
(round
(* value (*progress%-width*)))))
(swidth (- (*progress%-width*) bwidth)))
(display
(sprintf "\r[~A~A] ~A% ~A~A"
(make-string bwidth #\=)
(make-string swidth #\space)
ivalue%
(*current-progress%*)
eol)))))))
;; If the new value is different-enough from the current one, updates
;; it and re-prints the progress%
@ -156,7 +165,8 @@
(let ((result (thunk))
(stop (current-util-milliseconds)))
(print-current-progress% (sprintf " ~A ms" (- stop start)))
(when echo?
(when (and echo?
(not (*progress-quiet*)))
(newline))
result))))