03/11: packages: 'package-input-rewriting/spec' can rewrite implicit dependencies.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 2bf6f962b91123b0474c0f7123cd17efe7f09a66
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Sep 23 10:29:09 2020 +0200

    packages: 'package-input-rewriting/spec' can rewrite implicit dependencies.
    
    With this change, '--with-input', '--with-graft', etc. also apply to
    implicit dependencies.  Thus, it's now possible to do:
    
      guix build python-itsdangerous --with-input=python-wrapper=python@2
    
    or:
    
      guix build hello --with-graft=glibc=glibc@2.29
    
    Additionally, before, implicit inputs were not rewritten, which could
    lead to duplicates in the output of 'bag-transitive-inputs' (packages
    that are not 'eq?' but lead to the same derivation).  This in turn would
    lead to unnecessary rebuilds when using '--with-input' & co.  This
    change fixes it by ensuring even implicit inputs are rewritten.
    
    Fixes <https://bugs.gnu.org/42156>.
    
    * guix/packages.scm (package-input-rewriting/spec): Add #:deep?
    defaulting to #true, and pass it to 'package-mapping'.
    [replacement-property]: New variable.
    [rewrite]: Check that property and set it on the result of PROC.
    [cut?]: New procedure.
    * tests/packages.scm ("package-input-rewriting/spec"): Ensure implicit
    inputs were unchanged.
    ("package-input-rewriting/spec, partial match"): Pass #:deep? #f.
    ("package-input-rewriting/spec, deep")
    ("package-input-rewriting/spec, no duplicates"): New tests.
    (package/inherit): Move before use.
    * tests/guix-build.sh: Add tests.
    * tests/scripts-build.scm ("options->transformation, with-graft"):
    Compare dependencies by package name or derivation file name.
    * doc/guix.texi (Defining Packages): Adjust accordingly.
---
 doc/guix.texi           | 13 +++++-----
 guix/packages.scm       | 55 ++++++++++++++++++++++++++---------------
 tests/guix-build.sh     | 11 +++++++++
 tests/packages.scm      | 66 ++++++++++++++++++++++++++++++++++++++++++++++---
 tests/scripts-build.scm | 12 ++++++---
 5 files changed, 125 insertions(+), 32 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 054449d..e72e1ec 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6272,12 +6272,13 @@ This is exactly what the @option{--with-input} 
command-line option does
 The following variant of @code{package-input-rewriting} can match packages to
 be replaced by name rather than by identity.
 
-@deffn {Scheme Procedure} package-input-rewriting/spec @var{replacements}
-Return a procedure that, given a package, applies the given @var{replacements} 
to
-all the package graph (excluding implicit inputs).  @var{replacements} is a 
list of
-spec/procedures pair; each spec is a package specification such as 
@code{"gcc"} or
-@code{"guile@@2"}, and each procedure takes a matching package and returns a
-replacement for that package.
+@deffn {Scheme Procedure} package-input-rewriting/spec @var{replacements} 
[#:deep? #t]
+Return a procedure that, given a package, applies the given
+@var{replacements} to all the package graph, including implicit inputs
+unless @var{deep?} is false.  @var{replacements} is a list of
+spec/procedures pair; each spec is a package specification such as
+@code{"gcc"} or @code{"guile@@2"}, and each procedure takes a matching
+package and returns a replacement for that package.
 @end deffn
 
 The example above could be rewritten this way:
diff --git a/guix/packages.scm b/guix/packages.scm
index 171fd04..f696945 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -422,6 +422,16 @@ name of its URI."
                                                        package)
                                                       16)))))
 
+(define-syntax-rule (package/inherit p overrides ...)
+  "Like (package (inherit P) OVERRIDES ...), except that the same
+transformation is done to the package replacement, if any.  P must be a bare
+identifier, and will be bound to either P or its replacement when evaluating
+OVERRIDES."
+  (let loop ((p p))
+    (package (inherit p)
+      overrides ...
+      (replacement (and=> (package-replacement p) loop)))))
+
 (define (package-upstream-name package)
   "Return the upstream name of PACKAGE, which could be different from the name
 it has in Guix."
@@ -1051,12 +1061,12 @@ package and returns its new name after rewrite."
 
   (package-mapping rewrite (cut assq <> replacements)))
 
