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

Measure progress time.

Browse source
This commit is contained in:
Dominik Pantůček 2023-04-06 22:04:07 +02:00
parent 8bf4a882e3
commit 29631c640e
1 changed files with 33 additions and 26 deletions
Download patch file Download diff file Expand all files Collapse all files

21
src/progress.scm
View file

@ -44,7 +44,8 @@
(import scheme (import scheme
(chicken base) (chicken base)
(chicken format) (chicken format)
(chicken port)) (chicken port)
(chicken time))
;; Parameterized current progress string ;; Parameterized current progress string
(define *current-progress* (make-parameter #f)) (define *current-progress* (make-parameter #f))
@ -107,7 +108,10 @@
(define *current-progress%-range* (make-parameter (cons 0 1))) (define *current-progress%-range* (make-parameter (cons 0 1)))
;; Unconditionally prints the current progress. ;; Unconditionally prints the current progress.
(define (print-current-progress%) (define (print-current-progress% . eols)
(let ((eol (if (null? eols)
""
(car eols))))
(when (and (*current-progress%*) (when (and (*current-progress%*)
(*current-progress%-echo?*)) (*current-progress%-echo?*))
(let* ((raw-value (*current-progress%-value*)) (let* ((raw-value (*current-progress%-value*))
@ -122,11 +126,12 @@
(* value (*progress%-width*))))) (* value (*progress%-width*)))))
(swidth (- (*progress%-width*) bwidth))) (swidth (- (*progress%-width*) bwidth)))
(display (display
(sprintf "\r[~A~A] ~A% ~A" (sprintf "\r[~A~A] ~A% ~A~A"
(make-string bwidth #\=) (make-string bwidth #\=)
(make-string swidth #\space) (make-string swidth #\space)
ivalue% ivalue%
(*current-progress%*)))))) (*current-progress%*)
eol))))))
;; If the new value is different-enough from the current one, updates ;; If the new value is different-enough from the current one, updates
;; it and re-prints the progress% ;; it and re-prints the progress%
@ -146,12 +151,14 @@
(*current-progress%-value* 0) (*current-progress%-value* 0)
(*current-progress%-last-value* #f) (*current-progress%-last-value* #f)
(*current-progress%-range* (cons 0 1))) (*current-progress%-range* (cons 0 1)))
(let ((start (current-milliseconds)))
(print-current-progress%) (print-current-progress%)
(let ((result (thunk))) (let ((result (thunk))
(print-current-progress%) (stop (current-milliseconds)))
(print-current-progress% (sprintf " ~A ms" (- stop start)))
(when echo? (when echo?
(newline)) (newline))
result))) result))))
;; Runs named progress% ;; Runs named progress%
(define-syntax with-progress% (define-syntax with-progress%