05/06: profiles: Distinguish downgrades from upgrades.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 46b23e1a436d209d6b96daee4bc398f102267502
Author: Ludovic Courtès <address@hidden>
Date:   Sun Feb 8 18:52:00 2015 +0100

    profiles: Distinguish downgrades from upgrades.
    
    Fixes <http://bugs.gnu.org/19764>.
    
    * guix/profiles.scm (manifest-transaction-effects): Return downgraded
      packages as a fourth value.
    * guix/ui.scm (show-manifest-transaction): Adjust accordingly.
    * tests/profiles.scm ("manifest-transaction-effects and downgrades"):
      New test.
---
 guix/profiles.scm  |   31 +++++++++++++++++++------------
 guix/ui.scm        |   20 +++++++++++++++++++-
 tests/profiles.scm |   14 +++++++++++---
 3 files changed, 49 insertions(+), 16 deletions(-)

diff --git a/guix/profiles.scm b/guix/profiles.scm
index 921d001..ac20091 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -303,24 +303,25 @@ no match.."
            (default '())))
 
 (define (manifest-transaction-effects manifest transaction)
-  "Compute the effect of applying TRANSACTION to MANIFEST.  Return 3 values:
-the list of packages that would be removed, installed, or upgraded when
-applying TRANSACTION to MANIFEST.  Upgrades are represented as pairs where the
-head is the entry being upgraded and the tail is the entry that will replace
-it."
+  "Compute the effect of applying TRANSACTION to MANIFEST.  Return 4 values:
+the list of packages that would be removed, installed, upgraded, or downgraded
+when applying TRANSACTION to MANIFEST.  Upgrades are represented as pairs
+where the head is the entry being upgraded and the tail is the entry that will
+replace it."
   (define (manifest-entry->pattern entry)
     (manifest-pattern
       (name   (manifest-entry-name entry))
       (output (manifest-entry-output entry))))
 
-  (let loop ((input    (manifest-transaction-install transaction))
-             (install '())
-             (upgrade '()))
+  (let loop ((input     (manifest-transaction-install transaction))
+             (install   '())
+             (upgrade   '())
+             (downgrade '()))
     (match input
       (()
        (let ((remove (manifest-transaction-remove transaction)))
          (values (manifest-matching-entries manifest remove)
-                 (reverse install) (reverse upgrade))))
+                 (reverse install) (reverse upgrade) (reverse downgrade))))
       ((entry rest ...)
        ;; Check whether installing ENTRY corresponds to the installation of a
        ;; new package or to an upgrade.
@@ -328,12 +329,18 @@ it."
        ;; XXX: When the exact same output directory is installed, we're not
        ;; really upgrading anything.  Add a check for that case.
        (let* ((pattern  (manifest-entry->pattern entry))
-              (previous (manifest-lookup manifest pattern)))
+              (previous (manifest-lookup manifest pattern))
+              (newer?   (and previous
+                             (version>? (manifest-entry-version entry)
+                                        (manifest-entry-version previous)))))
          (loop rest
                (if previous install (cons entry install))
-               (if previous
+               (if (and previous newer?)
                    (alist-cons previous entry upgrade)
-                   upgrade)))))))
+                   upgrade)
+               (if (and previous (not newer?))
+                   (alist-cons previous entry downgrade)
+                   downgrade)))))))
 
 (define (manifest-perform-transaction manifest transaction)
   "Perform TRANSACTION on MANIFEST and return new manifest."
diff --git a/guix/ui.scm b/guix/ui.scm
index 696d0df..382b5b1 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -416,7 +416,7 @@ replacement if PORT is not Unicode-capable."
                 (package-output store item output)
                 item)))
 
-  (let-values (((remove install upgrade)
+  (let-values (((remove install upgrade downgrade)
                 (manifest-transaction-effects manifest transaction)))
     (match remove
       ((($ <manifest-entry> name version output item) ..1)
@@ -434,6 +434,24 @@ replacement if PORT is not Unicode-capable."
                          len)
                      remove))))
       (_ #f))
+    (match downgrade
+      (((($ <manifest-entry> name old-version)
+         . ($ <manifest-entry> _ new-version output item)) ..1)
+       (let ((len       (length name))
+             (downgrade (map upgrade-string
+                             name old-version new-version output item)))
+         (if dry-run?
+             (format (current-error-port)
+                     (N_ "The following package would be 
downgraded:~%~{~a~%~}~%"
+                         "The following packages would be 
downgraded:~%~{~a~%~}~%"
+                         len)
+                     downgrade)
+             (format (current-error-port)
+                     (N_ "The following package will be 
downgraded:~%~{~a~%~}~%"
+                         "The following packages will be 
downgraded:~%~{~a~%~}~%"
+                         len)
+                     downgrade))))
+      (_ #f))
     (match upgrade
       (((($ <manifest-entry> name old-version)
          . ($ <manifest-entry> _ new-version output item)) ..1)
diff --git a/tests/profiles.scm b/tests/profiles.scm
index d816248..c210123 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <address@hidden>
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2014 Alex Kost <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -155,12 +155,20 @@
          (t  (manifest-transaction
               (install (list guile-2.0.9 glibc))
               (remove (list (manifest-pattern (name "coreutils")))))))
-    (let-values (((remove install upgrade)
+    (let-values (((remove install upgrade downgrade)
                   (manifest-transaction-effects m0 t)))
-      (and (null? remove)
+      (and (null? remove) (null? downgrade)
            (equal? (list glibc) install)
            (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))
 
+(test-assert "manifest-transaction-effects and downgrades"
+  (let* ((m0 (manifest (list guile-2.0.9)))
+         (t  (manifest-transaction (install (list guile-1.8.8)))))
+    (let-values (((remove install upgrade downgrade)
+                  (manifest-transaction-effects m0 t)))
+      (and (null? remove) (null? install) (null? upgrade)
+           (equal? (list (cons guile-2.0.9 guile-1.8.8)) downgrade)))))
+
 (test-assertm "profile-derivation"
   (mlet* %store-monad
       ((entry ->   (package->manifest-entry %bootstrap-guile))