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

Collapse progressbars.

Browse source
This commit is contained in:
Dominik Pantůček 2023-06-24 17:11:31 +02:00
parent a22aec695b
commit b8f95657da
1 changed files with 36 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

39
src/progress.scm
View file

@ -123,6 +123,7 @@
(define *current-total-count%* (make-parameter 1))
(define *current-partial-progress%-number* (make-parameter #f))
(define *current-partial-echo?* (make-parameter #f))
(define *current-partial-start* (make-parameter #f))
;; Unconditionally prints the current progress.
(define (print-current-progress% . eols)
@ -144,7 +145,7 @@
(* value (*progress%-width*)))))
(swidth (- (*progress%-width*) bwidth)))
(display
(sprintf "\r[~A~A] ~A% ~A~A"
(sprintf "\r[~A~A] ~A% ~A~A\x1b[K"
(make-string bwidth #\=)
(make-string swidth #\space)
ivalue%
@ -163,7 +164,7 @@
(print-current-progress%)))))
;; Procedure realizing the actual progress tracking
(define (run-with-progress% echo? name thunk)
(define (run-with-progress-normal% echo? name thunk)
(parameterize ((*current-progress%* name)
(*current-progress%-echo?* echo?)
(*current-progress%-value* 0)
@ -179,6 +180,37 @@
(newline))
result))))
;; Procedure realizing the actual progress tracking
(define (run-with-progress-partial% echo? name thunk)
(let ((number (*current-partial-progress%-number*))
(total (*current-total-count%*)))
(*current-partial-progress%-number* (add1 number))
(parameterize ((*current-progress%* (format "~A ~A"
(*current-partial-progress%*)
name))
(*current-progress%-echo?* echo?)
(*current-progress%-value* 0)
(*current-progress%-last-value* #f)
(*current-progress%-range* (cons (/ number total)
(/ (add1 number) total))))
(let ((start (*current-partial-start*)))
(print-current-progress%)
(let ((result (thunk))
(stop (current-util-milliseconds)))
(when (and echo?
(not (*progress-quiet*))
(eq? (add1 number) total))
(*current-progress%* (*current-partial-progress%*))
(print-current-progress% (sprintf " ~A ms" (- stop start)))
(newline))
result)))))
;; Dispatching
(define (run-with-progress% echo? name thunk)
(if (*current-partial-progress%*)
(run-with-progress-partial% echo? name thunk)
(run-with-progress-normal% echo? name thunk)))
;; Runs named progress%
(define-syntax with-progress%
(syntax-rules ()
@ -192,7 +224,8 @@
(parameterize ((*current-partial-progress%* name)
(*current-total-count%* count)
(*current-partial-echo?* echo?)
(*current-partial-progress%-number* 0))
(*current-partial-progress%-number* 0)
(*current-partial-start* (current-util-milliseconds)))
(proc)))
;; Syntax wrapper