summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--doc/guix.texi5
-rw-r--r--guix/packages.scm65
-rw-r--r--tests/packages.scm36
3 files changed, 88 insertions, 18 deletions
diff --git a/doc/guix.texi b/doc/guix.texi
index 8384eee6c3..054449d8d6 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6296,10 +6296,11 @@ A more generic procedure to rewrite a package dependency graph is
@code{package-mapping}: it supports arbitrary changes to nodes in the
graph.
-@deffn {Scheme Procedure} package-mapping @var{proc} [@var{cut?}]
+@deffn {Scheme Procedure} package-mapping @var{proc} [@var{cut?}] [#:deep? #f]
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.
+when @var{cut?} returns true for a given package. When @var{deep?} is true, @var{proc} is
+applied to implicit inputs as well.
@end deffn
@menu
diff --git a/guix/packages.scm b/guix/packages.scm
index 6598bd3149..171fd048ef 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -968,10 +968,31 @@ packages they depend on, recursively."
(vhash-consq package #t visited)
(fold set-insert closure dependencies))))))))
-(define* (package-mapping proc #:optional (cut? (const #f)))
+(define (build-system-with-package-mapping bs rewrite)
+ "Return a variant of BS, a build system, that rewrites a bag's inputs by
+passing them through REWRITE, a procedure that takes an input tuplet and
+returns a \"rewritten\" input tuplet."
+ (define lower
+ (build-system-lower bs))
+
+ (define (lower* . args)
+ (let ((lowered (apply lower args)))
+ (bag
+ (inherit lowered)
+ (build-inputs (map rewrite (bag-build-inputs lowered)))
+ (host-inputs (map rewrite (bag-host-inputs lowered)))
+ (target-inputs (map rewrite (bag-target-inputs lowered))))))
+
+ (build-system
+ (inherit bs)
+ (lower lower*)))
+
+(define* (package-mapping proc #:optional (cut? (const #f))
+ #:key deep?)
"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."
+when CUT? returns true for a given package. When DEEP? is true, PROC is
+applied to implicit inputs as well."
(define (rewrite input)
(match input
((label (? package? package) outputs ...)
@@ -980,21 +1001,35 @@ when CUT? returns true for a given package."
(_
input)))
+ (define mapping-property
+ ;; Property indicating whether the package has already been processed.
+ (gensym " package-mapping-done"))
+
(define replace
(mlambdaq (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)))
- (replacement (and=> (package-replacement p) proc))))))
+ ;; If P is the result of a previous call, return it.
+ (if (assq-ref (package-properties p) mapping-property)
+ 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))
+ (build-system (if deep?
+ (build-system-with-package-mapping
+ (package-build-system p) rewrite)
+ (package-build-system p)))
+ (inputs (map rewrite (package-inputs p)))
+ (native-inputs (map rewrite (package-native-inputs p)))
+ (propagated-inputs (map rewrite (package-propagated-inputs p)))
+ (replacement (and=> (package-replacement p) proc))
+ (properties `((,mapping-property . #t)
+ ,@(package-properties p))))))))
replace)
diff --git a/tests/packages.scm b/tests/packages.scm
index cbd0503733..f33332a461 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1172,15 +1172,24 @@
(let* ((dep (dummy-package "chbouib"
(native-inputs `(("x" ,grep)))))
(p0 (dummy-package "example"
+ (source 77)
(inputs `(("foo" ,coreutils)
("bar" ,grep)
("baz" ,dep)))))
(transform (lambda (p)
(package (inherit p) (source 42))))
(rewrite (package-mapping transform))
- (p1 (rewrite p0)))
+ (p1 (rewrite p0))
+ (bag0 (package->bag p0))
+ (bag1 (package->bag p1)))
(and (eq? p1 (rewrite p0))
(eqv? 42 (package-source p1))
+
+ ;; Implicit inputs should be left unchanged (skip "source", "foo",
+ ;; "bar", and "baz" in this comparison).
+ (equal? (drop (bag-direct-inputs bag0) 4)
+ (drop (bag-direct-inputs bag1) 4))
+
(match (package-inputs p1)
((("foo" dep1) ("bar" dep2) ("baz" dep3))
(and (eq? dep1 (rewrite coreutils)) ;memoization
@@ -1194,6 +1203,31 @@
(and (eq? dep (rewrite grep))
(package-source dep))))))))))
+(test-equal "package-mapping, deep"
+ '(42)
+ (let* ((p0 (dummy-package "example"
+ (inputs `(("foo" ,coreutils)
+ ("bar" ,grep)))))
+ (transform (lambda (p)
+ (package (inherit p) (source 42))))
+ (rewrite (package-mapping transform #:deep? #t))
+ (p1 (rewrite p0))
+ (bag (package->bag p1)))
+ (and (eq? p1 (rewrite p0))
+ (match (bag-direct-inputs bag)
+ ((("source" 42) ("foo" dep1) ("bar" dep2) rest ..1)
+ (and (eq? dep1 (rewrite coreutils)) ;memoization
+ (eq? dep2 (rewrite grep))
+ (= 42 (package-source dep1))
+ (= 42 (package-source dep2))
+
+ ;; Check that implicit inputs of P0 also got rewritten.
+ (delete-duplicates
+ (map (match-lambda
+ ((_ package . _)
+ (package-source package)))
+ rest))))))))
+
(test-assert "package-input-rewriting"
(let* ((dep (dummy-package "chbouib"
(native-inputs `(("x" ,grep)))))