From bcb571cba499c29556d36f17554253d285d4d578 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 21 Oct 2015 13:04:34 +0200
Subject: refresh: Add '--type' option.

* guix/scripts/refresh.scm (%options, show-help): Add --type.
  (lookup-updater): New procedure.
  (update-package): Add 'updaters' parameter and honor it.
  (guix-refresh)[options->updaters]: New procedure.
  Use it, and honor --type.
---
 guix/scripts/refresh.scm | 63 ++++++++++++++++++++++++++++++++++--------------
 1 file changed, 45 insertions(+), 18 deletions(-)

(limited to 'guix/scripts')

diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 8e461ce380..bbfdf240d0 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -65,6 +65,9 @@ (define %options
                     (x
                      (leave (_ "~a: invalid selection; expected `core' or `non-core'~%")
                             arg)))))
+        (option '(#\t "type") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'updater (string->symbol arg) result)))
         (option '(#\l "list-dependent") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'list-dependent? #t result)))
@@ -106,6 +109,8 @@ (define (show-help)
   -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'"))
+  (display (_ "
   -l, --list-dependent   list top-level dependent packages that would need to
                          be rebuilt as a result of upgrading PACKAGE..."))
   (newline)
@@ -136,14 +141,21 @@ (define %updaters
   (list %gnu-updater
         %elpa-updater))
 
-(define* (update-package store package #:key (key-download 'interactive))
+(define (lookup-updater name)
+  "Return the updater called NAME."
+  (find (lambda (updater)
+          (eq? name (upstream-updater-name updater)))
+        %updaters))
+
+(define* (update-package store package updaters
+                         #:key (key-download 'interactive))
   "Update the source file that defines PACKAGE with the new version.
 KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
 values: 'interactive' (default), 'always', and 'never'."
   (let-values (((version tarball)
                 (catch #t
                   (lambda ()
-                    (package-update store package %updaters
+                    (package-update store package updaters
                                     #:key-download key-download))
                   (lambda _
                     (values #f #f))))
@@ -180,6 +192,19 @@ (define (parse-options)
                   (alist-cons 'argument arg result))
                 %default-options))
 
+  (define (options->updaters opts)
+    ;; Return the list of updaters to use.
+    (match (filter-map (match-lambda
+                         (('updater . name)
+                          (lookup-updater name))
+                         (_ #f))
+                       opts)
+      (()
+       ;; Use the default updaters.
+       %updaters)
+      (lst
+       lst)))
+
   (define (keep-newest package lst)
     ;; If a newer version of PACKAGE is already in LST, return LST; otherwise
     ;; return LST minus the other version of PACKAGE in it, plus PACKAGE.
@@ -196,8 +221,8 @@ (define (keep-newest package lst)
 
   (define core-package?
     (let* ((input->package (match-lambda
-                            ((name (? package? package) _ ...) package)
-                            (_ #f)))
+                             ((name (? package? package) _ ...) package)
+                             (_ #f)))
            (final-inputs   (map input->package %final-inputs))
            (core           (append final-inputs
                                    (append-map (compose (cut filter-map input->package <>)
@@ -216,6 +241,7 @@ (define core-package?
 
   (let* ((opts            (parse-options))
          (update?         (assoc-ref opts 'update?))
+         (updaters        (options->updaters opts))
          (list-dependent? (assoc-ref opts 'list-dependent?))
          (key-download    (assoc-ref opts 'key-download))
          (packages
@@ -226,18 +252,18 @@ (define core-package?
                                 (specification->package spec))
                                (_ #f))
                              opts)
-                 (()                          ; default to all packages
-                  (let ((select? (match (assoc-ref opts 'select)
-                                        ('core core-package?)
-                                        ('non-core (negate core-package?))
-                                        (_ (const #t)))))
-                    (fold-packages (lambda (package result)
-                                     (if (select? package)
-                                         (keep-newest package result)
-                                         result))
-                                   '())))
-                 (some                        ; user-specified packages
-                  some))))
+            (()                                   ; default to all packages
+             (let ((select? (match (assoc-ref opts 'select)
+                              ('core core-package?)
+                              ('non-core (negate core-package?))
+                              (_ (const #t)))))
+               (fold-packages (lambda (package result)
+                                (if (select? package)
+                                    (keep-newest package result)
+                                    result))
+                              '())))
+            (some                                 ; user-specified packages
+             some))))
     (with-error-handling
       (cond
        (list-dependent?
@@ -269,11 +295,12 @@ (define core-package?
                           (or (assoc-ref opts 'gpg-command)
                               (%gpg-command))))
             (for-each
-             (cut update-package store <> #:key-download key-download)
+             (cut update-package store <> updaters
+                  #:key-download key-download)
              packages))))
        (else
         (for-each (lambda (package)
-                    (match (package-update-path package %updaters)
+                    (match (package-update-path package updaters)
                       ((? upstream-source? source)
                        (let ((loc (or (package-field-location package 'version)
                                       (package-location package))))
-- 
cgit v1.2.3