diff options
author | Ludovic Courtès <ludo@gnu.org> | 2014-10-07 23:23:09 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2014-10-08 12:01:49 +0200 |
commit | fb59e275dd84152cf04f89cd5192145ccf071853 (patch) | |
tree | 49b04f16b355fae967a8474922377cf66350edd5 /guix/derivations.scm | |
parent | 3c762a13bf0a8e15f2cf67d6a9eb27cf6d55267d (diff) |
derivations: Add 'graft-derivation'.
* guix/derivations.scm (graft-derivation): New procedure.
* guix/build/graft.scm: New file.
* Makefile.am (MODULES): Add it.
* tests/derivations.scm ("graft-derivation"): New test.
Diffstat (limited to 'guix/derivations.scm')
-rw-r--r-- | guix/derivations.scm | 59 |
1 files changed, 59 insertions, 0 deletions
diff --git a/guix/derivations.scm b/guix/derivations.scm index 5ca516aa28..a9b2c5c79d 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -65,6 +65,7 @@ derivation-path->output-path derivation-path->output-paths derivation + graft-derivation map-derivation %guile-for-build @@ -952,6 +953,64 @@ they can refer to each other." #:guile-for-build guile #:local-build? #t))) +(define (graft-derivation store name drv replacements) + "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." + ;; XXX: Someday rewrite using gexps. + (define mapping + ;; List of store item pairs. + (map (match-lambda + (((source source-outputs ...) . (target target-outputs ...)) + (cons (if (derivation? source) + (apply derivation->output-path source source-outputs) + source) + (if (derivation? target) + (apply derivation->output-path target target-outputs) + target)))) + replacements)) + + (define outputs + (match (derivation-outputs drv) + (((names . outputs) ...) + (map derivation-output-path outputs)))) + + (define output-names + (match (derivation-outputs drv) + (((names . outputs) ...) + names))) + + (define build + `(begin + (use-modules (guix build graft) + (guix build utils) + (ice-9 match)) + + (let ((mapping ',mapping)) + (for-each (lambda (input output) + (format #t "rewriting '~a' to '~a'...~%" input output) + (rewrite-directory input output + `((,input . ,output) + ,@mapping))) + ',outputs + (match %outputs + (((names . files) ...) + files)))))) + + (define add-label + (cut cons "x" <>)) + + (match replacements + (((sources . targets) ...) + (build-expression->derivation store name build + #: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 (system (%current-system)) |