packages: 'package-mapping' can recurse on implicit inputs.

* guix/packages.scm (build-system-with-package-mapping): New procedure.
(package-mapping): Add #:deep? and honor it.
* tests/packages.scm ("package-mapping"): Compare the direct inputs of
the bag of P0 and that of P1.
("package-mapping, deep"): New test.

3 files changed, 88 insertions, 18 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index 8384eee6c3..054449d8d6 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6296,10 +6296,11 @@ A more generic procedure to rewrite a package dependency graph is
 @code{package-mapping}: it supports arbitrary changes to nodes in the
 graph.
 
-@deffn {Scheme Procedure} package-mapping @var{proc} [@var{cut?}]
+@deffn {Scheme Procedure} package-mapping @var{proc} [@var{cut?}] [#:deep? #f]
 Return a procedure that, given a package, applies @var{proc} to all the packages
 depended on and returns the resulting package.  The procedure stops recursion
-when @var{cut?} returns true for a given package.
+when @var{cut?} returns true for a given package.  When @var{deep?} is true, @var{proc} is
+applied to implicit inputs as well.
 @end deffn
 
 @menu
diff --git a/guix/packages.scm b/guix/packages.scm
index 6598bd3149..171fd048ef 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -968,10 +968,31 @@ packages they depend on, recursively."
                    (vhash-consq package #t visited)
                    (fold set-insert closure dependencies))))))))
 
-(define* (package-mapping proc #:optional (cut? (const #f)))
+(define (build-system-with-package-mapping bs rewrite)
+  "Return a variant of BS, a build system, that rewrites a bag's inputs by
+passing them through REWRITE, a procedure that takes an input tuplet and
+returns a \"rewritten\" input tuplet."
+  (define lower
+    (build-system-lower bs))
+
+  (define (lower* . args)
+    (let ((lowered (apply lower args)))
+      (bag
+        (inherit lowered)
+        (build-inputs (map rewrite (bag-build-inputs lowered)))
+        (host-inputs (map rewrite (bag-host-inputs lowered)))
+        (target-inputs (map rewrite (bag-target-inputs lowered))))))
+
+  (build-system
+    (inherit bs)
+    (lower lower*)))
+
+(define* (package-mapping proc #:optional (cut? (const #f))
+                          #:key deep?)
   "Return a procedure that, given a package, applies PROC to all the packages
 depended on and returns the resulting package.  The procedure stops recursion
-when CUT? returns true for a given package."
+when CUT? returns true for a given package.  When DEEP? is true, PROC is
+applied to implicit inputs as well."
   (define (rewrite input)
     (match input
       ((label (? package? package) outputs ...)
@@ -980,21 +1001,35 @@ when CUT? returns true for a given package."
       (_
        input)))
 
+  (define mapping-property
+    ;; Property indicating whether the package has already been processed.
+    (gensym " package-mapping-done"))
+
   (define replace
     (mlambdaq (p)
-      ;; Return a variant of P with PROC applied to P and its explicit
-      ;; dependencies, recursively.  Memoize the transformations.  Failing to
-      ;; do that, we would build a huge object graph with lots of duplicates,
-      ;; which in turns prevents us from benefiting from memoization in
-      ;; 'package-derivation'.
-      (let ((p (proc p)))
-        (package
-          (inherit p)
-          (location (package-location p))
-          (inputs (map rewrite (package-inputs p)))
-          (native-inputs (map rewrite (package-native-inputs p)))
-          (propagated-inputs (map rewrite (package-propagated-inputs p)))
-          (replacement (and=> (package-replacement p) proc))))))
+      ;; If P is the result of a previous call, return it.
+      (if (assq-ref (package-properties p) mapping-property)
+          p
+
+          ;; Return a variant of P with PROC applied to P and its explicit
+          ;; dependencies, recursively.  Memoize the transformations.  Failing
+          ;; to do that, we would build a huge object graph with lots of
+          ;; duplicates, which in turns prevents us from benefiting from
+          ;; memoization in 'package-derivation'.
+          (let ((p (proc p)))
+            (package
+              (inherit p)
+              (location (package-location p))
+              (build-system (if deep?
+                                (build-system-with-package-mapping
+                                 (package-build-system p) rewrite)
+                                (package-build-system p)))
+              (inputs (map rewrite (package-inputs p)))
+              (native-inputs (map rewrite (package-native-inputs p)))
+              (propagated-inputs (map rewrite (package-propagated-inputs p)))
+              (replacement (and=> (package-replacement p) proc))
+              (properties `((,mapping-property . #t)
+                            ,@(package-properties p))))))))
 
   replace)
 
diff --git a/tests/packages.scm b/tests/packages.scm
index cbd0503733..f33332a461 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1172,15 +1172,24 @@
   (let* ((dep       (dummy-package "chbouib"
                       (native-inputs `(("x" ,grep)))))
          (p0        (dummy-package "example"
+                      (source 77)
                       (inputs `(("foo" ,coreutils)
                                 ("bar" ,grep)
                                 ("baz" ,dep)))))
          (transform (lambda (p)
                       (package (inherit p) (source 42))))
          (rewrite   (package-mapping transform))
-         (p1        (rewrite p0)))
+         (p1        (rewrite p0))
+         (bag0      (package->bag p0))
+         (bag1      (package->bag p1)))
     (and (eq? p1 (rewrite p0))
          (eqv? 42 (package-source p1))
+
+         ;; Implicit inputs should be left unchanged (skip "source", "foo",
+         ;; "bar", and "baz" in this comparison).
+         (equal? (drop (bag-direct-inputs bag0) 4)
+                 (drop (bag-direct-inputs bag1) 4))
+
          (match (package-inputs p1)
            ((("foo" dep1) ("bar" dep2) ("baz" dep3))
             (and (eq? dep1 (rewrite coreutils))   ;memoization
@@ -1194,6 +1203,31 @@
                     (and (eq? dep (rewrite grep))
                          (package-source dep))))))))))
 
+(test-equal "package-mapping, deep"
+  '(42)
+  (let* ((p0        (dummy-package "example"
+                      (inputs `(("foo" ,coreutils)
+                                ("bar" ,grep)))))
+         (transform (lambda (p)
+                      (package (inherit p) (source 42))))
+         (rewrite   (package-mapping transform #:deep? #t))
+         (p1        (rewrite p0))
+         (bag       (package->bag p1)))
+    (and (eq? p1 (rewrite p0))
+         (match (bag-direct-inputs bag)
+           ((("source" 42) ("foo" dep1) ("bar" dep2) rest ..1)
+            (and (eq? dep1 (rewrite coreutils))   ;memoization
+                 (eq? dep2 (rewrite grep))
+                 (= 42 (package-source dep1))
+                 (= 42 (package-source dep2))
+
+                 ;; Check that implicit inputs of P0 also got rewritten.
+                 (delete-duplicates
+                  (map (match-lambda
+                         ((_ package . _)
+                          (package-source package)))
+                       rest))))))))
+
 (test-assert "package-input-rewriting"
   (let* ((dep     (dummy-package "chbouib"
                     (native-inputs `(("x" ,grep)))))