guix package: Better separate option processing.

* guix/scripts/package.scm (find-package): Rename to...
  (specification->package+output): ... this.  Rename 'name' parmameter
  to 'spec'.  Return a package and output name instead of a tuple.
  (options->installable): New procedure
  (guix-package)[process-actions]: Use it, and remove corresponding
  code.

1 files changed, 189 insertions, 168 deletions

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 84a33782da..c71cf8e76c 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -421,41 +421,43 @@ VERSION."
         ((_ version pkgs ...) pkgs)
         (#f '()))))
 
-(define* (find-package name #:optional (output "out"))
-  "Find the package NAME; NAME may contain a version number and a
-sub-derivation name.  If the version number is not present, return the
-preferred newest version.  If the sub-derivation name is not present, use
-OUTPUT."
-  (define request name)
+(define* (specification->package+output spec #:optional (output "out"))
+  "Find the package and output specified by SPEC, or #f and #f; SPEC may
+optionally contain a version number and an output name, as in these examples:
 
+  guile
+  guile-2.0.9
+  guile:debug
+  guile-2.0.9:debug
+
+If SPEC does not specify a version number, return the preferred newest
+version; if SPEC does not specify an output, return OUTPUT."
   (define (ensure-output p sub-drv)
     (if (member sub-drv (package-outputs p))
-        p
+        sub-drv
         (leave (_ "package `~a' lacks output `~a'~%")
                (package-full-name p)
                sub-drv)))
 
   (let*-values (((name sub-drv)
-                 (match (string-rindex name #\:)
-                   (#f    (values name output))
-                   (colon (values (substring name 0 colon)
-                                  (substring name (+ 1 colon))))))
+                 (match (string-rindex spec #\:)
+                   (#f    (values spec output))
+                   (colon (values (substring spec 0 colon)
+                                  (substring spec (+ 1 colon))))))
                 ((name version)
                  (package-name->name+version name)))
     (match (find-best-packages-by-name name version)
       ((p)
-       (list name (package-version p) sub-drv (ensure-output p sub-drv)
-             (package-transitive-propagated-inputs p)))
+       (values p (ensure-output p sub-drv)))
       ((p p* ...)
        (warning (_ "ambiguous package specification `~a'~%")
-                request)
+                spec)
        (warning (_ "choosing ~a from ~a~%")
                 (package-full-name p)
                 (location->string (package-location p)))
-       (list name (package-version p) sub-drv (ensure-output p sub-drv)
-             (package-transitive-propagated-inputs p)))
+       (values p (ensure-output p sub-drv)))
       (()
-       (leave (_ "~a: package not found~%") request)))))
+       (leave (_ "~a: package not found~%") spec)))))
 
 (define (upgradeable? name current-version current-path)
   "Return #t if there's a version of package NAME newer than CURRENT-VERSION,
@@ -707,6 +709,112 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
                   (cons `(query list-available ,(or arg ""))
                         result)))))
 
+(define (options->installable opts installed)
+  "Given INSTALLED, the set of currently installed packages, and OPTS, the
+result of 'args-fold', return two values: the new list of manifest entries,
+and the list of derivations that need to be built."
+  (define (canonicalize-deps deps)
+    ;; Remove duplicate entries from DEPS, a list of propagated inputs,
+    ;; where each input is a name/path tuple.
+    (define (same? d1 d2)
+      (match d1
+        ((_ p1)
+         (match d2
+           ((_ p2) (eq? p1 p2))
+           (_      #f)))
+        ((_ p1 out1)
+         (match d2
+           ((_ p2 out2)
+            (and (string=? out1 out2)
+                 (eq? p1 p2)))
+           (_ #f)))))
+
+    (delete-duplicates deps same?))
+
+  (define* (package->tuple p #:optional output)
+    ;; Convert package P to a manifest tuple.
+    ;; When given a package via `-e', install the first of its
+    ;; outputs (XXX).
+    (check-package-freshness p)
+    (let* ((output (or output (car (package-outputs p))))
+           (path   (package-output (%store) p output))
+           (deps   (package-transitive-propagated-inputs p)))
+      `(,(package-name p)
+        ,(package-version p)
+        ,output
+        ,path
+        ,(canonicalize-deps deps))))
+
+  (define upgrade-regexps
+    (filter-map (match-lambda
+                 (('upgrade . regexp)
+                  (make-regexp (or regexp "")))
+                 (_ #f))
+                opts))
+
+  (define packages-to-upgrade
+    (match upgrade-regexps
+      (()
+       '())
+      ((_ ...)
+       (let ((newest (find-newest-available-packages)))
+         (filter-map (match-lambda
+                      ((name version output path _)
+                       (and (any (cut regexp-exec <> name)
+                                 upgrade-regexps)
+                            (upgradeable? name version path)
+                            (let ((output (or output "out")))
+                              (call-with-values
+                                  (lambda ()
+                                    (specification->package+output name output))
+                                list))))
+                      (_ #f))
+                     installed)))))
+
+  (define to-upgrade
+    (map (match-lambda
+          ((package output)
+           (package->tuple package output)))
+         packages-to-upgrade))
+
+  (define packages-to-install
+    (filter-map (match-lambda
+                 (('install . (? package? p))
+                  (list p "out"))
+                 (('install . (? string? spec))
+                  (and (not (store-path? spec))
+                       (let-values (((package output)
+                                     (specification->package+output spec)))
+                         (and package (list package output)))))
+                 (_ #f))
+                opts))
+
+  (define to-install
+    (append (map (match-lambda
+                  ((package output)
+                   (package->tuple 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))))
+                            `(,name ,version #f ,path ())))
+                         (_ #f))
+                        opts)))
+
+  (define derivations
+    (map (match-lambda
+          ((package output)
+           ;; FIXME: We should really depend on just OUTPUT rather than on all
+           ;; the outputs of PACKAGE.
+           (package-derivation (%store) package)))
+         (append packages-to-install packages-to-upgrade)))
+
+  (values (append to-upgrade to-install) derivations))
+
 
 ;;;
 ;;; Entry point.
@@ -780,43 +888,12 @@ more information.~%"))
     (define verbose? (assoc-ref opts 'verbose?))
     (define profile  (assoc-ref opts 'profile))
 
-    (define (canonicalize-deps deps)
-      ;; Remove duplicate entries from DEPS, a list of propagated inputs,
-      ;; where each input is a name/path tuple.
-      (define (same? d1 d2)
-        (match d1
-          ((_ p1)
-           (match d2
-             ((_ p2) (eq? p1 p2))
-             (_      #f)))
-          ((_ p1 out1)
-           (match d2
-             ((_ p2 out2)
-              (and (string=? out1 out2)
-                   (eq? p1 p2)))
-             (_ #f)))))
-
-      (delete-duplicates deps same?))
-
     (define (same-package? tuple name out)
       (match tuple
         ((tuple-name _ tuple-output _ ...)
          (and (equal? name tuple-name)
               (equal? out tuple-output)))))
 
-    (define (package->tuple p)
-      ;; Convert package P to a tuple.
-      ;; When given a package via `-e', install the first of its
-      ;; outputs (XXX).
-      (let* ((out  (car (package-outputs p)))
-             (path (package-output (%store) p out))
-             (deps (package-transitive-propagated-inputs p)))
-        `(,(package-name p)
-          ,(package-version p)
-          ,out
-          ,p
-          ,(canonicalize-deps deps))))
-
     (define (show-what-to-remove/install remove install dry-run?)
       ;; Tell the user what's going to happen in high-level terms.
       ;; TODO: Report upgrades more clearly.
@@ -922,127 +999,71 @@ more information.~%"))
              (_ #f))
             opts))
           (else
-           (let* ((installed (manifest-packages (profile-manifest profile)))
-                  (upgrade-regexps (filter-map (match-lambda
-                                                (('upgrade . regexp)
-                                                 (make-regexp (or regexp "")))
-                                                (_ #f))
-                                               opts))
-                  (upgrade (if (null? upgrade-regexps)
-                               '()
-                               (let ((newest (find-newest-available-packages)))
-                                 (filter-map
-                                  (match-lambda
-                                   ((name version output path _)
-                                    (and (any (cut regexp-exec <> name)
-                                              upgrade-regexps)
-                                         (upgradeable? name version path)
-                                         (find-package name
-                                                       (or output "out"))))
-                                   (_ #f))
-                                  installed))))
-                  (install (append
-                            upgrade
-                            (filter-map (match-lambda
-                                         (('install . (? package? p))
-                                          (package->tuple p))
-                                         (('install . (? store-path?))
-                                          #f)
-                                         (('install . package)
-                                          (find-package package))
+           (let*-values (((installed)
+                          (manifest-packages (profile-manifest profile)))
+                         ((install* drv)
+                          (options->installable opts installed)))
+             (let* ((remove (filter-map (match-lambda
+                                         (('remove . package)
+                                          package)
                                          (_ #f))
-                                        opts)))
-                  (drv (filter-map (match-lambda
-                                    ((name version sub-drv
-                                           (? package? package)
-                                           (deps ...))
-                                     (check-package-freshness package)
-                                     (package-derivation (%store) package))
-                                    (_ #f))
-                                   install))
-                  (install*
-                   (append
-                    (filter-map (match-lambda
-                                 (('install . (? package? p))
-                                  #f)
-                                 (('install . (? store-path? path))
-                                  (let-values (((name version)
-                                                (package-name->name+version
-                                                 (store-path-package-name
-                                                  path))))
-                                    `(,name ,version #f ,path ())))
-                                 (_ #f))
-                                opts)
-                    (map (lambda (tuple drv)
-                           (match tuple
-                                  ((name version sub-drv _ (deps ...))
-                                   (let ((output-path
-                                          (derivation->output-path
-                                           drv sub-drv)))
-                                     `(,name ,version ,sub-drv ,output-path
-                                             ,(canonicalize-deps deps))))))
-                         install drv)))
-                  (remove (filter-map (match-lambda
-                                       (('remove . package)
-                                        package)
-                                        (_ #f))
-                                      opts))
-                  (remove* (filter-map (cut assoc <> installed) remove))
-                  (packages
-                   (append install*
-                           (fold (lambda (package result)
-                                   (match package
-                                          ((name _ out _ ...)
-                                           (filter (negate
-                                                    (cut same-package? <>
-                                                         name out))
-                                                   result))))
-                                 (fold alist-delete installed remove)
-                                 install*))))
-
-          (when (equal? profile %current-profile)
-            (ensure-default-profile))
-
-          (show-what-to-remove/install remove* install* dry-run?)
-          (show-what-to-build (%store) drv
-                              #:use-substitutes? (assoc-ref opts 'substitutes?)
-                              #:dry-run? dry-run?)
-
-          (or dry-run?
-              (and (build-derivations (%store) drv)
-                   (let* ((prof-drv (profile-derivation (%store) packages))
-                          (prof     (derivation->output-path prof-drv))
-                          (old-drv  (profile-derivation
-                                     (%store) (manifest-packages
-                                               (profile-manifest profile))))
-                          (old-prof (derivation->output-path old-drv))
-                          (number   (generation-number profile))
-
-                          ;; Always use NUMBER + 1 for the new profile,
-                          ;; possibly overwriting a "previous future
-                          ;; generation".
-                          (name     (format #f "~a-~a-link"
-                                            profile (+ 1 number))))
-                     (if (string=? old-prof prof)
-                         (when (or (pair? install) (pair? remove))
-                           (format (current-error-port)
-                                   (_ "nothing to be done~%")))
-                         (and (parameterize ((current-build-output-port
-                                              ;; Output something when Guile
-                                              ;; needs to be built.
-                                              (if (or verbose? (guile-missing?))
-                                                  (current-error-port)
-                                                  (%make-void-port "w"))))
-                                (build-derivations (%store) (list prof-drv)))
-                              (let ((count (length packages)))
-                                (switch-symlinks name prof)
-                                (switch-symlinks profile name)
-                                (format #t (N_ "~a package in profile~%"
-                                               "~a packages in profile~%"
-                                               count)
-                                        count)
-                                (display-search-paths packages
-                                                      profile)))))))))))
+                                        opts))
+                    (remove* (filter-map (cut assoc <> installed) remove))
+                    (packages
+                     (append install*
+                             (fold (lambda (package result)
+                                     (match package
+                                       ((name _ out _ ...)
+                                        (filter (negate
+                                                 (cut same-package? <>
+                                                      name out))
+                                                result))))
+                                   (fold alist-delete installed remove)
+                                   install*))))
+
+               (when (equal? profile %current-profile)
+                 (ensure-default-profile))
+
+               (show-what-to-remove/install remove* install* dry-run?)
+               (show-what-to-build (%store) drv
+                                   #:use-substitutes? (assoc-ref opts 'substitutes?)
+                                   #:dry-run? dry-run?)
+
+               (or dry-run?
+                   (and (build-derivations (%store) drv)
+                        (let* ((prof-drv (profile-derivation (%store) packages))
+                               (prof     (derivation->output-path prof-drv))
+                               (old-drv  (profile-derivation
+                                          (%store) (manifest-packages
+                                                    (profile-manifest profile))))
+                               (old-prof (derivation->output-path old-drv))
+                               (number   (generation-number profile))
+
+                               ;; Always use NUMBER + 1 for the new profile,
+                               ;; possibly overwriting a "previous future
+                               ;; generation".
+                               (name     (format #f "~a-~a-link"
+                                                 profile (+ 1 number))))
+                          (if (string=? old-prof prof)
+                              (when (or (pair? install*) (pair? remove))
+                                (format (current-error-port)
+                                        (_ "nothing to be done~%")))
+                              (and (parameterize ((current-build-output-port
+                                                   ;; Output something when Guile
+                                                   ;; needs to be built.
+                                                   (if (or verbose? (guile-missing?))
+                                                       (current-error-port)
+                                                       (%make-void-port "w"))))
+                                     (build-derivations (%store) (list prof-drv)))
+                                   (let ((count (length packages)))
+                                     (switch-symlinks name prof)
+                                     (switch-symlinks profile name)
+                                     (format #t (N_ "~a package in profile~%"
+                                                    "~a packages in profile~%"
+                                                    count)
+                                             count)
+                                     (display-search-paths packages
+                                                           profile))))))))))))
 
   (define (process-query opts)
     ;; Process any query specified by OPTS.  Return #t when a query was