diff options
| -rw-r--r-- | .dir-locals.el | 1 | ||||
| -rw-r--r-- | guix/derivations.scm | 57 | ||||
| -rw-r--r-- | tests/derivations.scm | 8 |
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))) |