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

Progress% ranges.

Browse source
This commit is contained in:
Dominik Pantůček 2023-03-30 20:33:48 +02:00
parent d2d4ff9fc6
commit 0057a9ad2a
2 changed files with 27 additions and 9 deletions
Download patch file Download diff file Expand all files Collapse all files

10
members-base.scm
View file

@ -64,13 +64,15 @@
(define (load-members dn . opts) (define (load-members dn . opts)
(let ((progress? (and (not (null? opts)) (let ((progress? (and (not (null? opts))
(car opts)))) (car opts))))
(with-progress (with-progress%
progress? "Loading-members " " ok." progress? "members"
(let* ((fss (load-members-dir dn)) (let* ((fss (load-members-dir dn))
(tot (sub1 (length (dict-keys fss))))
(prg 0)
(mb0 (dict-map (mb0 (dict-map
(lambda (symfn symlinks) (lambda (symfn symlinks)
(when progress? (set! prg (add1 prg))
(progress-advance ".")) (progress%-advance (/ prg tot))
(members-dir-load-member dn (members-dir-load-member dn
symfn symfn
symlinks)) symlinks))

26
progress.scm
View file

@ -103,26 +103,42 @@
(define *current-progress%* (make-parameter #f)) (define *current-progress%* (make-parameter #f))
(define *current-progress%-echo?* (make-parameter #f)) (define *current-progress%-echo?* (make-parameter #f))
(define *current-progress%-value* (make-parameter #f)) (define *current-progress%-value* (make-parameter #f))
(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%)
(when (*current-progress%-echo?*) (when (and (*current-progress%*)
#f)) (*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%))))
(display
(sprintf "\r[]~A%" ivalue%)))))
;; 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%
(define (progress%-advance new-value) (define (progress%-advance new-value)
(let ((old-value (*current-progress%-value*))) (when (*current-progress%*)
#f)) (let ((old-value (*current-progress%-value*)))
(when (>= (abs (- new-value old-value)) (*progress%-step*))
(*current-progress%-value* new-value)
(print-current-progress%)))))
;; Procedure realizing the actual progress tracking ;; Procedure realizing the actual progress tracking
(define (run-with-progress% echo? name thunk) (define (run-with-progress% echo? name thunk)
(parameterize ((*current-progress%* name) (parameterize ((*current-progress%* name)
(*current-progress%-echo?* echo?) (*current-progress%-echo?* echo?)
(*current-progress%-value* 0)) (*current-progress%-value* 0)
(*current-progress%-range* (cons 0 1)))
(print-current-progress%) (print-current-progress%)
(let ((result (thunk))) (let ((result (thunk)))
(print-current-progress%) (print-current-progress%)
(when echo?
(newline))
result))) result)))
;; Runs named progress% ;; Runs named progress%