mirror of
https://https.git.savannah.gnu.org/git/guix.git/
synced 2025-07-12 18:10:47 +02:00
grafts: Allow file-like objects in the ‘replacement’ field of <graft>.
This is a followup to and simplification of
3331d675fb.
* guix/grafts.scm (graft-derivation/shallow)[mapping]: Wrap origin and
replacement in ‘with-parameters’.
(cumulative-grafts)[finalize-graft]: Remove, and remove its sole user.
* guix/packages.scm (input-graft, input-cross-graft): Add ‘replacement’
straight into the ‘replacement’ field of <graft>.
* tests/packages.scm ("package-grafts, indirect grafts")
("package-grafts, indirect grafts, propagated inputs")
("package-grafts, same replacement twice")
("package-grafts, dependency on several outputs")
("replacement also grafted"): Adjust accordingly.
Suggested-by: David Elsing <david.elsing@posteo.net>
Change-Id: I286fceae53df9d3051137bbca5f944d51d0c92f3
This commit is contained in:
Ludovic Courtès
parent
3ad2d21671
commit
28e4018e59
3 changed files with 21 additions and 49 deletions
|
|
@ -101,9 +101,11 @@ are not recursively applied to dependencies of DRV."
|
|||
;; List of store item pairs.
|
||||
(map (lambda (graft)
|
||||
(gexp
|
||||
((ungexp (graft-origin graft)
|
||||
((ungexp (with-parameters ((%graft? #f))
|
||||
(graft-origin graft))
|
||||
(graft-origin-output graft))
|
||||
. (ungexp (graft-replacement graft)
|
||||
. (ungexp (with-parameters ((%graft? #t))
|
||||
(graft-replacement graft))
|
||||
(graft-replacement-output graft)))))
|
||||
grafts))
|
||||
|
||||
|
|
@ -275,20 +277,6 @@ derivations to the corresponding set of grafts."
|
|||
#:system system)))))
|
||||
(reference-origins drv items)))
|
||||
|
||||
;; If the 'replacement' field of the <graft> record is a procedure,
|
||||
;; this means that it is a value in the store monad and the actual
|
||||
;; derivation needs to be computed here.
|
||||
(define (finalize-graft item)
|
||||
(let ((replacement (graft-replacement item)))
|
||||
(if (procedure? replacement)
|
||||
(graft
|
||||
(inherit item)
|
||||
(replacement
|
||||
(run-with-store store replacement
|
||||
#:guile-for-build guile
|
||||
#:system system)))
|
||||
item)))
|
||||
|
||||
(with-cache (list (derivation-file-name drv) outputs grafts)
|
||||
(match (non-self-references store drv outputs)
|
||||
(() ;no dependencies
|
||||
|
|
@ -305,8 +293,7 @@ derivations to the corresponding set of grafts."
|
|||
;; Use APPLICABLE, the subset of GRAFTS that is really
|
||||
;; applicable to DRV, to avoid creating several identical
|
||||
;; grafted variants of DRV.
|
||||
(let* ((new (graft-derivation/shallow* store drv
|
||||
(map finalize-graft applicable)
|
||||
(let* ((new (graft-derivation/shallow* store drv applicable
|
||||
#:outputs outputs
|
||||
#:guile guile
|
||||
#:system system))
|
||||
|
|
|
|||
|
|
@ -1818,15 +1818,13 @@ graft, and #f otherwise."
|
|||
(if replacement
|
||||
(mcached eq? (=> %package-graft-cache)
|
||||
(mlet %store-monad ((orig (package->derivation package system
|
||||
#:graft? #f))
|
||||
(new -> (package->derivation replacement system
|
||||
#:graft? #t)))
|
||||
;; Keep NEW as a monadic value so that its computation
|
||||
;; is delayed until necessary.
|
||||
#:graft? #f)))
|
||||
;; Keep REPLACEMENT as a package so that its
|
||||
;; derivation is computed only when necessary.
|
||||
(return (graft
|
||||
(origin orig)
|
||||
(origin-output output)
|
||||
(replacement new)
|
||||
(replacement replacement)
|
||||
(replacement-output output))))
|
||||
package output system)
|
||||
(return #f))))
|
||||
|
|
@ -1842,16 +1840,13 @@ graft, and #f otherwise."
|
|||
(if replacement
|
||||
(mlet %store-monad ((orig (package->cross-derivation package
|
||||
target system
|
||||
#:graft? #f))
|
||||
(new -> (package->cross-derivation replacement
|
||||
target system
|
||||
#:graft? #t)))
|
||||
;; Keep NEW as a monadic value so that its computation
|
||||
;; is delayed until necessary.
|
||||
#:graft? #f)))
|
||||
;; Keep REPLACEMENT as a package so that its derivation is
|
||||
;; computed only when necessary.
|
||||
(return (graft
|
||||
(origin orig)
|
||||
(origin-output output)
|
||||
(replacement new)
|
||||
(replacement replacement)
|
||||
(replacement-output output))))
|
||||
(return #f))))
|
||||
(_
|
||||
|
|
|
|||
|
|
@ -1095,9 +1095,7 @@
|
|||
((graft)
|
||||
(and (eq? (graft-origin graft)
|
||||
(package-derivation %store dep))
|
||||
(eq? (run-with-store %store
|
||||
(graft-replacement graft))
|
||||
(package-derivation %store new)))))))
|
||||
(eq? (graft-replacement graft) new))))))
|
||||
|
||||
;; XXX: This test would require building the cross toolchain just to see if it
|
||||
;; needs grafting, which is obviously too expensive, and thus disabled.
|
||||
|
|
@ -1134,9 +1132,7 @@
|
|||
((graft)
|
||||
(and (eq? (graft-origin graft)
|
||||
(package-derivation %store dep))
|
||||
(eq? (run-with-store %store
|
||||
(graft-replacement graft))
|
||||
(package-derivation %store new)))))))
|
||||
(eq? (graft-replacement graft) new))))))
|
||||
|
||||
(test-assert "package-grafts, same replacement twice"
|
||||
(let* ((new (dummy-package "dep"
|
||||
|
|
@ -1161,9 +1157,7 @@
|
|||
(package-derivation %store
|
||||
(package (inherit dep)
|
||||
(replacement #f))))
|
||||
(eq? (run-with-store %store
|
||||
(graft-replacement graft))
|
||||
(package-derivation %store new)))))))
|
||||
(eq? (graft-replacement graft) new))))))
|
||||
|
||||
(test-assert "package-grafts, dependency on several outputs"
|
||||
;; Make sure we get one graft per output; see <https://bugs.gnu.org/41796>.
|
||||
|
|
@ -1183,9 +1177,9 @@
|
|||
((graft1 graft2)
|
||||
(and (eq? (graft-origin graft1) (graft-origin graft2)
|
||||
(package-derivation %store p0))
|
||||
(eq? (run-with-store %store (graft-replacement graft1))
|
||||
(run-with-store %store (graft-replacement graft2))
|
||||
(package-derivation %store p0*))
|
||||
(eq? (graft-replacement graft1)
|
||||
(graft-replacement graft2)
|
||||
p0*)
|
||||
(string=? "lib"
|
||||
(graft-origin-output graft1)
|
||||
(graft-replacement-output graft1))
|
||||
|
|
@ -1262,14 +1256,10 @@
|
|||
((graft1 graft2)
|
||||
(and (eq? (graft-origin graft1)
|
||||
(package-derivation %store p1 #:graft? #f))
|
||||
(eq? (run-with-store %store
|
||||
(graft-replacement graft1))
|
||||
(package-derivation %store p1r))
|
||||
(eq? (graft-replacement graft1) p1r)
|
||||
(eq? (graft-origin graft2)
|
||||
(package-derivation %store p2 #:graft? #f))
|
||||
(eq? (run-with-store %store
|
||||
(graft-replacement graft2))
|
||||
(package-derivation %store p2r #:graft? #t)))))))
|
||||
(eq? (graft-replacement graft2) p2r))))))
|
||||
|
||||
;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
|
||||
;;; find out about their run-time dependencies, so this test is no longer
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue