ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 05:18:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

packages: 'package-mapping' can recurse on implicit inputs.

Browse source 
* guix/packages.scm (build-system-with-package-mapping): New procedure.
(package-mapping): Add #:deep? and honor it.
* tests/packages.scm ("package-mapping"): Compare the direct inputs of
the bag of P0 and that of P1.
("package-mapping, deep"): New test.
This commit is contained in:
Ludovic Courtès 2020-09-21 17:44:29 +02:00
parent f458cfbcc5
commit ff39361c80
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 88 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
doc/guix.texi
View file

@ -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

65
guix/packages.scm
View file

@ -968,10 +968,31 @@ (define* (package-closure packages #:key (system (%current-system)))
(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 @@ (define (rewrite input)
(_
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)

36
tests/packages.scm
View file

@ -1172,15 +1172,24 @@ (define read-at
(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 @@ (define read-at
(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)))))