M guix/grafts.scm => guix/grafts.scm +18 -2
@@ 1,5 1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014-2024 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2024 David Elsing <david.elsing@posteo.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ 53,7 54,7 @@
(origin graft-origin) ;derivation | store item
(origin-output graft-origin-output ;string | #f
(default "out"))
- (replacement graft-replacement) ;derivation | store item
+ (replacement graft-replacement) ;derivation | store item | monadic
(replacement-output graft-replacement-output ;string | #f
(default "out")))
@@ 274,6 275,20 @@ 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
@@ 290,7 305,8 @@ 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 applicable
+ (let* ((new (graft-derivation/shallow* store drv
+ (map finalize-graft applicable)
#:outputs outputs
#:guile guile
#:system system))
M guix/packages.scm => guix/packages.scm +10 -5
@@ 11,6 11,7 @@
;;; Copyright © 2022 jgart <jgart@dismail.de>
;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2024 David Elsing <david.elsing@posteo.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ 1818,8 1819,10 @@ graft, and #f otherwise."
(mcached eq? (=> %package-graft-cache)
(mlet %store-monad ((orig (package->derivation package system
#:graft? #f))
- (new (package->derivation replacement system
- #:graft? #t)))
+ (new -> (package->derivation replacement system
+ #:graft? #t)))
+ ;; Keep NEW as a monadic value so that its computation
+ ;; is delayed until necessary.
(return (graft
(origin orig)
(origin-output output)
@@ 1840,9 1843,11 @@ graft, and #f otherwise."
(mlet %store-monad ((orig (package->cross-derivation package
target system
#:graft? #f))
- (new (package->cross-derivation replacement
- target system
- #:graft? #t)))
+ (new -> (package->cross-derivation replacement
+ target system
+ #:graft? #t)))
+ ;; Keep NEW as a monadic value so that its computation
+ ;; is delayed until necessary.
(return (graft
(origin orig)
(origin-output output)
M tests/packages.scm => tests/packages.scm +52 -35
@@ 1,5 1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2024 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2025 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
@@ 1091,10 1091,13 @@
(dummy (dummy-package "dummy"
(arguments '(#:implicit-inputs? #f))
(inputs (list dep*)))))
- (equal? (package-grafts %store dummy)
- (list (graft
- (origin (package-derivation %store dep))
- (replacement (package-derivation %store new)))))))
+ (match (package-grafts %store dummy)
+ ((graft)
+ (and (eq? (graft-origin graft)
+ (package-derivation %store dep))
+ (eq? (run-with-store %store
+ (graft-replacement graft))
+ (package-derivation %store 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.
@@ 1127,10 1130,13 @@
(dummy (dummy-package "dummy"
(arguments '(#:implicit-inputs? #f))
(inputs (list prop)))))
- (equal? (package-grafts %store dummy)
- (list (graft
- (origin (package-derivation %store dep))
- (replacement (package-derivation %store new)))))))
+ (match (package-grafts %store dummy)
+ ((graft)
+ (and (eq? (graft-origin graft)
+ (package-derivation %store dep))
+ (eq? (run-with-store %store
+ (graft-replacement graft))
+ (package-derivation %store new)))))))
(test-assert "package-grafts, same replacement twice"
(let* ((new (dummy-package "dep"
@@ 1149,12 1155,15 @@
(p3 (dummy-package "final"
(arguments '(#:implicit-inputs? #f))
(inputs (list p1 p2)))))
- (equal? (package-grafts %store p3)
- (list (graft
- (origin (package-derivation %store
- (package (inherit dep)
- (replacement #f))))
- (replacement (package-derivation %store new)))))))
+ (match (package-grafts %store p3)
+ ((graft)
+ (and (eq? (graft-origin graft)
+ (package-derivation %store
+ (package (inherit dep)
+ (replacement #f))))
+ (eq? (run-with-store %store
+ (graft-replacement graft))
+ (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>.
@@ 1167,17 1176,22 @@
(p1 (dummy-package "p1"
(arguments '(#:implicit-inputs? #f))
(inputs (list p0 `(,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"))))))
+ (match (sort (package-grafts %store p1)
+ (lambda (graft1 graft2)
+ (string<? (graft-origin-output graft1)
+ (graft-origin-output graft2))))
+ ((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*))
+ (string=? "lib"
+ (graft-origin-output graft1)
+ (graft-replacement-output graft1))
+ (string=? "out"
+ (graft-origin-output graft2)
+ (graft-replacement-output graft2)))))))
(test-assert "replacement also grafted"
;; We build a DAG as below, where dotted arrows represent replacements and
@@ 1244,15 1258,18 @@
(symlink (assoc-ref %build-inputs "p2")
"p2")
#t))))))
- (lset= equal?
- (package-grafts %store p3)
- (list (graft
- (origin (package-derivation %store p1 #:graft? #f))
- (replacement (package-derivation %store p1r)))
- (graft
- (origin (package-derivation %store p2 #:graft? #f))
- (replacement
- (package-derivation %store p2r #:graft? #t)))))))
+ (match (package-grafts %store p3)
+ ((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-origin graft2)
+ (package-derivation %store p2 #:graft? #f))
+ (eq? (run-with-store %store
+ (graft-replacement graft2))
+ (package-derivation %store p2r #:graft? #t)))))))
;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
;;; find out about their run-time dependencies, so this test is no longer