diff --git a/guix/grafts.scm b/guix/grafts.scm index d97e112ba4..7636df9267 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014-2024 Ludovic Courtès +;;; Copyright © 2024 David Elsing ;;; ;;; This file is part of GNU Guix. ;;; @@ -53,7 +54,7 @@ (define-record-type* graft make-graft (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 @@ (define (dependency-grafts items) #:system system))))) (reference-origins drv items))) + ;; If the 'replacement' field of the 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 @@ (define (dependency-grafts items) ;; 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)) diff --git a/guix/packages.scm b/guix/packages.scm index ff9fbd8470..d266805ba8 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -11,6 +11,7 @@ ;;; Copyright © 2022 jgart ;;; Copyright © 2023 Simon Tournier ;;; Copyright © 2024 Janneke Nieuwenhuizen +;;; Copyright © 2024 David Elsing ;;; ;;; This file is part of GNU Guix. ;;; @@ -1818,8 +1819,10 @@ (define (input-graft system) (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 @@ (define (input-cross-graft target system) (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) diff --git a/tests/packages.scm b/tests/packages.scm index 9713262d4c..a4a0e2c3e8 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012-2024 Ludovic Courtès +;;; Copyright © 2012-2025 Ludovic Courtès ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; Copyright © 2021 Maxim Cournoyer ;;; Copyright © 2021 Maxime Devos @@ -1091,10 +1091,13 @@ (define right-system? (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 @@ (define right-system? (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 @@ (define right-system? (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 . @@ -1167,17 +1176,22 @@ (define right-system? (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