ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2025-01-11 13:49:23 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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 @@ (define %graft-cache
(make-weak-key-hash-table 200)) (make-weak-key-hash-table 200))
(define (input-graft store system) (define (input-graft store system)
"Return a procedure that, given a package with a graft, returns a graft, and "Return a procedure that, given a package with a replacement and an output name,
#f otherwise." returns a graft, and #f otherwise."
(match-lambda (match-lambda*
((? package? package) (((? package? package) output)
(let ((replacement (package-replacement package))) (let ((replacement (package-replacement package)))
(and replacement (and replacement
(cached (=> %graft-cache) package system (cached (=> %graft-cache) package (cons output system)
(let ((orig (package-derivation store package system (let ((orig (package-derivation store package system
#:graft? #f)) #:graft? #f))
(new (package-derivation store replacement system (new (package-derivation store replacement system
#:graft? #t))) #:graft? #t)))
(graft (graft
(origin orig) (origin orig)
(replacement new))))))) (origin-output output)
(x (replacement new)
#f))) (replacement-output output)))))))))
(define (input-cross-graft store target system) (define (input-cross-graft store target system)
"Same as 'input-graft', but for cross-compilation inputs." "Same as 'input-graft', but for cross-compilation inputs."
(match-lambda (match-lambda*
((? package? package) (((? package? package) output)
(let ((replacement (package-replacement package))) (let ((replacement (package-replacement package)))
(and replacement (and replacement
(let ((orig (package-cross-derivation store package target system (let ((orig (package-cross-derivation store package target system
#:graft? #f)) #:graft? #f))
(new (package-cross-derivation store replacement (new (package-cross-derivation store replacement
target system target system
#:graft? #t))) #:graft? #t)))
(graft (graft
(origin orig) (origin orig)
(replacement new)))))) (origin-output output)
(_ (replacement new)
#f))) (replacement-output output))))))))
(define* (fold-bag-dependencies proc seed bag (define* (fold-bag-dependencies proc seed bag
#:key (native? #t)) #:key (native? #t))
@ -1243,26 +1243,21 @@ (define bag-direct-inputs*
(bag-host-inputs bag)))) (bag-host-inputs bag))))
bag-host-inputs)) bag-host-inputs))
(define nodes (let loop ((inputs (bag-direct-inputs* bag))
(match (bag-direct-inputs* bag)
(((labels things _ ...) ...)
things)))
(let loop ((nodes nodes)
(result seed) (result seed)
(visited (setq))) (visited vlist-null))
(match nodes (match inputs
(() (()
result) result)
(((? package? head) . tail) (((label (? package? head) . rest) . tail)
(if (set-contains? visited head) (let ((output (match rest (() "out") ((output) output)))
(loop tail result visited) (outputs (vhash-foldq* cons '() head visited)))
(let ((inputs (bag-direct-inputs* (package->bag head)))) (if (member output outputs)
(loop (match inputs (loop tail result visited)
(((labels things _ ...) ...) (let ((inputs (bag-direct-inputs* (package->bag head))))
(append things tail))) (loop (append inputs tail)
(proc head result) (proc head output result)
(set-insert head visited))))) (vhash-consq head output visited))))))
((head . tail) ((head . tail)
(loop tail result visited))))) (loop tail result visited)))))
@ -1279,8 +1274,8 @@ (define native-grafts
(let ((->graft (input-graft store system))) (let ((->graft (input-graft store system)))
(parameterize ((%current-system system) (parameterize ((%current-system system)
(%current-target-system #f)) (%current-target-system #f))
(fold-bag-dependencies (lambda (package grafts) (fold-bag-dependencies (lambda (package output grafts)
(match (->graft package) (match (->graft package output)
(#f grafts) (#f grafts)
(graft (cons graft grafts)))) (graft (cons graft grafts))))
'() '()
@ -1291,8 +1286,8 @@ (define target-grafts
(let ((->graft (input-cross-graft store target system))) (let ((->graft (input-cross-graft store target system)))
(parameterize ((%current-system system) (parameterize ((%current-system system)
(%current-target-system target)) (%current-target-system target))
(fold-bag-dependencies (lambda (package grafts) (fold-bag-dependencies (lambda (package output grafts)
(match (->graft package) (match (->graft package output)
(#f grafts) (#f grafts)
(graft (cons graft grafts)))) (graft (cons graft grafts))))
'() '()

24
tests/packages.scm
View file

@ -900,6 +900,30 @@ (define read-at
(replacement #f)))) (replacement #f))))
(replacement (package-derivation %store new))))))) (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" (test-assert "replacement also grafted"
;; We build a DAG as below, where dotted arrows represent replacements and ;; We build a DAG as below, where dotted arrows represent replacements and
;; solid arrows represent dependencies: ;; solid arrows represent dependencies: