mirror/guix
mirror/guix
1
Fork 0
mirror of https://https.git.savannah.gnu.org/git/guix.git/ synced 2025-07-13 18:40:57 +02:00
Code Releases Activity

grafts: Allow file-like objects in the ‘replacement’ field of <graft>.

Browse source 
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 2025-01-28 14:53:03 +01:00
parent 3ad2d21671
commit 28e4018e59
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 21 additions and 49 deletions
Download patch file Download diff file Expand all files Collapse all files

23
guix/grafts.scm
View file

@ -101,9 +101,11 @@ are not recursively applied to dependencies of DRV."
;; List of store item pairs. ;; List of store item pairs.
(map (lambda (graft) (map (lambda (graft)
(gexp (gexp
((ungexp (graft-origin graft) ((ungexp (with-parameters ((%graft? #f))
(graft-origin graft))
(graft-origin-output graft)) (graft-origin-output graft))
. (ungexp (graft-replacement graft) . (ungexp (with-parameters ((%graft? #t))
(graft-replacement graft))
(graft-replacement-output graft))))) (graft-replacement-output graft)))))
grafts)) grafts))
@ -275,20 +277,6 @@ derivations to the corresponding set of grafts."
#:system system))))) #:system system)))))
(reference-origins drv items))) (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) (with-cache (list (derivation-file-name drv) outputs grafts)
(match (non-self-references store drv outputs) (match (non-self-references store drv outputs)
(() ;no dependencies (() ;no dependencies
@ -305,8 +293,7 @@ derivations to the corresponding set of grafts."
;; Use APPLICABLE, the subset of GRAFTS that is really ;; Use APPLICABLE, the subset of GRAFTS that is really
;; applicable to DRV, to avoid creating several identical ;; applicable to DRV, to avoid creating several identical
;; grafted variants of DRV. ;; grafted variants of DRV.
(let* ((new (graft-derivation/shallow* store drv (let* ((new (graft-derivation/shallow* store drv applicable
(map finalize-graft applicable)
#:outputs outputs #:outputs outputs
#:guile guile #:guile guile
#:system system)) #:system system))

21
guix/packages.scm
View file

@ -1818,15 +1818,13 @@ graft, and #f otherwise."
(if replacement (if replacement
(mcached eq? (=> %package-graft-cache) (mcached eq? (=> %package-graft-cache)
(mlet %store-monad ((orig (package->derivation package system (mlet %store-monad ((orig (package->derivation package system
#:graft? #f)) #:graft? #f)))
(new -> (package->derivation replacement system ;; Keep REPLACEMENT as a package so that its
#:graft? #t))) ;; derivation is computed only when necessary.
;; Keep NEW as a monadic value so that its computation
;; is delayed until necessary.
(return (graft (return (graft
(origin orig) (origin orig)
(origin-output output) (origin-output output)
(replacement new) (replacement replacement)
(replacement-output output)))) (replacement-output output))))
package output system) package output system)
(return #f)))) (return #f))))
@ -1842,16 +1840,13 @@ graft, and #f otherwise."
(if replacement (if replacement
(mlet %store-monad ((orig (package->cross-derivation package (mlet %store-monad ((orig (package->cross-derivation package
target system target system
#:graft? #f)) #:graft? #f)))
(new -> (package->cross-derivation replacement ;; Keep REPLACEMENT as a package so that its derivation is
target system ;; computed only when necessary.
#:graft? #t)))
;; Keep NEW as a monadic value so that its computation
;; is delayed until necessary.
(return (graft (return (graft
(origin orig) (origin orig)
(origin-output output) (origin-output output)
(replacement new) (replacement replacement)
(replacement-output output)))) (replacement-output output))))
(return #f)))) (return #f))))
(_ (_

26
tests/packages.scm
View file

@ -1095,9 +1095,7 @@
((graft) ((graft)
(and (eq? (graft-origin graft) (and (eq? (graft-origin graft)
(package-derivation %store dep)) (package-derivation %store dep))
(eq? (run-with-store %store (eq? (graft-replacement graft) new))))))
(graft-replacement graft))
(package-derivation %store new)))))))
;; XXX: This test would require building the cross toolchain just to see if it ;; XXX: This test would require building the cross toolchain just to see if it
;; needs grafting, which is obviously too expensive, and thus disabled. ;; needs grafting, which is obviously too expensive, and thus disabled.
@ -1134,9 +1132,7 @@
((graft) ((graft)
(and (eq? (graft-origin graft) (and (eq? (graft-origin graft)
(package-derivation %store dep)) (package-derivation %store dep))
(eq? (run-with-store %store (eq? (graft-replacement graft) new))))))
(graft-replacement graft))
(package-derivation %store new)))))))
(test-assert "package-grafts, same replacement twice" (test-assert "package-grafts, same replacement twice"
(let* ((new (dummy-package "dep" (let* ((new (dummy-package "dep"
@ -1161,9 +1157,7 @@
(package-derivation %store (package-derivation %store
(package (inherit dep) (package (inherit dep)
(replacement #f)))) (replacement #f))))
(eq? (run-with-store %store (eq? (graft-replacement graft) new))))))
(graft-replacement graft))
(package-derivation %store new)))))))
(test-assert "package-grafts, dependency on several outputs" (test-assert "package-grafts, dependency on several outputs"
;; Make sure we get one graft per output; see <https://bugs.gnu.org/41796>. ;; Make sure we get one graft per output; see <https://bugs.gnu.org/41796>.
@ -1183,9 +1177,9 @@
((graft1 graft2) ((graft1 graft2)
(and (eq? (graft-origin graft1) (graft-origin graft2) (and (eq? (graft-origin graft1) (graft-origin graft2)
(package-derivation %store p0)) (package-derivation %store p0))
(eq? (run-with-store %store (graft-replacement graft1)) (eq? (graft-replacement graft1)
(run-with-store %store (graft-replacement graft2)) (graft-replacement graft2)
(package-derivation %store p0*)) p0*)
(string=? "lib" (string=? "lib"
(graft-origin-output graft1) (graft-origin-output graft1)
(graft-replacement-output graft1)) (graft-replacement-output graft1))
@ -1262,14 +1256,10 @@
((graft1 graft2) ((graft1 graft2)
(and (eq? (graft-origin graft1) (and (eq? (graft-origin graft1)
(package-derivation %store p1 #:graft? #f)) (package-derivation %store p1 #:graft? #f))
(eq? (run-with-store %store (eq? (graft-replacement graft1) p1r)
(graft-replacement graft1))
(package-derivation %store p1r))
(eq? (graft-origin graft2) (eq? (graft-origin graft2)
(package-derivation %store p2 #:graft? #f)) (package-derivation %store p2 #:graft? #f))
(eq? (run-with-store %store (eq? (graft-replacement graft2) p2r))))))
(graft-replacement graft2))
(package-derivation %store p2r #:graft? #t)))))))
;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to ;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
;;; find out about their run-time dependencies, so this test is no longer ;;; find out about their run-time dependencies, so this test is no longer