04/08: packages: Add 'package-input-rewriting/spec'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit f258d8862852db9779945658b3a3f2b8a2a4c217
Author: Ludovic Courtès <address@hidden>
Date:   Tue Mar 12 21:39:48 2019 +0100

    packages: Add 'package-input-rewriting/spec'.
    
    * guix/packages.scm (package-input-rewriting/spec): New procedure.
    * tests/packages.scm ("package-input-rewriting/spec")
    ("package-input-rewriting/spec, partial match"): New tests.
    * doc/guix.texi (Defining Packages): Document it.
---
 doc/guix.texi      | 23 +++++++++++++++++++++++
 guix/packages.scm  | 38 ++++++++++++++++++++++++++++++++++++++
 tests/packages.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 112 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 139a09d..6124c9c 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5241,6 +5241,29 @@ 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}}).
 
+The following variant of @code{package-input-rewriting} can match packages to
+be replaced by name rather than by identity.
+
address@hidden {Scheme Procedure} package-input-rewriting/spec 
@var{replacements}
+Return a procedure that, given a package, applies the given @var{replacements} 
to
+all the package graph (excluding implicit inputs).  @var{replacements} is a 
list of
+spec/procedures pair; each spec is a package specification such as 
@code{"gcc"} or
address@hidden"guile@@2"}, and each procedure takes a matching package and 
returns a
+replacement for that package.
address@hidden deffn
+
+The example above could be rewritten this way:
+
address@hidden
+(define libressl-instead-of-openssl
+  ;; Replace all the packages called "openssl" with LibreSSL.
+  (package-input-rewriting/spec `(("openssl" . ,(const libressl)))))
address@hidden example
+
+The key difference here is that, this time, packages are matched by spec and
+not by identity.  In other words, any package in the graph that is called
address@hidden will be replaced.
+
 A more generic procedure to rewrite a package dependency graph is
 @code{package-mapping}: it supports arbitrary changes to nodes in the
 graph.
diff --git a/guix/packages.scm b/guix/packages.scm
index f191327..d20a256 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -102,6 +102,7 @@
             package-transitive-supported-systems
             package-mapping
             package-input-rewriting
+            package-input-rewriting/spec
             package-source-derivation
             package-derivation
             package-cross-derivation
@@ -869,6 +870,43 @@ package and returns its new name after rewrite."
 
   (package-mapping rewrite (cut assq <> replacements)))
 
+(define (package-input-rewriting/spec replacements)
+  "Return a procedure that, given a package, applies the given REPLACEMENTS to
+all the package graph (excluding implicit inputs).  REPLACEMENTS is a list of
+spec/procedures pair; each spec is a package specification such as \"gcc\" or
+\"address@hidden", and each procedure takes a matching package and returns a
+replacement for that package."
+  (define table
+    (fold (lambda (replacement table)
+            (match replacement
+              ((spec . proc)
+               (let-values (((name version)
+                             (package-name->name+version spec)))
+                 (vhash-cons name (list version proc) table)))))
+          vlist-null
+          replacements))
+
+  (define (find-replacement package)
+    (vhash-fold* (lambda (item proc)
+                   (or proc
+                       (match item
+                         ((#f proc)
+                          proc)
+                         ((version proc)
+                          (and (version-prefix? version
+                                                (package-version package))
+                               proc)))))
+                 #f
+                 (package-name package)
+                 table))
+
+  (define (rewrite package)
+    (match (find-replacement package)
+      (#f package)
+      (proc (proc package))))
+
+  (package-mapping rewrite find-replacement))
+
 (define-syntax-rule (package/inherit p overrides ...)
   "Like (package (inherit P) OVERRIDES ...), except that the same
 transformation is done to the package replacement, if any.  P must be a bare
diff --git a/tests/packages.scm b/tests/packages.scm
index 4e4bffc..613b2f1 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -981,6 +981,57 @@
                    ((("x" dep))
                     (eq? dep findutils)))))))))
 
+(test-assert "package-input-rewriting/spec"
+  (let* ((dep     (dummy-package "chbouib"
+                    (native-inputs `(("x" ,grep)))))
+         (p0      (dummy-package "example"
+                    (inputs `(("foo" ,coreutils)
+                              ("bar" ,grep)
+                              ("baz" ,dep)))))
+         (rewrite (package-input-rewriting/spec
+                   `(("coreutils" . ,(const sed))
+                     ("grep" . ,(const findutils)))))
+         (p1      (rewrite p0))
+         (p2      (rewrite p0)))
+    (and (not (eq? p1 p0))
+         (eq? p1 p2)                              ;memoization
+         (string=? "example" (package-name p1))
+         (match (package-inputs p1)
+           ((("foo" dep1) ("bar" dep2) ("baz" dep3))
+            (and (string=? (package-full-name dep1)
+                           (package-full-name sed))
+                 (string=? (package-full-name dep2)
+                           (package-full-name findutils))
+                 (string=? (package-name dep3) "chbouib")
+                 (eq? dep3 (rewrite dep))         ;memoization
+                 (match (package-native-inputs dep3)
+                   ((("x" dep))
+                    (string=? (package-full-name dep)
+                              (package-full-name findutils))))))))))
+
+(test-assert "package-input-rewriting/spec, partial match"
+  (let* ((dep     (dummy-package "chbouib"
+                    (version "1")
+                    (native-inputs `(("x" ,grep)))))
+         (p0      (dummy-package "example"
+                    (inputs `(("foo" ,coreutils)
+                              ("bar" ,dep)))))
+         (rewrite (package-input-rewriting/spec
+                   `(("address@hidden" . ,(const sed)) ;not matched
+                     ("grep" . ,(const findutils)))))
+         (p1      (rewrite p0)))
+    (and (not (eq? p1 p0))
+         (string=? "example" (package-name p1))
+         (match (package-inputs p1)
+           ((("foo" dep1) ("bar" dep2))
+            (and (string=? (package-full-name dep1)
+                           (package-full-name coreutils))
+                 (eq? dep2 (rewrite dep))         ;memoization
+                 (match (package-native-inputs dep2)
+                   ((("x" dep))
+                    (string=? (package-full-name dep)
+                              (package-full-name findutils))))))))))
+
 (test-equal "package-patched-vulnerabilities"
   '(("CVE-2015-1234")
     ("CVE-2016-1234" "CVE-2018-4567")