packages: Honor system and target system for graft replacements.

Fixes <https://issues.guix.gnu.org/76110>.

Fixes a regression introduced in
28e4018e59d30efb3d52aa950ce2261f11b69b33 where the system and target
system would be ignored.

* 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.

Change-Id: I1663f0cc50842bb9abb53ba4aa9935052022d1f4
Signed-off-by: Ludovic Courtès <[email protected]>
Reported-by: Denis 'GNUtoo' Carikli <[email protected]>

2 files changed, 51 insertions, 10 deletions

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 @@ graft, and #f otherwise."
                         (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 @@ graft, and #f otherwise."
                (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 <[email protected]>
 ;;; Copyright © 2021 Maxime Devos <[email protected]>
 ;;; Copyright © 2023 Simon Tournier <[email protected]>
+;;; Copyright © 2025 David Elsing <[email protected]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -1095,7 +1096,29 @@
       ((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 @@
       ((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 @@
                  (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 @@
       ((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 @@
       ((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