weather: Use (guix progress) for progress report.

* guix/progress.scm (start-progress-reporter!, stop-progress-reporter!)
(progress-reporter-report!): New procedures.
* guix/scripts/weather.scm (call-with-progress-reporter): New procedure.
(package-outputs)[update-progress!]: Remove.
Use 'call-with-progress-reporter' instead.
(guix-weather): Parameterize 'current-terminal-columns'.

.dir-locals.el

@@ -77,7 +77,8 @@
    (eval . (put 'container-excursion 'scheme-indent-function 1))
    (eval . (put 'eventually 'scheme-indent-function 1))
 
-   ;; Recognize '~', '+', and '$', as used for gexps, as quotation symbols.
+   (eval . (put 'call-with-progress-reporter 'scheme-indent-function 1))
+
    ;; This notably allows '(' in Paredit to not insert a space when the
    ;; preceding symbol is one of these.
    (eval . (modify-syntax-entry ?~ "'"))

guix/progress.scm

@@ -31,6 +31,10 @@
             progress-reporter?
             call-with-progress-reporter
 
+            start-progress-reporter!
+            stop-progress-reporter!
+            progress-reporter-report!
+
             progress-reporter/silent
             progress-reporter/file
             progress-reporter/bar
@@ -60,6 +64,24 @@ stopped."
     (($ <progress-reporter> start report stop)
      (dynamic-wind start (lambda () (proc report)) stop))))
 
+(define (start-progress-reporter! reporter)
+  "Low-level procedure to start REPORTER."
+  (match reporter
+    (($ <progress-reporter> start report stop)
+     (start))))
+
+(define (progress-reporter-report! reporter)
+  "Low-level procedure to lead REPORTER to emit a report."
+  (match reporter
+    (($ <progress-reporter> start report stop)
+     (report))))
+
+(define (stop-progress-reporter! reporter)
+  "Low-level procedure to stop REPORTER."
+  (match reporter
+    (($ <progress-reporter> start report stop)
+     (stop))))
+
 (define progress-reporter/silent
   (make-progress-reporter noop noop noop))
 

guix/scripts/weather.scm

@@ -23,10 +23,11 @@
   #:use-module (guix packages)
   #:use-module (guix profiles)
   #:use-module (guix derivations)
+  #:use-module (guix progress)
   #:use-module (guix monads)
   #:use-module (guix store)
   #:use-module (guix grafts)
-  #:use-module (guix build syscalls)
+  #:use-module ((guix build syscalls) #:select (terminal-columns))
   #:use-module (guix scripts substitute)
   #:use-module (gnu packages)
   #:use-module (web uri)
@@ -48,42 +49,38 @@
                       (cons package result))))
                  '()))
 
+(define (call-with-progress-reporter reporter proc)
+  "This is a variant of 'call-with-progress-reporter' that works with monadic
+scope."
+  ;; TODO: Move to a more appropriate place.
+  (with-monad %store-monad
+    (start-progress-reporter! reporter)
+    (mlet* %store-monad ((report -> (lambda ()
+                                      (progress-reporter-report! reporter)))
+                         (result (proc report)))
+      (stop-progress-reporter! reporter)
+      (return result))))
+
 (define* (package-outputs packages
                           #:optional (system (%current-system)))
   "Return the list of outputs of all of PACKAGES for the given SYSTEM."
   (let ((packages (filter (cut supported-package? <> system) packages)))
-
-    (define update-progress!
-      (let ((total (length packages))
-            (done  0)
-            (width (max 10 (- (terminal-columns) 10))))
-        (lambda ()
-          (set! done (+ 1 done))
-          (let* ((ratio (/ done total 1.))
-                 (done  (inexact->exact (round (* width ratio))))
-                 (left  (- width done)))
-            (format (current-error-port) "~5,1f% [~a~a]\r"
-                    (* ratio 100.)
-                    (make-string done #\#)
-                    (make-string left #\space))
-            (when (>= done total)
-              (newline (current-error-port)))
-            (force-output (current-error-port))))))
-
     (format (current-error-port)
             (G_ "computing ~h package derivations for ~a...~%")
             (length packages) system)
 
+    (call-with-progress-reporter (progress-reporter/bar (length packages))
+      (lambda (report)
         (foldm %store-monad
                (lambda (package result)
                  (mlet %store-monad ((drv (package->derivation package system
                                                                #:graft? #f)))
-               (update-progress!)
+                   (report)
                    (match (derivation->output-paths drv)
                      (((names . items) ...)
                       (return (append items result))))))
                '()
-           packages)))
+               packages)))))
 
 (cond-expand
   (guile-2.2
@@ -204,6 +201,7 @@ Report the availability of substitutes.\n"))
 
 (define (guix-weather . args)
   (with-error-handling
+    (parameterize ((current-terminal-columns (terminal-columns)))
       (let* ((opts     (parse-command-line args %options
                                            (list %default-options)
                                            #:build-options? #f))
@@ -228,7 +226,7 @@ Report the availability of substitutes.\n"))
                                     systems)))))))
         (for-each (lambda (server)
                     (report-server-coverage server items))
-                urls))))
+                  urls)))))
 
 ;;; Local Variables:
 ;;; eval: (put 'let/time 'scheme-indent-function 1)