Add progress% skeleton.
This commit is contained in:
parent
94148130dd
commit
d2d4ff9fc6
1 changed files with 46 additions and 0 deletions
46
progress.scm
46
progress.scm
|
@ -33,6 +33,12 @@
|
|||
with-progress
|
||||
run-progress-break
|
||||
progress-break
|
||||
|
||||
*progress%-width*
|
||||
*progress%-step*
|
||||
run-with-progress%
|
||||
with-progress%
|
||||
progress%-advance
|
||||
)
|
||||
|
||||
(import scheme
|
||||
|
@ -87,6 +93,46 @@
|
|||
((_ body ...)
|
||||
(run-progress-break (lambda () body ...)))))
|
||||
|
||||
;; Progress% visual configuration
|
||||
(define *progress%-width* (make-parameter 40))
|
||||
|
||||
;; Progress% time step configuration
|
||||
(define *progress%-step* (make-parameter 0.01))
|
||||
|
||||
;; Tracking the progress via set of parameters
|
||||
(define *current-progress%* (make-parameter #f))
|
||||
(define *current-progress%-echo?* (make-parameter #f))
|
||||
(define *current-progress%-value* (make-parameter #f))
|
||||
|
||||
;; Unconditionally prints the current progress.
|
||||
(define (print-current-progress%)
|
||||
(when (*current-progress%-echo?*)
|
||||
#f))
|
||||
|
||||
;; If the new value is different-enough from the current one, updates
|
||||
;; it and re-prints the progress%
|
||||
(define (progress%-advance new-value)
|
||||
(let ((old-value (*current-progress%-value*)))
|
||||
#f))
|
||||
|
||||
;; Procedure realizing the actual progress tracking
|
||||
(define (run-with-progress% echo? name thunk)
|
||||
(parameterize ((*current-progress%* name)
|
||||
(*current-progress%-echo?* echo?)
|
||||
(*current-progress%-value* 0))
|
||||
(print-current-progress%)
|
||||
(let ((result (thunk)))
|
||||
(print-current-progress%)
|
||||
result)))
|
||||
|
||||
;; Runs named progress%
|
||||
(define-syntax with-progress%
|
||||
(syntax-rules ()
|
||||
((_ echo? name body ...)
|
||||
(run-with-progress%
|
||||
echo? name
|
||||
(lambda () body ...)))))
|
||||
|
||||
;; If the program uses progress module, disable buffering
|
||||
(set-buffering-mode! (current-output-port) #:none)
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue