diff options
| -rw-r--r-- | guix/profiles.scm | 31 | ||||
| -rw-r--r-- | guix/ui.scm | 20 | ||||
| -rw-r--r-- | tests/profiles.scm | 14 |
3 files changed, 49 insertions, 16 deletions
diff --git a/guix/profiles.scm b/guix/profiles.scm index 921d001fa2..ac2009154f 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 696d0df964..382b5b1e0d 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 d816248994..c210123f74 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 <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> ;;; ;;; 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)) |