rekahsoft
/
guix
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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'.
This commit is contained in:
Ludovic Courtès 2017-11-22 14:39:26 +01:00
parent 4cdb27af48
commit 1fafa2f587
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 76 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.dir-locals.el
View File

@ -77,7 +77,8 @@
(eval . (put 'container-excursion 'scheme-indent-function 1)) (eval . (put 'container-excursion 'scheme-indent-function 1))
(eval . (put 'eventually '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 ;; This notably allows '(' in Paredit to not insert a space when the
;; preceding symbol is one of these. ;; preceding symbol is one of these.
(eval . (modify-syntax-entry ?~ "'")) (eval . (modify-syntax-entry ?~ "'"))

22
guix/progress.scm
View File

@ -31,6 +31,10 @@
progress-reporter? progress-reporter?
call-with-progress-reporter call-with-progress-reporter
start-progress-reporter!
stop-progress-reporter!
progress-reporter-report!
progress-reporter/silent progress-reporter/silent
progress-reporter/file progress-reporter/file
progress-reporter/bar progress-reporter/bar
@ -60,6 +64,24 @@ stopped."
(($ <progress-reporter> start report stop) (($ <progress-reporter> start report stop)
(dynamic-wind start (lambda () (proc 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 (define progress-reporter/silent
(make-progress-reporter noop noop noop)) (make-progress-reporter noop noop noop))

106
guix/scripts/weather.scm
View File

@ -23,10 +23,11 @@
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix profiles) #:use-module (guix profiles)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix progress)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix grafts) #:use-module (guix grafts)
#:use-module (guix build syscalls) #:use-module ((guix build syscalls) #:select (terminal-columns))
#:use-module (guix scripts substitute) #:use-module (guix scripts substitute)
#:use-module (gnu packages) #:use-module (gnu packages)
#:use-module (web uri) #:use-module (web uri)
@ -48,42 +49,38 @@
(cons package result)))) (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 (define* (package-outputs packages
#:optional (system (%current-system))) #:optional (system (%current-system)))
"Return the list of outputs of all of PACKAGES for the given SYSTEM." "Return the list of outputs of all of PACKAGES for the given SYSTEM."
(let ((packages (filter (cut supported-package? <> system) packages))) (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) (format (current-error-port)
(G_ "computing ~h package derivations for ~a...~%") (G_ "computing ~h package derivations for ~a...~%")
(length packages) system) (length packages) system)
(foldm %store-monad (call-with-progress-reporter (progress-reporter/bar (length packages))
(lambda (package result) (lambda (report)
(mlet %store-monad ((drv (package->derivation package system (foldm %store-monad
#:graft? #f))) (lambda (package result)
(update-progress!) (mlet %store-monad ((drv (package->derivation package system
(match (derivation->output-paths drv) #:graft? #f)))
(((names . items) ...) (report)
(return (append items result)))))) (match (derivation->output-paths drv)
'() (((names . items) ...)
packages))) (return (append items result))))))
'()
packages)))))
(cond-expand (cond-expand
(guile-2.2 (guile-2.2
@ -204,31 +201,32 @@ Report the availability of substitutes.\n"))
(define (guix-weather . args) (define (guix-weather . args)
(with-error-handling (with-error-handling
(let* ((opts (parse-command-line args %options (parameterize ((current-terminal-columns (terminal-columns)))
(list %default-options) (let* ((opts (parse-command-line args %options
#:build-options? #f)) (list %default-options)
(urls (assoc-ref opts 'substitute-urls)) #:build-options? #f))
(systems (match (filter-map (match-lambda (urls (assoc-ref opts 'substitute-urls))
(('system . system) system) (systems (match (filter-map (match-lambda
(_ #f)) (('system . system) system)
opts) (_ #f))
(() (list (%current-system))) opts)
(systems systems))) (() (list (%current-system)))
(packages (let ((file (assoc-ref opts 'manifest))) (systems systems)))
(if file (packages (let ((file (assoc-ref opts 'manifest)))
(load-manifest file) (if file
(all-packages)))) (load-manifest file)
(items (with-store store (all-packages))))
(parameterize ((%graft? #f)) (items (with-store store
(concatenate (parameterize ((%graft? #f))
(run-with-store store (concatenate
(mapm %store-monad (run-with-store store
(lambda (system) (mapm %store-monad
(package-outputs packages system)) (lambda (system)
systems))))))) (package-outputs packages system))
(for-each (lambda (server) systems)))))))
(report-server-coverage server items)) (for-each (lambda (server)
urls)))) (report-server-coverage server items))
urls)))))
;;; Local Variables: ;;; Local Variables:
;;; eval: (put 'let/time 'scheme-indent-function 1) ;;; eval: (put 'let/time 'scheme-indent-function 1)