aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.dir-locals.el1
-rw-r--r--guix/derivations.scm57
-rw-r--r--tests/derivations.scm8
3 files changed, 45 insertions, 21 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index fe1f41c3ed..106c35bce6 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -25,6 +25,7 @@
(eval . (put 'origin 'scheme-indent-function 0))
(eval . (put 'build-system 'scheme-indent-function 0))
(eval . (put 'bag 'scheme-indent-function 0))
+ (eval . (put 'graft 'scheme-indent-function 0))
(eval . (put 'operating-system 'scheme-indent-function 0))
(eval . (put 'file-system 'scheme-indent-function 0))
(eval . (put 'manifest-entry 'scheme-indent-function 0))
diff --git a/guix/derivations.scm b/guix/derivations.scm
index c0b69e71d6..15faf59616 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -30,6 +30,7 @@
#:use-module (guix utils)
#:use-module (guix hash)
#:use-module (guix base32)
+ #:use-module (guix records)
#:export (<derivation>
derivation?
derivation-outputs
@@ -65,7 +66,15 @@
derivation-path->output-path
derivation-path->output-paths
derivation
+
+ graft
+ graft?
+ graft-origin
+ graft-replacement
+ graft-origin-output
+ graft-replacement-output
graft-derivation
+
map-derivation
%guile-for-build
@@ -965,23 +974,31 @@ they can refer to each other."
#:guile-for-build guile
#:local-build? #t)))
-(define* (graft-derivation store name drv replacements
+(define-record-type* <graft> graft make-graft
+ graft?
+ (origin graft-origin) ;derivation | store item
+ (origin-output graft-origin-output ;string | #f
+ (default "out"))
+ (replacement graft-replacement) ;derivation | store item
+ (replacement-output graft-replacement-output ;string | #f
+ (default "out")))
+
+(define* (graft-derivation store name drv grafts
#:key (guile (%guile-for-build)))
- "Return a derivation called NAME, based on DRV but with all the first
-elements of REPLACEMENTS replaced by the corresponding second element.
-REPLACEMENTS must be a list of ((DRV OUTPUT) . (DRV2 OUTPUT)) pairs."
+ "Return a derivation called NAME, based on DRV but with all the GRAFTS
+applied."
;; XXX: Someday rewrite using gexps.
(define mapping
;; List of store item pairs.
(map (match-lambda
- (((source source-outputs ...) . (target target-outputs ...))
+ (($ <graft> source source-output target target-output)
(cons (if (derivation? source)
- (apply derivation->output-path source source-outputs)
+ (derivation->output-path source source-output)
source)
(if (derivation? target)
- (apply derivation->output-path target target-outputs)
+ (derivation->output-path target target-output)
target))))
- replacements))
+ grafts))
(define outputs
(match (derivation-outputs drv)
@@ -1013,17 +1030,19 @@ REPLACEMENTS must be a list of ((DRV OUTPUT) . (DRV2 OUTPUT)) pairs."
(define add-label
(cut cons "x" <>))
- (match replacements
- (((sources . targets) ...)
- (build-expression->derivation store name build
- #:guile-for-build guile
- #:modules '((guix build graft)
- (guix build utils))
- #:inputs `(("original" ,drv)
- ,@(append (map add-label sources)
- (map add-label targets)))
- #:outputs output-names
- #:local-build? #t))))
+ (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
+ #:guile-for-build guile
+ #:modules '((guix build graft)
+ (guix build utils))
+ #:inputs `(("original" ,drv)
+ ,@(append (map add-label sources)
+ (map add-label targets)))
+ #:outputs output-names
+ #:local-build? #t)))))
(define* (build-expression->derivation store name exp
#:key
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 48d12990e6..e774fed4c3 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -831,8 +831,12 @@ Deriver: ~a~%"
(lambda (port)
(display "fake mkdir" port)))))
(graft (graft-derivation %store "graft" orig
- `(((,%bash) . (,one))
- ((,%mkdir) . (,two))))))
+ (list (graft
+ (origin %bash)
+ (replacement one))
+ (graft
+ (origin %mkdir)
+ (replacement two))))))
(and (build-derivations %store (list graft))
(let ((two (derivation->output-path two))
(graft (derivation->output-path graft)))