diff --git a/src/progress.scm b/src/progress.scm index 1f66874..17d2dac 100644 --- a/src/progress.scm +++ b/src/progress.scm @@ -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