aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2022-10-14 23:01:33 +0200
committerLudovic Courtès <ludo@gnu.org>2022-10-22 01:49:57 +0200
commit863c228bfd53aac478eee46f6ee54d87fee9d764 (patch)
tree77f61d4448dbd3f29123ebc80d023cd52cd812bf
parenta3619079f95213c4f983e69210ed12b38fd31022 (diff)
downloadguix-863c228bfd53aac478eee46f6ee54d87fee9d764.tar
guix-863c228bfd53aac478eee46f6ee54d87fee9d764.tar.gz
grafts: Rewrite using gexps.
Fixes <https://issues.guix.gnu.org/58419>. * guix/grafts.scm (graft-derivation/shallow): Rewrite using gexps and remove 'store' parameter. (graft-derivation/shallow*): New variable. (cumulative-grafts): Use it instead of 'graft-derivation/shallow'.
-rw-r--r--guix/grafts.scm113
1 files changed, 51 insertions, 62 deletions
diff --git a/guix/grafts.scm b/guix/grafts.scm
index 252abfd8b3..1686aa1413 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -24,6 +24,7 @@
#:use-module (guix derivations)
#:use-module ((guix utils) #:select (%current-system))
#:use-module (guix sets)
+ #:use-module (guix gexp)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
@@ -78,7 +79,7 @@
(($ <graft> (? string? item))
item)))
-(define* (graft-derivation/shallow store drv grafts
+(define* (graft-derivation/shallow drv grafts
#:key
(name (derivation-name drv))
(outputs (derivation-output-names drv))
@@ -87,72 +88,60 @@
"Return a derivation called NAME, which applies GRAFTS to the specified
OUTPUTS of DRV. This procedure performs \"shallow\" grafting in that GRAFTS
are not recursively applied to dependencies of DRV."
- ;; XXX: Someday rewrite using gexps.
(define mapping
;; List of store item pairs.
- (map (match-lambda
- (($ <graft> source source-output target target-output)
- (cons (if (derivation? source)
- (derivation->output-path source source-output)
- source)
- (if (derivation? target)
- (derivation->output-path target target-output)
- target))))
+ (map (lambda (graft)
+ (gexp
+ ((ungexp (graft-origin graft)
+ (graft-origin-output graft))
+ . (ungexp (graft-replacement graft)
+ (graft-replacement-output graft)))))
grafts))
- (define output-pairs
- (map (lambda (output)
- (cons output
- (derivation-output-path
- (assoc-ref (derivation-outputs drv) output))))
- outputs))
-
(define build
- `(begin
- (use-modules (guix build graft)
- (guix build utils)
- (ice-9 match))
-
- (let* ((old-outputs ',output-pairs)
- (mapping (append ',mapping
- (map (match-lambda
- ((name . file)
- (cons (assoc-ref old-outputs name)
- file)))
- %outputs))))
- (graft old-outputs %outputs mapping))))
-
- (define add-label
- (cut cons "x" <>))
+ (with-imported-modules '((guix build graft)
+ (guix build utils)
+ (guix build debug-link)
+ (guix elf))
+ #~(begin
+ (use-modules (guix build graft)
+ (guix build utils)
+ (ice-9 match))
+
+ (define %outputs
+ (ungexp (outputs->gexp outputs)))
+
+ (let* ((old-outputs '(ungexp
+ (map (lambda (output)
+ (gexp ((ungexp output)
+ . (ungexp drv output))))
+ outputs)))
+ (mapping (append '(ungexp mapping)
+ (map (match-lambda
+ ((name . file)
+ (cons (assoc-ref old-outputs name)
+ file)))
+ %outputs))))
+ (graft old-outputs %outputs mapping)))))
+
(define properties
`((type . graft)
(graft (count . ,(length grafts)))))
- (match grafts
- ((($ <graft> sources source-outputs targets target-outputs) ...)
- (let ((sources (zip sources source-outputs))
- (targets (zip targets target-outputs)))
- (build-expression->derivation store name build
- #:system system
- #:guile-for-build guile
- #:modules '((guix build graft)
- (guix build utils)
- (guix build debug-link)
- (guix elf))
- #:inputs `(,@(map (lambda (out)
- `("x" ,drv ,out))
- outputs)
- ,@(append (map add-label sources)
- (map add-label targets)))
- #:outputs outputs
-
- ;; Grafts are computationally cheap so no
- ;; need to offload or substitute.
- #:local-build? #t
- #:substitutable? #f
-
- #:properties properties)))))
+ (gexp->derivation name build
+ #:system system
+ #:guile-for-build guile
+
+ ;; Grafts are computationally cheap so no
+ ;; need to offload or substitute.
+ #:local-build? #t
+ #:substitutable? #f
+
+ #:properties properties))
+
+(define graft-derivation/shallow*
+ (store-lower graft-derivation/shallow))
(define (non-self-references store drv outputs)
"Return the list of references of the OUTPUTS of DRV, excluding self
@@ -291,10 +280,10 @@ 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 applicable
- #:outputs outputs
- #:guile guile
- #:system system))
+ (let* ((new (graft-derivation/shallow* store drv applicable
+ #:outputs outputs
+ #:guile guile
+ #:system system))
(grafts (append (map (lambda (output)
(graft
(origin drv)