packages: Add 'package-mapping' and base 'package-input-rewriting' on it.

* guix/packages.scm (package-mapping): New procedure.
(package-input-rewriting): Rewrite in terms of 'package-mapping'.
* tests/packages.scm ("package-mapping"): New test.
* doc/guix.texi (Defining Packages): Document it.

doc/guix.texi

@@ -2946,6 +2946,16 @@ with @var{libressl}.  Then we use it to define a @dfn{variant} of the
 This is exactly what the @option{--with-input} command-line option does
 (@pxref{Package Transformation Options, @option{--with-input}}).
 
+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?}]
+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.
+@end deffn
+
 @menu
 * package Reference ::          The package data type.
 * origin Reference::            The origin data type.

guix/packages.scm

@@ -98,6 +98,7 @@ (define-module (guix packages)
             package-transitive-propagated-inputs
             package-transitive-native-search-paths
             package-transitive-supported-systems
+            package-mapping
             package-input-rewriting
             package-source-derivation
             package-derivation
@@ -741,6 +742,35 @@ (define (bag-transitive-target-inputs bag)
   "Return the \"target inputs\" of BAG, recursively."
   (transitive-inputs (bag-target-inputs bag)))
 
+(define* (package-mapping proc #:optional (cut? (const #f)))
+  "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."
+  (define (rewrite input)
+    (match input
+      ((label (? package? package) outputs ...)
+       (let ((proc (if (cut? package) proc replace)))
+         (cons* label (proc package) outputs)))
+      (_
+       input)))
+
+  (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)))))))
+
+  replace)
+
 (define* (package-input-rewriting replacements
                                   #:optional (rewrite-name identity))
   "Return a procedure that, when passed a package, replaces its direct and
@@ -750,26 +780,14 @@ (define* (package-input-rewriting replacements
 
 Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
 package and returns its new name after rewrite."
-  (define (rewrite input)
-    (match input
-      ((label (? package? package) outputs ...)
-       (match (assq-ref replacements package)
-         (#f  (cons* label (replace package) outputs))
-         (new (cons* label new outputs))))
-      (_
-       input)))
+  (define (rewrite p)
+    (match (assq-ref replacements p)
+      (#f  (package
+             (inherit p)
+             (name (rewrite-name (package-name p)))))
+      (new new)))
 
-  (define replace
-    (mlambdaq (p)
-      ;; Return a variant of P with its inputs rewritten.
-      (package
-        (inherit p)
-        (name (rewrite-name (package-name p)))
-        (inputs (map rewrite (package-inputs p)))
-        (native-inputs (map rewrite (package-native-inputs p)))
-        (propagated-inputs (map rewrite (package-propagated-inputs p))))))
-
-  replace)
+  (package-mapping rewrite (cut assq <> replacements)))
 
 
 ;;;

tests/packages.scm

@@ -886,6 +886,33 @@ (define read-at
            (and (build-derivations %store (list drv))
                 (file-exists? (string-append out "/bin/make")))))))
 
+(test-equal "package-mapping"
+  42
+  (let* ((dep       (dummy-package "chbouib"
+                      (native-inputs `(("x" ,grep)))))
+         (p0        (dummy-package "example"
+                      (inputs `(("foo" ,coreutils)
+                                ("bar" ,grep)
+                                ("baz" ,dep)))))
+         (transform (lambda (p)
+                      (package (inherit p) (source 42))))
+         (rewrite   (package-mapping transform))
+         (p1        (rewrite p0)))
+    (and (eq? p1 (rewrite p0))
+         (eqv? 42 (package-source p1))
+         (match (package-inputs p1)
+           ((("foo" dep1) ("bar" dep2) ("baz" dep3))
+            (and (eq? dep1 (rewrite coreutils))   ;memoization
+                 (eq? dep2 (rewrite grep))
+                 (eq? dep3 (rewrite dep))
+                 (eqv? 42
+                       (package-source dep1) (package-source dep2)
+                       (package-source dep3))
+                 (match (package-native-inputs dep3)
+                   ((("x" dep))
+                    (and (eq? dep (rewrite grep))
+                         (package-source dep))))))))))
+
 (test-assert "package-input-rewriting"
   (let* ((dep     (dummy-package "chbouib"
                     (native-inputs `(("x" ,grep)))))