refresh: Add `--select'.

* guix/scripts/refresh.scm (%options): Add `--select'.
  (show-help): Likewise.  Augment initial help text.
  (guix-refresh)[core-package?]: New procedure.
  Use it when selecting packages.

1 files changed, 82 insertions, 37 deletions

diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 036da38a3f..da318b07ad 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -23,6 +23,7 @@
   #:use-module (guix packages)
   #:use-module (guix gnu-maintenance)
   #:use-module (gnu packages)
+  #:use-module ((gnu packages base) #:select (%final-inputs))
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
@@ -46,6 +47,15 @@
   (list (option '(#\n "dry-run") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'dry-run? #t result)))
+        (option '(#\s "select") #t #f
+                (lambda (opt name arg result)
+                  (match arg
+                    ((or "core" "non-core")
+                     (alist-cons 'select (string->symbol arg)
+                                 result))
+                    (x
+                     (leave (_ "~a: invalid selection; expected `core' or `non-core'")
+                            arg)))))
 
         (option '(#\h "help") #f #f
                 (lambda args
@@ -57,9 +67,16 @@
 
 (define (show-help)
   (display (_ "Usage: guix refresh [OPTION]... PACKAGE...
-Update package definitions to match the latest upstream version.\n"))
+Update package definitions to match the latest upstream version.
+
+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 (_ "
   -n, --dry-run          do not build the derivations"))
+  (display (_ "
+  -s, --select=SUBSET    select all the packages in SUBSET, one of
+                         `core' or `non-core'"))
   (newline)
   (display (_ "
   -h, --help             display this help and exit"))
@@ -83,6 +100,26 @@ Update package definitions to match the latest upstream version.\n"))
                  (alist-cons 'argument arg result))
                %default-options))
 
+  (define core-package?
+    (let* ((input->package (match-lambda
+                            ((name (? package? package) _ ...) package)
+                            (_ #f)))
+           (final-inputs   (map input->package %final-inputs))
+           (core           (append final-inputs
+                                   (append-map (compose (cut filter-map input->package <>)
+                                                        package-transitive-inputs)
+                                               final-inputs)))
+           (names          (delete-duplicates (map package-name core))))
+      (lambda (package)
+        "Return true if PACKAGE is likely a \"core package\"---i.e., one whose
+update would trigger a complete rebuild."
+        ;; Compare by name because packages in base.scm basically inherit
+        ;; other packages.  So, even if those packages are not core packages
+        ;; themselves, updating them would also update those who inherit from
+        ;; them.
+        ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input.
+        (member (package-name package) names))))
+
   (let* ((opts     (parse-options))
          (dry-run? (assoc-ref opts 'dry-run?))
          (packages (match (concatenate
@@ -96,42 +133,50 @@ Update package definitions to match the latest upstream version.\n"))
                                         (_ #f))
                                        opts))
                      (()                          ; default to all packages
-                      ;; TODO: Keep only the newest of each package.
-                      (fold-packages cons '()))
+                      (let ((select? (match (assoc-ref opts 'select)
+                                       ('core core-package?)
+                                       ('non-core (negate core-package?))
+                                       (_ (const #t)))))
+                        ;; TODO: Keep only the newest of each package.
+                        (fold-packages (lambda (package result)
+                                         (if (select? package)
+                                             (cons package result)
+                                             result))
+                                       '())))
                      (some                        ; user-specified packages
                       some))))
-   (with-error-handling
-     (if dry-run?
-         (for-each (lambda (package)
-                     (match (false-if-exception (package-update-path package))
-                       ((new-version . directory)
-                        (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)
-                                  new-version)))
-                       (_ #f)))
-                   packages)
-         (let ((store (open-connection)))
-           (for-each (lambda (package)
-                       (let-values (((version tarball)
-                                     (catch #t
-                                       (lambda ()
-                                         (package-update store package))
-                                       (lambda _
-                                         (values #f #f))))
-                                    ((loc)
-                                     (or (package-field-location package
-                                                                 'version)
-                                         (package-location package))))
-                         (when version
+    (with-error-handling
+      (if dry-run?
+          (for-each (lambda (package)
+                      (match (false-if-exception (package-update-path package))
+                        ((new-version . directory)
+                         (let ((loc (or (package-field-location package 'version)
+                                        (package-location package))))
                            (format (current-error-port)
-                                   (_ "~a: ~a: updating from version ~a to version ~a...~%")
-                                   (location->string loc) (package-name package)
-                                   (package-version package) version)
-                           (let ((hash (call-with-input-file tarball
-                                         (compose sha256 get-bytevector-all))))
-                             (update-package-source package version hash)))))
-                     packages))))))
+                                   (_ "~a: ~a would be upgraded from ~a to ~a~%")
+                                   (location->string loc)
+                                   (package-name package) (package-version package)
+                                   new-version)))
+                        (_ #f)))
+                    packages)
+          (let ((store (open-connection)))
+            (for-each (lambda (package)
+                        (let-values (((version tarball)
+                                      (catch #t
+                                        (lambda ()
+                                          (package-update store package))
+                                        (lambda _
+                                          (values #f #f))))
+                                     ((loc)
+                                      (or (package-field-location package
+                                                                  'version)
+                                          (package-location package))))
+                          (when version
+                            (format (current-error-port)
+                                    (_ "~a: ~a: updating from version ~a to version ~a...~%")
+                                    (location->string loc) (package-name package)
+                                    (package-version package) version)
+                            (let ((hash (call-with-input-file tarball
+                                          (compose sha256 get-bytevector-all))))
+                              (update-package-source package version hash)))))
+                      packages))))))