Collapse progressbars.

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