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

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit f37f2b83fa95c1fe2bf01c4b8072cfc23d4c67ec
Author: Ludovic Courtès <address@hidden>
Date:   Wed Apr 5 15:19:15 2017 +0200

    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      | 10 ++++++++++
 guix/packages.scm  | 56 ++++++++++++++++++++++++++++++++++++------------------
 tests/packages.scm | 27 ++++++++++++++++++++++++++
 3 files changed, 74 insertions(+), 19 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index aa779e3..b2498d0 100644
--- a/doc/guix.texi
+++ b/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
address@hidden: it supports arbitrary changes to nodes in the
+graph.
+
address@hidden {Scheme Procedure} package-mapping @var{proc} address@hidden
+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.
address@hidden deffn
+
 @menu
 * package Reference ::          The package data type.
 * origin Reference::            The origin data type.
diff --git a/guix/packages.scm b/guix/packages.scm
index b68b3de..44f2c32 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -98,6 +98,7 @@
             package-transitive-propagated-inputs
             package-transitive-native-search-paths
             package-transitive-supported-systems
+            package-mapping
             package-input-rewriting
             package-source-derivation
             package-derivation
@@ -741,36 +742,53 @@ dependencies are known to build on SYSTEM."
   "Return the \"target inputs\" of BAG, recursively."
   (transitive-inputs (bag-target-inputs bag)))
 
-(define* (package-input-rewriting replacements
-                                  #:optional (rewrite-name identity))
-  "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.
-
-Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
-package and returns its new name after rewrite."
+(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 ...)
-       (match (assq-ref replacements package)
-         (#f  (cons* label (replace package) outputs))
-         (new (cons* label new outputs))))
+       (let ((proc (if (cut? package) proc replace)))
+         (cons* label (proc package) outputs)))
       (_
        input)))
 
   (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))))))
+      ;; 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
+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.
+
+Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
+package and returns its new name after rewrite."
+  (define (rewrite p)
+    (match (assq-ref replacements p)
+      (#f  (package
+             (inherit p)
+             (name (rewrite-name (package-name p)))))
+      (new new)))
+
+  (package-mapping rewrite (cut assq <> replacements)))
+
 
 ;;;
 ;;; Package derivations.
diff --git a/tests/packages.scm b/tests/packages.scm
index 51dc1ba..930374d 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -886,6 +886,33 @@
            (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)))))