From: "Ludovic Courtès" <ludo@gnu.org>
To: 29509@debbugs.gnu.org
Subject: [bug#29509] [PATCH 4/6] weather: Use (guix progress) for progress report.
Date: Thu, 30 Nov 2017 14:57:00 +0100 [thread overview]
Message-ID: <20171130135702.4321-4-ludo@gnu.org> (raw)
In-Reply-To: <20171130135702.4321-1-ludo@gnu.org>
* 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
next prev parent reply other threads:[~2017-11-30 13:58 UTC|newest]
Thread overview: 11+ messages / expand[flat|nested] mbox.gz Atom feed top
2017-11-30 13:46 [bug#29509] [PATCH 0/6] Display progress bar in 'guix system init' Ludovic Courtès
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-12-14 22:03 ` Danny Milosavljevic
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 [this message]
2017-11-30 13:57 ` [bug#29509] [PATCH 5/6] guix system: Simplify closure copy 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
2017-12-15 9:47 ` Ludovic Courtès
2017-12-01 15:03 ` bug#29509: [PATCH 0/6] Display progress bar in 'guix system init' Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20171130135702.4321-4-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=29509@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).