aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2020-06-11 18:24:59 +0200
committerLudovic Courtès <ludo@gnu.org>2020-06-11 19:05:05 +0200
commit03a70e4c190420e87c0b535285caf8f77260d4ff (patch)
treedbf3f3952af4990b959e048b1ae2766c1fc83ffa
parentcbd9581acc41cd49eb81c2432452cad4de805cbd (diff)
downloadguix-03a70e4c190420e87c0b535285caf8f77260d4ff.tar
guix-03a70e4c190420e87c0b535285caf8f77260d4ff.tar.gz
packages: 'package-grafts' returns grafts for all the relevant outputs.
Fixes <https://bugs.gnu.org/41796>. Reported by Jakub Kądziołka <kuba@kadziolka.net>. * guix/packages.scm (input-graft): Add 'output' parameter and honor it. Add OUTPUT to the cache key. (input-cross-graft): Likewise. (fold-bag-dependencies): Operate on inputs instead of nodes. Turn VISITED into a vhash instead of a set. Pass PROC HEAD and OUTPUT instead of just HEAD. (bag-grafts): Adjust accordingly. * tests/packages.scm ("package-grafts, dependency on several outputs"): New test.
-rw-r--r--guix/packages.scm81
-rw-r--r--tests/packages.scm24
2 files changed, 62 insertions, 43 deletions
diff --git a/guix/packages.scm b/guix/packages.scm
index 0ccd31a7a9..1e0ec41b76 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1194,39 +1194,39 @@ and return it."
(make-weak-key-hash-table 200))
(define (input-graft store system)
- "Return a procedure that, given a package with a graft, returns a graft, and
-#f otherwise."
- (match-lambda
- ((? package? package)
+ "Return a procedure that, given a package with a replacement and an output name,
+returns a graft, and #f otherwise."
+ (match-lambda*
+ (((? package? package) output)
(let ((replacement (package-replacement package)))
(and replacement
- (cached (=> %graft-cache) package system
+ (cached (=> %graft-cache) package (cons output system)
(let ((orig (package-derivation store package system
#:graft? #f))
(new (package-derivation store replacement system
#:graft? #t)))
(graft
(origin orig)
- (replacement new)))))))
- (x
- #f)))
+ (origin-output output)
+ (replacement new)
+ (replacement-output output)))))))))
(define (input-cross-graft store target system)
"Same as 'input-graft', but for cross-compilation inputs."
- (match-lambda
- ((? package? package)
- (let ((replacement (package-replacement package)))
- (and replacement
- (let ((orig (package-cross-derivation store package target system
- #:graft? #f))
- (new (package-cross-derivation store replacement
- target system
- #:graft? #t)))
- (graft
- (origin orig)
- (replacement new))))))
- (_
- #f)))
+ (match-lambda*
+ (((? package? package) output)
+ (let ((replacement (package-replacement package)))
+ (and replacement
+ (let ((orig (package-cross-derivation store package target system
+ #:graft? #f))
+ (new (package-cross-derivation store replacement
+ target system
+ #:graft? #t)))
+ (graft
+ (origin orig)
+ (origin-output output)
+ (replacement new)
+ (replacement-output output))))))))
(define* (fold-bag-dependencies proc seed bag
#:key (native? #t))
@@ -1243,26 +1243,21 @@ dependencies; otherwise, restrict to target dependencies."
(bag-host-inputs bag))))
bag-host-inputs))
- (define nodes
- (match (bag-direct-inputs* bag)
- (((labels things _ ...) ...)
- things)))
-
- (let loop ((nodes nodes)
+ (let loop ((inputs (bag-direct-inputs* bag))
(result seed)
- (visited (setq)))
- (match nodes
+ (visited vlist-null))
+ (match inputs
(()
result)
- (((? package? head) . tail)
- (if (set-contains? visited head)
- (loop tail result visited)
- (let ((inputs (bag-direct-inputs* (package->bag head))))
- (loop (match inputs
- (((labels things _ ...) ...)
- (append things tail)))
- (proc head result)
- (set-insert head visited)))))
+ (((label (? package? head) . rest) . tail)
+ (let ((output (match rest (() "out") ((output) output)))
+ (outputs (vhash-foldq* cons '() head visited)))
+ (if (member output outputs)
+ (loop tail result visited)
+ (let ((inputs (bag-direct-inputs* (package->bag head))))
+ (loop (append inputs tail)
+ (proc head output result)
+ (vhash-consq head output visited))))))
((head . tail)
(loop tail result visited)))))
@@ -1279,8 +1274,8 @@ to (see 'graft-derivation'.)"
(let ((->graft (input-graft store system)))
(parameterize ((%current-system system)
(%current-target-system #f))
- (fold-bag-dependencies (lambda (package grafts)
- (match (->graft package)
+ (fold-bag-dependencies (lambda (package output grafts)
+ (match (->graft package output)
(#f grafts)
(graft (cons graft grafts))))
'()
@@ -1291,8 +1286,8 @@ to (see 'graft-derivation'.)"
(let ((->graft (input-cross-graft store target system)))
(parameterize ((%current-system system)
(%current-target-system target))
- (fold-bag-dependencies (lambda (package grafts)
- (match (->graft package)
+ (fold-bag-dependencies (lambda (package output grafts)
+ (match (->graft package output)
(#f grafts)
(graft (cons graft grafts))))
'()
diff --git a/tests/packages.scm b/tests/packages.scm
index 72e87dbfb7..c7b6f669b5 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -900,6 +900,30 @@
(replacement #f))))
(replacement (package-derivation %store new)))))))
+(test-assert "package-grafts, dependency on several outputs"
+ ;; Make sure we get one graft per output; see <https://bugs.gnu.org/41796>.
+ (letrec* ((p0 (dummy-package "p0"
+ (version "1.0")
+ (replacement p0*)
+ (arguments '(#:implicit-inputs? #f))
+ (outputs '("out" "lib"))))
+ (p0* (package (inherit p0) (version "1.1")))
+ (p1 (dummy-package "p1"
+ (arguments '(#:implicit-inputs? #f))
+ (inputs `(("p0" ,p0)
+ ("p0:lib" ,p0 "lib"))))))
+ (lset= equal? (pk (package-grafts %store p1))
+ (list (graft
+ (origin (package-derivation %store p0))
+ (origin-output "out")
+ (replacement (package-derivation %store p0*))
+ (replacement-output "out"))
+ (graft
+ (origin (package-derivation %store p0))
+ (origin-output "lib")
+ (replacement (package-derivation %store p0*))
+ (replacement-output "lib"))))))
+
(test-assert "replacement also grafted"
;; We build a DAG as below, where dotted arrows represent replacements and
;; solid arrows represent dependencies: