From: "Ludovic Courtès" <ludo@gnu.org>
To: 34838@debbugs.gnu.org
Subject: [bug#34838] [PATCH 2/6] packages: Add 'package-input-rewriting/spec'.
Date: Wed, 13 Mar 2019 11:47:47 +0100 [thread overview]
Message-ID: <20190313104751.20758-2-ludo@gnu.org> (raw)
In-Reply-To: <20190313104751.20758-1-ludo@gnu.org>
* 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 42885577be..b0b7ee5dd0 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5155,6 +5155,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.
+
+@deffn {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
+@code{"guile@@2"}, and each procedure takes a matching package and returns a
+replacement for that package.
+@end deffn
+
+The example above could be rewritten this way:
+
+@example
+(define libressl-instead-of-openssl
+ ;; Replace all the packages called "openssl" with LibreSSL.
+ (package-input-rewriting/spec `(("openssl" . ,(const libressl)))))
+@end 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
+@code{openssl} 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 f191327718..d20a2562c3 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
+\"guile@2\", 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 4e4bffc48c..613b2f1221 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
+ `(("chbouib@123" . ,(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")
--
2.21.0
next prev parent reply other threads:[~2019-03-13 11:04 UTC|newest]
Thread overview: 8+ messages / expand[flat|nested] mbox.gz Atom feed top
2019-03-13 9:57 [bug#34838] [PATCH 0/6] Add '--with-git-url' and make sure it composes well Ludovic Courtès
2019-03-13 10:47 ` [bug#34838] [PATCH 1/6] guix build: Add '--with-git-url' Ludovic Courtès
2019-03-13 10:47 ` Ludovic Courtès [this message]
2019-03-13 10:47 ` [bug#34838] [PATCH 3/6] guix build: Factorize 'package-git-url' Ludovic Courtès
2019-03-13 10:47 ` [bug#34838] [PATCH 4/6] guix build: Transformation options match packages by spec Ludovic Courtès
2019-03-13 10:47 ` [bug#34838] [PATCH 5/6] guix build: '--with-commit' makes recursive checkouts Ludovic Courtès
2019-03-13 10:47 ` [bug#34838] [PATCH 6/6] guix build: '--with-branch' strips slashes from the version string Ludovic Courtès
2019-03-17 21:56 ` bug#34838: [PATCH 0/6] Add '--with-git-url' and make sure it composes well Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20190313104751.20758-2-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=34838@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.