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 '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 ?~ "'"))

22
guix/progress.scm
View File

@ -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))

106
guix/scripts/weather.scm
View File

@ -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)