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