diff options
| -rw-r--r-- | guix/packages.scm | 81 | ||||
| -rw-r--r-- | tests/packages.scm | 24 |
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: |