futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

packages: 'package-grafts' returns grafts for all the relevant outputs.

Browse Source 
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.
This commit is contained in:
Ludovic Courtès 2020-06-11 18:24:59 +02:00
parent cbd9581acc
commit 03a70e4c19
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 62 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
guix/packages.scm
View File

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

24
tests/packages.scm
View File

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