summaryrefslogtreecommitdiff
path: root/guix/scripts/refresh.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts/refresh.scm')
-rw-r--r--guix/scripts/refresh.scm159
1 files changed, 126 insertions, 33 deletions
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 6f7ca4a41b..a5834d12cc 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -26,7 +27,11 @@
#:use-module (guix utils)
#:use-module (guix packages)
#:use-module (guix upstream)
- #:use-module ((guix gnu-maintenance) #:select (%gnu-updater))
+ #:use-module (guix graph)
+ #:use-module (guix scripts graph)
+ #:use-module (guix monads)
+ #:use-module ((guix gnu-maintenance)
+ #:select (%gnu-updater %gnome-updater))
#:use-module (guix import elpa)
#:use-module (guix import cran)
#:use-module (guix gnupg)
@@ -41,7 +46,8 @@
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-37)
#:use-module (rnrs io ports)
- #:export (guix-refresh))
+ #:export (guix-refresh
+ %updaters))
;;;
@@ -68,7 +74,16 @@
arg)))))
(option '(#\t "type") #t #f
(lambda (opt name arg result)
- (alist-cons 'updater (string->symbol arg) result)))
+ (let* ((not-comma (char-set-complement (char-set #\,)))
+ (names (map string->symbol
+ (string-tokenize arg not-comma))))
+ (alist-cons 'updaters names result))))
+ (option '(#\L "list-updaters") #f #f
+ (lambda args
+ (list-updaters-and-exit)))
+ (option '(#\e "expression") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'expression arg result)))
(option '(#\l "list-dependent") #f #f
(lambda (opt name arg result)
(alist-cons 'list-dependent? #t result)))
@@ -105,12 +120,17 @@ When PACKAGE... is given, update only the specified packages. Otherwise
update all the packages of the distribution, or the subset thereof
specified with `--select'.\n"))
(display (_ "
+ -e, --expression=EXPR consider the package EXPR evaluates to"))
+ (display (_ "
-u, --update update source files in place"))
(display (_ "
-s, --select=SUBSET select all the packages in SUBSET, one of
`core' or `non-core'"))
(display (_ "
- -t, --type=UPDATER restrict to updates from UPDATER--e.g., 'gnu'"))
+ -t, --type=UPDATER,... restrict to updates from the specified updaters
+ (e.g., 'gnu')"))
+ (display (_ "
+ -L, --list-updaters list available updaters and exit"))
(display (_ "
-l, --list-dependent list top-level dependent packages that would need to
be rebuilt as a result of upgrading PACKAGE..."))
@@ -137,17 +157,62 @@ specified with `--select'.\n"))
;;; Updates.
;;;
+(define-syntax maybe-updater
+ ;; Helper macro for 'list-updaters'.
+ (syntax-rules (=>)
+ ((_ ((module => updater) rest ...) result)
+ (maybe-updater (rest ...)
+ (let ((iface (false-if-exception
+ (resolve-interface 'module)))
+ (tail result))
+ (if iface
+ (cons (module-ref iface 'updater) tail)
+ tail))))
+ ((_ (updater rest ...) result)
+ (maybe-updater (rest ...)
+ (cons updater result)))
+ ((_ () result)
+ (reverse result))))
+
+(define-syntax-rule (list-updaters updaters ...)
+ "Expand to '(list UPDATERS ...)' but only the subset of UPDATERS that are
+either unconditional, or have their requirement met.
+
+A conditional updater has this form:
+
+ ((SOME MODULE) => UPDATER)
+
+meaning that UPDATER is added to the list if and only if (SOME MODULE) could
+be resolved at run time.
+
+This is a way to discard at macro expansion time updaters that depend on
+unavailable optional dependencies such as Guile-JSON."
+ (maybe-updater (updaters ...) '()))
+
(define %updaters
;; List of "updaters" used by default. They are consulted in this order.
- (list %gnu-updater
- %elpa-updater
- %cran-updater))
+ (list-updaters %gnu-updater
+ %gnome-updater
+ %elpa-updater
+ %cran-updater
+ ((guix import pypi) => %pypi-updater)))
(define (lookup-updater name)
"Return the updater called NAME."
- (find (lambda (updater)
- (eq? name (upstream-updater-name updater)))
- %updaters))
+ (or (find (lambda (updater)
+ (eq? name (upstream-updater-name updater)))
+ %updaters)
+ (leave (_ "~a: no such updater~%") name)))
+
+(define (list-updaters-and-exit)
+ "Display available updaters and exit."
+ (format #t (_ "Available updaters:~%"))
+ (for-each (lambda (updater)
+ (format #t "- ~a: ~a~%"
+ (upstream-updater-name updater)
+ (_ (upstream-updater-description updater))))
+ %updaters)
+ (exit 0))
(define* (update-package store package updaters
#:key (key-download 'interactive))
@@ -177,6 +242,50 @@ downloaded and authenticated; not updating~%")
;;;
+;;; Dependents.
+;;;
+
+(define (all-packages)
+ "Return the list of all the distro's packages."
+ (fold-packages cons '()))
+
+(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)))
+
+ ((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 \
+dependent packages are rebuilt: ~{~a~^ ~}~%"
+ (length covering))
+ (length covering) (length dependents)
+ (map package-full-name covering))))
+ (return #t))))))
+
+
+;;;
;;; Entry point.
;;;
@@ -193,15 +302,15 @@ downloaded and authenticated; not updating~%")
(define (options->updaters opts)
;; Return the list of updaters to use.
(match (filter-map (match-lambda
- (('updater . name)
- (lookup-updater name))
+ (('updaters . names)
+ (map lookup-updater names))
(_ #f))
opts)
(()
;; Use the default updaters.
%updaters)
- (lst
- lst)))
+ (lists
+ (concatenate lists))))
(define (keep-newest package lst)
;; If a newer version of PACKAGE is already in LST, return LST; otherwise
@@ -248,6 +357,8 @@ update would trigger a complete rebuild."
;; Take either the specified version or the
;; latest one.
(specification->package spec))
+ (('expression . exp)
+ (read/eval-package-expression exp))
(_ #f))
opts)
(() ; default to all packages
@@ -265,25 +376,7 @@ update would trigger a complete rebuild."
(with-error-handling
(cond
(list-dependent?
- (let* ((rebuilds (map package-full-name
- (package-covering-dependents packages)))
- (total-dependents
- (length (package-transitive-dependents packages))))
- (if (= total-dependents 0)
- (format (current-output-port)
- (N_ "No dependents other than itself: ~{~a~}~%"
- "No dependents other than themselves: ~{~a~^ ~}~%"
- (length packages))
- (map package-full-name packages))
- (format (current-output-port)
- (N_ (N_ "A single dependent package: ~2*~{~a~}~%"
- "Building the following package would ensure ~d \
-dependent packages are rebuilt; ~*~{~a~^ ~}~%"
- total-dependents)
- "Building the following ~d packages would ensure ~d \
-dependent packages are rebuilt: ~{~a~^ ~}~%"
- (length rebuilds))
- (length rebuilds) total-dependents rebuilds))))
+ (list-dependents packages))
(update?
(let ((store (open-connection)))
(parameterize ((%openpgp-key-server
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-09 11:38:54 +0000