David Elsing wrote 1 weeks ago
(address . guix-patches@gnu.org)(name . David Elsing)(address . david.elsing@posteo.net)
20250302224357.23572-1-david.elsing@posteo.net
* guix/packages.scm (input-graft, input-cross-graft): Wrap graft replacement
in ‘with-parameters’.
* 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 by comparing the replacement
after lowering to a derivation.
("package-grafts, indirect grafts, #:system argument"): New test.
---
The modified tests are now more expensive, because comparing the
replacements now needs to be done by comparing the resulting derivations
due to the wrapping in <parameterized>. This requires building the
original package.
guix/packages.scm | 9 ++++++--
tests/packages.scm | 52 +++++++++++++++++++++++++++++++++++++++-------
2 files changed, 51 insertions(+), 10 deletions(-)
Toggle diff (129 lines)
diff --git a/guix/packages.scm b/guix/packages.scm
index bdcea66f77..70ccd8a924 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1824,7 +1824,9 @@ (define (input-graft system)
(return (graft
(origin orig)
(origin-output output)
- (replacement replacement)
+ (replacement
+ (with-parameters ((%current-system system))
+ replacement))
(replacement-output output))))
package output system)
(return #f))))
@@ -1846,7 +1848,10 @@ (define (input-cross-graft target system)
(return (graft
(origin orig)
(origin-output output)
- (replacement replacement)
+ (replacement
+ (with-parameters ((%current-system system)
+ (%current-target-system target))
+ replacement))
(replacement-output output))))
(return #f))))
(_
diff --git a/tests/packages.scm b/tests/packages.scm
index 2863fb5991..50c1cab915 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2025 David Elsing <david.elsing@posteo.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -1095,7 +1096,29 @@ (define right-system?
((graft)
(and (eq? (graft-origin graft)
(package-derivation %store dep))
- (eq? (graft-replacement graft) new))))))
+ (eq? (run-with-store %store
+ (lower-object (graft-replacement graft)))
+ (package-derivation %store new)))))))
+
+(test-assert "package-grafts, indirect grafts, #:system argument"
+ (let* ((system (if (string=? (%current-system) "riscv64-linux")
+ "x86_64-linux"
+ "riscv64-linux"))
+ (new (dummy-package "dep"
+ (arguments `(#:implicit-inputs? #f
+ #:system ,system))))
+ (dep (package (inherit new) (version "0.0")))
+ (dep* (package (inherit dep) (replacement new)))
+ (dummy (dummy-package "dummy"
+ (arguments '(#:implicit-inputs? #f))
+ (inputs (list dep*)))))
+ (match (package-grafts %store dummy)
+ ((graft)
+ (and (eq? (graft-origin graft)
+ (package-derivation %store dep system))
+ (eq? (run-with-store %store
+ (lower-object (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.
@@ -1132,7 +1155,9 @@ (define right-system?
((graft)
(and (eq? (graft-origin graft)
(package-derivation %store dep))
- (eq? (graft-replacement graft) new))))))
+ (eq? (run-with-store %store
+ (lower-object (graft-replacement graft)))
+ (package-derivation %store new)))))))
(test-assert "package-grafts, same replacement twice"
(let* ((new (dummy-package "dep"
@@ -1157,7 +1182,9 @@ (define right-system?
(package-derivation %store
(package (inherit dep)
(replacement #f))))
- (eq? (graft-replacement graft) new))))))
+ (eq? (run-with-store %store
+ (lower-object (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>.
@@ -1177,9 +1204,11 @@ (define right-system?
((graft1 graft2)
(and (eq? (graft-origin graft1) (graft-origin graft2)
(package-derivation %store p0))
- (eq? (graft-replacement graft1)
- (graft-replacement graft2)
- p0*)
+ (eq? (run-with-store %store
+ (lower-object (graft-replacement graft1)))
+ (run-with-store %store
+ (lower-object (graft-replacement graft2)))
+ (package-derivation %store p0*))
(string=? "lib"
(graft-origin-output graft1)
(graft-replacement-output graft1))
@@ -1256,10 +1285,17 @@ (define right-system?
((graft1 graft2)
(and (eq? (graft-origin graft1)
(package-derivation %store p1 #:graft? #f))
- (eq? (graft-replacement graft1) p1r)
+ (eq? (run-with-store %store
+ (lower-object (graft-replacement graft1)))
+ (package-derivation %store p1r #:graft? #t))
(eq? (graft-origin graft2)
(package-derivation %store p2 #:graft? #f))
- (eq? (graft-replacement graft2) p2r))))))
+ ;; XXX: Remove parameterize when
+ ;; <https://issues.guix.gnu.org/75879> is fixed.
+ (eq? (parameterize ((%graft? #t))
+ (run-with-store %store
+ (lower-object (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
--
2.48.1