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.
master
Ludovic Courtès 2017-04-05 15:19:15 +02:00
parent 79f912c710
commit f37f2b83fa
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 74 additions and 19 deletions

View File

@ -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
@code{package-mapping}: it supports arbitrary changes to nodes in the
graph.
@deffn {Scheme Procedure} package-mapping @var{proc} [@var{cut?}]
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.
@end deffn
@menu
* package Reference :: The package data type.
* origin Reference:: The origin data type.

View File

@ -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,6 +742,35 @@ dependencies are known to build on SYSTEM."
"Return the \"target inputs\" of BAG, recursively."
(transitive-inputs (bag-target-inputs bag)))
(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 ...)
(let ((proc (if (cut? package) proc replace)))
(cons* label (proc package) outputs)))
(_
input)))
(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)))))))
replace)
(define* (package-input-rewriting replacements
#:optional (rewrite-name identity))
"Return a procedure that, when passed a package, replaces its direct and
@ -750,26 +780,14 @@ 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 input)
(match input
((label (? package? package) outputs ...)
(match (assq-ref replacements package)
(#f (cons* label (replace package) outputs))
(new (cons* label new outputs))))
(_
input)))
(define (rewrite p)
(match (assq-ref replacements p)
(#f (package
(inherit p)
(name (rewrite-name (package-name p)))))
(new new)))
(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))))))
replace)
(package-mapping rewrite (cut assq <> replacements)))
;;;

View File

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