From 28e4018e59d30efb3d52aa950ce2261f11b69b33 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 28 Jan 2025 14:53:03 +0100 Subject: [PATCH] =?UTF-8?q?grafts:=20Allow=20file-like=20objects=20in=20th?= =?UTF-8?q?e=20=E2=80=98replacement=E2=80=99=20field=20of=20.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is a followup to and simplification of 3331d675fbf5287e8cbe12af48fb2de14f1ad8bc. * 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 . * 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 Change-Id: I286fceae53df9d3051137bbca5f944d51d0c92f3 --- guix/grafts.scm | 23 +++++------------------ guix/packages.scm | 21 ++++++++------------- tests/packages.scm | 26 ++++++++------------------ 3 files changed, 21 insertions(+), 49 deletions(-) diff --git a/guix/grafts.scm b/guix/grafts.scm index 7636df9267..98ef1e4058 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -101,9 +101,11 @@ are not recursively applied to dependencies of DRV." ;; List of store item pairs. (map (lambda (graft) (gexp - ((ungexp (graft-origin graft) + ((ungexp (with-parameters ((%graft? #f)) + (graft-origin graft)) (graft-origin-output graft)) - . (ungexp (graft-replacement graft) + . (ungexp (with-parameters ((%graft? #t)) + (graft-replacement graft)) (graft-replacement-output graft))))) grafts)) @@ -275,20 +277,6 @@ derivations to the corresponding set of grafts." #: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 @@ -305,8 +293,7 @@ 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 - (map finalize-graft applicable) + (let* ((new (graft-derivation/shallow* store drv applicable #:outputs outputs #:guile guile #:system system)) diff --git a/guix/packages.scm b/guix/packages.scm index d266805ba8..78726b089a 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1818,15 +1818,13 @@ graft, and #f otherwise." (if replacement (mcached eq? (=> %package-graft-cache) (mlet %store-monad ((orig (package->derivation package system - #:graft? #f)) - (new -> (package->derivation replacement system - #:graft? #t))) - ;; Keep NEW as a monadic value so that its computation - ;; is delayed until necessary. + #:graft? #f))) + ;; Keep REPLACEMENT as a package so that its + ;; derivation is computed only when necessary. (return (graft (origin orig) (origin-output output) - (replacement new) + (replacement replacement) (replacement-output output)))) package output system) (return #f)))) @@ -1842,16 +1840,13 @@ graft, and #f otherwise." (if replacement (mlet %store-monad ((orig (package->cross-derivation package target system - #:graft? #f)) - (new -> (package->cross-derivation replacement - target system - #:graft? #t))) - ;; Keep NEW as a monadic value so that its computation - ;; is delayed until necessary. + #:graft? #f))) + ;; Keep REPLACEMENT as a package so that its derivation is + ;; computed only when necessary. (return (graft (origin orig) (origin-output output) - (replacement new) + (replacement replacement) (replacement-output output)))) (return #f)))) (_ diff --git a/tests/packages.scm b/tests/packages.scm index a4a0e2c3e8..2863fb5991 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1095,9 +1095,7 @@ ((graft) (and (eq? (graft-origin graft) (package-derivation %store dep)) - (eq? (run-with-store %store - (graft-replacement graft)) - (package-derivation %store new))))))) + (eq? (graft-replacement graft) 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. @@ -1134,9 +1132,7 @@ ((graft) (and (eq? (graft-origin graft) (package-derivation %store dep)) - (eq? (run-with-store %store - (graft-replacement graft)) - (package-derivation %store new))))))) + (eq? (graft-replacement graft) new)))))) (test-assert "package-grafts, same replacement twice" (let* ((new (dummy-package "dep" @@ -1161,9 +1157,7 @@ (package-derivation %store (package (inherit dep) (replacement #f)))) - (eq? (run-with-store %store - (graft-replacement graft)) - (package-derivation %store new))))))) + (eq? (graft-replacement graft) new)))))) (test-assert "package-grafts, dependency on several outputs" ;; Make sure we get one graft per output; see . @@ -1183,9 +1177,9 @@ ((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*)) + (eq? (graft-replacement graft1) + (graft-replacement graft2) + p0*) (string=? "lib" (graft-origin-output graft1) (graft-replacement-output graft1)) @@ -1262,14 +1256,10 @@ ((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-replacement graft1) 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))))))) + (eq? (graft-replacement graft2) p2r)))))) ;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to ;;; find out about their run-time dependencies, so this test is no longer