nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

refresh: Make 'list-dependents' a monadic procedure. 

* guix/scripts/refresh.scm (list-dependents): Remove use of 'with-store'
and 'run-with-store'.
(guix-refresh): Wrap body in with-store/run-with-store.
master
Ludovic Courtès 2016-05-23 22:24:02 +02:00
parent 88ac650c7b
commit 9a6beb3b7f
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 60 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

117
guix/scripts/refresh.scm
View File

@ -258,38 +258,36 @@ downloaded and authenticated; not updating~%")
(define (list-dependents packages) (define (list-dependents packages)
"List all the things that would need to be rebuilt if PACKAGES are changed." "List all the things that would need to be rebuilt if PACKAGES are changed."
(with-store store ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE
(run-with-store store ;; because it includes implicit dependencies.
;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE (mlet %store-monad ((edges (node-back-edges %bag-node-type
;; because it includes implicit dependencies. (all-packages))))
(mlet %store-monad ((edges (node-back-edges %bag-node-type (let* ((dependents (node-transitive-edges packages edges))
(all-packages)))) (covering (filter (lambda (node)
(let* ((dependents (node-transitive-edges packages edges)) (null? (edges node)))
(covering (filter (lambda (node) dependents)))
(null? (edges node))) (match dependents
dependents))) (()
(match dependents (format (current-output-port)
(() (N_ "No dependents other than itself: ~{~a~}~%"
(format (current-output-port) "No dependents other than themselves: ~{~a~^ ~}~%"
(N_ "No dependents other than itself: ~{~a~}~%" (length packages))
"No dependents other than themselves: ~{~a~^ ~}~%" (map package-full-name packages)))
(length packages))
(map package-full-name packages)))
((x) ((x)
(format (current-output-port) (format (current-output-port)
(_ "A single dependent package: ~a~%") (_ "A single dependent package: ~a~%")
(package-full-name x))) (package-full-name x)))
(lst (lst
(format (current-output-port) (format (current-output-port)
(N_ "Building the following package would ensure ~d \ (N_ "Building the following package would ensure ~d \
dependent packages are rebuilt: ~*~{~a~^ ~}~%" dependent packages are rebuilt: ~*~{~a~^ ~}~%"
"Building the following ~d packages would ensure ~d \ "Building the following ~d packages would ensure ~d \
dependent packages are rebuilt: ~{~a~^ ~}~%" dependent packages are rebuilt: ~{~a~^ ~}~%"
(length covering)) (length covering))
(length covering) (length dependents) (length covering) (length dependents)
(map package-full-name covering)))) (map package-full-name covering))))
(return #t)))))) (return #t))))
;;; ;;;
@ -381,31 +379,36 @@ update would trigger a complete rebuild."
(some ; user-specified packages (some ; user-specified packages
some)))) some))))
(with-error-handling (with-error-handling
(cond (with-store store
(list-dependent? (run-with-store store
(list-dependents packages)) (cond
(update? (list-dependent?
(let ((store (open-connection))) (list-dependents packages))
(parameterize ((%openpgp-key-server (update?
(or (assoc-ref opts 'key-server) (parameterize ((%openpgp-key-server
(%openpgp-key-server))) (or (assoc-ref opts 'key-server)
(%gpg-command (%openpgp-key-server)))
(or (assoc-ref opts 'gpg-command) (%gpg-command
(%gpg-command)))) (or (assoc-ref opts 'gpg-command)
(for-each (%gpg-command))))
(cut update-package store <> updaters (for-each
#:key-download key-download) (cut update-package store <> updaters
packages)))) #:key-download key-download)
(else packages)
(for-each (lambda (package) (with-monad %store-monad
(match (package-update-path package updaters) (return #t))))
((? upstream-source? source) (else
(let ((loc (or (package-field-location package 'version) (for-each (lambda (package)
(package-location package)))) (match (package-update-path package updaters)
(format (current-error-port) ((? upstream-source? source)
(_ "~a: ~a would be upgraded from ~a to ~a~%") (let ((loc (or (package-field-location package 'version)
(location->string loc) (package-location package))))
(package-name package) (package-version package) (format (current-error-port)
(upstream-source-version source)))) (_ "~a: ~a would be upgraded from ~a to ~a~%")
(#f #f))) (location->string loc)
packages)))))) (package-name package) (package-version package)
(upstream-source-version source))))
(#f #f)))
packages)
(with-monad %store-monad
(return #t)))))))))