04/09: weather: Use (guix progress) for progress report.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 1fafa2f58732a3fb75258be342c92a2772af2860
Author: Ludovic Courtès <address@hidden>
Date:   Wed Nov 22 14:39:26 2017 +0100

    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           |   3 +-
 guix/progress.scm        |  22 ++++++++++
 guix/scripts/weather.scm | 106 +++++++++++++++++++++++------------------------
 3 files changed, 76 insertions(+), 55 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 04b58d2..949f7e0 100644
--- a/.dir-locals.el
+++ b/.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 ?~ "'"))
diff --git a/guix/progress.scm b/guix/progress.scm
index 1ee7ec3..0ca5c08 100644
--- a/guix/progress.scm
+++ b/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))
 
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index 0d4a7fa..2e782e3 100644
--- a/guix/scripts/weather.scm
+++ b/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)
 
-    (foldm %store-monad
-           (lambda (package result)
-             (mlet %store-monad ((drv (package->derivation package system
-                                                           #:graft? #f)))
-               (update-progress!)
-               (match (derivation->output-paths drv)
-                 (((names . items) ...)
-                  (return (append items result))))))
-           '()
-           packages)))
+    (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)))
+                   (report)
+                   (match (derivation->output-paths drv)
+                     (((names . items) ...)
+                      (return (append items result))))))
+               '()
+               packages)))))
 
 (cond-expand
   (guile-2.2
@@ -204,31 +201,32 @@ Report the availability of substitutes.\n"))
 
 (define (guix-weather . args)
   (with-error-handling
-    (let* ((opts     (parse-command-line args %options
-                                         (list %default-options)
-                                         #:build-options? #f))
-           (urls     (assoc-ref opts 'substitute-urls))
-           (systems  (match (filter-map (match-lambda
-                                          (('system . system) system)
-                                          (_ #f))
-                                        opts)
-                       (() (list (%current-system)))
-                       (systems systems)))
-           (packages (let ((file (assoc-ref opts 'manifest)))
-                       (if file
-                           (load-manifest file)
-                           (all-packages))))
-           (items    (with-store store
-                       (parameterize ((%graft? #f))
-                         (concatenate
-                          (run-with-store store
-                            (mapm %store-monad
-                                  (lambda (system)
-                                    (package-outputs packages system))
-                                  systems)))))))
-      (for-each (lambda (server)
-                  (report-server-coverage server items))
-                urls))))
+    (parameterize ((current-terminal-columns (terminal-columns)))
+      (let* ((opts     (parse-command-line args %options
+                                           (list %default-options)
+                                           #:build-options? #f))
+             (urls     (assoc-ref opts 'substitute-urls))
+             (systems  (match (filter-map (match-lambda
+                                            (('system . system) system)
+                                            (_ #f))
+                                          opts)
+                         (() (list (%current-system)))
+                         (systems systems)))
+             (packages (let ((file (assoc-ref opts 'manifest)))
+                         (if file
+                             (load-manifest file)
+                             (all-packages))))
+             (items    (with-store store
+                         (parameterize ((%graft? #f))
+                           (concatenate
+                            (run-with-store store
+                              (mapm %store-monad
+                                    (lambda (system)
+                                      (package-outputs packages system))
+                                    systems)))))))
+        (for-each (lambda (server)
+                    (report-server-coverage server items))
+                  urls)))))
 
 ;;; Local Variables:
 ;;; eval: (put 'let/time 'scheme-indent-function 1)