[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/06: packages: Add 'package-mapping' and base 'package-input-rewriting
From: |
Ludovic Courtès |
Subject: |
02/06: packages: Add 'package-mapping' and base 'package-input-rewriting' on it. |
Date: |
Wed, 5 Apr 2017 16:56:39 -0400 (EDT) |
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)))))
- branch master updated (b28187c -> 50f4ea1), Ludovic Courtès, 2017/04/05
- 01/06: Revert "gnu: openexr: Add IlmBase include sub-directory to 'OpenEXR.pc'.", Ludovic Courtès, 2017/04/05
- 06/06: environment: Deal with single-entry search paths., Ludovic Courtès, 2017/04/05
- 03/06: build-system/python: 'package-with-explicit-python' uses 'package-mapping'., Ludovic Courtès, 2017/04/05
- 05/06: doc: Add "Documentation" section., Ludovic Courtès, 2017/04/05
- 04/06: profiles: Generate database file for man pages., Ludovic Courtès, 2017/04/05
- 02/06: packages: Add 'package-mapping' and base 'package-input-rewriting' on it.,
Ludovic Courtès <=