05/06: packages: Add 'package-superseded' and associated support.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 01afdab89c6a91f4cd05d3c4f4ff95a0402703eb
Author: Ludovic Courtès <address@hidden>
Date:   Tue Sep 6 23:14:07 2016 +0200

    packages: Add 'package-superseded' and associated support.
    
    This provides a way to mark a package as superseded by another one.
    Upgrades replace superseded packages with their replacement.
    
    * guix/packages.scm (package-superseded, deprecated-package): New
    procedures.
    * gnu/packages.scm (%find-package): Check for 'package-superseded'.
    * guix/scripts/package.scm (transaction-upgrade-entry)[supersede]: New
    procedure.  Call it when 'package-superseded' is true.
    * tests/guix-build.sh: Add test for a superseded package.
    * tests/packages.scm ("package-superseded")
    ("transaction-upgrade-entry, superseded package"): New tests.
---
 gnu/packages.scm         |    9 ++++++++-
 guix/packages.scm        |   14 ++++++++++++++
 guix/scripts/package.scm |   46 +++++++++++++++++++++++++++++++---------------
 tests/guix-build.sh      |    6 ++++++
 tests/packages.scm       |   30 ++++++++++++++++++++++++++++++
 5 files changed, 89 insertions(+), 16 deletions(-)

diff --git a/gnu/packages.scm b/gnu/packages.scm
index 68a9eef..5d60423 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -305,7 +305,14 @@ return its return value."
      (when fallback?
        (warning (_ "deprecated NAME-VERSION syntax; \
 use address@hidden instead~%")))
-     pkg)
+
+     (match (package-superseded pkg)
+       ((? package? new)
+        (info (_ "package '~a' has been superseded by '~a'~%")
+              (package-name pkg) (package-name new))
+        new)
+       (#f
+        pkg)))
     (_
      (if version
          (leave (_ "~A: package not found for version ~a~%") name version)
diff --git a/guix/packages.scm b/guix/packages.scm
index d544c34..afbafc7 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -83,6 +83,8 @@
             package-location
             hidden-package
             hidden-package?
+            package-superseded
+            deprecated-package
             package-field-location
 
             package-direct-sources
@@ -306,6 +308,18 @@ user interfaces, ignores."
 interfaces."
   (assoc-ref (package-properties p) 'hidden?))
 
+(define (package-superseded p)
+  "Return the package the supersedes P, or #f if P is still current."
+  (assoc-ref (package-properties p) 'superseded))
+
+(define (deprecated-package old-name p)
+  "Return a package called OLD-NAME and marked as superseded by P, a package
+object."
+  (package
+    (inherit p)
+    (name old-name)
+    (properties `((superseded . ,p)))))
+
 (define (package-field-location package field)
   "Return the source code location of the definition of FIELD for PACKAGE, or
 #f if it could not be determined."
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index dc5fcba..b87aee0 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -264,25 +264,41 @@ synopsis or description matches all of REGEXPS."
 (define (transaction-upgrade-entry entry transaction)
   "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a
 <manifest-entry>."
+  (define (supersede old new)
+    (info (_ "package '~a' has been superseded by '~a'~%")
+          (manifest-entry-name old) (package-name new))
+    (manifest-transaction-install-entry
+     (package->manifest-entry new (manifest-entry-output old))
+     (manifest-transaction-remove-pattern
+      (manifest-pattern
+        (name (manifest-entry-name old))
+        (version (manifest-entry-version old))
+        (output (manifest-entry-output old)))
+      transaction)))
+
   (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)
-          ((>)
-           (manifest-transaction-install-entry
-            (package->manifest-entry pkg output)
-            transaction))
-          ((<)
-           transaction)
-          ((=)
-           (let ((candidate-path (derivation->output-path
-                                  (package-derivation (%store) pkg))))
-             (if (string=? path candidate-path)
-                 transaction
-                 (manifest-transaction-install-entry
-                  (package->manifest-entry pkg output)
-                  transaction))))))
+        (match (package-superseded pkg)
+          ((? package? new)
+           (supersede entry new))
+          (#f
+           (case (version-compare candidate-version version)
+             ((>)
+              (manifest-transaction-install-entry
+               (package->manifest-entry pkg output)
+               transaction))
+             ((<)
+              transaction)
+             ((=)
+              (let ((candidate-path (derivation->output-path
+                                     (package-derivation (%store) pkg))))
+                (if (string=? path candidate-path)
+                    transaction
+                    (manifest-transaction-install-entry
+                     (package->manifest-entry pkg output)
+                     transaction))))))))
        (#f
         transaction)))))
 
diff --git a/tests/guix-build.sh b/tests/guix-build.sh
index 6d4f970..9e9788b 100644
--- a/tests/guix-build.sh
+++ b/tests/guix-build.sh
@@ -93,6 +93,9 @@ cat > "$module_dir/foo.scm"<<EOF
 (define-public baz
   (dummy-package "baz" (replacement foo)))
 
+(define-public superseded
+  (deprecated-package "superseded" bar))
+
 EOF
 
 GUIX_PACKAGE_PATH="$module_dir"
@@ -168,6 +171,9 @@ test "$drv1" = "$drv2"
 if guix build guile --with-input=libunistring=something-really-silly
 then false; else true; fi
 
+# Deprecated/superseded packages.
+test "`guix build superseded -d`" = "`guix build bar -d`"
+
 # Parsing package names and versions.
 guix build -n time             # PASS
 guix build -n address@hidden           # PASS, version found
diff --git a/tests/packages.scm b/tests/packages.scm
index 456e691..b8e1f11 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -84,6 +84,15 @@
   (and (hidden-package? (hidden-package (dummy-package "foo")))
        (not (hidden-package? (dummy-package "foo")))))
 
+(test-assert "package-superseded"
+  (let* ((new (dummy-package "bar"))
+         (old (deprecated-package "foo" new)))
+    (and (eq? (package-superseded old) new)
+         (mock ((gnu packages) find-best-packages-by-name (const (list old)))
+               (specification->package "foo")
+               (and (eq? new (specification->package "foo"))
+                    (eq? new (specification->package+output "foo")))))))
+
 (test-assert "transaction-upgrade-entry, zero upgrades"
   (let* ((old (dummy-package "foo" (version "1")))
          (tx  (mock ((gnu packages) find-newest-available-packages
@@ -112,6 +121,27 @@
             (eq? item new)))
          (null? (manifest-transaction-remove tx)))))
 
+(test-assert "transaction-upgrade-entry, superseded package"
+  (let* ((old (dummy-package "foo" (version "1")))
+         (new (dummy-package "bar" (version "2")))
+         (dep (deprecated-package "foo" new))
+         (tx  (mock ((gnu packages) find-newest-available-packages
+                     (const (vhash-cons "foo" (list "2" dep) 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> "bar" "2" "out" item))
+            (eq? item new)))
+         (match (manifest-transaction-remove tx)
+           (((? manifest-pattern? pattern))
+            (and (string=? (manifest-pattern-name pattern) "foo")
+                 (string=? (manifest-pattern-version pattern) "1")
+                 (string=? (manifest-pattern-output pattern) "out")))))))
+
 (test-assert "package-field-location"
   (let ()
     (define (goto port line column)