05/11: packages: 'package-input-rewriting' has a #:deep? parameter.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 8819551c8d2a12cd4e84e09b51e434d05a012c9d
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Sep 23 14:56:38 2020 +0200

    packages: 'package-input-rewriting' has a #:deep? parameter.
    
    * guix/packages.scm (package-input-rewriting): Add #:deep? and pass it
    to 'package-mapping'.
    [replacement-property]: New variable.
    [rewrite]: Check it.
    [cut?]: New procedure.
    * tests/packages.scm ("package-input-rewriting"): Pass #:deep? #f and
    ensure implicit inputs were not rewritten.  Avoid 'eq?' comparisons.
    ("package-input-rewriting, deep"): New test.
    * gnu/packages/guile.scm (package-for-guile-2.0, package-for-guile-3.0):
    Pass #:deep? #f.
---
 doc/guix.texi          | 10 +++++-----
 gnu/packages/guile.scm |  6 ++++--
 guix/packages.scm      | 35 +++++++++++++++++++++++++----------
 tests/packages.scm     | 20 ++++++++++++++++++--
 4 files changed, 52 insertions(+), 19 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index e72e1ec..0805e2d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6238,12 +6238,12 @@ transformation is @dfn{input rewriting}, whereby the 
dependency tree of
 a package is rewritten by replacing specific inputs by others:
 
 @deffn {Scheme Procedure} package-input-rewriting @var{replacements} @
-           [@var{rewrite-name}]
+           [@var{rewrite-name}] [#:deep? #t]
 Return a procedure that, when passed a package, replaces its direct and
-indirect dependencies (but not its implicit inputs) according to
-@var{replacements}.  @var{replacements} is a list of package pairs; the
-first element of each pair is the package to replace, and the second one
-is the replacement.
+indirect dependencies, including implicit inputs when @var{deep?} is
+true, according to @var{replacements}.  @var{replacements} is a list of
+package pairs; the first element of each pair is the package to replace,
+and the second one is the replacement.
 
 Optionally, @var{rewrite-name} is a one-argument procedure that takes
 the name of a package and returns its new name after rewrite.
diff --git a/gnu/packages/guile.scm b/gnu/packages/guile.scm
index c59daee..280053b 100644
--- a/gnu/packages/guile.scm
+++ b/gnu/packages/guile.scm
@@ -420,11 +420,13 @@ GNU@tie{}Guile.  Use the @code{(ice-9 readline)} module 
and call its
   ;; A procedure that rewrites the dependency tree of the given package to use
   ;; GUILE-2.0 instead of GUILE-3.0.
   (package-input-rewriting `((,guile-3.0 . ,guile-2.0))
-                           (guile-variant-package-name "guile2.0")))
+                           (guile-variant-package-name "guile2.0")
+                           #:deep? #f))
 
 (define package-for-guile-2.2
   (package-input-rewriting `((,guile-3.0 . ,guile-2.2))
-                           (guile-variant-package-name "guile2.2")))
+                           (guile-variant-package-name "guile2.2")
+                           #:deep? #f))
 
 (define-syntax define-deprecated-guile3.0-package
   (lambda (s)
diff --git a/guix/packages.scm b/guix/packages.scm
index 0d0d749..4f2bb432 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1044,22 +1044,37 @@ applied to implicit inputs as well."
   replace)
 
 (define* (package-input-rewriting replacements
-                                  #:optional (rewrite-name identity))
+                                  #:optional (rewrite-name identity)
+                                  #:key (deep? #t))
   "Return a procedure that, when passed a package, replaces its direct and
-indirect dependencies (but not its implicit inputs) according to REPLACEMENTS.
-REPLACEMENTS is a list of package pairs; the first element of each pair is the
-package to replace, and the second one is the replacement.
+indirect dependencies, including implicit inputs when DEEP? is true, according
+to REPLACEMENTS.  REPLACEMENTS is a list of package pairs; the first element
+of each pair is the package to replace, and the second one is the replacement.
 
 Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
 package and returns its new name after rewrite."
+  (define replacement-property
+    ;; Property to tag right-hand sides in REPLACEMENTS.
+    (gensym " package-replacement"))
+
   (define (rewrite p)
-    (match (assq-ref replacements p)
-      (#f  (package
-             (inherit p)
-             (name (rewrite-name (package-name p)))))
-      (new new)))
+    (if (assq-ref (package-properties p) replacement-property)
+        p
+        (match (assq-ref replacements p)
+          (#f  (package/inherit p
+                 (name (rewrite-name (package-name p)))))
+          (new (if deep?
+                   (package/inherit new
+                     (properties `((,replacement-property . #t)
+                                   ,@(package-properties new))))
+                   new)))))
 
-  (package-mapping rewrite (cut assq <> replacements)))
+  (define (cut? p)
+    (or (assq-ref (package-properties p) replacement-property)
+        (assq-ref replacements p)))
+
+  (package-mapping rewrite cut?
+                   #:deep? deep?))
 
 (define* (package-input-rewriting/spec replacements #:key (deep? #t))
   "Return a procedure that, given a package, applies the given REPLACEMENTS to
diff --git a/tests/packages.scm b/tests/packages.scm
index e31dea6..af8941c 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1239,7 +1239,8 @@
                               ("baz" ,dep)))))
          (rewrite (package-input-rewriting `((,coreutils . ,sed)
                                              (,grep . ,findutils))
-                                           (cut string-append "r-" <>)))
+                                           (cut string-append "r-" <>)
+                                           #:deep? #f))
          (p1      (rewrite p0))
          (p2      (rewrite p0)))
     (and (not (eq? p1 p0))
@@ -1253,7 +1254,22 @@
                  (eq? dep3 (rewrite dep))         ;memoization
                  (match (package-native-inputs dep3)
                    ((("x" dep))
-                    (eq? dep findutils)))))))))
+                    (eq? dep 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-eq "package-input-rewriting, deep"
+  (derivation-file-name (package-derivation %store sed))
+  (let* ((p0      (dummy-package "chbouib"
+                    (build-system python-build-system)
+                    (arguments `(#:python ,python))))
+         (rewrite (package-input-rewriting `((,python . ,sed))))
+         (p1      (rewrite p0)))
+    (match (bag-direct-inputs (package->bag p1))
+      ((("python" python) _ ...)
+       (derivation-file-name (package-derivation %store python))))))
 
 (test-assert "package-input-rewriting/spec"
   (let* ((dep     (dummy-package "chbouib"