01/02: packages: Add 'package-input-rewriting'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 2a75b0b63dbf123023c1c7ae99cf01a3866612a1
Author: Ludovic Courtès <address@hidden>
Date:   Thu Sep 1 22:35:35 2016 +0200

    packages: Add 'package-input-rewriting'.
    
    * guix/packages.scm (package-input-rewriting): New procedure.
    * tests/packages.scm ("package-input-rewriting"): New test.
    * doc/guix.texi (Defining Packages): Document it.
    (Package Transformation Options): Add cross-reference.
---
 doc/guix.texi      |   42 +++++++++++++++++++++++++++++++++++++++++-
 guix/packages.scm  |   30 ++++++++++++++++++++++++++++++
 tests/packages.scm |   25 +++++++++++++++++++++++++
 3 files changed, 96 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 5448c66..2a7fd4d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2574,6 +2574,45 @@ and operating system, such as @code{"mips64el-linux-gnu"}
 Configure and Build System}).
 @end deffn
 
address@hidden package transformations
address@hidden input rewriting
address@hidden dependency tree rewriting
+Packages can be manipulated in arbitrary ways.  An example of a useful
+transformation is @dfn{input rewriting}, whereby the dependency tree of
+a package is rewritten by replacing specific inputs by others:
+
address@hidden {Scheme Procedure} package-input-rewriting @var{replacements} @
+           address@hidden
+Return a procedure that, when passed a package, replaces its direct and
+indirect dependencies (but not its implicit inputs) according to
address@hidden  @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.
address@hidden deffn
+
address@hidden
+Consider this example:
+
address@hidden
+(define libressl-instead-of-openssl
+  ;; This is a procedure to replace OPENSSL by LIBRESSL,
+  ;; recursively.
+  (package-input-rewriting `((,openssl . ,libressl))))
+
+(define git-with-libressl
+  (libressl-instead-of-openssl git))
address@hidden example
+
address@hidden
+Here we first define a rewriting procedure that replaces @var{openssl}
+with @var{libressl}.  Then we use it to define a @dfn{variant} of the
address@hidden package that uses @var{libressl} instead of @var{openssl}.
+This is exactly what the @option{--with-input} command-line option does
+(@pxref{Package Transformation Options, @option{--with-input}}).
+
 @menu
 * package Reference ::          The package data type.
 * origin Reference::            The origin data type.
@@ -4362,7 +4401,8 @@ This is a recursive, deep replacement.  So in this 
example, both
 @code{guix} and its dependency @code{guile-json} (which also depends on
 @code{guile}) get rebuilt against @code{guile-next}.
 
-However, implicit inputs are left unchanged.
+This is implemented using the @code{package-input-rewriting} Scheme
+procedure (@pxref{Defining Packages, @code{package-input-rewriting}}).
 @end table
 
 @node Additional Build Options
diff --git a/guix/packages.scm b/guix/packages.scm
index 3646b9b..d544c34 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -94,6 +94,7 @@
             package-transitive-propagated-inputs
             package-transitive-native-search-paths
             package-transitive-supported-systems
+            package-input-rewriting
             package-source-derivation
             package-derivation
             package-cross-derivation
@@ -732,6 +733,35 @@ 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 (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-memoized/v (replace 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 derivations.
diff --git a/tests/packages.scm b/tests/packages.scm
index e9c8690..daceea5 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -742,6 +742,31 @@
            (and (build-derivations %store (list drv))
                 (file-exists? (string-append out "/bin/make")))))))
 
+(test-assert "package-input-rewriting"
+  (let* ((dep     (dummy-package "chbouib"
+                    (native-inputs `(("x" ,grep)))))
+         (p0      (dummy-package "example"
+                    (inputs `(("foo" ,coreutils)
+                              ("bar" ,grep)
+                              ("baz" ,dep)))))
+         (rewrite (package-input-rewriting `((,coreutils . ,sed)
+                                             (,grep . ,findutils))
+                                           (cut string-append "r-" <>)))
+         (p1      (rewrite p0))
+         (p2      (rewrite p0)))
+    (and (not (eq? p1 p0))
+         (eq? p1 p2)                              ;memoization
+         (string=? "r-example" (package-name p1))
+         (match (package-inputs p1)
+           ((("foo" dep1) ("bar" dep2) ("baz" dep3))
+            (and (eq? dep1 sed)
+                 (eq? dep2 findutils)
+                 (string=? (package-name dep3) "r-chbouib")
+                 (eq? dep3 (rewrite dep))         ;memoization
+                 (match (package-native-inputs dep3)
+                   ((("x" dep))
+                    (eq? dep findutils)))))))))
+
 (test-eq "fold-packages" hello
   (fold-packages (lambda (p r)
                    (if (string=? (package-name p) "hello")