From 27b91d7851859c1c82e891fafc4a326b71fbf88d Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 30 Nov 2015 22:00:39 +0200
Subject: guix package: Refactor 'options->installable'.

* guix/scripts/package.scm (options->upgrade-predicate)
(store-item->manifest-entry): New procedures.
* guix/scripts/package.scm (options->installable): Use them.  Remove the
'packages-to-upgrade' and 'packages-to-install' variables by getting rid
of a level of indirection.
---
 guix/scripts/package.scm | 119 +++++++++++++++++++++--------------------------
 1 file changed, 54 insertions(+), 65 deletions(-)

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 5f65ed949d..c62daee9a7 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -510,87 +510,76 @@ kind of search path~%")
 
          %standard-build-options))
 
-(define (options->installable opts manifest)
-  "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
-return the new list of manifest entries."
-  (define (package->manifest-entry* package output)
-    (check-package-freshness package)
-    ;; When given a package via `-e', install the first of its
-    ;; outputs (XXX).
-    (package->manifest-entry package output))
-
+(define (options->upgrade-predicate opts)
+  "Return a predicate based on the upgrade/do-not-upgrade regexps in OPTS
+that, given a package name, returns true if the package is a candidate for
+upgrading, #f otherwise."
   (define upgrade-regexps
     (filter-map (match-lambda
-                 (('upgrade . regexp)
-                  (make-regexp* (or regexp "")))
-                 (_ #f))
+                  (('upgrade . regexp)
+                   (make-regexp* (or regexp "")))
+                  (_ #f))
                 opts))
 
   (define do-not-upgrade-regexps
     (filter-map (match-lambda
-                 (('do-not-upgrade . regexp)
-                  (make-regexp* regexp))
-                 (_ #f))
+                  (('do-not-upgrade . regexp)
+                   (make-regexp* regexp))
+                  (_ #f))
                 opts))
 
-  (define packages-to-upgrade
-    (match upgrade-regexps
-      (()
-       '())
-      ((_ ...)
-       (filter-map (match-lambda
-                    (($ <manifest-entry> name version output path _)
-                     (and (any (cut regexp-exec <> name)
-                               upgrade-regexps)
-                          (not (any (cut regexp-exec <> name)
-                                    do-not-upgrade-regexps))
-                          (upgradeable? name version path)
-                          (let ((output (or output "out")))
-                            (call-with-values
-                                (lambda ()
-                                  (specification->package+output name output))
-                              list))))
-                    (_ #f))
-                   (manifest-entries manifest)))))
+  (lambda (name)
+    (and (any (cut regexp-exec <> name) upgrade-regexps)
+         (not (any (cut regexp-exec <> name) do-not-upgrade-regexps)))))
+
+(define (store-item->manifest-entry item)
+  "Return a manifest entry for ITEM, a \"/gnu/store/...\" file name."
+  (let-values (((name version)
+                (package-name->name+version (store-path-package-name item))))
+    (manifest-entry
+      (name name)
+      (version version)
+      (output #f)
+      (item item))))
+
+(define (options->installable opts manifest)
+  "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
+return the new list of manifest entries."
+  (define (package->manifest-entry* package output)
+    (check-package-freshness package)
+    (package->manifest-entry package output))
+
+  (define upgrade?
+    (options->upgrade-predicate opts))
 
   (define to-upgrade
-    (map (match-lambda
-          ((package output)
-           (package->manifest-entry* package output)))
-         packages-to-upgrade))
+    (filter-map (match-lambda
+                  (($ <manifest-entry> name version output path _)
+                   (and (upgrade? name)
+                        (upgradeable? name version path)
+                        (let ((output (or output "out")))
+                          (call-with-values
+                              (lambda ()
+                                (specification->package+output name output))
+                            package->manifest-entry*))))
+                  (_ #f))
+                (manifest-entries manifest)))
 
-  (define packages-to-install
+  (define to-install
     (filter-map (match-lambda
-                 (('install . (? package? p))
-                  (list p "out"))
-                 (('install . (? string? spec))
-                  (and (not (store-path? spec))
+                  (('install . (? package? p))
+                   ;; When given a package via `-e', install the first of its
+                   ;; outputs (XXX).
+                   (package->manifest-entry* p "out"))
+                  (('install . (? string? spec))
+                   (if (store-path? spec)
+                       (store-item->manifest-entry spec)
                        (let-values (((package output)
                                      (specification->package+output spec)))
-                         (and package (list package output)))))
-                 (_ #f))
+                         (package->manifest-entry* package output))))
+                  (_ #f))
                 opts))
 
-  (define to-install
-    (append (map (match-lambda
-                  ((package output)
-                   (package->manifest-entry* package output)))
-                 packages-to-install)
-            (filter-map (match-lambda
-                         (('install . (? package?))
-                          #f)
-                         (('install . (? store-path? path))
-                          (let-values (((name version)
-                                        (package-name->name+version
-                                         (store-path-package-name path))))
-                            (manifest-entry
-                             (name name)
-                             (version version)
-                             (output #f)
-                             (item path))))
-                         (_ #f))
-                        opts)))
-
   (append to-upgrade to-install))
 
 (define (options->removable options manifest)
-- 
cgit v1.2.3