Support for quieting progresses.

src/progress.scm

@@ -28,6 +28,8 @@
 (module
  progress
  (
+  *progress-quiet*
+  
   run-with-progress
   progress-advance
   with-progress
@@ -47,13 +49,17 @@
 	 (chicken port)
 	 util-time)
 
+ ;; Suppress all output if #t
+ (define *progress-quiet* (make-parameter #f))
+
  ;; Parameterized current progress string
  (define *current-progress* (make-parameter #f))
 
  ;; Prints current progress.
  (define (print-current-progress . args)
    (let ((cp (*current-progress*)))
-     (when cp
+     (when (and cp
+		(not (*progress-quiet*)))
        (display (sprintf "\r\x1b[K~A" cp)))))
 
  ;; Adds something to current progress and refreshes the display.
@@ -71,13 +77,15 @@
      (print-current-progress)
      (let ((result (thunk)))
        (print-current-progress)
-       (when echo?
+       (when (and echo?
+		  (not (*progress-quiet*)))
 	 (print post-msg))
        result)))
 
  ;; Allows printing output when progress is advancing.
  (define (run-progress-break thunk)
-   (when (*current-progress*)
+   (when (and (*current-progress*)
+	      (not (*progress-quiet*)))
      (display "\r\x1b[K"))
    (thunk)
    (print-current-progress))
@@ -109,6 +117,7 @@
 
  ;; Unconditionally prints the current progress.
  (define (print-current-progress% . eols)
+   (when (not (*progress-quiet*))
      (let ((eol (if (null? eols)
 		    ""
 		    (car eols))))
@@ -131,7 +140,7 @@
 		     (make-string swidth #\space)
 		     ivalue%
 		     (*current-progress%*)
-		   eol))))))
+		     eol)))))))
 
  ;; If the new value is different-enough from the current one, updates
  ;; it and re-prints the progress%
@@ -156,7 +165,8 @@
        (let ((result (thunk))
 	     (stop (current-util-milliseconds)))
 	 (print-current-progress% (sprintf " ~A ms" (- stop start)))
-	 (when echo?
+	 (when (and echo?
+		    (not (*progress-quiet*)))
 	   (newline))
 	 result))))