diff mbox series

[bug#61363,1/2] packages: Add explicit-grafting record type to assist with grafts.

Message ID 20230208075403.11788-1-mail@cbaines.net
State New
Headers show
Series self: Apply grafts to the outputs of the guix derivation. | expand

Commit Message

Christopher Baines Feb. 8, 2023, 7:54 a.m. UTC 
Normally the grafting takes place when lowering packages, but this record
assists with applying the same transformation to arbitrary objects/store
items.

I'm adding this to allow grafting the channel instance derivation outputs.

* guix/packages.scm (explicit-grafting, explicit-grafting?,
explicit-grafting-obj, explicit-grafting-grafts): New procedures.
---
 guix/packages.scm | 45 ++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 44 insertions(+), 1 deletion(-)
diff mbox series

Patch

diff --git a/guix/packages.scm b/guix/packages.scm
index 041a872f9d..877bf89522 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -188,7 +188,12 @@  (define-module (guix packages)
             package-file
             package->derivation
             package->cross-derivation
-            origin->derivation))
+            origin->derivation
+
+            explicit-grafting
+            explicit-grafting?
+            explicit-grafting-obj
+            explicit-grafting-grafts))
 
 ;; The 'source-module-closure' procedure ca. 1.2.0 did not recognize
 ;; #:re-export-and-replace: <https://issues.guix.gnu.org/52694>.
@@ -2093,3 +2098,41 @@  (define package-source-derivation                 ;somewhat deprecated
          (add-to-store store (basename file) #t "sha256" file))
         (_
          (lower store source system))))))
+
+;; Apply grafts explicitly
+(define-immutable-record-type <explicit-grafting>
+  (%explicit-grafting obj packages)
+  explicit-grafting?
+  (obj      explicit-grafting-obj)       ;obj
+  (packages explicit-grafting-packages)) ;list of <package>s
+
+(define (write-explicit-grafting rec port)
+  (match rec
+    (($ <explicit-grafting> obj packages)
+     (format port "#<explicit-grafting ~s ~s>" obj packages))))
+
+(define (explicit-grafting obj packages)
+  (%explicit-grafting obj packages))
+
+(define-gexp-compiler (explicit-grafting-compiler (explicit-grafting <explicit-grafting>)
+                                                  system target)
+  (match explicit-grafting
+    (($ <explicit-grafting> obj packages)
+     (mlet* %store-monad ((drv (without-grafting
+                                (lower-object obj system #:target target)))
+                          (grafts
+                           (mapm %store-monad
+                                 (lambda (pkg)
+                                   (package-grafts* pkg system #:target target))
+                                 packages)))
+       (match (delete-duplicates
+               (concatenate grafts))
+         (()
+          (return drv))
+         (grafts
+          (mlet %store-monad ((guile (package->derivation
+                                      (guile-for-grafts)
+                                      system #:graft? #f)))
+            (graft-derivation* drv grafts
+                               #:system system
+                               #:guile guile))))))))