-(define (package-input-rewriting/spec replacements)
+(define* (package-input-rewriting/spec replacements #:key (deep? #t))
   "Return a procedure that, given a package, applies the given REPLACEMENTS to
-all the package graph (excluding implicit inputs).  REPLACEMENTS is a list of
-spec/procedures pair; each spec is a package specification such as \"gcc\" or
-\"guile@2\", and each procedure takes a matching package and returns a
-replacement for that package."
+all the package graph, including implicit inputs unless DEEP? is false.
+REPLACEMENTS is a list of spec/procedures pair; each spec is a package
+specification such as \"gcc\" or \"guile@2\", and each procedure takes a
+matching package and returns a replacement for that package."
   (define table
     (fold (lambda (replacement table)
             (match replacement
@@ -1081,22 +1091,27 @@ replacement for that package."
                  (package-name package)
                  table))
 
-  (define (rewrite package)
-    (match (find-replacement package)
-      (#f package)
-      (proc (proc package))))
-
-  (package-mapping rewrite find-replacement))
+  (define replacement-property
+    (gensym " package-replacement"))
 
-(define-syntax-rule (package/inherit p overrides ...)
-  "Like (package (inherit P) OVERRIDES ...), except that the same
-transformation is done to the package replacement, if any.  P must be a bare
-identifier, and will be bound to either P or its replacement when evaluating
-OVERRIDES."
-  (let loop ((p p))
-    (package (inherit p)
-      overrides ...
-      (replacement (and=> (package-replacement p) loop)))))
+  (define (rewrite p)
+    (if (assq-ref (package-properties p) replacement-property)
+        p
+        (match (find-replacement p)
+          (#f p)
+          (proc
+           (let ((new (proc p)))
+             ;; Mark NEW as already processed.
+             (package/inherit new
+               (properties `((,replacement-property . #t)
+                             ,@(package-properties new)))))))))
+
+  (define (cut? p)
+    (or (assq-ref (package-properties p) replacement-property)
+        (find-replacement p)))
+
+  (package-mapping rewrite cut?
+                   #:deep? deep?))
 
 
 ;;;
diff --git a/tests/guix-build.sh b/tests/guix-build.sh
index 6c08857..ec2f736 100644
--- a/tests/guix-build.sh
+++ b/tests/guix-build.sh
@@ -259,6 +259,17 @@ drv1=`guix build guile -d`
 drv2=`guix build guile --with-input=gimp=ruby -d`
 test "$drv1" = "$drv2"
 
+# See <https://bugs.gnu.org/42156>.
+drv1=`guix build glib -d`
+drv2=`guix build glib -d --with-input=libreoffice=inkscape`
+test "$drv1" = "$drv2"
+
+# Rewriting implicit inputs.
+drv1=`guix build hello -d`
+drv2=`guix build hello -d --with-input=gcc=gcc-toolchain`
+test "$drv1" != "$drv2"
+guix gc -R "$drv2" | grep `guix build -d gcc-toolchain`
+
 if guix build guile --with-input=libunistring=something-really-silly
 then false; else true; fi
 
diff --git a/tests/packages.scm b/tests/packages.scm
index f33332a..6fa4ad2 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -38,6 +38,7 @@
   #:use-module (guix build-system)
   #:use-module (guix build-system trivial)
   #:use-module (guix build-system gnu)
+  #:use-module (guix build-system python)
   #:use-module (guix memoization)
   #:use-module (guix profiles)
   #:use-module (guix scripts package)
@@ -45,6 +46,7 @@
   #:use-module (gnu packages base)
   #:use-module (gnu packages guile)
   #:use-module (gnu packages bootstrap)
+  #:use-module (gnu packages python)
   #:use-module (gnu packages version-control)
   #:use-module (gnu packages xml)
   #:use-module (srfi srfi-1)
@@ -1262,7 +1264,8 @@
                               ("baz" ,dep)))))
          (rewrite (package-input-rewriting/spec
                    `(("coreutils" . ,(const sed))
-                     ("grep" . ,(const findutils)))))
+                     ("grep" . ,(const findutils)))
+                   #:deep? #f))
          (p1      (rewrite p0))
          (p2      (rewrite p0)))
     (and (not (eq? p1 p0))
@@ -1279,7 +1282,11 @@
                  (match (package-native-inputs dep3)
                    ((("x" dep))
                     (string=? (package-full-name dep)
-                              (package-full-name findutils))))))))))
+                              (package-full-name findutils)))))))
+
+         ;; Make sure implicit inputs were left unchanged.
+         (equal? (drop (bag-direct-inputs (package->bag p1)) 3)
+                 (drop (bag-direct-inputs (package->bag p0)) 3)))))
 
 (test-assert "package-input-rewriting/spec, partial match"
   (let* ((dep     (dummy-package "chbouib"
@@ -1290,7 +1297,8 @@
                               ("bar" ,dep)))))
          (rewrite (package-input-rewriting/spec
                    `(("chbouib@123" . ,(const sed)) ;not matched
-                     ("grep" . ,(const findutils)))))
+                     ("grep" . ,(const findutils)))
+                   #:deep? #f))
          (p1      (rewrite p0)))
     (and (not (eq? p1 p0))
          (string=? "example" (package-name p1))
@@ -1304,6 +1312,58 @@
                     (string=? (package-full-name dep)
                               (package-full-name findutils))))))))))
 
+(test-assert "package-input-rewriting/spec, deep"
+  (let* ((dep     (dummy-package "chbouib"))
+         (p0      (dummy-package "example"
+                    (build-system gnu-build-system)
+                    (inputs `(("dep" ,dep)))))
+         (rewrite (package-input-rewriting/spec
+                   `(("tar"  . ,(const sed))
+                     ("gzip" . ,(const findutils)))))
+         (p1      (rewrite p0))
+         (p2      (rewrite p0)))
+    (and (not (eq? p1 p0))
+         (eq? p1 p2)                              ;memoization
+         (string=? "example" (package-name p1))
+         (match (package-inputs p1)
+           ((("dep" dep1))
+            (and (string=? (package-full-name dep1)
+                           (package-full-name dep))
+                 (eq? dep1 (rewrite dep)))))      ;memoization
+
+         ;; Make sure implicit inputs were replaced.
+         (match (bag-direct-inputs (package->bag p1))
+           ((("dep" dep1) ("tar" tar) ("gzip" gzip) _ ...)
+            (and (eq? dep1 (rewrite dep))
+                 (string=? (package-full-name tar)
+                           (package-full-name sed))
+                 (string=? (package-full-name gzip)
+                           (package-full-name findutils))))))))
+
+(test-assert "package-input-rewriting/spec, no duplicates"
+  ;; Ensure that deep input rewriting does not forget implicit inputs.  Doing
+  ;; so could lead to duplicates in a package's inputs: in the example below,
+  ;; P0's transitive inputs would contain one rewritten "python" and one
+  ;; original "python".  These two "python" packages are thus not 'eq?' but
+  ;; they lower to the same derivation.  See <https://bugs.gnu.org/42156>,
+  ;; which can be reproduced by passing #:deep? #f.
+  (let* ((dep0    (dummy-package "dep0"
+                    (build-system trivial-build-system)
+                    (propagated-inputs `(("python" ,python)))))
+         (p0      (dummy-package "chbouib"
+                    (build-system python-build-system)
+                    (arguments `(#:python ,python))
+                    (inputs `(("dep0" ,dep0)))))
+         (rewrite (package-input-rewriting/spec '() #:deep? #t))
+         (p1      (rewrite p0))
+         (bag1    (package->bag p1))
+         (pythons (filter-map (match-lambda
+                                (("python" python) python)
+                                (_ #f))
+                              (bag-transitive-inputs bag1))))
+    (match (delete-duplicates pythons eq?)
+      ((p) (eq? p (rewrite python))))))
+
 (test-equal "package-patched-vulnerabilities"
   '(("CVE-2015-1234")
     ("CVE-2016-1234" "CVE-2018-4567")
diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm
index 12114fc..5f91360 100644
--- a/tests/scripts-build.scm
+++ b/tests/scripts-build.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,6 +19,7 @@
 (define-module (test-scripts-build)
   #:use-module (guix tests)
   #:use-module (guix store)
+  #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix git-download)
   #:use-module (guix scripts build)
@@ -163,11 +164,16 @@
                ((("foo" dep1) ("bar" dep2))
                 (and (string=? (package-full-name dep1)
                                (package-full-name grep))
-                     (eq? (package-replacement dep1) findutils)
+                     (string=? (package-full-name (package-replacement dep1))
+                               (package-full-name findutils))
                      (string=? (package-name dep2) "chbouib")
                      (match (package-native-inputs dep2)
                        ((("x" dep))
-                        (eq? (package-replacement dep) findutils)))))))))))
+                        (with-store store
+                          (string=? (derivation-file-name
+                                     (package-derivation store findutils))
+                                    (derivation-file-name
+                                     (package-derivation store 
dep))))))))))))))
 
 (test-equal "options->transformation, with-branch"
   (git-checkout (url "https://example.org";)