From 5239f3d90841de767c86d0f3a7975b8d799d583d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 6 Sep 2016 22:28:12 +0200
Subject: 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 +++++++++++++++++++++++++++--------------------
 1 file changed, 58 insertions(+), 42 deletions(-)

(limited to 'guix')

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 14a0895b43..dc5fcba922 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?
-- 
cgit v1.2.3