[bug#29509] [PATCH 0/6] Display progress bar in 'guix system init'

[bug#29509] [PATCH 0/6] Display progress bar in 'guix system init'

[Ludovic Courtès]

Hello!

This patch set factorizes support for progress bars in the (guix
progress) module that 宋文武 implemented a while back.

It then uses it in ‘guix weather’ (which had its own progress bar) and
in ‘guix system init’ when copying store items to the target partition.

Feedback welcome!

Ludo’.

Ludovic Courtès (6):
  progress: Factorize erase-in-line.
  progress: 'progress-bar' accounts for brackets.
  progress: Add 'progress-reporter/bar'.
  weather: Use (guix progress) for progress report.
  guix system: Simplify closure copy.
  guix system: 'init' displays a progress bar while copying.

 .dir-locals.el           |   3 +-
 guix/progress.scm        |  69 ++++++++++++++++++++++++++++--
 guix/scripts/system.scm  |  76 ++++++++++++++++++---------------
 guix/scripts/weather.scm | 106 +++++++++++++++++++++++------------------------
 4 files changed, 163 insertions(+), 91 deletions(-)

-- 
2.15.0

[bug#29509] [PATCH 1/6] progress: Factorize erase-in-line.

[Ludovic Courtès]

* guix/progress.scm (erase-in-line): New procedure.
(progress-reporter/file): Use it.
---
 guix/progress.scm | 9 +++++++--
 1 file changed, 7 insertions(+), 2 deletions(-)

diff --git a/guix/progress.scm b/guix/progress.scm
index beca2c22a..1993c7403 100644
--- a/guix/progress.scm
+++ b/guix/progress.scm
@@ -153,6 +153,11 @@ width of the bar is BAR-WIDTH."
             (make-string filled #\#)
             (make-string empty #\space))))
 
+(define (erase-in-line port)
+  "Write an ANSI erase-in-line sequence to PORT to erase the whole line and
+move the cursor to the beginning of the line."
+  (display "\r\x1b[K" port))
+
 (define* (progress-reporter/file file size
                                  #:optional (log-port (current-output-port))
                                  #:key (abbreviation basename))
@@ -176,7 +181,7 @@ ABBREVIATION used to shorten FILE for display."
                                      (byte-count->string throughput)
                                      (seconds->string elapsed)
                                      (progress-bar %) %)))
-            (display "\r\x1b[K" log-port)
+            (erase-in-line log-port)
             (display (string-pad-middle left right
                                         (current-terminal-columns))
                      log-port)
@@ -188,7 +193,7 @@ ABBREVIATION used to shorten FILE for display."
                                      (byte-count->string throughput)
                                      (seconds->string elapsed)
                                      (byte-count->string transferred))))
-            (display "\r\x1b[K" log-port)
+            (erase-in-line log-port)
             (display (string-pad-middle left right
                                         (current-terminal-columns))
                      log-port)
-- 
2.15.0

[bug#29509] [PATCH 2/6] progress: 'progress-bar' accounts for brackets.

[Ludovic Courtès]

* guix/progress.scm (progress-bar): Subtract 2 to BAR-WIDTH to account
for brackets.
---
 guix/progress.scm | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/guix/progress.scm b/guix/progress.scm
index 1993c7403..ba7944214 100644
--- a/guix/progress.scm
+++ b/guix/progress.scm
@@ -146,7 +146,8 @@ INTERVAL (a time-duration object), otherwise does nothing and returns #f."
 (define* (progress-bar % #:optional (bar-width 20))
   "Return % as a string representing an ASCII-art progress bar.  The total
 width of the bar is BAR-WIDTH."
-  (let* ((fraction (/ % 100))
+  (let* ((bar-width (max 3 (- bar-width 2)))
+         (fraction (/ % 100))
          (filled   (inexact->exact (floor (* fraction bar-width))))
          (empty    (- bar-width filled)))
     (format #f "[~a~a]"
-- 
2.15.0

[bug#29509] [PATCH 3/6] progress: Add 'progress-reporter/bar'.

[Ludovic Courtès]

* guix/progress.scm (progress-reporter/bar): New procedure.
---
 guix/progress.scm | 35 +++++++++++++++++++++++++++++++++++
 1 file changed, 35 insertions(+)

diff --git a/guix/progress.scm b/guix/progress.scm
index ba7944214..1ee7ec319 100644
--- a/guix/progress.scm
+++ b/guix/progress.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com>
 ;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
+;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -32,6 +33,7 @@
 
             progress-reporter/silent
             progress-reporter/file
+            progress-reporter/bar
 
             byte-count->string
             current-terminal-columns
@@ -212,6 +214,39 @@ ABBREVIATION used to shorten FILE for display."
      ;; Don't miss the last report.
      (stop render))))
 
+(define* (progress-reporter/bar total
+                                #:optional
+                                (prefix "")
+                                (port (current-error-port)))
+  "Return a reporter that shows a progress bar every time one of the TOTAL
+tasks is performed.  Write PREFIX at the beginning of the line."
+  (define done 0)
+
+  (define (report-progress)
+    (set! done (+ 1 done))
+    (unless (> done total)
+      (let* ((ratio (* 100. (/ done total))))
+        (erase-in-line port)
+        (if (string-null? prefix)
+            (display (progress-bar ratio (current-terminal-columns)) port)
+            (let ((width (- (current-terminal-columns)
+                            (string-length prefix) 3)))
+              (display prefix port)
+              (display "  " port)
+              (display (progress-bar ratio width) port)))
+        (force-output port))))
+
+  (progress-reporter
+   (start (lambda ()
+            (set! done 0)))
+   (report report-progress)
+   (stop (lambda ()
+           (erase-in-line port)
+           (unless (string-null? prefix)
+             (display prefix port)
+             (newline port))
+           (force-output port)))))
+
 ;; TODO: replace '(@ (guix build utils) dump-port))'.
 (define* (dump-port* in out
                      #:key (buffer-size 16384)
-- 
2.15.0

[bug#29509] [PATCH 4/6] weather: Use (guix progress) for progress report.

[Ludovic Courtès]

* 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 04b58d2ce..949f7e0bc 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 1ee7ec319..0ca5c0878 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 0d4a7fa26..2e782e36c 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)
-- 
2.15.0

[bug#29509] [PATCH 5/6] guix system: Simplify closure copy.

[Ludovic Courtès]

* guix/scripts/system.scm (copy-item): Add 'references' argument and
remove 'references*' call.  Turn into a non-monadic procedure.
(copy-closure): Remove initial call to 'references*'.  Only pass ITEM to
'topologically-sorted*' since that's equivalent.  Compute the list of
references corresponding to TO-COPY and pass it to 'copy-item'.
---
 guix/scripts/system.scm | 61 +++++++++++++++++++++++--------------------------
 1 file changed, 29 insertions(+), 32 deletions(-)

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index e50f1d8ac..acfa5fdbf 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -107,47 +107,44 @@ BODY..., and restore them."
   (store-lift topologically-sorted))
 
 
-(define* (copy-item item target
+(define* (copy-item item references target
                     #:key (log-port (current-error-port)))
-  "Copy ITEM to the store under root directory TARGET and register it."
-  (mlet* %store-monad ((refs (references* item)))
-    (let ((dest  (string-append target item))
-          (state (string-append target "/var/guix")))
-      (format log-port "copying '~a'...~%" item)
+  "Copy ITEM to the store under root directory TARGET and register it with
+REFERENCES as its set of references."
+  (let ((dest  (string-append target item))
+        (state (string-append target "/var/guix")))
+    (format log-port "copying '~a'...~%" item)
 
-      ;; Remove DEST if it exists to make sure that (1) we do not fail badly
-      ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and
-      ;; (2) we end up with the right contents.
-      (when (file-exists? dest)
-        (delete-file-recursively dest))
+    ;; Remove DEST if it exists to make sure that (1) we do not fail badly
+    ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and
+    ;; (2) we end up with the right contents.
+    (when (file-exists? dest)
+      (delete-file-recursively dest))
 
-      (copy-recursively item dest
-                        #:log (%make-void-port "w"))
+    (copy-recursively item dest
+                      #:log (%make-void-port "w"))
 
-      ;; Register ITEM; as a side-effect, it resets timestamps, etc.
-      ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid
-      ;; reproducing the user's current settings; see
-      ;; <http://bugs.gnu.org/18049>.
-      (unless (register-path item
-                             #:prefix target
-                             #:state-directory state
-                             #:references refs)
-        (leave (G_ "failed to register '~a' under '~a'~%")
-               item target))
-
-      (return #t))))
+    ;; Register ITEM; as a side-effect, it resets timestamps, etc.
+    ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid
+    ;; reproducing the user's current settings; see
+    ;; <http://bugs.gnu.org/18049>.
+    (unless (register-path item
+                           #:prefix target
+                           #:state-directory state
+                           #:references references)
+      (leave (G_ "failed to register '~a' under '~a'~%")
+             item target))))
 
 (define* (copy-closure item target
                        #:key (log-port (current-error-port)))
   "Copy ITEM and all its dependencies to the store under root directory
 TARGET, and register them."
-  (mlet* %store-monad ((refs    (references* item))
-                       (to-copy (topologically-sorted*
-                                 (delete-duplicates (cons item refs)
-                                                    string=?))))
-    (sequence %store-monad
-              (map (cut copy-item <> target #:log-port log-port)
-                   to-copy))))
+  (mlet* %store-monad ((to-copy (topologically-sorted* (list item)))
+                       (refs    (mapm %store-monad references* to-copy)))
+    (for-each (cut copy-item <> <> target #:log-port log-port)
+              to-copy refs)
+
+    (return *unspecified*)))
 
 (define* (install-bootloader installer-drv
                              #:key
-- 
2.15.0

[bug#29509] [PATCH 6/6] guix system: 'init' displays a progress bar while copying.

[Ludovic Courtès]

Until now it would print the name of each store item being copied, which
was verbose and unhelpful.

* guix/scripts/system.scm (copy-closure): Use 'progress-reporter/bar'
and 'call-with-progress-reporter'.
(guix-system): Parameterize 'current-terminal-columns'.
---
 guix/scripts/system.scm | 19 ++++++++++++++++---
 1 file changed, 16 insertions(+), 3 deletions(-)

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index acfa5fdbf..91d151d22 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -36,6 +36,8 @@
   #:use-module (guix graph)
   #:use-module (guix scripts graph)
   #:use-module (guix build utils)
+  #:use-module (guix progress)
+  #:use-module ((guix build syscalls) #:select (terminal-columns))
   #:use-module (gnu build install)
   #:autoload   (gnu build file-systems)
                  (find-partition-by-label find-partition-by-uuid)
@@ -141,8 +143,18 @@ REFERENCES as its set of references."
 TARGET, and register them."
   (mlet* %store-monad ((to-copy (topologically-sorted* (list item)))
                        (refs    (mapm %store-monad references* to-copy)))
-    (for-each (cut copy-item <> <> target #:log-port log-port)
-              to-copy refs)
+    (define progress-bar
+      (progress-reporter/bar (length to-copy)
+                             (format #f (G_ "copying to '~a'...")
+                                     target)))
+
+    (call-with-progress-reporter progress-bar
+      (lambda (report)
+        (let ((void (%make-void-port "w")))
+          (for-each (lambda (item refs)
+                      (copy-item item refs target #:log-port void)
+                      (report))
+                    to-copy refs))))
 
     (return *unspecified*)))
 
@@ -1092,7 +1104,8 @@ argument list and OPTS is the option alist."
                                          parse-sub-command))
            (args     (option-arguments opts))
            (command  (assoc-ref opts 'action)))
-      (parameterize ((%graft? (assoc-ref opts 'graft?)))
+      (parameterize ((%graft? (assoc-ref opts 'graft?))
+                     (current-terminal-columns (terminal-columns)))
         (process-command command args opts)))))
 
 ;;; Local Variables:
-- 
2.15.0

bug#29509: [PATCH 0/6] Display progress bar in 'guix system init'

[Ludovic Courtès]

Ludovic Courtès <ludo@gnu.org> skribis:

>   progress: Factorize erase-in-line.
>   progress: 'progress-bar' accounts for brackets.
>   progress: Add 'progress-reporter/bar'.
>   weather: Use (guix progress) for progress report.
>   guix system: Simplify closure copy.
>   guix system: 'init' displays a progress bar while copying.

I got an informal “LGTM” from Mathieu yesterday on IRC and it all seems
to work for me, so I went ahead and pushed.

Ludo’.

[bug#29509] [PATCH 1/6] progress: Factorize erase-in-line.

[Danny Milosavljevic]

> +(define (erase-in-line port)
> +  "Write an ANSI erase-in-line sequence to PORT to erase the whole line and
> +move the cursor to the beginning of the line."
> +  (display "\r\x1b[K" port))
> +

Hmm, with the "\r" in front it's more like erase-current-line, no? (f.e. the order is different: move the cursor to the beginning of the line and then erase the rest of the line - which then means: whole line)

Otherwise LGTM!

[bug#29509] [PATCH 2/6] progress: 'progress-bar' accounts for brackets.

[Danny Milosavljevic]

LGTM!

[bug#29509] [PATCH 1/6] progress: Factorize erase-in-line.

[Ludovic Courtès]

Danny Milosavljevic <dannym@scratchpost.org> skribis:

>> +(define (erase-in-line port)
>> +  "Write an ANSI erase-in-line sequence to PORT to erase the whole line and
>> +move the cursor to the beginning of the line."
>> +  (display "\r\x1b[K" port))
>> +
>
> Hmm, with the "\r" in front it's more like erase-current-line, no? (f.e. the order is different: move the cursor to the beginning of the line and then erase the rest of the line - which then means: whole line)

Yes you’re right: it uses the “erase-in-line” ANSI sequence but what it
does is more appropriately described as “erase current line” (which is
what the docstring says.)

I’ve renamed it to ‘erase-current-line’.

Thanks,
Ludo’.