* [bug#29509] [PATCH 2/6] progress: 'progress-bar' accounts for brackets.
2017-11-30 13:56 ` [bug#29509] [PATCH 1/6] progress: Factorize erase-in-line Ludovic Courtès
@ 2017-11-30 13:56 ` Ludovic Courtès
2017-12-14 22:03 ` Danny Milosavljevic
2017-11-30 13:56 ` [bug#29509] [PATCH 3/6] progress: Add 'progress-reporter/bar' Ludovic Courtès
` (4 subsequent siblings)
5 siblings, 1 reply; 11+ messages in thread
From: Ludovic Courtès @ 2017-11-30 13:56 UTC (permalink / raw)
To: 29509
* 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
^ permalink raw reply related [flat|nested] 11+ messages in thread
* [bug#29509] [PATCH 3/6] progress: Add 'progress-reporter/bar'.
2017-11-30 13:56 ` [bug#29509] [PATCH 1/6] progress: Factorize erase-in-line Ludovic Courtès
2017-11-30 13:56 ` [bug#29509] [PATCH 2/6] progress: 'progress-bar' accounts for brackets Ludovic Courtès
@ 2017-11-30 13:56 ` Ludovic Courtès
2017-11-30 13:57 ` [bug#29509] [PATCH 4/6] weather: Use (guix progress) for progress report Ludovic Courtès
` (3 subsequent siblings)
5 siblings, 0 replies; 11+ messages in thread
From: Ludovic Courtès @ 2017-11-30 13:56 UTC (permalink / raw)
To: 29509
* 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
^ permalink raw reply related [flat|nested] 11+ messages in thread
* [bug#29509] [PATCH 4/6] weather: Use (guix progress) for progress report.
2017-11-30 13:56 ` [bug#29509] [PATCH 1/6] progress: Factorize erase-in-line Ludovic Courtès
2017-11-30 13:56 ` [bug#29509] [PATCH 2/6] progress: 'progress-bar' accounts for brackets Ludovic Courtès
2017-11-30 13:56 ` [bug#29509] [PATCH 3/6] progress: Add 'progress-reporter/bar' Ludovic Courtès
@ 2017-11-30 13:57 ` Ludovic Courtès
2017-11-30 13:57 ` [bug#29509] [PATCH 5/6] guix system: Simplify closure copy Ludovic Courtès
` (2 subsequent siblings)
5 siblings, 0 replies; 11+ messages in thread
From: Ludovic Courtès @ 2017-11-30 13:57 UTC (permalink / raw)
To: 29509
* 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
^ permalink raw reply related [flat|nested] 11+ messages in thread
* [bug#29509] [PATCH 5/6] guix system: Simplify closure copy.
2017-11-30 13:56 ` [bug#29509] [PATCH 1/6] progress: Factorize erase-in-line Ludovic Courtès
` (2 preceding siblings ...)
2017-11-30 13:57 ` [bug#29509] [PATCH 4/6] weather: Use (guix progress) for progress report Ludovic Courtès
@ 2017-11-30 13:57 ` Ludovic Courtès
2017-11-30 13:57 ` [bug#29509] [PATCH 6/6] guix system: 'init' displays a progress bar while copying Ludovic Courtès
2017-12-14 22:01 ` [bug#29509] [PATCH 1/6] progress: Factorize erase-in-line Danny Milosavljevic
5 siblings, 0 replies; 11+ messages in thread
From: Ludovic Courtès @ 2017-11-30 13:57 UTC (permalink / raw)
To: 29509
* 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
^ permalink raw reply related [flat|nested] 11+ messages in thread
* [bug#29509] [PATCH 6/6] guix system: 'init' displays a progress bar while copying.
2017-11-30 13:56 ` [bug#29509] [PATCH 1/6] progress: Factorize erase-in-line Ludovic Courtès
` (3 preceding siblings ...)
2017-11-30 13:57 ` [bug#29509] [PATCH 5/6] guix system: Simplify closure copy Ludovic Courtès
@ 2017-11-30 13:57 ` Ludovic Courtès
2017-12-14 22:01 ` [bug#29509] [PATCH 1/6] progress: Factorize erase-in-line Danny Milosavljevic
5 siblings, 0 replies; 11+ messages in thread
From: Ludovic Courtès @ 2017-11-30 13:57 UTC (permalink / raw)
To: 29509
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
^ permalink raw reply related [flat|nested] 11+ messages in thread
* [bug#29509] [PATCH 1/6] progress: Factorize erase-in-line.
2017-11-30 13:56 ` [bug#29509] [PATCH 1/6] progress: Factorize erase-in-line Ludovic Courtès
` (4 preceding siblings ...)
2017-11-30 13:57 ` [bug#29509] [PATCH 6/6] guix system: 'init' displays a progress bar while copying Ludovic Courtès
@ 2017-12-14 22:01 ` Danny Milosavljevic
2017-12-15 9:47 ` Ludovic Courtès
5 siblings, 1 reply; 11+ messages in thread
From: Danny Milosavljevic @ 2017-12-14 22:01 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 29509
> +(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!
^ permalink raw reply [flat|nested] 11+ messages in thread
* [bug#29509] [PATCH 1/6] progress: Factorize erase-in-line.
2017-12-14 22:01 ` [bug#29509] [PATCH 1/6] progress: Factorize erase-in-line Danny Milosavljevic
@ 2017-12-15 9:47 ` Ludovic Courtès
0 siblings, 0 replies; 11+ messages in thread
From: Ludovic Courtès @ 2017-12-15 9:47 UTC (permalink / raw)
To: Danny Milosavljevic; +Cc: 29509
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’.
^ permalink raw reply [flat|nested] 11+ messages in thread