03/06: guix package: Build up the transaction incrementally.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 5239f3d90841de767c86d0f3a7975b8d799d583d
Author: Ludovic Courtès <address@hidden>
Date:   Tue Sep 6 22:28:12 2016 +0200

    guix package: Build up the transaction incrementally.
    
    * guix/scripts/package.scm (upgraded-manifest-entry): Rename to...
    (transaction-upgrade-entry): ... this.  Add 'transaction' parameter and
    return a transaction.
    (options->installable): Likewise.
    [to-upgrade]: Rename to...
    [upgraded]: ... this, and change to be a transaction.  Return a
    transaction.
    (options->removable): Likewise.
    (process-actions): Adjust accordingly.
    * tests/packages.scm ("transaction-upgrade-entry, zero upgrades")
    ("transaction-upgrade-entry, one upgrade"): New tests.
---
 guix/scripts/package.scm |  100 +++++++++++++++++++++++++++-------------------
 tests/packages.scm       |   29 ++++++++++++++
 2 files changed, 87 insertions(+), 42 deletions(-)

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 14a0895..dc5fcba 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -261,25 +261,30 @@ synopsis or description matches all of REGEXPS."
        ((<)  #t)
        (else #f)))))
 
-(define (upgraded-manifest-entry entry)
-  "Return either a <manifest-entry> corresponding to an upgrade of ENTRY, or
-#f if no upgrade was found."
+(define (transaction-upgrade-entry entry transaction)
+  "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a
+<manifest-entry>."
   (match entry
     (($ <manifest-entry> name version output (? string? path))
      (match (vhash-assoc name (find-newest-available-packages))
        ((_ candidate-version pkg . rest)
         (case (version-compare candidate-version version)
           ((>)
-           (package->manifest-entry pkg output))
+           (manifest-transaction-install-entry
+            (package->manifest-entry pkg output)
+            transaction))
           ((<)
-           #f)
+           transaction)
           ((=)
            (let ((candidate-path (derivation->output-path
                                   (package-derivation (%store) pkg))))
-             (and (not (string=? path candidate-path))
-                  (package->manifest-entry pkg output))))))
+             (if (string=? path candidate-path)
+                 transaction
+                 (manifest-transaction-install-entry
+                  (package->manifest-entry pkg output)
+                  transaction))))))
        (#f
-        #f)))))
+        transaction)))))
 
 
 ;;;
@@ -559,17 +564,20 @@ upgrading, #f otherwise."
       (output #f)
       (item item))))
 
-(define (options->installable opts manifest)
+(define (options->installable opts manifest transaction)
   "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
-return the new list of manifest entries."
+return an variant of TRANSACTION that accounts for the specified installations
+and upgrades."
   (define upgrade?
     (options->upgrade-predicate opts))
 
-  (define to-upgrade
-    (filter-map (lambda (entry)
-                  (and (upgrade? (manifest-entry-name entry))
-                       (upgraded-manifest-entry entry)))
-                (manifest-entries manifest)))
+  (define upgraded
+    (fold (lambda (entry transaction)
+            (if (upgrade? (manifest-entry-name entry))
+                (transaction-upgrade-entry entry transaction)
+                transaction))
+          transaction
+          (manifest-entries manifest)))
 
   (define to-install
     (filter-map (match-lambda
@@ -586,23 +594,29 @@ return the new list of manifest entries."
                   (_ #f))
                 opts))
 
-  (append to-upgrade to-install))
-
-(define (options->removable options manifest)
-  "Given options, return the list of manifest patterns of packages to be
-removed from MANIFEST."
-  (filter-map (match-lambda
-               (('remove . spec)
-                (call-with-values
-                    (lambda ()
-                      (package-specification->name+version+output spec))
-                  (lambda (name version output)
-                    (manifest-pattern
-                      (name name)
-                      (version version)
-                      (output output)))))
-               (_ #f))
-              options))
+  (fold manifest-transaction-install-entry
+        upgraded
+        to-install))
+
+(define (options->removable options manifest transaction)
+  "Given options, return a variant of TRANSACTION augmented with the list of
+patterns of packages to remove."
+  (fold (lambda (opt transaction)
+          (match opt
+            (('remove . spec)
+             (call-with-values
+                 (lambda ()
+                   (package-specification->name+version+output spec))
+               (lambda (name version output)
+                 (manifest-transaction-remove-pattern
+                  (manifest-pattern
+                    (name name)
+                    (version version)
+                    (output output))
+                  transaction))))
+            (_ transaction)))
+        transaction
+        options))
 
 (define (register-gc-root store profile)
   "Register PROFILE, a profile generation symlink, as a GC root, unless it
@@ -813,16 +827,18 @@ processed, #f otherwise."
             opts)
 
   ;; Then, process normal package installation/removal/upgrade.
-  (let* ((manifest    (profile-manifest profile))
-         (install     (options->installable opts manifest))
-         (remove      (options->removable opts manifest))
-         (transaction (manifest-transaction
-                       (install (map transform-entry install))
-                       (remove remove)))
-         (new         (manifest-perform-transaction manifest transaction)))
-
-    (unless (and (null? install) (null? remove))
-      (show-manifest-transaction store manifest transaction
+  (let* ((manifest (profile-manifest profile))
+         (step1    (options->installable opts manifest
+                                         (manifest-transaction)))
+         (step2    (options->removable opts manifest step1))
+         (step3    (manifest-transaction
+                    (inherit step2)
+                    (install (map transform-entry
+                                  (manifest-transaction-install step2)))))
+         (new      (manifest-perform-transaction manifest step3)))
+
+    (unless (manifest-transaction-null? step3)
+      (show-manifest-transaction store manifest step3
                                  #:dry-run? dry-run?)
       (build-and-use-profile store profile new
                              #:bootstrap? bootstrap?
diff --git a/tests/packages.scm b/tests/packages.scm
index daceea5..456e691 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -49,6 +49,7 @@
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-64)
   #:use-module (rnrs io ports)
+  #:use-module (ice-9 vlist)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match))
 
@@ -83,6 +84,34 @@
   (and (hidden-package? (hidden-package (dummy-package "foo")))
        (not (hidden-package? (dummy-package "foo")))))
 
+(test-assert "transaction-upgrade-entry, zero upgrades"
+  (let* ((old (dummy-package "foo" (version "1")))
+         (tx  (mock ((gnu packages) find-newest-available-packages
+                     (const vlist-null))
+                    ((@@ (guix scripts package) transaction-upgrade-entry)
+                     (manifest-entry
+                       (inherit (package->manifest-entry old))
+                       (item (string-append (%store-prefix) "/"
+                                            (make-string 32 #\e) "-foo-1")))
+                     (manifest-transaction)))))
+    (manifest-transaction-null? tx)))
+
+(test-assert "transaction-upgrade-entry, one upgrade"
+  (let* ((old (dummy-package "foo" (version "1")))
+         (new (dummy-package "foo" (version "2")))
+         (tx  (mock ((gnu packages) find-newest-available-packages
+                     (const (vhash-cons "foo" (list "2" new) vlist-null)))
+                    ((@@ (guix scripts package) transaction-upgrade-entry)
+                     (manifest-entry
+                       (inherit (package->manifest-entry old))
+                       (item (string-append (%store-prefix) "/"
+                                            (make-string 32 #\e) "-foo-1")))
+                     (manifest-transaction)))))
+    (and (match (manifest-transaction-install tx)
+           ((($ <manifest-entry> "foo" "2" "out" item))
+            (eq? item new)))
+         (null? (manifest-transaction-remove tx)))))
+
 (test-assert "package-field-location"
   (let ()
     (define (goto port line column)